1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
{-# 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 Locales (BlogLang (..))
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,
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
|
