feat(tazblog): Implement entry fetching from DNS
Not all error cases are properly handled yet, stay tuned.
This commit is contained in:
parent
f298bdd183
commit
c5ef3e01b2
1 changed files with 119 additions and 20 deletions
|
@ -15,6 +15,10 @@
|
||||||
--
|
--
|
||||||
-- This module implements logic for assembling a post out of these
|
-- This module implements logic for assembling a post out of these
|
||||||
-- fragments and caching it based on the TTL of its `_meta` record.
|
-- fragments and caching it based on the TTL of its `_meta` record.
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
module BlogStore(
|
module BlogStore(
|
||||||
BlogCache,
|
BlogCache,
|
||||||
EntryId(..),
|
EntryId(..),
|
||||||
|
@ -22,54 +26,149 @@ module BlogStore(
|
||||||
withCache,
|
withCache,
|
||||||
listEntries,
|
listEntries,
|
||||||
getEntry,
|
getEntry,
|
||||||
|
show',
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Data.Aeson ((.:), FromJSON(..), Value(Object), decodeStrict)
|
||||||
import Data.Text (Text)
|
import Control.Applicative ((<$>), (<*>))
|
||||||
import Data.Time (UTCTime)
|
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 Locales (BlogLang (..))
|
||||||
import Network.DNS.Lookup (lookupTXT)
|
import Network.DNS (lookupTXT, DNSError)
|
||||||
import qualified Network.DNS.Resolver as R
|
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}
|
newtype EntryId = EntryId {unEntryId :: Integer}
|
||||||
deriving (Eq, Ord)
|
deriving (Eq, Ord, FromJSON)
|
||||||
|
|
||||||
instance Show EntryId where
|
instance Show EntryId where
|
||||||
|
|
||||||
show = show . unEntryId
|
show = show . unEntryId
|
||||||
|
|
||||||
data Entry
|
data Entry
|
||||||
= Entry
|
= Entry
|
||||||
{ entryId :: EntryId,
|
{ entryId :: EntryId,
|
||||||
lang :: BlogLang,
|
lang :: BlogLang,
|
||||||
author :: Text,
|
author :: Text,
|
||||||
title :: Text,
|
title :: Text,
|
||||||
btext :: Text,
|
btext :: Text,
|
||||||
mtext :: Text,
|
mtext :: Text,
|
||||||
edate :: UTCTime
|
edate :: Day
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
-- | Wraps a DNS resolver with caching configured. For the initial
|
-- | Wraps a DNS resolver with caching configured. For the initial
|
||||||
-- version of this, all caching of entries is done by the resolver
|
-- version of this, all caching of entries is done by the resolver
|
||||||
-- (i.e. no pre-assembled versions of entries are cached).
|
-- (i.e. no pre-assembled versions of entries are cached).
|
||||||
data BlogCache
|
data BlogCache = BlogCache R.Resolver Text
|
||||||
= BlogCache { resolver :: R.Resolver
|
|
||||||
, zone :: String }
|
|
||||||
|
|
||||||
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
|
withCache zone f = do
|
||||||
let conf = R.defaultResolvConf { R.resolvCache = Just R.defaultCacheConf
|
let conf = R.defaultResolvConf { R.resolvCache = Just R.defaultCacheConf
|
||||||
, R.resolvConcurrent = True }
|
, R.resolvConcurrent = True }
|
||||||
seed <- R.makeResolvSeed conf
|
seed <- R.makeResolvSeed conf
|
||||||
R.withResolver seed $ (\r -> f $ BlogCache r zone)
|
R.withResolver seed $ (\r -> f $ BlogCache r zone)
|
||||||
|
|
||||||
|
|
||||||
listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
|
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 :: 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
|
||||||
|
|
Loading…
Reference in a new issue