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