diff --git a/config/routes b/config/routes index cf4e549..3a3cb45 100644 --- a/config/routes +++ b/config/routes @@ -56,3 +56,7 @@ /stack/#Text DownloadStackR GET /status/mirror MirrorStatusR GET + +/blog BlogHomeR GET +/blog/#Year/#Month/#Text BlogPostR GET +/blog/feed BlogFeedR GET diff --git a/src/Application.hs b/src/Application.hs index 29b3b4e..303208a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -58,6 +58,7 @@ import Handler.OldLinks import Handler.Feed import Handler.DownloadStack import Handler.MirrorStatus +import Handler.Blog import Network.Wai.Middleware.Prometheus (prometheus) import Prometheus (register) diff --git a/src/Data/WebsiteContent.hs b/src/Data/WebsiteContent.hs index 44b3325..9012429 100644 --- a/src/Data/WebsiteContent.hs +++ b/src/Data/WebsiteContent.hs @@ -1,6 +1,7 @@ module Data.WebsiteContent ( WebsiteContent (..) , StackRelease (..) + , Post (..) , loadWebsiteContent ) where @@ -9,6 +10,7 @@ import Text.Markdown (markdown, msXssProtect, msAddHeadingId) import Data.GhcLinks import Data.Aeson (withObject) import Data.Yaml +import System.FilePath (takeFileName) data WebsiteContent = WebsiteContent { wcHomepage :: !Html @@ -16,8 +18,18 @@ data WebsiteContent = WebsiteContent , wcOlderReleases :: !Html , wcGhcLinks :: !GhcLinks , wcStackReleases :: ![StackRelease] + , wcPosts :: !(Vector Post) } +data Post = Post + { postTitle :: !Text + , postSlug :: !Text + , postAuthor :: !Text + , postTime :: !UTCTime + , postDescription :: !Text + , postBody :: !Html + } + loadWebsiteContent :: FilePath -> IO WebsiteContent loadWebsiteContent dir = do wcHomepage <- readHtml "homepage.html" @@ -27,6 +39,9 @@ loadWebsiteContent dir = do wcGhcLinks <- readGhcLinks $ dir "stackage-cli" wcStackReleases <- decodeFileEither (dir "stack" "releases.yaml") >>= either throwIO return + wcPosts <- loadPosts (dir "posts") `catchAny` \e -> do + putStrLn $ "Error loading posts: " ++ tshow e + return mempty return WebsiteContent {..} where readHtml fp = fmap (preEscapedToMarkup . decodeUtf8 :: ByteString -> Html) @@ -37,6 +52,42 @@ loadWebsiteContent dir = do } . fromStrict . decodeUtf8) $ readFile $ dir fp +loadPosts :: FilePath -> IO (Vector Post) +loadPosts dir = + fmap (sortBy (\x y -> postTime y `compare` postTime x)) + $ runConduitRes + $ sourceDirectory dir + .| concatMapC (stripSuffix ".md") + .| mapMC loadPost + .| sinkVector + where + loadPost :: FilePath -> ResourceT IO Post + loadPost noExt = handleAny (\e -> throwString $ "Could not parse " ++ noExt ++ ".md: " ++ show e) $ do + bs <- readFile $ noExt ++ ".md" + let slug = pack $ takeFileName noExt + text = filter (/= '\r') $ decodeUtf8 bs + (frontmatter, body) <- + case lines text of + "---":rest -> + case break (== "---") rest of + (frontmatter, "---":body) -> return (unlines frontmatter, unlines body) + _ -> error "Missing closing --- on frontmatter" + _ -> error "Does not start with --- frontmatter" + case Data.Yaml.decodeEither' $ encodeUtf8 frontmatter of + Left e -> throwIO e + Right mkPost -> return $ mkPost slug $ markdown def + { msXssProtect = False + , msAddHeadingId = True + } $ fromStrict body + +instance (slug ~ Text, body ~ Html) => FromJSON (slug -> body -> Post) where + parseJSON = withObject "Post" $ \o -> do + postTitle <- o .: "title" + postAuthor <- o .: "author" + postTime <- o .: "timestamp" + postDescription <- o .: "description" + return $ \postSlug postBody -> Post {..} + data StackRelease = StackRelease { srName :: !Text , srPattern :: !Text diff --git a/src/Handler/Blog.hs b/src/Handler/Blog.hs new file mode 100644 index 0000000..b00f8dc --- /dev/null +++ b/src/Handler/Blog.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +module Handler.Blog + ( getBlogHomeR + , getBlogPostR + , getBlogFeedR + ) where + +import Import +import Data.WebsiteContent +import Yesod.GitRepo (grContent) +import Yesod.AtomFeed (atomLink) + +getPosts :: Handler (Vector Post) +getPosts = do + now <- liftIO getCurrentTime + posts <- getYesod >>= fmap wcPosts . liftIO . grContent . appWebsiteContent + mpreview <- lookupGetParam "preview" + case mpreview of + Just "true" -> return posts + _ -> return $ filter (\p -> postTime p <= now) posts + +getAddPreview :: Handler (Route App -> (Route App, [(Text, Text)])) +getAddPreview = do + mpreview <- lookupGetParam "preview" + case mpreview of + Just "true" -> return $ \route -> (route, [("preview", "true")]) + _ -> return $ \route -> (route, []) + +postYear :: Post -> Year +postYear p = + let (y, _, _) = toGregorian $ utctDay $ postTime p + in fromInteger y + +postMonth :: Post -> Month +postMonth p = + let (_, m, _) = toGregorian $ utctDay $ postTime p + in Month m + +getBlogHomeR :: Handler () +getBlogHomeR = do + posts <- getPosts + case headMay posts of + Nothing -> notFound + Just post -> do + addPreview <- getAddPreview + redirect $ addPreview $ BlogPostR (postYear post) (postMonth post) (postSlug post) + +getBlogPostR :: Year -> Month -> Text -> Handler Html +getBlogPostR year month slug = do + posts <- getPosts + post <- maybe notFound return $ find matches posts + now <- liftIO getCurrentTime + addPreview <- getAddPreview + defaultLayout $ do + setTitle $ toHtml $ postTitle post + atomLink BlogFeedR "Stackage Curator blog" + $(widgetFile "blog-post") + toWidgetHead [shamlet||] + where + matches p = postYear p == year && postMonth p == month && postSlug p == slug + +getBlogFeedR :: Handler TypedContent +getBlogFeedR = do + posts <- fmap (take 10) getPosts + latest <- maybe notFound return $ headMay posts + newsFeed Feed + { feedTitle = "Stackage Curator blog" + , feedLinkSelf = BlogFeedR + , feedLinkHome = HomeR + , feedAuthor = "The Stackage Curator team" + , feedDescription = "Messages from the Stackage Curators about the Stackage project" + , feedLanguage = "en" + , feedUpdated = postTime latest + , feedLogo = Nothing + , feedEntries = map toEntry $ toList posts + } + where + toEntry post = FeedEntry + { feedEntryLink = BlogPostR (postYear post) (postMonth post) (postSlug post) + , feedEntryUpdated = postTime post + , feedEntryTitle = postTitle post + , feedEntryContent = postBody post + , feedEntryEnclosure = Nothing + } diff --git a/src/Types.hs b/src/Types.hs index 568c68b..5428852 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,6 +10,7 @@ import qualified Data.Text.Lazy.Builder.Int as Builder import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy as LText import qualified Data.Text.Read as Reader +import Data.Char (ord) data SnapshotBranch = LtsMajorBranch Int | LtsBranch @@ -165,3 +166,17 @@ instance PathPiece SupportedArch where fromPathPiece "mac32" = Just Mac32 fromPathPiece "mac64" = Just Mac64 fromPathPiece _ = Nothing + +type Year = Int +newtype Month = Month Int + deriving (Eq, Read, Show, Ord) +instance PathPiece Month where + toPathPiece (Month i) + | i < 10 = pack $ '0' : show i + | otherwise = tshow i + fromPathPiece "10" = Just $ Month 10 + fromPathPiece "11" = Just $ Month 11 + fromPathPiece "12" = Just $ Month 12 + fromPathPiece (unpack -> ['0', c]) + | '1' <= c && c <= '9' = Just $ Month $ ord c - ord '0' + fromPathPiece _ = Nothing diff --git a/templates/blog-post.hamlet b/templates/blog-post.hamlet new file mode 100644 index 0000000..f0ee8e2 --- /dev/null +++ b/templates/blog-post.hamlet @@ -0,0 +1,17 @@ +

#{postTitle post} +

+ By #{postAuthor post}, # + #{dateDiff now (utctDay $ postTime post)} + +

#{postBody post} + +
+ +

Archive + +