Merge branch 'mk-howtocards-fixes' into 'master'

updates required for howto-cards

See merge request lcsb/sps/reploy!5

1 files changed, 152 insertions, 259 deletions

diff --git a/reploy.hs b/reploy.hs
index ca1b663..c29a81b 100644
--- a/reploy.hs
+++ b/reploy.hs
@@ -14,22 +14,21 @@
  - under the License.
  -}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
--- | The main site deployment executable.
+-- | The main site deployment executable module.
 module Main where
 
-import Control.Monad ((>=>), filterM, join, unless, when)
-import Control.Monad.Extra (ifM, whenM)
+import Control.Monad ((>=>), join, unless, when)
+import Control.Monad.Extra (whenM)
 import Control.Monad.Trans.State.Lazy
 import qualified Data.Aeson as AE
 import qualified Data.Aeson.Key as K
 import qualified Data.Aeson.KeyMap as KM
-import Data.Bool (bool)
 import qualified Data.ByteString.Lazy as B
 import Data.Digest.Pure.SHA (sha256, showDigest)
 import Data.Foldable (traverse_)
 import Data.List (inits, nub, sort)
-import Data.List.Extra (groupSort)
 import qualified Data.Map as M
 import qualified Data.Scientific
 import qualified Data.Set as S
@@ -47,9 +46,7 @@ import System.FilePath
   ( (</>)
   , isAbsolute
   , joinPath
-  , splitDirectories
   , splitFileName
-  , splitPath
   , takeDirectory
   , takeFileName
   )
@@ -63,23 +60,19 @@ import Text.Pandoc.Writers.HTML (writeHtml5String)
 import Text.Pandoc.Writers.Shared (toTableOfContents)
 import qualified Text.Parsec.Error
 
+import AesonUtils
 import FormatOpts
+import Tags
 import Types
 import Utils
 
--- | Check if a given path should be sourced or not
-isSourceablePath :: FilePath -> Site Bool
-isSourceablePath fp = do
-  notSource <- use notSourceDirs
-  pure $ (&&) <$> hasSuffix ".md" . last <*> not . any (`elem` notSource) . init $
-    splitDirectories fp
-
 -- | Load the pages from a directory and add them to `pages`.
 sourcePages :: FilePath -> Site ()
-sourcePages fp =
-  (io $ getRecursiveContents (pure . const False) fp) >>=
-  filterM isSourceablePath >>=
-  traverse_ (loadPage . (fp </>))
+sourcePages fp = sourcePaths fp go
+  where
+    go p
+      | hasSuffix ".md" (takeFileName p) = loadPage (fp </> p)
+      | otherwise = pure ()
 
 {- | Extract `PageInfo` about a single page and save it into `pages` in
  - `SiteState`. -}
@@ -147,7 +140,8 @@ sourceTemplates templdir = do
 indexFilename :: FilePath -> Site FilePath
 indexFilename mount = do
   od <- use outputDir
-  pure (od </> mount </> "index.html")
+  idxf <- use indexFile
+  pure (od </> mount </> idxf)
 
 -- | Check that the page was not rendered before, and add it to the rendered set
 checkTarget :: FilePath -> Site ()
@@ -157,22 +151,31 @@ checkTarget fp = do
     then error $ "colliding renders for page: " ++ fp
     else targets %= S.insert fp
 
--- | Prepend the root path to the given link
-rootUrl' :: FilePath -> FilePath -> FilePath
-rootUrl' root = (root </>) . unAbsolute
-
--- | Same as `rootUrl'` but conveniently in the monad
-rootUrl :: FilePath -> Site FilePath
-rootUrl fp = flip rootUrl' fp <$> use urlBase
-
--- | Like `rootUrl'` but also appends @index.html@ for systems that don't have
--- working directory indexes.
-rootPageUrl' :: FilePath -> Bool -> FilePath -> FilePath
-rootPageUrl' root index fp = bool id (</> "index.html") index $ rootUrl' root fp
-
--- | Convenient version of `rootPageUrl'`
-rootPageUrl :: FilePath -> Site FilePath
-rootPageUrl fp = rootPageUrl' <$> use urlBase <*> use appendUrlIndex <*> pure fp
+-- | Conjure a function that transforms absolute links to pages to full rooted
+-- URLs.
+rootedPageLink' :: Site (FilePath -> FilePath)
+rootedPageLink' = do
+  ub <- use urlBase
+  app <- use appendUrlIndex
+  if app
+    then do
+      idxf <- use indexFile
+      pure $ \x -> ub </> x </> idxf
+    else pure (ub </>)
+
+-- | Transform a link to page to a full rooted URL
+rootedPageLink :: FilePath -> Site FilePath
+rootedPageLink = (<*>) rootedPageLink' . pure
+
+-- | Conjure a function that transforms absolute links to files to rooted URLs.
+rootedLink' :: Site (FilePath -> FilePath)
+rootedLink' = do
+  ub <- use urlBase
+  pure (ub </>)
+
+-- | Transform a link to file to a rooted URL.
+rootedLink :: FilePath -> Site FilePath
+rootedLink = (<*>) rootedLink' . pure
 
 -- | Process a single link pointing out from a page.
 processLink :: FilePath -> FilePath -> Site String
