first commit

exe/Config.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
+
+module Config where
+
+import Data.Aeson
+import Data.Text
+import GHC.Generics
+import System.FilePath
+import qualified Data.ByteString.Lazy as B
+
+data Config = Config
+   { confNumFront :: Int
+   , confNumRSS :: Int
+   , confTitle :: String
+   , confDesc :: String
+   , confAuthor :: String
+   , confEmail :: String
+   , confRoot :: String
+   } deriving (Show, Generic)
+
+instance FromJSON Config
+instance ToJSON Config
+
+configName :: FilePath
+configName = "config.json"
+
+getConfig :: FilePath -> IO Config
+getConfig dir = do
+   c <- (eitherDecode <$> (B.readFile (dir </> configName)))
+   case c of
+      Left e -> error e
+      Right conf -> return conf

exe/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import Options
+import Site
+
+import Options.Applicative
+
+main :: IO ()
+main = generateSite =<< execParser getOptions

exe/Options.hs

@@ -0,0 +1,82 @@
+module Options where
+
+import System.FilePath.Posix
+import Data.Maybe
+import Data.Semigroup ((<>))
+import Data.List.Predicate
+import Options.Applicative
+
+data Options = Options
+   { optIn    :: String
+   , optOut   :: String
+   , optTmp   :: String
+   , optStore :: String
+   }
+
+validateOptions :: Options -> Maybe [String]
+validateOptions opts =
+   case res of
+      [] -> Nothing
+      es -> Just es
+   where
+      res = catMaybes $ map (\f -> f opts) optionTests
+
+optionTests :: [(Options -> Maybe String)]
+optionTests = reverse
+   [ (validPath optIn "input")
+   , (validPath optOut "output")
+   , (validPath optTmp "temp")
+   , (validPath optStore "store")
+   , uniqPaths
+   ]
+
+validPath :: (Options -> String) -> String -> Options -> Maybe String
+validPath f n o =
+   if isValid (f o)
+   then Nothing
+   else Just $ "invalid " ++ n ++ " path: " ++ (f o)
+
+uniqPaths :: Options -> Maybe String
+uniqPaths o =
+   if allUnique $ pathList o
+   then Nothing
+   else Just $ "directories must be unique (i think)"
+   where
+      pathList o=
+         [ (optIn o)
+         , (optOut o)
+         , (optTmp o)
+         , (optStore o)
+         ]
+
+options :: Parser Options
+options = Options
+   <$> strOption
+       ( long "input"
+      <> short 'i'
+      <> metavar "DIR"
+      <> help "source input directory" )
+   <*> strOption
+       ( long "output"
+      <> short 'o'
+      <> metavar "DIR"
+      <> help "build output directory" )
+   <*> strOption
+       ( long "temp"
+      <> short 't'
+      <> metavar "DIR"
+      <> showDefault
+      <> value "./tmp"
+      <> help "temp directory (possibly unused)" )
+   <*> strOption
+       ( long "store"
+      <> short 's'
+      <> metavar "DIR"
+      <> showDefault
+      <> value "./store"
+      <> help "store directory (possibly unused)" )
+
+getOptions = info (options <**> helper)
+   ( fullDesc
+  <> progDesc "build a static site from a set of input files"
+  <> header "rf-hakyll - a static site generator" )

exe/Site.hs

