diff options
Diffstat (limited to 'services/tazblog/src')
| -rw-r--r-- | services/tazblog/src/BlogStore.hs | 139 |
1 files changed, 119 insertions, 20 deletions
diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs index 17149ef86a8e..8fc47c84758d 100644 --- a/services/tazblog/src/BlogStore.hs +++ b/services/tazblog/src/BlogStore.hs @@ -15,6 +15,10 @@ -- -- 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(..), @@ -22,54 +26,149 @@ module BlogStore( withCache, listEntries, getEntry, + show', ) where -import Control.Monad.IO.Class (MonadIO) -import Data.Text (Text) -import Data.Time (UTCTime) +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.Lookup (lookupTXT) +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) +import Debug.Trace (trace) newtype EntryId = EntryId {unEntryId :: Integer} - deriving (Eq, Ord) + 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 :: UTCTime + 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 { resolver :: R.Resolver - , zone :: String } +data BlogCache = BlogCache R.Resolver Text -type Offset = Integer +data StoreError + = PostNotFound EntryId + | DNS DNSError + | InvalidMetadata + | InvalidChunk + | InvalidPosts + deriving (Show) -type Count = Integer +type Offset = Int -withCache :: String -> (BlogCache -> IO a) -> IO a +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 (BlogCache r z) offset count = undefined +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 $ trace (show entries) entries getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry) -getEntry (BlogCache r z) eId = undefined +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 |