4 files changed, 452 insertions, 0 deletions
diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs
new file mode 100644
index 000000000000..0a53b5f2fbf4
--- /dev/null
+++ b/services/tazblog/src/Blog.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Blog where
+
+import BlogStore
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import Data.Text.Lazy (fromStrict)
+import Data.Time
+import Text.Blaze.Html (preEscapedToHtml)
+import Text.Hamlet
+import Text.Markdown
+
+blogTitle :: Text = "tazjin's blog"
+
+repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
+
+mailTo :: Text = "mailto:mail@tazj.in"
+
+twitter :: Text = "https://twitter.com/tazjin"
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y = map (\z -> if z == x then y else z)
+
+-- |After this date all entries are Markdown
+markdownCutoff :: Day
+markdownCutoff = fromGregorian 2013 04 28
+
+blogTemplate :: Text -> Html -> Html
+blogTemplate t_append body =
+  [shamlet|
+$doctype 5
+  <head>
+    <meta charset="utf-8">
+    <meta name="viewport" content="width=device-width, initial-scale=1">
+    <meta name="description" content=#{blogTitle}#{t_append}>
+    <link rel="stylesheet" type="text/css" href="/static/blog.css" media="all">
+    <link rel="alternate" type="application/rss+xml" title="RSS-Feed" href="/rss.xml">
+    <title>#{blogTitle}#{t_append}
+  <body>
+    <header>
+      <h1>
+        <a href="/" .unstyled-link>#{blogTitle}
+      <hr>
+    ^{body}
+    ^{showFooter}
+|]
+
+showFooter :: Html
+showFooter =
+  [shamlet|
+<footer>
+  <p .footer>Served without any dynamic languages.
+  <p .footer>
+    <a href=#{repoURL} .uncoloured-link>
+    |
+    <a href=#{twitter} .uncoloured-link>Twitter
+    |
+    <a href=#{mailTo} .uncoloured-link>Mail
+  <p .lod>
+    ಠ_ಠ
+|]
+
+isEntryMarkdown :: Entry -> Bool
+isEntryMarkdown e = edate e > markdownCutoff
+
+renderEntryMarkdown :: Text -> Html
+renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
+
+renderEntries :: [Entry] -> Maybe Html -> Html
+renderEntries entries pageLinks =
+  [shamlet|
+$forall entry <- entries
+  <article>
+    <h2 .inline>
+      <a href=#{linkElems entry} .unstyled-link>
+        #{title entry}
+    <aside .date>
+      #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" $ edate entry}
+    $if (isEntryMarkdown entry)
+      ^{renderEntryMarkdown $ text entry}
+    $else
+      ^{preEscapedToHtml $ text entry}
+  <hr>
+$maybe links <- pageLinks
+  ^{links}
+|]
+  where
+    linkElems Entry {..} = "/" ++ show entryId
+
+showLinks :: Maybe Int -> Html
+showLinks (Just i) =
+  [shamlet|
+  $if ((>) i 1)
+    <div .navigation>
+      <a href=#{nLink $ succ i} .uncoloured-link>Earlier
+      |
+      <a href=#{nLink $ pred i} .uncoloured-link>Later
+  $elseif ((<=) i 1)
+    ^{showLinks Nothing}
+|]
+  where
+    nLink page = T.concat ["/?page=", show' page]
+showLinks Nothing =
+  [shamlet|
+<div .navigation>
+  <a href="/?page=2" .uncoloured-link>Earlier
+|]
+
+renderEntry :: Entry -> Html
+renderEntry e@Entry {..} =
+  [shamlet|
+<article>
+  <h2 .inline>
+    #{title}
+  <aside .date>
+    #{pack $ formatTime defaultTimeLocale "%Y-%m-%d" edate}
+  $if (isEntryMarkdown e)
+    ^{renderEntryMarkdown text}
+  $else
+    ^{preEscapedToHtml $ text}
+<hr>
+|]
+
+showError :: Text -> Text -> Html
+showError title err =
+  blogTemplate (": " <> title)
+    [shamlet|
+<p>:(
+<p>#{err}
+<hr>
+|]
diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs
new file mode 100644
index 000000000000..60ccd0b5a003
--- /dev/null
+++ b/services/tazblog/src/BlogStore.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |This module implements fetching of individual blog entries from
+-- DNS. Yes, you read that correctly.
+--
+-- Each blog post is stored as a set of records in a designated DNS
+-- zone. For the production blog, this zone is `blog.tazj.in.`.
+--
+-- A top-level record at `_posts` contains a list of all published
+-- post IDs.
+--
+-- For each of these post IDs, there is a record at `_meta.$postID`
+-- that contains the title and number of post chunks.
+--
+-- For each post chunk, there is a record at `_$chunkID.$postID` that
+-- contains a base64-encoded post fragment.
+--
+-- This module implements logic for assembling a post out of these
+-- fragments and caching it based on the TTL of its `_meta` record.
+module BlogStore
+  ( BlogCache,
+    EntryId (..),
+    Entry (..),
+    withCache,
+    listEntries,
+    getEntry,
+    show'
+    )
+where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (mzero)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson ((.:), FromJSON (..), Value (Object), decodeStrict)
+import Data.ByteString.Base64 (decodeLenient)
+import Data.Either (fromRight)
+import Data.List (sortBy)
+import Data.Text as T (Text, concat, pack)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Time (Day)
+import Network.DNS (DNSError, lookupTXT)
+import qualified Network.DNS.Resolver as R
+
+newtype EntryId = EntryId {unEntryId :: Integer}
+  deriving (Eq, Ord, FromJSON)
+
+instance Show EntryId where
+
+  show = show . unEntryId
+
+data Entry
+  = Entry
+      { entryId :: EntryId,
+        author :: Text,
+        title :: Text,
+        text :: Text,
+        edate :: Day
+        }
+  deriving (Eq, Ord, Show)
+
+-- | Wraps a DNS resolver with caching configured. For the initial
+-- version of this, all caching of entries is done by the resolver
+-- (i.e. no pre-assembled versions of entries are cached).
+data BlogCache = BlogCache R.Resolver Text
+
+data StoreError
+  = PostNotFound EntryId
+  | DNS DNSError
+  | InvalidMetadata
+  | InvalidChunk
+  | InvalidPosts
+  deriving (Show)
+
+type Offset = Int
+
+type Count = Int
+
+withCache :: Text -> (BlogCache -> IO a) -> IO a
+withCache zone f = do
+  let conf =
+        R.defaultResolvConf
+          { R.resolvCache = Just R.defaultCacheConf,
+            R.resolvConcurrent = True
+            }
+  seed <- R.makeResolvSeed conf
+  R.withResolver seed (\r -> f $ BlogCache r zone)
+
+listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
+listEntries cache offset count = liftIO $ do
+  posts <- postList cache
+  entries <- mapM (entryFromDNS cache) $ take count $ drop offset $ fromRight (error "no posts") posts
+  -- TODO: maybe don't just drop broken entries
+  return
+    $ fromRight (error "no entries")
+    $ sequence entries
+
+getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
+getEntry cache eid = liftIO $ entryFromDNS cache eid >>= \case
+  Left _ -> return Nothing -- TODO: ??
+  Right entry -> return $ Just entry
+
+show' :: Show a => a -> Text
+show' = pack . show
+
+-- * DNS fetching implementation
+type Chunk = Integer
+
+-- | Represents the metadata stored for each post in the _meta record.
+data Meta = Meta Integer Text Day
+  deriving (Show)
+
+instance FromJSON Meta where
+
+  parseJSON (Object v) =
+    Meta
+      <$> v
+      .: "c"
+      <*> v
+      .: "t"
+      <*> v
+      .: "d"
+  parseJSON _ = mzero
+
+entryMetadata :: BlogCache -> EntryId -> IO (Either StoreError Meta)
+entryMetadata (BlogCache r z) (EntryId eid) =
+  let domain = encodeUtf8 ("_meta." <> show' eid <> "." <> z)
+      record = lookupTXT r domain
+      toMeta rrdata = case decodeStrict $ decodeLenient rrdata of
+        Nothing -> Left InvalidMetadata
+        Just m -> Right m
+   in record >>= \case
+        (Left err) -> return $ Left $ DNS err
+        (Right [bs]) -> return $ toMeta bs
+        _ -> return $ Left InvalidMetadata
+
+entryChunk :: BlogCache -> EntryId -> Chunk -> IO (Either StoreError Text)
+entryChunk (BlogCache r z) (EntryId eid) c =
+  let domain = encodeUtf8 ("_" <> show' c <> "." <> show' eid <> "." <> z)
+      record = lookupTXT r domain
+      toChunk rrdata = case decodeUtf8' $ decodeLenient rrdata of
+        Left _ -> Left InvalidChunk
+        Right chunk -> Right chunk
+   in record >>= \case
+        (Left err) -> return $ Left $ DNS err
+        (Right [bs]) -> return $ toChunk bs
+        _ -> return $ Left InvalidChunk
+
+fetchAssembleChunks :: BlogCache -> EntryId -> Meta -> IO (Either StoreError Text)
+fetchAssembleChunks cache eid (Meta n _ _) = do
+  chunks <- mapM (entryChunk cache eid) [0 .. (n - 1)]
+  return $ fmap T.concat $ sequence chunks
+
+entryFromDNS :: BlogCache -> EntryId -> IO (Either StoreError Entry)
+entryFromDNS cache eid = do
+  meta <- entryMetadata cache eid
+  case meta of
+    Left err -> return $ Left err
+    Right meta -> do
+      chunks <- fetchAssembleChunks cache eid meta
+      let (Meta _ t d) = meta
+      return
+        $ either Left
+            ( \text -> Right $ Entry
+                { entryId = eid,
+                  author = "tazjin",
+                  title = t,
+                  text = text,
+                  edate = d
+                  }
+              )
+            chunks
+
+postList :: BlogCache -> IO (Either StoreError [EntryId])
+postList (BlogCache r z) =
+  let domain = encodeUtf8 ("_posts." <> z)
+      record = lookupTXT r domain
+      toPosts =
+        fmap (sortBy (flip compare))
+          . mapM (maybe (Left InvalidPosts) Right . decodeStrict)
+   in either (Left . DNS) toPosts <$> record
diff --git a/services/tazblog/src/RSS.hs b/services/tazblog/src/RSS.hs
new file mode 100644
index 000000000000..913aa9a4081b
--- /dev/null
+++ b/services/tazblog/src/RSS.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module RSS
+  ( renderFeed
+    )
+where
+
+import BlogStore
+import Data.Maybe (fromJust)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime)
+import Network.URI (URI, parseURI)
+import Text.RSS
+
+createChannel :: UTCTime -> [ChannelElem]
+createChannel now =
+  [ Language "en",
+    Copyright "Vincent Ambo",
+    WebMaster "mail@tazj.in",
+    ChannelPubDate now
+    ]
+
+createRSS :: UTCTime -> [Item] -> RSS
+createRSS t =
+  let link = fromJust $ parseURI "https://tazj.in"
+   in RSS "tazjin's blog" link "tazjin's blog feed" (createChannel t)
+
+createItem :: Entry -> Item
+createItem Entry {..} =
+  [ Title "tazjin's blog",
+    Link $ entryLink entryId,
+    Description $ T.unpack text,
+    PubDate $ UTCTime edate $ secondsToDiffTime 0
+    ]
+
+entryLink :: EntryId -> URI
+entryLink i =
+  let url = "http://tazj.in/" ++ "/" ++ show i
+   in fromJust $ parseURI url
+
+createItems :: [Entry] -> [Item]
+createItems = map createItem
+
+createFeed :: [Entry] -> IO RSS
+createFeed e = getCurrentTime >>= (\t -> return $ createRSS t $ createItems e)
+
+renderFeed :: [Entry] -> IO String
+renderFeed e = fmap (showXML . rssToXML) (createFeed e)
diff --git a/services/tazblog/src/Server.hs b/services/tazblog/src/Server.hs
new file mode 100644
index 000000000000..40129988393b
--- /dev/null
+++ b/services/tazblog/src/Server.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Server where
+
+import Blog
+import BlogStore
+import Control.Applicative (optional)
+import Control.Monad (msum)
+import Control.Monad.IO.Class (liftIO)
+import Data.Maybe (maybe)
+import qualified Data.Text as T
+import Happstack.Server hiding (Session)
+import RSS
+
+pageSize :: Int
+pageSize = 3
+
+tmpPolicy :: BodyPolicy
+tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
+
+runBlog :: Int -> String -> IO ()
+runBlog port respath =
+  withCache "blog.tazj.in." $ \cache ->
+    simpleHTTP nullConf {port = port} $ tazblog cache respath
+
+tazblog :: BlogCache -> String -> ServerPart Response
+tazblog cache resDir =
+  msum
+    [ -- legacy language-specific routes
+      dir "de" $ blogHandler cache,
+      dir "en" $ blogHandler cache,
+      dir "static" $ staticHandler resDir,
+      blogHandler cache,
+      staticHandler resDir,
+      notFound $ toResponse $ showError "Not found" "Page not found"
+      ]
+
+blogHandler :: BlogCache -> ServerPart Response
+blogHandler cache =
+  msum
+    [ path $ \(eId :: Integer) -> showEntry cache $ EntryId eId,
+      nullDir >> showIndex cache,
+      dir "rss" $ nullDir >> showRSS cache,
+      dir "rss.xml" $ nullDir >> showRSS cache
+      ]
+
+staticHandler :: String -> ServerPart Response
+staticHandler resDir = do
+  setHeaderM "cache-control" "max-age=630720000"
+  setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
+  serveDirectory DisableBrowsing [] resDir
+
+showEntry :: BlogCache -> EntryId -> ServerPart Response
+showEntry cache eId = do
+  entry <- getEntry cache eId
+  tryEntry entry
+
+tryEntry :: Maybe Entry -> ServerPart Response
+tryEntry Nothing = notFound $ toResponse $ showError "Not found" "Blog entry not found"
+tryEntry (Just entry) = ok $ toResponse $ blogTemplate eTitle $ renderEntry entry
+  where
+    eTitle = T.append ": " (title entry)
+
+offset :: Maybe Int -> Int
+offset = maybe 0 (pageSize *)
+
+showIndex :: BlogCache -> ServerPart Response
+showIndex cache = do
+  (page :: Maybe Int) <- optional $ lookRead "page"
+  entries <- listEntries cache (offset page) pageSize
+  ok $ toResponse $ blogTemplate ""
+    $ renderEntries entries (Just $ showLinks page)
+
+showRSS :: BlogCache -> ServerPart Response
+showRSS cache = do
+  entries <- listEntries cache 0 4
+  feed <- liftIO $ renderFeed entries
+  setHeaderM "content-type" "text/xml"
+  ok $ toResponse feed