snix/services/tazblog/src/BlogStore.hs

-- |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.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module BlogStore(
  BlogCache,
  EntryId(..),
  Entry(..),
  withCache,
  listEntries,
  getEntry,
  show',
) where

import Data.Aeson ((.:), FromJSON(..), Value(Object), decodeStrict)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Text as T (Text, concat, pack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8')
import Data.Time (Day)
import Locales (BlogLang (..))
import Network.DNS (lookupTXT, DNSError)
import qualified Network.DNS.Resolver as R
import Data.ByteString.Base64 (decodeLenient)
import Data.List (sortBy)
import Data.Either (fromRight)

newtype EntryId = EntryId {unEntryId :: Integer}
  deriving (Eq, Ord, FromJSON)

instance Show EntryId where
  show = show . unEntryId

data Entry
  = Entry
      { entryId :: EntryId,
        lang    :: BlogLang,
        author  :: Text,
        title   :: Text,
        btext   :: Text,
        mtext   :: 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 $ either Left (Right . 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,
                               lang = EN,
                               author = "tazjin",
                               title = t,
                               btext = text,
                               mtext = "",
                               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)) . sequence .
        map (\r -> maybe (Left InvalidPosts) Right (decodeStrict r))
  in record >>= return . either (Left . DNS) toPosts