diff options
author | Vincent Ambo <tazjin@google.com> | 2019-12-20T20·18+0000 |
---|---|---|
committer | Vincent Ambo <tazjin@google.com> | 2019-12-20T20·18+0000 |
commit | 03bfe08e1dd9faf48b06cb146bfa446575cde88a (patch) | |
tree | 55317968922a9b2a01516f1b79527874df037517 /services/tazblog/src/BlogStore.hs | |
parent | e52eed3cd4f73779c2e7c350537fb346835ba9f3 (diff) |
chore: Significantly restructure folder layout r/237
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)
Diffstat (limited to 'services/tazblog/src/BlogStore.hs')
-rw-r--r-- | services/tazblog/src/BlogStore.hs | 182 |
1 files changed, 0 insertions, 182 deletions
diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs deleted file mode 100644 index 60ccd0b5a003..000000000000 --- a/services/tazblog/src/BlogStore.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# 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 |