render, install files

8 files changed, 115 insertions, 52 deletions

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
--- /dev/null
+++ b/external/mypage/img/awesome.png
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 @@
 <html>
 {{> head.html}}
 <body>
-aaaaaa
+{{{body}}}
 </body>
 </html>
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 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="utf-8"/>
+    <meta name="viewport" content="width=device-width, initial-scale=1.0"/>
+    <meta http-equiv="refresh" content="0; url={{target}}"/>
+    <link rel="canonical" href="{{target}}"/>
+    <title>Permanent Redirect</title>
+  </head>
+  <body>
+    <p>The page has moved to <a href="{{target}}">here</a>.</p>
+  </body>
+</html>