@@ -181,67 +184,65 @@ processLink base l =
      "#"
     then pure l
     else if isAbsolute l
-           then rootPageUrl l
-           else installFile (base </> l) >>= rootUrl
-
--- | Get a mount point of the page into the correct location.
--- (Pages are currently mounted just to the root.)
-pageFilename :: FilePath -> Site FilePath
-pageFilename = indexFilename
+           then rootedPageLink l
+           else installFile (base </> l) >>= rootedLink
 
 -- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors
 checkedSubstitute :: Mu.Template -> MT.Value -> IO T.Text
 checkedSubstitute t v = do
   let (es, txt) = Mu.checkedSubstitute t v
   traverse_ (putStrLn . ("Error: " ++) . show) es
-  --null es `unless` error "template substitution problems"
+  null es `unless` error "template substitution problems!"
   pure txt
 
 -- | Add global information to page metadata for rendering (at this point just the url base)
 addGlobalMeta :: Y.Value -> Site MT.Value
 addGlobalMeta (Y.Object m) = do
   r <- use urlBase
-  i <- use appendUrlIndex
-  em <- use extraMeta
+  rt <- rootedLink'
+  rtp <- rootedPageLink'
   let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m
-  pure . Mu.object $ l ++ map (\(k, v) -> (T.pack k, Mu.toMustache v)) em ++
+  pure . Mu.object $ l ++
     [ ("root", Mu.toMustache $ T.pack r)
-    , ("rawRootUrl", Mu.overText $ T.pack . rootUrl' r . T.unpack)
-    , ("pageLink", Mu.overText $ T.pack . rootPageUrl' r i . T.unpack)
+    , ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack)
+    , ("pageLink", Mu.overText $ T.pack . rtp . T.unpack)
     ]
 
 -- | Get the expected timestamp file for a given filepath
-timestampFile :: FilePath -> Site FilePath
-timestampFile fp = do
-  sfx <- use timestampSuffix
+metadataFile :: FilePath -> Site FilePath
+metadataFile fp = do
+  sfx <- use metadataSuffix
   pure . uncurry (</>) . fmap (++ sfx) . splitFileName $ fp
 
--- | If a timestamp file for the page exists, add the timestamp metadata.
-addTimeMeta :: PageInfo -> Y.Value -> Site Y.Value
-addTimeMeta pi m'@(Y.Object m)
-  | "timestamp" `KM.member` m = pure m' -- do not overwrite the timestamp if present
-  | otherwise = do
-    tspath <- timestampFile $ pi ^. pagePath
-    io $
-      ifM
-        (doesFileExist tspath)
-        (do putStrLn $ "timestamp <- " ++ tspath
-            ts <- Y.String <$> TIO.readFile tspath
-            pure . Y.Object $ KM.insert "timestamp" ts m)
-        (pure m')
+-- | If an extra-metadata file exists, patch it over the current metadata.
+addExtraMeta :: PageInfo -> Y.Value -> Site Y.Value
+addExtraMeta pi m = do
+  metaPath <- metadataFile $ pi ^. pagePath
+  metaExists <- io $ doesFileExist metaPath
+  gem <- use extraMeta
+  objMerge gem <$>
+    if metaExists
+      then do
+        em' <- io $ Y.decodeFileEither metaPath
+        case em' of
+          Left pe ->
+            error $ "decoding " ++ metaPath ++ " failed: " ++
+            Y.prettyPrintParseException pe
+          Right em -> pure $ objMerge em m
+      else pure m
 
 -- | Add page-specific information to the metadata. In this instance, this just
--- expands the tags for rendering. Eventually would be nice to have the timestamps
--- and possibly other info sourced right here.
+-- expands the tags for rendering and continues by adding extra metadata via
+-- `addExtraMeta`.
 addPageMeta :: PageInfo -> Y.Value -> Site Y.Value
 addPageMeta pi (Y.Object m) = do
   htagMeta <-
-    traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
+    traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" .
     values .
     _String .
     to T.unpack .
-    to splitDirectories
-  addTimeMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
+    to splitTag
+  addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m
 
 -- | If viable for a page (by config), add the TOC field
 addTOC :: PageInfo -> Text.Pandoc.Definition.Pandoc -> Y.Value -> Site Y.Value
@@ -263,7 +264,7 @@ installPage :: FilePath -> PageInfo -> Site ()
 installPage mount pi = do
   tname <- pageTemplate pi
   templ <- use $ templates . to (M.! fromString tname)
-  file <- pageFilename mount
+  file <- indexFilename mount
   fixedUrlDoc <-
     walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
   checkTarget file
@@ -282,7 +283,7 @@ installPage mount pi = do
 {- | Install a simple redirect handler page. -}
 installRedirect :: FilePath -> FilePath -> Site ()
 installRedirect target' from = do
-  target <- rootPageUrl target'
+  target <- rootedPageLink target'
   tname <- use redirectTemplate
   templ <- use $ templates . to (M.! fromString tname)
   file <- indexFilename from
@@ -333,231 +334,123 @@ installFile fp = do
       copy fp file
   pure loc
 
--- | Simply copy a strictly named asset.
-installAsset :: FilePath -> Site ()
-installAsset fp = do
+-- | Simply copy an explicitly named asset in the given asset dir
+installAsset :: FilePath -> FilePath -> Site ()
+installAsset ad fp = do
   od <- use outputDir
-  ad <- use assetDir
   let [src, dst] = map (</> fp) [ad, od]
   checkTarget dst
   io $ do
-    putStrLn $ "A -> " ++ src ++ " -> " ++ dst
+    putStrLn $ "A " ++ src ++ " -> " ++ dst
     copy src dst
 
--- | Copy all files from asset directory.
-installAssets :: Site ()
-installAssets =
-  use assetDir >>=
-  (io . getRecursiveContents (pure . const False) >=> traverse_ installAsset)
-
--- | Load tag names from a directory and add them to `tagNames`.
-sourceTagnames :: FilePath -> Site ()
-sourceTagnames fp =
-  io
-    (map (fp </>) . filter ((== "tagnames.yml") . last . splitPath) <$>
-     getRecursiveContents (pure . const False) fp) >>=
-  traverse_ sourceTagnameFile
-
--- | Single item for `sourceTagnames`
-sourceTagnameFile :: FilePath -> Site ()
-sourceTagnameFile fp = do
-  yml' <-
-    io $ do
-      putStrLn $ "# <- " ++ fp
-      Y.decodeFileEither fp
-  case yml' of
-    Left err ->
-      error $ "Failed to load tagnames from " ++ fp ++ ": " ++ show err
-    Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String)
-      where add :: (KM.Key, String) -> Site ()
-            add (k, v) =
-              let go (Just ov) =
-                    if v == ov
-                      then Just ov
-                      else error
-                             ("conflicting tag names for tag " ++ K.toString k)
-                  go Nothing = Just v
-               in tagNames %= M.alter go (K.toString k)
-
--- | Find the humanized name for a tag piece
-getTagName :: String -> Site String
-getTagName t = handleEmpty . maybe t id <$> use (tagNames . to (M.!? t))
-  where
-    handleEmpty "" = "all"
-    handleEmpty x = x
-
--- | Get all tags from the pages of the site.
-sourceTags :: Site ()
-sourceTags = do
-  sgat <-
-    map
-      (second $ map splitDirectories .
-       (^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
-    M.assocs <$>
-    use pages
-  ehtags .= M.fromList (invExpandTags sgat)
-  htags .= M.fromList (invTags sgat)
-
--- | Organize a list of pages with hierarchical tags to a list with
--- hierarchical tags with pages attached; with tags implying parents.
-invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
-invExpandTags x =
-  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
-
--- | Like `invExpandTags` but without the expansion.
-invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
-invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl]
+-- | Copy all files from a given asset directory.
+installAssetDir :: FilePath -> Site ()
+installAssetDir ad =
+  io (getRecursiveContents (pure . const False) ad) >>=
+  traverse_ (installAsset ad)
 
--- | Get the destination for the tag page.
-tagFilename :: FilePath -> Site FilePath
-tagFilename tag = indexFilename $ "tag" </> tag
+-- | Copy all files from the asset directories.
+installAssets :: Site ()
+installAssets = use assetDirs >>= traverse_ installAssetDir
 
 -- | Get the destination for the tag page.
-listFilename :: FilePath -> Site FilePath
-listFilename tag = indexFilename $ "list" </> tag
-
--- | Fold the hierarchical tag bits to a slashed path.
-tagPath :: [String] -> FilePath
-tagPath = joinPath
+tagFilename :: [String] -> Site FilePath
+tagFilename = indexFilename . joinPath . ("tag" :)
 
 -- | Make a link to the tag page
 tagLink :: [String] -> Site FilePath
-tagLink = rootPageUrl . ("tag" </>) . tagPath
+tagLink = rootedPageLink . joinPath . ("tag" :)
 
--- | Fold the hierarchical tag bits to a slashed path.
-listPath :: [String] -> FilePath
-listPath = joinPath
+-- | Get the destination for the tag page.
+listFilename :: [String] -> Site FilePath
+listFilename = indexFilename . joinPath . ("list" :)
 
 -- | Make a link to the tag page
 listLink :: [String] -> Site FilePath
-listLink = rootPageUrl . ("list" </>) . listPath
-
--- | Make metadata for printing out a single hierarchical tag (all levels clickable)
-makeHTagMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value
-makeHTagMeta lf tag = do
-  links <- traverse lf (inits tag)
-  tags <- traverse getTagName ("" : tag)
-  pure . Y.array $
-    zipWith
-      (\t l -> Y.object [("tag", fromString t), ("href", fromString l)])
-      tags
-      links
+listLink = rootedPageLink . joinPath . ("list" :)
 
 -- | Make metadata for printing out a link to a page
-makePageLinkMeta :: FilePath -> Site Y.Value
-makePageLinkMeta mount = do
-  link <- rootPageUrl mount
+makePageLinkRenderMeta :: FilePath -> Site Y.Value
+makePageLinkRenderMeta mount = do
+  link <- rootedPageLink mount
   meta <- use $ pages . to (M.! mount) . pageMeta
-  pure $ Y.object [("href", fromString link), ("meta", meta)]
-
--- | Like `makeTagMeta`, but returns only plain YAML without the functions (in
--- outcome the result is easier to work with using the YAML machinery,
--- allowing this to recurse to itself).
-makeTagMeta' :: [String] -> Site Y.Value
-makeTagMeta' tag = do
-  taggedPages <- use $ htags . to (M.!? tag) . to (maybe [] id)
-  subtags <-
-    gets
-      (^.. ehtags . to M.keys . each . filtered (not . null) .
-           filtered ((== tag) . init))
-  htagMeta <- makeHTagMeta tagLink tag
-  subtagsMeta <- Y.array <$> traverse makeTagMeta' subtags
-  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
-  link <- tagLink tag
-  listlink <- listLink tag
-  tags <- Y.array . map fromString <$> traverse getTagName tag
   pure $
     Y.object
-      [ ("href", fromString link)
-      , ("tags", tags)
-      , ("htag", htagMeta)
-      , ("subtags", subtagsMeta)
-      , ("pages", pagesMeta)
-      , ("listhref", fromString listlink)
-      ]
-
--- | Create the complete metadata structure for the template that renders a given categorical tag pages
-makeTagMeta :: [String] -> Site MT.Value
-makeTagMeta tag = makeTagMeta' tag >>= addGlobalMeta
-
--- | Make metadata for printing out a single tag as-is, without levels
-makeHTagLinkMeta :: [String] -> Site Y.Value
-makeHTagLinkMeta tag = do
-  link <- listLink tag
-  tags <- Y.array . map fromString <$> traverse getTagName tag
-  pure $ Y.object [("href", fromString link), ("tags", tags)]
-
--- | Create the structure for rendering a complete listing of one hierarchical tag.
-makeListMeta :: [String] -> Site MT.Value
-makeListMeta tag = do
-  taggedPages <- use $ ehtags . to (M.! tag)
-  subtags <-
-    gets
-      (^.. ehtags . to M.keys . each . filtered (not . null) .
-           filtered ((== tag) . init))
-  htagMeta <- makeHTagMeta listLink tag
-  subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags
-  pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages
-  tl <- tagLink tag
-  addGlobalMeta $
-    Y.object
-      [ ("htag", htagMeta)
-      , ("subtags", subtagsMeta)
-      , ("pages", pagesMeta)
-      , ("taghref", fromString tl)
-      ]
-
--- | Render a site for a given tag string.
-renderTag :: [String] -> Site ()
-renderTag tag = do
-  tname <- use tagTemplate
-  templ <- use $ templates . to (M.! fromString tname)
-  file <- tagFilename (tagPath tag)
-  checkTarget file
-  meta <- makeTagMeta tag
-  io $ do
-    putStrLn $ "# -> " ++ file
-    makeDirectories file
-    checkedSubstitute templ meta >>= TIO.writeFile file
+      [("mount", fromString mount), ("href", fromString link), ("meta", meta)]
 
--- | Render all tag sites.
-renderTags :: Site ()
-renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag
+wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value
+wrapPagesMeta x linkname link =
+  Y.object [("pages", x), (fromString linkname, fromString link)]
 
--- | Render a site for a given tag string.
-renderList :: [String] -> Site ()
-renderList tag = do
-  tname <- use listTemplate
-  templ <- use $ templates . to (M.! fromString tname)
-  file <- listFilename (listPath tag)
+makeTagRenderMeta :: [String] -> Site Y.Value
+makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta
+  where
+    extra htag = do
+      meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag
+      wrapPagesMeta meta "listhref" <$> listLink htag
+
+makeListRenderMeta :: [String] -> Site Y.Value
+makeListRenderMeta =
+  htagRenderMetaWithSubtags
+    listLink
+    pr
+    (htagRenderMetaWithSubtags
+       listLink
+       (const $ pure (Y.object []))
+       (const $ pure Y.Null))
+  where
+    pr htag = do
+      meta <- allTaggedPagesRenderMeta makePageLinkRenderMeta htag
+      wrapPagesMeta meta "taghref" <$> tagLink htag
+
+-- | Parametrized render of a listing-style site.
+renderListing ::
+     String
+  -> ([String] -> Site FilePath)
+  -> ([String] -> Site MT.Value)
+  -> String
+  -> [String]
+  -> Site ()
+renderListing templName fileName makeMeta mark htag = do
+  templ <- (M.! fromString templName) <$> use templates
+  file <- fileName htag
   checkTarget file
-  meta <- makeListMeta tag
+  meta <- makeMeta htag
   io $ do
-    putStrLn $ "* -> " ++ file
+    putStrLn $ (mark ++ " -> " ++ file)
     makeDirectories file
     checkedSubstitute templ meta >>= TIO.writeFile file
 
--- | Render all tag sites.
-renderLists :: Site ()
-renderLists = use (ehtags . to M.keys) >>= traverse_ renderList
+renderTags = do
+  lt <- use tagTemplate
+  M.keys <$> use ehtags >>=
+    traverse_
+      (renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#")
+
+renderLists = do
+  lt <- use listTemplate
+  M.keys <$> use ehtags >>=
+    traverse_
+      (renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*")
 
 -- | Transform one mounted PageInfo to the base search data
-mkSearchData :: FilePath -> PageInfo -> Site [Y.Value]
-mkSearchData mount pi = do
-  link <- rootPageUrl mount
+makeSearchData :: FilePath -> PageInfo -> Site [Y.Value]
+makeSearchData mount pi = do
+  link <- rootedPageLink mount
   text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc)
-  let title = pi ^? pageMeta . key "title" . _String
-  -- TODO: unify retrieval of tags
+  let name = pi ^? pageMeta . key "name" . _String
+  -- TODO: unify retrieval of tags?
   let tags =
         sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack
-  tagnames <- traverse (traverse getTagName . splitDirectories) tags
+  tagnames <- traverse (traverse getTagGroupName . inits . splitTag) tags
   let tagarray = Y.array . map (Y.array . map fromString) $ tagnames
   if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool
     then pure []
     else pure $
          [ Y.object
              [ ("link", fromString link)
-             , ("title", maybe (fromString mount) Y.String title)
+             , ("name", maybe (fromString mount) Y.String name)
              , ("tags", tagarray)
              , ("text", Y.String text)
              ]
@@ -568,7 +461,7 @@ renderSearchData :: Site ()
 renderSearchData = use searchDataOut >>= traverse_ go
   where
     go out = do
-      ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData)
+      ps <- use (pages . to M.assocs) >>= traverse (uncurry makeSearchData)
       io $ do
         putStrLn $ "S -> " ++ out
         AE.encodeFile out $ Y.array (concat ps)
@@ -579,7 +472,7 @@ main = do
   flip runStateT init $ do
     installAssets
     use sourceDirs >>= traverse sourcePages
-    use sourceDirs >>= traverse sourceTagnames
+    use sourceDirs >>= traverse sourceTagMeta
     sourceTags
     use templateDir >>= sourceTemplates
     use pages >>= traverse (uncurry installPage) . M.assocs