/
Post.hs
375 lines (290 loc) · 11.6 KB
/
Post.hs
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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE StandaloneDeriving #-}
module Snap.StaticPages.Internal.Post
( getTimeStamp
, parsePersons
, collectPosts
, recentPosts
, chronologicalPosts
, reverseChronologicalPosts
, alphabeticalPosts
, buildContentMap
, setEntryId
, setEntryTitle
, setEntryUpdated
, setEntryAuthors
, setEntrySummary
, setEntryHTMLContent
, setEntryContributor
, setEntryCategories
, setEntryLinks
, setEntryPublished
, setEntryRights
, setEntrySource
, setEntryInReplyTo
, setEntryInReplyTotal
, setEntryAttrs
, setEntryOther
)
where
------------------------------------------------------------------------
import Control.Applicative
import Control.Exception
import Control.Monad.Error
import qualified Data.Attoparsec.Text as Atto
import Data.Attoparsec.Text (Parser)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.UTF8 as UTF8
import Data.Char
import Data.List
import Data.List.Split
import qualified Data.Map as Map
import Data.Map (Map)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock
import Data.Time.LocalTime
import qualified Filesystem as F
import System.Directory
import System.FilePath
import Text.Atom.Feed
import Text.XML.Light
import Heist.Splices.Markdown
------------------------------------------------------------------------
import Snap.StaticPages.Internal.Time
import Snap.StaticPages.Internal.Types
import qualified Snap.StaticPages.Internal.Util.ExcludeList as EL
import Snap.StaticPages.Internal.Util.ExcludeList (ExcludeList)
------------------------------------------------------------------------
getTimeStamp :: FilePath -> IO UTCTime
getTimeStamp filePath = F.getModified $ fromString filePath
trim :: String -> String
trim = f . f where f = reverse . dropWhile isSpace
parsePersons :: String -> [Person]
parsePersons = map mkPerson . endBy ","
where
mkPerson s = Person x Nothing y []
where
(x,y) = parseOut s
parseOut s = (trim a, mb c)
where
mb x = if null x then Nothing else Just x
(a,b') = span (/= '<') s
b = drop 1 b'
(c,_) = span (/= '>') b
emptyPost :: String -> Date -> Post
emptyPost pId atm = Post $ nullEntry pId (HTMLString "") atm
{-
FIXME: REMOVE
parseHeaders :: String -> (Either Cfg.CPError Cfg.ConfigParser)
parseHeaders = Cfg.readstring Cfg.emptyCP
getKVP :: Cfg.ConfigParser -> String -> Maybe String
getKVP cp key = retval
where
e :: Either Cfg.CPError String
e = runIdentity . runErrorT $ Cfg.get cp "DEFAULT" key
retval = case e of Left _ -> Nothing
Right x -> Just x
-}
headerParser :: Parser [(Text,Text)]
headerParser = go id
where
endOfLine c = c == '\r' || c == '\n'
parseLine = do
!l <- Atto.takeWhile (not . endOfLine)
_ <- Atto.takeWhile endOfLine
return l
goLine = do
k <- Atto.takeWhile (\c -> c /= ':' && not (endOfLine c))
_ <- Atto.takeWhile1 (== ':')
v <- Atto.takeWhile (not . endOfLine)
_ <- Atto.takeWhile endOfLine
continue (T.strip k) (T.strip v)
continue !k !v = (Atto.try $ do
_ <- Atto.takeWhile1 isSpace
l <- parseLine
continue k (T.concat [ v, " ", T.strip l ]))
<|> return (k,v)
go !dlist = do
end <- Atto.atEnd
if end
then return $! dlist []
else do
(k,v) <- goLine
go (dlist . ((T.toLower k, v):))
stringToHeaders :: ByteString -> IO (Map Text Text)
stringToHeaders bsHdrs =
liftM Map.fromList $
either (throwIO . StaticPagesException . formatMsg)
return
(Atto.parseOnly headerParser txtHdrs)
where
formatMsg s = concat [ "Error parsing headers: "
, s
, "\nHeaders were:\n"
, T.unpack txtHdrs ]
txtHdrs = T.decodeUtf8 bsHdrs
headerTable :: [(String, String -> Post -> Post)]
headerTable = [ ("title", setEntryTitle)
, ("author", setEntryAuthors)
, ("authors" , setEntryAuthors)
, ("summary", setEntrySummary)
, ("updated", setEntryUpdated)
, ("published", setEntryPublished . Just) ]
-- break the post apart at the header ender, strip the prefix chars
-- off of the header, return both
breakPost :: B.ByteString -> (B.ByteString, B.ByteString)
breakPost s = (B.unlines hdr, B.unlines body)
where
chomp x = if "| " `B.isPrefixOf` x
then B.drop 2 x
else if "|" `B.isPrefixOf` x
then B.drop 1 x
else x
lns = B.lines s
(hdr', body) = span ("|" `B.isPrefixOf`) lns
hdr = chomp `map` hdr'
parseHeaders :: ByteString -- ^ headers
-> [(String, String -> Post -> Post)] -- ^ header table
-> Post
-> IO Post
parseHeaders str table post = do
kvps <- stringToHeaders str
return $ foldl (\p (k,f) -> case Map.lookup (T.pack k) kvps of
Nothing -> p
Just x -> f (T.unpack x) p)
post
table
readPost :: String -> FilePath -> IO Post
readPost pId path = do
!tz <- getCurrentTimeZone
!t <- getTimeStamp path
let !atm = formatAtomTime tz t
!contents <- B.readFile path
let (hdr,body) = breakPost contents
!post <- parseHeaders hdr headerTable $ emptyPost pId atm
mbPandocpath <- findExecutable "pandoc"
pandocpath <- maybe
(throwIO (StaticPagesException "pandoc executable not found"))
return
mbPandocpath
html <- pandocBS pandocpath body
return $! setEntryHTMLContent (UTF8.toString html)
$! setEntryLinks [ (nullLink pId) {
linkRel = Just $ Left "alternate"
} ]
$! post
collectPosts :: ExcludeList -> ContentMap -> [Post]
collectPosts el m = help el ("", ContentDirectory "" m)
where
-- don't count posts named "index" -- they're there to provide
-- text for directory indices
help :: ExcludeList -> (ByteString, ContentItem) -> [Post]
help s (nm, ContentPost p) =
if nm == "index" || EL.matches nm s then [] else [p]
help s (nm, ContentDirectory _ cm) =
if not $ EL.matches nm s
then concatMap (help (EL.descend nm s)) $ Map.assocs cm
else []
help _ _ = []
recentPosts :: ExcludeList -> ContentMap -> Int -> [Post]
recentPosts sl m nposts =
take nposts $ reverseChronologicalPosts sl m
chronologicalPosts :: ExcludeList -> ContentMap -> [Post]
chronologicalPosts sl m =
sortBy cmp $ collectPosts sl m
where
pt = zonedTimeToUTC . getPostTime
cmp a b = pt a `compare` pt b
reverseChronologicalPosts :: ExcludeList -> ContentMap -> [Post]
reverseChronologicalPosts = (reverse .) . chronologicalPosts
alphabeticalPosts :: ExcludeList -> ContentMap -> [Post]
alphabeticalPosts sl m = sortBy cmp $ collectPosts sl m
where
cmp (Post a) (Post b) = entryId a `compare` entryId b
buildContentMap :: String -> FilePath -> IO ContentMap
buildContentMap baseURL basedir = build [] "."
where
build :: [String] -> FilePath -> IO ContentMap
build prefixes path = do
files <- getDirectoryContents $ basedir </> path
foldM processFile Map.empty files
where
----------------------------------------------------------------
pathSoFar :: FilePath
pathSoFar = intercalate "/" prefixes
----------------------------------------------------------------
processFile :: ContentMap -> FilePath -> IO ContentMap
processFile mp f =
if "." `isPrefixOf` f || "~" `isSuffixOf` f then
return mp
else do
isDir <- doesDirectoryExist $ basedir </> pathSoFar </> f
if isDir then dir mp f else file mp f
----------------------------------------------------------------
dir :: ContentMap -> FilePath -> IO ContentMap
dir mp f = do
let fp = if null pathSoFar then f else concat [pathSoFar, "/", f]
let fullPath = B.pack (concat [baseURL, "/", fp])
!cm <- build (prefixes ++ [f]) fp
return $! Map.insert (B.pack f)
(ContentDirectory fullPath cm)
mp
----------------------------------------------------------------
file :: ContentMap -> FilePath -> IO ContentMap
file mp f = do
let fp = basedir </> pathSoFar </> f
if ".md" `isSuffixOf` f then do
-- it's a post
let baseName = dropExtension f
let pId = if null pathSoFar
then concat [baseURL, "/", baseName]
else concat [baseURL, "/", pathSoFar, "/", baseName]
!p <- readPost pId fp
return $! Map.insert (B.pack baseName) (ContentPost p) mp
else
-- it's a static item
return $! Map.insert (B.pack f) (ContentStatic fp) mp
------------------------------------------------------------------------
-- mutator functions for post objects
setEntryId :: String -> Post -> Post
setEntryId x (Post p) = Post $ p { entryId = x }
setEntryTitle :: String -> Post -> Post
setEntryTitle x (Post p) = Post $ p { entryTitle = TextString x }
--setEntryUpdated :: TimeZone -> UTCTime -> Post -> Post
--setEntryUpdated tz tm (Post p) = Post $ p { entryUpdated = formatAtomTime tz tm }
setEntryUpdated :: String -> Post -> Post
setEntryUpdated tm (Post p) = Post $ p { entryUpdated = tm }
setEntryAuthors :: String -> Post -> Post
setEntryAuthors x (Post p) = Post $ p { entryAuthors = parsePersons x }
setEntrySummary :: String -> Post -> Post
setEntrySummary x (Post p) = Post $ p { entrySummary = Just $ HTMLString x }
setEntryHTMLContent :: String -> Post -> Post
setEntryHTMLContent x (Post p) = Post $ p { entryContent = Just $ HTMLContent x }
setEntryContributor :: String -> Post -> Post
setEntryContributor x (Post p) = Post $ p { entryContributor = parsePersons x }
-- doubt we'll be using these for now
setEntryCategories :: [Category] -> Post -> Post
setEntryCategories x (Post p) = Post $ p { entryCategories = x }
setEntryLinks :: [Link] -> Post -> Post
setEntryLinks x (Post p) = Post $ p { entryLinks = x }
setEntryPublished :: Maybe Date -> Post -> Post
setEntryPublished x (Post p) = Post $ p { entryPublished = x }
setEntryRights :: Maybe TextContent -> Post -> Post
setEntryRights x (Post p) = Post $ p { entryRights = x }
setEntrySource :: Maybe Source -> Post -> Post
setEntrySource x (Post p) = Post $ p { entrySource = x }
setEntryInReplyTo :: Maybe InReplyTo -> Post -> Post
setEntryInReplyTo x (Post p) = Post $ p { entryInReplyTo = x }
setEntryInReplyTotal :: Maybe InReplyTotal -> Post -> Post
setEntryInReplyTotal x (Post p) = Post $ p { entryInReplyTotal = x }
setEntryAttrs :: [Attr] -> Post -> Post
setEntryAttrs x (Post p) = Post $ p { entryAttrs = x }
setEntryOther :: [Element] -> Post -> Post
setEntryOther x (Post p) = Post $ p { entryOther = x }