Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 312 lines (243 sloc) 10.24 kb
8df94af @gregorycollins Blaaargh: first draft
authored
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5
b2af34e @gregorycollins Reorganize code and give haddock some love
authored
6 module Blaaargh.Internal.Post
8df94af @gregorycollins Blaaargh: first draft
authored
7 ( getTimeStamp
8 , parsePersons
9 , collectPosts
10 , recentPosts
11 , chronologicalPosts
12 , reverseChronologicalPosts
13 , alphabeticalPosts
14 , buildContentMap
15 , setEntryId
16 , setEntryTitle
17 , setEntryUpdated
18 , setEntryAuthors
19 , setEntrySummary
20 , setEntryHTMLContent
21 , setEntryContributor
22 , setEntryCategories
23 , setEntryLinks
24 , setEntryPublished
25 , setEntryRights
26 , setEntrySource
27 , setEntryInReplyTo
28 , setEntryInReplyTotal
29 , setEntryAttrs
30 , setEntryOther
31 )
32 where
33
34 ------------------------------------------------------------------------
35 import Control.Applicative
36 import Control.Monad.Error
37 import Control.Monad.Identity
38 import Control.Monad.State
39 import qualified Data.ByteString.Char8 as B
40 import Data.ByteString.Char8 (ByteString)
41 import Data.Char
42 import qualified Data.ConfigFile as Cfg
43 import Data.List
44 import Data.List.Split
45 import qualified Data.Map as Map
46 import Data.Maybe
47 import Data.Time.Clock
48 import Data.Time.Clock.POSIX
49 import Data.Time.LocalTime
50 import System.Directory
51 import System.FilePath
52 import System.IO
53 import System.Posix.Files
54 import Text.Atom.Feed
55 import qualified Text.Pandoc as Pandoc
56 import Text.Printf
57 import Text.XML.Light
58 ------------------------------------------------------------------------
b2af34e @gregorycollins Reorganize code and give haddock some love
authored
59 import Blaaargh.Internal.Time
60 import Blaaargh.Internal.Types
61 import qualified Blaaargh.Internal.Util.ExcludeList as EL
62 import Blaaargh.Internal.Util.ExcludeList (ExcludeList)
8df94af @gregorycollins Blaaargh: first draft
authored
63 ------------------------------------------------------------------------
64
65
66 getTimeStamp :: FilePath -> IO UTCTime
67 getTimeStamp file =
68 (posixSecondsToUTCTime . realToFrac)
69 <$> modificationTime
70 <$> getFileStatus file
71
72
73 trim :: String -> String
74 trim = f . f where f = reverse . dropWhile isSpace
75
76
77 parsePersons :: String -> [Person]
78 parsePersons = map mkPerson . endBy ","
79 where
80 mkPerson s = Person x Nothing y []
81 where
82 (x,y) = parseOut s
83
84 parseOut s = (trim a, mb c)
85 where
86 mb x = if null x then Nothing else Just x
87 (a,b') = span (/= '<') s
88 b = drop 1 b'
89 (c,_) = span (/= '>') b
90
91
92
93 parseHeaders :: String -> (Either Cfg.CPError Cfg.ConfigParser)
94 parseHeaders = Cfg.readstring Cfg.emptyCP
95
96
97 getKVP :: Cfg.ConfigParser -> String -> Maybe String
98 getKVP cp key = retval
99 where
100 e :: Either Cfg.CPError String
101 e = runIdentity . runErrorT $ Cfg.get cp "DEFAULT" key
102 retval = case e of Left _ -> Nothing
103 Right x -> Just x
104
105
106 headerTable :: [(String, String -> Post -> Post)]
107 headerTable = [ ("title", setEntryTitle)
108 , ("author", setEntryAuthors)
109 , ("authors" , setEntryAuthors)
110 , ("summary", setEntrySummary)
111 , ("updated", setEntryUpdated)
112 , ("published", setEntryPublished . Just) ]
113
114
115 -- break the post apart at the header ender, strip the prefix chars
116 -- off of the header, return both
117 breakPost :: B.ByteString -> (B.ByteString, B.ByteString)
118 breakPost s = (B.unlines hdr, B.unlines body)
119 where
120 chomp x = if "| " `B.isPrefixOf` x
121 then B.drop 2 x
122 else if "|" `B.isPrefixOf` x
123 then B.drop 1 x
124 else x
125
126 lns = B.lines s
127 (hdr', body) = span ("|" `B.isPrefixOf`) lns
128 hdr = chomp `map` hdr'
129
130
131 readPost :: String -> FilePath -> IO Post
132 readPost pId path = do
133 !tz <- getCurrentTimeZone
134 !t <- getTimeStamp path
135 let !atm = formatAtomTime tz t
136
137 !contents <- B.readFile path
138
139 let (hdr,body) = breakPost contents
140
141 let !hdrS = B.unpack hdr
142
143 let !cfg = case parseHeaders hdrS of
144 Left e -> error
145 $ printf "Couldn't parse headers from %s:\n%s"
146 path (show e)
147 Right r -> r
148
149 let !post = foldl (\p (k,f) ->
150 case getKVP cfg k of
151 Nothing -> p
152 Just x -> f x p)
153 (Post $ nullEntry pId (HTMLString "") atm)
154 headerTable
155
156 let !pstate = Pandoc.defaultParserState { Pandoc.stateSmart = True
157 , Pandoc.stateSanitizeHTML=True }
158 let !wopts = Pandoc.defaultWriterOptions { Pandoc.writerStandalone = False }
159 let !html = Pandoc.writeHtmlString wopts $ Pandoc.readMarkdown pstate $ B.unpack body
160
161 return $! setEntryHTMLContent html
162 $! setEntryLinks [ (nullLink pId) {
163 linkRel = Just $ Left "alternate"
164 } ]
165 $! post
166
167
168
169 collectPosts :: ExcludeList -> ContentMap -> [Post]
170 collectPosts el m = help el ("", ContentDirectory "" m)
171 where
172 -- don't count posts named "index" -- they're there to provide
173 -- text for directory indices
174 help :: ExcludeList -> (ByteString, ContentItem) -> [Post]
175 help s (nm, ContentPost p) =
176 if nm == "index" || EL.matches nm s then [] else [p]
177 help s (nm, ContentDirectory _ cm) =
178 if not $ EL.matches nm s
179 then concatMap (help (EL.descend nm s)) $ Map.assocs cm
180 else []
181 help _ _ = []
182
183
184 recentPosts :: ExcludeList -> ContentMap -> Int -> [Post]
185 recentPosts sl m nposts =
186 take nposts $ reverseChronologicalPosts sl m
187
188
189 chronologicalPosts :: ExcludeList -> ContentMap -> [Post]
190 chronologicalPosts sl m =
191 sortBy cmp $ collectPosts sl m
192 where
193 pt = zonedTimeToUTC . getPostTime
194
195 cmp a b = pt a `compare` pt b
196
197
198 reverseChronologicalPosts :: ExcludeList -> ContentMap -> [Post]
199 reverseChronologicalPosts = (reverse .) . chronologicalPosts
200
201
202 alphabeticalPosts :: ExcludeList -> ContentMap -> [Post]
203 alphabeticalPosts sl m = sortBy cmp $ collectPosts sl m
204 where
205 cmp (Post a) (Post b) = entryId a `compare` entryId b
206
207
72a0bf1 @gregorycollins Cleanup imports/exports/warnings
authored
208 buildContentMap :: String -> FilePath -> IO ContentMap
209 buildContentMap baseURL basedir = build [] "."
8df94af @gregorycollins Blaaargh: first draft
authored
210 where
211 build :: [String] -> FilePath -> IO ContentMap
212 build prefixes path = do
213 files <- getDirectoryContents $ basedir </> path
214
215 foldM processFile Map.empty files
216
217 where
218 ----------------------------------------------------------------
219 pathSoFar :: FilePath
220 pathSoFar = intercalate "/" prefixes
221
222 ----------------------------------------------------------------
223 processFile :: ContentMap -> FilePath -> IO ContentMap
224 processFile mp f =
225 if "." `isPrefixOf` f || "~" `isSuffixOf` f then
226 return mp
227 else do
228 isDir <- doesDirectoryExist $ basedir </> pathSoFar </> f
229 if isDir then dir mp f else file mp f
230
231 ----------------------------------------------------------------
232 dir :: ContentMap -> FilePath -> IO ContentMap
233 dir mp f = do
234 let fp = if null pathSoFar then f else concat [pathSoFar, "/", f]
235 let fullPath = B.pack (concat [baseURL, "/", fp])
236 !cm <- build (prefixes ++ [f]) fp
237 return $! Map.insert (B.pack f)
238 (ContentDirectory fullPath cm)
239 mp
240
241 ----------------------------------------------------------------
242 file :: ContentMap -> FilePath -> IO ContentMap
243 file mp f = do
244 let fp = basedir </> pathSoFar </> f
245
246 if ".md" `isSuffixOf` f then do
247 -- it's a post
248 let baseName = dropExtension f
249 let pId = concat [baseURL, "/", pathSoFar, "/", baseName]
250 !p <- readPost pId fp
251 return $! Map.insert (B.pack baseName) (ContentPost p) mp
252 else
253 -- it's a static item
254 return $! Map.insert (B.pack f) (ContentStatic fp) mp
255
256
257
258 ------------------------------------------------------------------------
259 -- mutator functions for post objects
260 setEntryId :: String -> Post -> Post
261 setEntryId x (Post p) = Post $ p { entryId = x }
262
263 setEntryTitle :: String -> Post -> Post
264 setEntryTitle x (Post p) = Post $ p { entryTitle = TextString x }
265
266 --setEntryUpdated :: TimeZone -> UTCTime -> Post -> Post
267 --setEntryUpdated tz tm (Post p) = Post $ p { entryUpdated = formatAtomTime tz tm }
268
269 setEntryUpdated :: String -> Post -> Post
270 setEntryUpdated tm (Post p) = Post $ p { entryUpdated = tm }
271
272 setEntryAuthors :: String -> Post -> Post
273 setEntryAuthors x (Post p) = Post $ p { entryAuthors = parsePersons x }
274
275 setEntrySummary :: String -> Post -> Post
276 setEntrySummary x (Post p) = Post $ p { entrySummary = Just $ HTMLString x }
277
278 setEntryHTMLContent :: String -> Post -> Post
279 setEntryHTMLContent x (Post p) = Post $ p { entryContent = Just $ HTMLContent x }
280
281 setEntryContributor :: String -> Post -> Post
282 setEntryContributor x (Post p) = Post $ p { entryContributor = parsePersons x }
283
284
285 -- doubt we'll be using these for now
286 setEntryCategories :: [Category] -> Post -> Post
287 setEntryCategories x (Post p) = Post $ p { entryCategories = x }
288
289 setEntryLinks :: [Link] -> Post -> Post
290 setEntryLinks x (Post p) = Post $ p { entryLinks = x }
291
292 setEntryPublished :: Maybe Date -> Post -> Post
293 setEntryPublished x (Post p) = Post $ p { entryPublished = x }
294
295 setEntryRights :: Maybe TextContent -> Post -> Post
296 setEntryRights x (Post p) = Post $ p { entryRights = x }
297
298 setEntrySource :: Maybe Source -> Post -> Post
299 setEntrySource x (Post p) = Post $ p { entrySource = x }
300
301 setEntryInReplyTo :: Maybe InReplyTo -> Post -> Post
302 setEntryInReplyTo x (Post p) = Post $ p { entryInReplyTo = x }
303
304 setEntryInReplyTotal :: Maybe InReplyTotal -> Post -> Post
305 setEntryInReplyTotal x (Post p) = Post $ p { entryInReplyTotal = x }
306
307 setEntryAttrs :: [Attr] -> Post -> Post
308 setEntryAttrs x (Post p) = Post $ p { entryAttrs = x }
309
310 setEntryOther :: [Element] -> Post -> Post
311 setEntryOther x (Post p) = Post $ p { entryOther = x }
Something went wrong with that request. Please try again.