diff --git a/FormatOpts.hs b/FormatOpts.hs new file mode 100644 index 0000000..363f6cd --- /dev/null +++ b/FormatOpts.hs @@ -0,0 +1,23 @@ +module FormatOpts where + +import Text.Pandoc.Extensions +import Text.Pandoc.Highlighting (pygments) +import Text.Pandoc.Options + +-- | Default markdown reading options for Pandoc. +markdownReadOpts = + def + { readerExtensions = + Text.Pandoc.Extensions.enableExtension + Text.Pandoc.Extensions.Ext_smart + Text.Pandoc.Extensions.pandocExtensions + } + +-- | Default HTML writing options for Pandoc. +htmlWriteOpts :: WriterOptions +htmlWriteOpts = + def + { writerExtensions = enableExtension Ext_smart pandocExtensions + , writerHighlightStyle = Just pygments + , writerWrapText = WrapPreserve + } diff --git a/Types.hs b/Types.hs index b46011e..9dba9a4 100644 --- a/Types.hs +++ b/Types.hs @@ -16,7 +16,7 @@ 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 + , _pageDoc :: Text.Pandoc.Definition.Pandoc -- ^ Page data } deriving (Show) @@ -32,10 +32,10 @@ data SiteState = -- | 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) + -- | List of installed files (enables sharing) , _installs :: S.Set FilePath - -- | List of installed pages (basically directories with index; prevents overwriting) - , _renders :: S.Set 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 @@ -54,7 +54,7 @@ emptySiteState = , _redirects = M.empty , _htags = M.empty , _installs = S.empty - , _renders = S.empty + , _targets = S.empty , _templates = M.empty , _outputDir = "_site" , _defaultTemplate = "default.html" diff --git a/Utils.hs b/Utils.hs new file mode 100644 index 0000000..d058c1c --- /dev/null +++ b/Utils.hs @@ -0,0 +1,18 @@ + +module Utils where +import Data.Maybe (isJust) +import Data.List.Extra (stripSuffix) +import Control.Monad.IO.Class + +-- | 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) + +-- | Test for whether something listy has a suffix +hasSuffix :: Eq a => [a] -> [a] -> Bool +hasSuffix s = isJust . stripSuffix s diff --git a/external/mypage/img/awesome.png b/external/mypage/img/awesome.png new file mode 100644 index 0000000..769a333 Binary files /dev/null and b/external/mypage/img/awesome.png differ diff --git a/reploy.cabal b/reploy.cabal index ee413b6..a41412e 100644 --- a/reploy.cabal +++ b/reploy.cabal @@ -5,8 +5,10 @@ cabal-version: >= 1.10 executable site main-is: site.hs - other-modules: Types + other-modules: Types, Utils, FormatOpts build-depends: base == 4.* + , aeson + , bytestring , containers , data-default , extra @@ -20,8 +22,9 @@ executable site , pandoc , pandoc-types , parsec + , SHA , text , transformers , yaml - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wunused-imports default-language: Haskell2010 diff --git a/site.hs b/site.hs index a1e03b5..8ab060f 100644 --- a/site.hs +++ b/site.hs @@ -4,14 +4,13 @@ module Main where import Control.Monad (unless, when) -import Control.Monad.IO.Class import Control.Monad.Trans.State.Lazy -import Data.Default (def) +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.Extra (stripSuffix) import qualified Data.Map as M -import Data.Maybe (fromMaybe, isJust) import qualified Data.Set as S import Data.String (fromString) import qualified Data.Text as T @@ -22,29 +21,16 @@ import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories) import Lens.Micro import Lens.Micro.Aeson import Lens.Micro.Mtl -import System.Environment (getArgs) -import System.FilePath ((), splitPath) +import System.FilePath ((), splitPath, takeFileName) import qualified Text.Mustache as Mu import Text.Pandoc.Class (runIOorExplode) -import qualified Text.Pandoc.Extensions -import Text.Pandoc.Options (ReaderOptions(..)) import Text.Pandoc.Readers.Markdown (readMarkdown) +import Text.Pandoc.Writers.HTML (writeHtml5String) import qualified Text.Parsec.Error +import FormatOpts 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) - --- | Test for whether something listy has a suffix -hasSuffix :: Eq a => [a] -> [a] -> Bool -hasSuffix s = isJust . stripSuffix s +import Utils -- | Load the pages from a directory and add them to `pages`. sourcePages :: FilePath -> Site () @@ -54,20 +40,11 @@ sourcePages fp = do getRecursiveContents (pure . const False) fp traverse_ loadPage (map (fp ) links) --- | Default markdown reading options for Pandoc. -markdownReadOpts = - def - { readerExtensions = - Text.Pandoc.Extensions.enableExtension - Text.Pandoc.Extensions.Ext_smart - 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 + io $ putStrLn $ "P <- " ++ fp txt <- io $ TIO.readFile fp {- tear out the metadata manually -} (T.take 4 txt == "---\n") `unless` @@ -82,7 +59,7 @@ loadPage fp = do 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} + M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pageDoc = md} -- | Find which template to use for rendering a page. pageTemplate :: PageInfo -> Site FilePath @@ -102,7 +79,7 @@ compileTemplate :: -> Site (Either Text.Parsec.Error.ParseError Mu.Template) compileTemplate templdir templ = io $ do - putStrLn $ "TTT " ++ (templdir templ) + putStrLn $ "T <- " ++ (templdir templ) Mu.automaticCompile [templdir] templ -- | Use a template set from a given directory. @@ -121,12 +98,12 @@ indexFilename mount = do pure (od mount "index.html") -- | Check that the page was not rendered before, and add it to the rendered set -checkRender :: FilePath -> Site () -checkRender fp = do - found <- S.member fp <$> use renders +checkTarget :: FilePath -> Site () +checkTarget fp = do + found <- S.member fp <$> use targets if found then error $ "colliding renders for page: " ++ fp - else renders %= S.insert fp + else targets %= S.insert fp -- | Render a page using the current template. installPage :: FilePath -> PageInfo -> Site () @@ -136,11 +113,14 @@ installPage mount pi tname <- pageTemplate pi templ <- use $ templates . to (M.! fromString tname) file <- indexFilename mount - checkRender file + checkTarget file io $ do - putStrLn $ ">>> " ++ file + putStrLn $ "P -> " ++ file makeDirectories file - TIO.writeFile file . Mu.substitute templ $ pi ^. pageMeta + body <- runIOorExplode $ writeHtml5String htmlWriteOpts (pi ^. pageDoc) + let Y.Object meta' = pi ^. pageMeta + meta = Y.Object $ KM.insert "body" (Y.String body) meta' + TIO.writeFile file $ Mu.substitute templ meta {- | Install a simple redirect handler page. -} installRedirect :: FilePath -> FilePath -> Site () @@ -148,9 +128,9 @@ installRedirect target from = do tname <- use redirectTemplate templ <- use $ templates . to (M.! fromString tname) file <- indexFilename from - checkRender file + checkTarget file io $ do - putStrLn $ "@@@ " ++ file ++ " -> " ++ target + putStrLn $ "@ -> " ++ file ++ " -> " ++ target makeDirectories file TIO.writeFile file . Mu.substitute templ $ Y.object [("target", Y.String $ T.pack target)] @@ -167,11 +147,35 @@ installRedirects :: Site () installRedirects = use pages >>= traverse_ (uncurry installPageRedirects) . M.assocs +-- | Find the path to the file of a given hash +dataFilename :: String -> FilePath -> Site (FilePath, FilePath) +dataFilename hash basename = do + od <- use outputDir + let (h1, h2) = splitAt 3 hash + loc = "data" h1 h2 basename + pure (od loc, loc) + {- | 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 +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 + unless alreadyExists $ do + installs %= S.insert hash + checkTarget file + io $ do + putStrLn $ "F -> " ++ fp ++ " -> " ++ file + makeDirectories file + B.readFile fp >>= B.writeFile file + pure loc + +-- | Simply copy a strictly named asset. +installAsset :: FilePath -> Site () +installAsset fp = undefined -- | Render a site for a given tag string. renderTag :: [String] -> Site () @@ -186,6 +190,8 @@ main = flip runStateT emptySiteState $ do traverse sourcePages ["external"] sourceTemplates "templates" - installRedirects use pages >>= traverse (uncurry installPage) . M.assocs + installRedirects + installFile "external/mypage/img/awesome.png" + io $ putStrLn "OK" get >>= io . print diff --git a/templates/default.html b/templates/default.html index ca9aee0..214229e 100644 --- a/templates/default.html +++ b/templates/default.html @@ -1,6 +1,6 @@ {{> head.html}} -aaaaaa +{{{body}}} diff --git a/templates/redirect.html b/templates/redirect.html new file mode 100644 index 0000000..33ee528 --- /dev/null +++ b/templates/redirect.html @@ -0,0 +1,13 @@ + + + + + + + + Permanent Redirect + + +

The page has moved to here.

+ +