From 03bfe08e1dd9faf48b06cb146bfa446575cde88a Mon Sep 17 00:00:00 2001 From: Vincent Ambo Date: Fri, 20 Dec 2019 20:18:41 +0000 Subject: chore: Significantly restructure folder layout This moves the various projects from "type-based" folders (such as "services" or "tools") into more appropriate semantic folders (such as "nix", "ops" or "web"). Deprecated projects (nixcon-demo & gotest) which only existed for testing/demonstration purposes have been removed. (Note: *all* builds are broken with this commit) --- web/tazblog/src/BlogStore.hs | 182 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 web/tazblog/src/BlogStore.hs (limited to 'web/tazblog/src/BlogStore.hs') diff --git a/web/tazblog/src/BlogStore.hs b/web/tazblog/src/BlogStore.hs new file mode 100644 index 000000000000..60ccd0b5a003 --- /dev/null +++ b/web/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 -- cgit 1.4.1