tags get sourced

3 files changed, 52 insertions, 11 deletions

diff --git a/Types.hs b/Types.hs
index 9dba9a4..72f81c7 100644
--- a/Types.hs
+++ b/Types.hs
@@ -33,13 +33,14 @@ data SiteState =
     -- tagged page mounts
     , _htags :: M.Map [String] [FilePath]
     -- | List of installed files (enables sharing)
-    , _installs :: S.Set FilePath
+    , _installs :: S.Set (String, FilePath)
     -- | List of installed files (prevents overwriting)
     , _targets :: 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
+    , _assetDir :: FilePath -- ^ Directory for output
     , _defaultTemplate :: FilePath -- ^ Name of the default template
     , _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages
     }
@@ -57,6 +58,7 @@ emptySiteState =
     , _targets = S.empty
     , _templates = M.empty
     , _outputDir = "_site"
+    , _assetDir = "assets"
     , _defaultTemplate = "default.html"
     , _redirectTemplate = "redirect.html"
     }
diff --git a/Utils.hs b/Utils.hs
index 2650d2e..c609262 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -16,3 +16,7 @@ just err Nothing = error ("Missing: " ++ err)
 -- | Test for whether something listy has a suffix
 hasSuffix :: Eq a => [a] -> [a] -> Bool
 hasSuffix s = isJust . stripSuffix s
+
+-- | The same second as from arrows et al.
+second :: (a -> b) -> (c, a) -> (c, b)
+second f (a, b) = (a, f b)
diff --git a/site.hs b/site.hs
index 8ab060f..2b489e9 100644
--- a/site.hs
+++ b/site.hs
@@ -3,13 +3,14 @@
 -- | The main deployment script.
 module Main where
 
-import Control.Monad (unless, when)
+import Control.Monad ((>=>), unless, when)
 import Control.Monad.Trans.State.Lazy
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Lazy as B
 import Data.Digest.Pure.SHA (sha256, showDigest)
 import Data.Foldable (traverse_)
-import Data.List (nub)
+import Data.List (inits, nub)
+import Data.List.Extra (groupSort)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.String (fromString)
@@ -21,7 +22,7 @@ import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories)
 import Lens.Micro
 import Lens.Micro.Aeson
 import Lens.Micro.Mtl
-import System.FilePath ((</>), splitPath, takeFileName)
+import System.FilePath ((</>), splitDirectories, splitPath, takeFileName)
 import qualified Text.Mustache as Mu
 import Text.Pandoc.Class (runIOorExplode)
 import Text.Pandoc.Readers.Markdown (readMarkdown)
@@ -139,8 +140,8 @@ installRedirect target from = do
 installPageRedirects :: FilePath -> PageInfo -> Site ()
 installPageRedirects target pi = do
   traverse_
-    (installRedirect target . T.unpack)
-    (pi ^.. pageMeta . key "redirects" . values . _String)
+    (installRedirect target)
+    (pi ^.. pageMeta . key "redirects" . values . _String . to T.unpack)
 
 -- | Install all redirects required by all pages.
 installRedirects :: Site ()
@@ -155,6 +156,12 @@ dataFilename hash basename = do
       loc = "data" </> h1 </> h2 </> basename
   pure (od </> loc, loc)
 
+-- | Copy a source file to the destination, making the necessary directories in the process.
+copy :: FilePath -> FilePath -> IO ()
+copy src dst = do
+  makeDirectories dst
+  B.readFile src >>= B.writeFile dst
+
 {- | 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. -}
@@ -162,20 +169,46 @@ installFile :: FilePath -> Site FilePath
 installFile fp = do
   let basename = takeFileName fp
   hash <- showDigest . sha256 <$> io (B.readFile fp)
-  alreadyExists <- S.member hash <$> use installs
   (file, loc) <- dataFilename hash basename
+  alreadyExists <- S.member (hash, basename) <$> use installs
   unless alreadyExists $ do
-    installs %= S.insert hash
+    installs %= S.insert (hash, basename)
     checkTarget file
     io $ do
       putStrLn $ "F -> " ++ fp ++ " -> " ++ file
-      makeDirectories file
-      B.readFile fp >>= B.writeFile file
+      copy fp file
   pure loc
 
 -- | Simply copy a strictly named asset.
 installAsset :: FilePath -> Site ()
-installAsset fp = undefined
+installAsset fp = do
+  od <- use outputDir
+  ad <- use assetDir
+  let [src,dst] = map (</> fp) [ad,od]
+  checkTarget dst
+  io $ do
+    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)
+
+sourceTags :: Site ()
+sourceTags = do
+  sgat <-
+    map
+      (second $ map splitDirectories .
+       (^.. pageMeta . key "tags" . values . _String . to T.unpack)) .
+    M.assocs <$>
+    use pages
+  htags .= M.fromList (invTags sgat)
+
+invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])]
+invTags x =
+  map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht]
 
 -- | Render a site for a given tag string.
 renderTag :: [String] -> Site ()
@@ -188,7 +221,9 @@ renderTags = undefined
 -- | Build the whole site.
 main =
   flip runStateT emptySiteState $ do
+    installAssets
     traverse sourcePages ["external"]
+    sourceTags
     sourceTemplates "templates"
     use pages >>= traverse (uncurry installPage) . M.assocs
     installRedirects