src/Lib.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Lib
   4     ( someFunc
   5     ) where
   6
   7 import Data.Function (on)
   8 import Data.List (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 stampsToEntryList :: [BlogEntry] -> EntryList
  37 stampsToEntryList stamps = reverse $ map (\(a,b) -> (a, reverse $ map (\(c,d) -> (c, map (\(x, y) -> ("0" `append` (fromString . show) x, y)) $ zip [1..] d)) b)) $
  38                            map (\(a, b) -> (a, myGroup b)) $
  39                            map (\(a, b) -> (a, concat b)) $ myGroup $
  40                            foldl (\c -> \v ->
  41                                      c ++ [(format (postDate v) "%Y", [(format (postDate v) "%B", v)])]) [] stamps
  42
  43 entryListToPaths :: EntryList -> [Text]
  44 entryListToPaths el = concat $ concat $ map (\(year, months)
  45                                      -> map (\(month, entries)
  46                                              -> map (\(entryNum, entry) ->
  47                                                        year `append`
  48                                                        "/" `append`
  49                                                        month) entries) months) el
  50
  51 entryListToIndex :: EntryList -> Text
  52 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
  53
  54 i2t :: Integer -> Text
  55 i2t = (fromString . show)
  56
  57 slugify = toLower. replace " " "-"
  58 urlify = slugify . replace "?" ""
  59
  60 timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8)
  61
  62 entryToMarkup entry template = toStrict $ render template tmplContext
  63   where
  64     tmplContext = context $ [("title", title entry), ("date", timeStampToDateString $ postDate entry), ("body", body entry)] ++
  65       case video entry of
  66         Nothing -> []
  67         Just a -> [("video", a)]
  68
  69 wrapInTags :: Text -> [Text] -> Text
  70 wrapInTags tag = foldMap $ (<> close) . (open <>)
  71   where  close = "</" `append` tag `append` ">"
  72          open = "<" `append` tag `append` ">"
  73
  74 paragraphs = wrapInTags "p"
  75
  76 unorderedList :: Maybe Text -> [Text] -> Text
  77 unorderedList heading items = case heading of
  78   Just x -> x `append` unorderedList Nothing items
  79   Nothing -> "<ul>" `append` (wrapInTags "li" items) `append` "</ul>"
  80
  81 rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (unpack $ meta !! 0)))) (meta !! 1) (paragraphs (snd (splitAt 1 fileLines))) (lookup 2 metaMap)
  82   where
  83     metaMap = zip [0..] meta
  84     meta = splitOn "::" (fileLines !! 0)
  85     fileLines = lines rawEntry
  86
  87 allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(filter(/= ".gitignore"))<$>(getDirectoryContents dir)
  88
  89 exportEntry entry = do
  90   rawTemplateNormal <- readFile "templates/entry.html"
  91   rawTemplateVideo <- readFile "templates/entry-video.html"
  92
  93   let entryTemplate = template . pack $ case (video entry) of
  94         Nothing -> rawTemplateNormal
  95         Just a -> rawTemplateVideo
  96
  97   writeFile (unpack $ intercalate "/" [
  98                 "build",
  99                 format (postDate entry) "%Y",
 100                 format (postDate entry) "%B",
 101                 urlify (title entry) `append` ".html"]) $ unpack $ entryToMarkup entry entryTemplate
 102
 103 exportIndex :: EntryList -> IO()
 104 exportIndex entryList = do
 105   rawTemplate <- readFile "templates/index.html"
 106
 107   let indexTemplate = template . pack $ rawTemplate
 108   let indexContext = context [("index", entryListToIndex entryList)]
 109
 110   writeFile "build/index.html" $ unpack $ toStrict $ render indexTemplate indexContext
 111
 112 someFunc = do
 113   files <- allFilesIn "entries"
 114   rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files
 115   entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries
 116   entryPaths <- return $ entryListToPaths $ stampsToEntryList entryList
 117   mapM_ (createDirectoryIfMissing True . ("build/" ++) . unpack) entryPaths
 118   mapM_ exportEntry entryList
 119   exportIndex $ stampsToEntryList entryList
 120
 121 context :: [(Text, Text)] -> Context
 122 context assocs x = case lookup x $ assocs of
 123                      Nothing -> "lol could not find that " `append` x
 124                      Just a -> a