Stackage blog

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

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)

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

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|<meta name=og:description value=#{postDescription post}>|]
+  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
+      }

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

templates/blog-post.hamlet

@@ -0,0 +1,17 @@
+<h1>#{postTitle post}
+<p #author>
+  By #{postAuthor post}, #
+  <abbr title=#{show $ postTime post}>#{dateDiff now (utctDay $ postTime post)}
+
+<article>#{postBody post}
+
+<section #archive>
+
+  <h2>Archive
+
+  <ul>
+    $forall post' <- posts
+      <li>
+        <a href=@?{addPreview $ BlogPostR (postYear post') (postMonth post') (postSlug post')}>
+          #{postTitle post'}, #
+          <abbr title=#{show $ postTime post}>#{dateDiff now (utctDay $ postTime post')}

templates/blog-post.lucius

@@ -0,0 +1,13 @@
+#author {
+  font-size: 120%;
+  font-style: italic;
+  border-bottom: 1px solid black;
+  margin-bottom: 1em;
+  padding-bottom: 1em;
+}
+
+#archive {
+  border-top: 1px solid black;
+  margin-top: 1em;
+  padding-top: 1em;
+}

templates/default-layout-wrapper.hamlet

@@ -14,8 +14,10 @@ $newline never
             #{pageTitle pc}
             $if notHome
                 \ :: Stackage Server
-        <meta name="description" content="">
-        <meta name="author" content="">
+
+        <meta name=og:site_name content="Stackage">
+        <meta name=twitter:card content=summary>
+        <meta name=og:title content=#{pageTitle pc}>
 
         <meta name="viewport" content="width=device-width,initial-scale=1">