diff options
| -rw-r--r-- | README.md | 4 | ||||
| -rw-r--r-- | Types.hs | 60 | ||||
| -rw-r--r-- | reploy.cabal (renamed from pagedeploy.cabal) | 2 | ||||
| -rw-r--r-- | site.hs | 98 |
4 files changed, 113 insertions, 51 deletions
diff --git a/README.md b/README.md new file mode 100644 index 0000000..4360aa4 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ + +# reploy + +A redo of deployment of R3 sites. diff --git a/Types.hs b/Types.hs new file mode 100644 index 0000000..8e842f4 --- /dev/null +++ b/Types.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Separated-out main types of the deployment scriptage. +module Types where + +import Control.Monad.Trans.State.Lazy +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Yaml as Y +import Lens.Micro.TH +import qualified Text.Mustache as Mu +import qualified Text.Pandoc.Definition + +-- | Information about a single deployed page (with metadata etc). +data PageInfo = + PageInfo + { _pagePath :: FilePath -- ^ original path to the markdown file + , _pageMeta :: Y.Value -- ^ YAML metadata extracted from the file + , _pagePandoc :: Text.Pandoc.Definition.Pandoc -- ^ Page data + } + deriving (Show) + +makeLenses ''PageInfo + +-- | Complete internal state of the deployment process that holds all data +data SiteState = + SiteState + -- | Map of page mounts to `PageInfo` + { _pages :: M.Map FilePath PageInfo + -- | Map of redirects (from -> to) + , _redirects :: M.Map FilePath FilePath + -- | Map of tags, assigning to each tag sequence a list of + -- tagged page mounts + , _htags :: M.Map [String] [FilePath] + -- | List of installed files (prevents overwriting) + , _installs :: S.Set FilePath + -- | Map of Mustache templates organized by template search path (within + -- the template directory) + , _templates :: M.Map FilePath Mu.Template + , _outputDir :: FilePath -- ^ Directory for output + , _defaultTemplate :: FilePath -- ^ Name of the default template + } + deriving (Show) + +makeLenses ''SiteState + +-- | Make a completely empty `SiteState` for the `Site` monad. +emptySiteState = + SiteState + { _pages = M.empty + , _redirects = M.empty + , _htags = M.empty + , _installs = S.empty + , _templates = M.empty + , _outputDir = "_site" + , _defaultTemplate = "default.html" + } + +-- | Monad for running the site generator. +type Site a = StateT SiteState IO a diff --git a/pagedeploy.cabal b/reploy.cabal index 124e55f..ee413b6 100644 --- a/pagedeploy.cabal +++ b/reploy.cabal @@ -5,6 +5,7 @@ cabal-version: >= 1.10 executable site main-is: site.hs + other-modules: Types build-depends: base == 4.* , containers , data-default @@ -18,6 +19,7 @@ executable site , mustache , pandoc , pandoc-types + , parsec , text , transformers , yaml @@ -1,6 +1,8 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +-- | The main deployment script. +module Main where + import Control.Monad (unless, when) import Control.Monad.IO.Class import Control.Monad.Trans.State.Lazy @@ -19,63 +21,31 @@ import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories) import Lens.Micro import Lens.Micro.Aeson import Lens.Micro.Mtl -import Lens.Micro.TH import System.Environment (getArgs) import System.FilePath ((</>), splitPath) import qualified Text.Mustache as Mu +import qualified Text.Parsec.Error import Text.Pandoc.Class (runIOorExplode) -import qualified Text.Pandoc.Definition import qualified Text.Pandoc.Extensions import Text.Pandoc.Options (ReaderOptions(..)) import Text.Pandoc.Readers.Markdown (readMarkdown) -import Debug.Trace +import Types +-- | A shortcut for `liftIO`. io :: MonadIO m => IO a -> m a io = liftIO +-- | A helper for throwing an error if something is `Nothing` +just :: String -> Maybe a -> a just _ (Just val) = val just err Nothing = error ("Missing: " ++ err) -data PageInfo = - PageInfo - { _pagePath :: FilePath - , _pageMeta :: Y.Value - , _pagePandoc :: Text.Pandoc.Definition.Pandoc - } - deriving (Show) - -makeLenses ''PageInfo - -data SiteState = - SiteState - { _pages :: M.Map FilePath PageInfo - , _redirects :: M.Map FilePath FilePath -- from -> to - , _htags :: M.Map [String] [FilePath] -- tag sequence -> tagged locs - , _installs :: M.Map FilePath FilePath -- file hash -> install location - , _templates :: M.Map FilePath Mu.Template -- TODO mustache templates - , _outputDir :: FilePath - , _defaultTemplate :: FilePath - } - deriving (Show) - -makeLenses ''SiteState - -emptySiteState out = - SiteState - { _pages = M.empty - , _redirects = M.empty - , _htags = M.empty - , _installs = M.empty - , _templates = M.empty - , _outputDir = out - , _defaultTemplate = "default.html" - } - -type Site a = StateT SiteState IO a - +-- | Test for whether something listy has a suffix +hasSuffix :: Eq a => [a] -> [a] -> Bool hasSuffix s = isJust . stripSuffix s +-- | Load the pages from a directory and add them to `pages`. sourcePages :: FilePath -> Site () sourcePages fp = do links <- @@ -83,6 +53,7 @@ sourcePages fp = do getRecursiveContents (pure . const False) fp traverse_ loadPage (map (fp </>) links) +-- | Default markdown reading options for Pandoc. markdownReadOpts = def { readerExtensions = @@ -91,69 +62,94 @@ markdownReadOpts = Text.Pandoc.Extensions.pandocExtensions } +{- | Extract `PageInfo` about a single page and save it into `pages` in + - `SiteState`. -} loadPage :: FilePath -> Site () loadPage fp = do + io $ putStrLn $ "<<< " ++ fp txt <- io $ TIO.readFile fp + {- tear out the metadata manually -} (T.take 4 txt == "---\n") `unless` error ("metadata block start missing in " ++ fp) let (meta, markdown) = T.breakOn "\n---\n" (T.drop 4 txt) T.null meta `when` error ("metadata block bad in " ++ fp) + {- parse everything -} yml <- Y.decodeThrow $ Data.Text.Encoding.encodeUtf8 meta md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown) + {- find the main mount point for the page -} let mount = T.unpack . just ("mount point of " ++ fp) $ yml ^? key "title" . _String + {- save to the state -} pages %= M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pagePandoc = md} +-- | Find which template to use for rendering a page. pageTemplate :: PageInfo -> Site FilePath pageTemplate pi = do dt <- use defaultTemplate pure . maybe dt T.unpack $ pi ^? pageMeta . key "template" . _String +-- | Collect all templates required for rendering the currently loaded pages. pageTemplates :: Site [FilePath] pageTemplates = nub <$> (gets (^.. pages . traverse) >>= traverse pageTemplate) +compileTemplate :: FilePath -> FilePath -> Site (Either Text.Parsec.Error.ParseError Mu.Template) +compileTemplate templdir templ = io $ do + putStrLn $ "TTT " ++ (templdir </> templ) + Mu.automaticCompile [templdir] templ + +-- | Use a template set from a given directory. sourceTemplates :: FilePath -> Site () sourceTemplates templdir = do ts <- pageTemplates - templs' <- fmap sequence . traverse (io . Mu.automaticCompile [templdir]) $ ts + templs' <- fmap sequence . traverse (compileTemplate templdir) $ ts case templs' of Left err -> error $ "template compilation: " ++ show err Right templs -> templates .= M.fromList (zip ts templs) +-- | Find the path to the "index.html" of a given mount. indexFilename :: FilePath -> Site FilePath indexFilename mount = do od <- use outputDir pure (od </> mount </> "index.html") +-- | Render a page using the current template. installPage :: FilePath -> PageInfo -> Site () installPage mount pi = do - tname <- fromString <$> pageTemplate pi - templ <- use $ templates . to (M.! tname) + {- find the correct template and metadata -} + tname <- pageTemplate pi + templ <- use $ templates . to (M.! fromString tname) file <- indexFilename mount io $ do putStrLn $ ">>> " ++ file makeDirectories file TIO.writeFile file . Mu.substitute templ $ pi ^. pageMeta +{- | Install a file. Files are installed into a single shared location. That + - prevents file duplication and also gives a bit of control for where the + - files reside and what are their names. -} installFile :: FilePath -> Site FilePath installFile = undefined -makeRedirect :: FilePath -> FilePath -> Site () -makeRedirect = undefined +{- | Install a simple redirect handler page. -} +installRedirect :: FilePath -> FilePath -> Site () +installRedirect = undefined -makeRedirects :: Site () -makeRedirects = undefined +-- | Install all redirects required by pages. +installRedirects :: Site () +installRedirects = undefined +-- | Render a site for a given tag string. renderTag :: [String] -> Site () renderTag = undefined +-- | Render all tag sites. renderTags :: Site () renderTags = undefined -main = do - [targetDir] <- getArgs - flip runStateT (emptySiteState targetDir) $ do +-- | Build the whole site. +main = + flip runStateT emptySiteState $ do traverse sourcePages ["external"] sourceTemplates "templates" use pages >>= traverse (uncurry installPage) . M.assocs |