WIP

.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+sitepipe-shake.cabal
+*~
+.shake/

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for sitepipe-shake
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,30 @@
+Copyright Chris Penner (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Chris Penner nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

OldSite.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Main where
+
+import Control.Monad
+import Data.Function (on)
+import Data.List (sortBy)
+import qualified Data.Text as T
+import Data.Text.Lens
+import Data.Time
+import SitePipe
+import qualified Text.Mustache as MT
+import qualified Text.Mustache.Types as MT
+
+author, domain, blogTitle :: T.Text
+domain = "http://chrispenner.ca"
+
+author = "Chris Penner"
+
+blogTitle = "Chris Penner"
+
+rfc3339 :: Maybe String
+rfc3339 = Just "%H:%M:%SZ"
+
+main :: IO ()
+main =
+  siteWithGlobals funcs $ do
+    posts <-
+      neighbouringPosts . sortByDate . fmap formatDate <$>
+      resourceLoader markdownReader ["posts/*.md"]
+    drafts <-
+      sortByDate . fmap formatDate <$>
+      resourceLoader markdownReader ["drafts/*.md"]
+    let tags = getTags (setExt "html" . addPrefix "/tag/") posts
+    writeTemplate "templates/index.html" [mkIndexEnv posts tags]
+    writeTemplate
+      "templates/post.html"
+      (over (key "tags" . _Array . traverse) stripHTMLSuffix <$> posts)
+    writeTemplate
+      "templates/post.html"
+      (over (key "tags" . _Array . traverse) stripHTMLSuffix <$> drafts)
+    writeTemplate "templates/tag.html" (stripPostsHTMLSuffix <$> tags)
+    atomRssFeed posts
+    staticAssets
+
+funcs :: MT.Value
+funcs =
+  MT.object
+    [ "truncate" MT.~> MT.overText (T.take 30)
+    , "stripExt" MT.~> MT.overText (T.pack . setExt "" . T.unpack)
+    ]
+
+sortByDate :: [Value] -> [Value]
+sortByDate = sortBy (flip compareDates)
+  where
+    compareDates = compare `on` view (key "date" . _String)
+
+stripHTMLSuffix :: Value -> Value
+stripHTMLSuffix obj = obj & key "url" . _String . unpacked %~ setExt ""
+
+stripPostsHTMLSuffix :: Value -> Value
+stripPostsHTMLSuffix tag =
+  tag & key "posts" . _Array . traversed . key "url" . _String . unpacked %~
+  setExt ""
+
+formatDate :: Value -> Value
+formatDate post =
+  post & _Object . at "date" ?~ String (T.pack (toIsoDate parsedTime)) & _Object .
+  at "humanDate" ?~
+  String (T.pack humanDate)
+  where
+    humanDate = post ^?! key "date" . _String . unpacked
+    parsedTime =
+      parseTimeOrError True defaultTimeLocale "%b %e, %Y" humanDate :: UTCTime
+
+toIsoDate :: UTCTime -> String
+toIsoDate = formatTime defaultTimeLocale (iso8601DateFormat rfc3339)
+
+neighbouringPosts :: [Value] -> [Value]
+neighbouringPosts posts =
+  zipWith3 addNeighbours (Nothing : mPosts) posts (tail mPosts ++ [Nothing])
+  where
+    mPosts :: [Maybe Value]
+    mPosts = pure . stripHTMLSuffix <$> posts
+    addNeighbours :: Maybe Value -> Value -> Maybe Value -> Value
+    addNeighbours mPrevPost post mNextPost =
+      post & _Object . at "prevPost" .~ mPrevPost & _Object . at "nextPost" .~
+      mNextPost
+
+mkIndexEnv :: [Value] -> [Value] -> Value
+mkIndexEnv posts tags =
+  object
+    [ "posts" .= (stripHTMLSuffix <$> posts)
+    , "tags" .= (stripHTMLSuffix <$> tags)
+    , "url" .= ("/index.html" :: T.Text)
+    ]
+
+staticAssets :: SiteM ()
+staticAssets = void $ copyFiles ["css", "js", "images"]
+
+atomRssFeed :: [Value] -> SiteM ()
+atomRssFeed posts = do
+  now <- liftIO getCurrentTime
+  let atomEnv =
+        object
+          [ "title" .= blogTitle
+          , "domain" .= domain
+          , "author" .= author
+          , "posts" .= posts
+          , "currentTime" .= toIsoDate now
+          , "url" .= ("/atom.xml" :: T.Text)
+          ]
+  writeTemplate "templates/atom.xml" [atomEnv]

README.md

@@ -0,0 +1 @@
+# sitepipe-shake

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Helpers.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Helpers where
+
+import Data.Aeson as A
+import Data.ByteString.Lazy
+import Development.Shake hiding (Resource)
+import Development.Shake.Classes
+import GHC.Generics (Generic)
+
+newtype CacheQuery q =
+  CacheQuery q
+  deriving (Show, Eq, Generic, Binary, NFData, Hashable)
+
+jsonOracle ::
+     forall a q. (ToJSON a, FromJSON a, ShakeValue q)
+  => (q -> Action a)
+  -> Rules (q -> Action a)
+jsonOracle loader =
+  unpackJSON <$> addOracleCache (\(CacheQuery q) -> A.encode <$> loader q)
+  where
+    unpackJSON ::
+         FromJSON a => (CacheQuery q -> Action ByteString) -> q -> Action a
+    unpackJSON runCacheQuery =
+      \q -> do
+        bytes <- runCacheQuery $ CacheQuery q
+        case A.eitherDecode bytes of
+          Left err -> fail err
+          Right res -> pure res
+
+type instance RuleResult (CacheQuery q) = ByteString
+
+simpleJsonCache ::
+     (ToJSON a, FromJSON a)
+  => (String -> Action a)
+  -> Rules (String -> Action a)
+simpleJsonCache = jsonOracle

app/Main.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import Data.Aeson as A
+import Data.Foldable
+import Development.Shake hiding (Resource)
+import GHC.Generics (Generic)
+import Helpers
+
+data Post = Post
+  { name :: String
+  , author :: String
+  } deriving (Generic)
+
+instance FromJSON Post
+
+loadPosts :: Action [String]
+loadPosts = do
+  postNames <- getDirectoryFiles "." ["assets/site/posts//*.md"]
+  files <- traverse readFile' postNames
+  return files
+
+main :: IO ()
+main =
+  shakeArgs shakeOptions $ do
+    want ["dist/contents.html"]
+    postOracle <- simpleJsonCache (const loadPosts)
+    -- "site" ~> need ["dist/index.html"]
+    "dist/contents.html" %> \out -> do
+      liftIO $ print "running contents!"
+      posts <- postOracle "posts"
+      liftIO . print $ posts
+      writeFile' out (fold posts)
+    -- "dist/*.html" %> \out -> do
+      -- srcIndex <- readFile' ("stuff" </> (dropDirectory1 out))
+    --
+    --   parts <- getDirectoryFiles "." ["stuff/parts/*.html"]
+    --   partFiles <- traverse readFile' parts
+    --   let resultIndex = srcIndex <> intercalate "\n---\n" partFiles
+    --   writeFile' out resultIndex
+    --