src/Lib.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Lib
   4     ( someFunc
   5     ) where
   6
   7 import Data.Function (on)
   8 import Data.List (sort, sortBy, groupBy)
   9 import Data.Ord (comparing)
  10 import Data.String hiding (lines)
  11 import Data.Text hiding (groupBy, map, concat, foldl, head, splitAt, filter, zip, length, reverse)
  12 import Data.Text.Lazy (toStrict)
  13 import Data.Text.Template
  14 import Data.Time.Clock
  15 import Data.Time.Clock.POSIX
  16 import Data.Time.Format
  17 import Data.Time.LocalTime
  18 import Prelude hiding (lines)
  19 import System.Directory
  20 import System.FilePath.Posix (takeBaseName)
  21
  22 data BlogEntry = BlogEntry {
  23   postDate :: UTCTime,
  24   title :: Text,
  25   body :: Text,
  26   video :: Maybe Text
  27   } deriving (Show)
  28
  29 type EntryList = [(Text, [(Text, [(Text, BlogEntry)])])]
  30
  31 format t format = fromString $ formatTime defaultTimeLocale format $ utcToLocalTime (hoursToTimeZone 8) t
  32
  33 myGroup :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
  34 myGroup = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst) . sortBy (comparing fst)
  35
  36 myGroupNoSort :: (Eq a, Ord a) => [(a, b)] -> [(a, [b])]
  37 myGroupNoSort = map (\l -> (fst . head $ l, map snd l)) . groupBy ((==) `on` fst)
  38
  39 stampsToEntryList :: [BlogEntry] -> EntryList
  40 stampsToEntryList stamps = map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, reverse $ map (\(x, y) -> ("0" `append` (fromString . show) x, y)) $ zip [1..] d)) b)) $
  41                            map (\(a, b) -> (a, myGroupNoSort b)) $
  42                            map (\(a, b) -> (a, concat b)) $ myGroupNoSort $
  43                            foldl (\c -> \v ->
  44                                      c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
  45
  46 entryListToPaths :: EntryList -> [Text]
  47 entryListToPaths el = concat $ concat $ map (\(year, months)
  48                                      -> map (\(month, entries)
  49                                              -> map (\(entryNum, entry) ->
  50                                                        year `append`
  51                                                        "/" `append`
  52                                                        month) entries) months) el
  53
  54 entryListToIndex :: EntryList -> Text
  55 entryListToIndex el = unorderedList Nothing $ map (\(year, monthList) -> unorderedList (Just year) $ map (\(month, entryList) -> unorderedList (Just month) $ map (\x -> "<a href=\"" <> year <> "/" <> month <> "/" <> ((urlify . title . snd) x) <>  ".html\">" <> (title . snd) x <> "</a>") entryList) monthList) el
  56
  57 i2t :: Integer -> Text
  58 i2t = (fromString . show)
  59
  60 slugify = toLower. replace " " "-"
  61 urlify = slugify . replace "?" ""
  62
  63 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
  64
  65 entryToMarkup entry template = toStrict $ render template tmplContext
  66   where
  67     tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
  68       case video entry of
  69         Nothing -> []
  70         Just a -> [("video", a)]
  71
  72 wrapInTags :: Text -> [Text] -> Text
  73 wrapInTags tag = foldMap $ (<> close) . (open <>)
  74   where  close = "</" `append` tag `append` ">"
  75          open = "<" `append` tag `append` ">"
  76
  77 paragraphs = wrapInTags "p"
  78
  79 unorderedList :: Maybe Text -> [Text] -> Text
  80 unorderedList heading items = case heading of
  81   Just x -> x `append` unorderedList Nothing items
  82   Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
  83
  84 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
  85   where
  86     metaMap = zip [0..] meta
  87     meta = splitOn "::" (fileLines !! 0)
  88     fileLines = lines rawEntry
  89
  90 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(filter(/= ".gitignore"))<$>(getDirectoryContents dir)
  91
  92 exportEntry entry = do
  93   rawTemplateNormal <- readFile "templates/entry.html"
  94   rawTemplateVideo <- readFile "templates/entry-video.html"
  95
  96   let entryTemplate = template . pack $ case (video entry) of
  97         Nothing -> rawTemplateNormal
  98         Just a -> rawTemplateVideo
  99
 100   writeFile (unpack $ intercalate "/" [
 101                 "build",
 102                 format (postDate entry) "%Y",
 103                 format (postDate entry) "%B",
 104                 urlify (title entry) `append` ".html"]) $ unpack $ entryToMarkup entry entryTemplate
 105
 106 exportIndex :: EntryList -> IO()
 107 exportIndex entryList = do
 108   rawTemplate <- readFile "templates/index.html"
 109
 110   let indexTemplate = template . pack $ rawTemplate
 111   let indexContext = context [("index", entryListToIndex entryList)]
 112
 113   writeFile "build/index.html" $ unpack $ toStrict $ render indexTemplate indexContext
 114
 115 someFunc = do
 116   files <- fmap (reverse . sort) $ allFilesIn "entries"
 117   rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
 118   entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
 119   entryPaths <- return $ entryListToPaths $ stampsToEntryList entryList
 120   mapM_ (createDirectoryIfMissing True . ("build/" ++) . unpack) entryPaths
 121   mapM_ exportEntry entryList
 122   exportIndex $ stampsToEntryList entryList
 123
 124 context :: [(Text, Text)] -> Context
 125 context assocs x = case lookup x $ assocs of
 126                      Nothing -> "lol could not find that " `append` x
 127                      Just a -> a