@@ -0,0 +1,172 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Site where
+
+import Config
+import Options
+
+import Data.Maybe
+import Data.Monoid
+import Data.List
+import Data.Typeable
+import GHC.IO.Encoding
+import Hakyll
+import Hakyll.Favicon
+import System.FilePath.Posix
+import System.Exit
+import System.IO
+
+report :: [String] -> IO ()
+report es = do
+   hPutStrLn stderr "@ ERRORs @"
+   hPutStrLn stderr "----------"
+   mapM_ (hPutStrLn stderr) es
+   exitWith $ ExitFailure 1
+
+optionsToConfig :: Options.Options -> Configuration
+optionsToConfig c = defaultConfiguration
+   { destinationDirectory = (optOut c)
+   , storeDirectory = (optStore c)
+   , tmpDirectory = (optTmp c)
+   , providerDirectory = (optIn c)
+   }
+
+generateSite :: Options.Options -> IO ()
+generateSite opts = do
+   case validateOptions opts of
+      Just errs -> report errs
+      Nothing -> do
+         setLocaleEncoding utf8
+         feedConf <- getConfig (optIn opts)
+         let rfConf = optionsToConfig opts
+         hakyllWithArgs rfConf (Hakyll.Options True Rebuild) $ do
+
+            -- favicon generation
+            faviconsRules "icons/favicon.svg"
+
+            -- straight copy
+            match (fromList ["humans.txt", "robots.txt", "fonts/*"]) $ do
+               route idRoute
+               compile copyFileCompiler
+
+            -- css compilation + minification
+            match "css/*" $ do
+               route idRoute
+               compile compressCssCompiler
+
+            -- formatted pages
+            match (fromList ["about.md", "contact.md"]) $ do
+               route $ cleanRoute
+               compile $ pandocCompiler
+                  >>= loadAndApplyTemplate "templates/default.html" ctx
+                  >>= relativizeUrls
+                  >>= cleanIndexUrls
+
+            -- render atom + rss feeds
+            create ["atom.xml"] $ do
+               route idRoute
+               compileFeed feedConf renderAtom
+
+            create ["rss.xml"] $ do
+               route idRoute
+               compileFeed feedConf renderRss
+
+            -- template compilation
+            match "templates/*" $ compile templateBodyCompiler
+
+            -- archive page + post list compilation
+            match "archive.md" $ do
+               route $ cleanRoute
+               compile $ do
+                  posts <- recentFirst =<< loadAll "posts/*"
+                  let archiveCtx = listField "posts" postCtx (return posts) <> ctx
+                  pandocCompiler
+                     >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
+                     >>= loadAndApplyTemplate "templates/default.html" archiveCtx
+                     >>= relativizeUrls
+                     >>= cleanIndexUrls
+
+            -- post compilation
+            match "index.md" $ do
+               route $ setExtension "html"
+               compile $ pandocCompiler
+                  >>= loadAndApplyTemplate "templates/index.html" ctx
+                  >>= relativizeUrls
+                  >>= cleanIndexUrls
+
+               compile $ do
+                  posts <- (return . (take (confNumFront feedConf)))
+                           =<< recentFirst
+                           =<< loadAll "posts/*"
+                  let indexCtx = listField "posts" postCtx (return posts) <> ctx
+                  pandocCompiler
+                     >>= applyAsTemplate indexCtx
+                     >>= loadAndApplyTemplate "templates/index.html" indexCtx
+                     >>= loadAndApplyTemplate "templates/default.html" indexCtx
+                     >>= relativizeUrls
+                     >>= cleanIndexUrls
+
+            -- post compilation + snapshots for feeds
+            match "posts/*" $ do
+               route $ cleanRoute
+               compile $ pandocCompiler
+                  >>= loadAndApplyTemplate "templates/post.html" postCtx
+                  >>= saveSnapshot "content"
+                  >>= loadAndApplyTemplate "templates/default.html" postCtx
+                  >>= relativizeUrls
+                  >>= cleanIndexUrls
+                  >>= cleanIndexHtmls
+
+-- abstract feed creation
+compileFeed :: Config ->
+               (FeedConfiguration
+                  -> Context String
+                  -> [Item String]
+                  -> Compiler (Item String))
+               -> Rules ()
+compileFeed c f = compile $ do
+   let feedCtx = postCtx <> bodyField "description"
+   posts <- fmap (take (confNumRSS c)) . recentFirst
+      =<< loadAllSnapshots "posts/*" "content"
+   f (feedConfig c) feedCtx posts
+
+feedConfig :: Config -> FeedConfiguration
+feedConfig c = FeedConfiguration
+   { feedTitle = (confTitle c)
+   , feedDescription = (confDesc c)
+   , feedAuthorName = (confAuthor c)
+   , feedAuthorEmail = (confEmail c)
+   , feedRoot = (confRoot c)
+   }
+
+-- default context
+ctx :: Context String
+ctx = defaultContext <> faviconsField
+
+-- default post context
+postCtx :: Context String
+postCtx = (dateField "date" "%B %e, %Y") <> ctx
+
+-- cleaner urls
+cleanRoute :: Routes
+cleanRoute = customRoute createIndexRoute
+   where
+      createIndexRoute ident =
+         takeDirectory p </> takeBaseName p </> "index.html"
+            where p = toFilePath ident
+
+cleanIndexUrls :: Item String -> Compiler (Item String)
+cleanIndexUrls = return . fmap (withUrls cleanIndex)
+
+cleanIndexHtmls :: Item String -> Compiler (Item String)
+cleanIndexHtmls = return . fmap (replaceAll pattern replacement)
+   where
+      pattern = "/index.html"
+      replacement = const "/"
+
+cleanIndex :: String -> String
+cleanIndex url
+   | idx `isSuffixOf` url = take (length url - length idx) url
+   | otherwise = url
+   where
+      idx = "index.html"

rf-hakyll.cabal

@@ -0,0 +1,35 @@
+cabal-version: 1.12
+
+name:       rf-hakyll
+version:    0.0.0.1
+license:    MIT
+build-type: Simple
+
+synopsis: a static site generator
+description: the static site generator used to build "regular flolloping"
+homepage: <NA>
+
+author: Thorn Avery
+maintainer: ta@p7.co.nz
+
+executable rf-hakyll
+   main-is: Main.hs
+   ghc-options: -O2
+   hs-source-dirs:
+      exe
+   build-depends:
+      aeson
+    , base
+    , bytestring
+    , filepath
+    , hakyll
+    , hakyll-favicon
+    , list-predicate
+    , optparse-applicative
+    , process
+    , text
+   other-modules:
+      Options
+      Site
+      Config
+   default-language: Haskell2010