diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,38 @@ +# Changelog for Shakebook + +## (v0.1.5.0) + +* Factored out API into this library. +* Standardised lens and enrichment functions. +* Supports user-specified enrichments. +* Adds a Shakebook monad and a ShakebookA monad that wraps shake's + Rules and shake's Action monads respectively. +* Supports reader based config of input and output directories, baseUrl, + markdown reader and writer config options and posts per page. +* Supports more general pager specifications allowing user specified data + extraction from the URL fragment into a page Zipper. +* Adds general loading function via `loadSortFilterExtract` for loading + markdown via the monad through patterns. + +## (v0.1.0.0) + +* Note: Unreleased in this repo. Copied from original shakebook.site template. +* Shake static site application that can export technical documentation both to + HTML and to PDF using [pandoc](https://pandoc.org) +* Comes with a [nix](https://nixos.org/nix/) shell with full +* [LaTeX](https://www.latex-project.org/) and video rendering capabilities. +* Supports user configuration of table of contents via the `Shakefile.hs` +* Supports additional compilation units via [shake](https://shakebuild.com). +* Features two examples - one video rendering example with + [reanimate](https://hackage.haskell.org/package/reanimate) and one generated +image using [R](https://www.r-project.org/) using +[inline-r](https://hackage.haskell.org/package/inline-r). +* Supports a blog section with tags, links to tag filtered pages and links to + month filtered pages. +* Includes [bootstrap](https://getbootstrap.com/) and + [fontawesome](https://fontawesome.com/) Supports +* [MathJax](https://www.mathjax.org/) and code syntax highlighting via pandoc's + highlighting engine. Features an example documentation section containing +the documentation for Shakebook itself. +* Supports [Atom](https://validator.w3.org/feed/docs/atom.html) feed generation + from blog data. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# Shakebook - Static Site & Technical Documentation Generator + +Shakebook is a collection of data handlers, shake rules and useful conventions +for generating technical documentation and blogs. This is the API library. For +a running example see http://shakebook.site. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/shakebook.cabal b/shakebook.cabal new file mode 100644 --- /dev/null +++ b/shakebook.cabal @@ -0,0 +1,91 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 89dc02888ad0b93e61bf9ab4de3d216c189724afda313bd2d725737f44d65c74 + +name: shakebook +version: 0.1.5.0 +synopsis: Shake-based markdown/latex webbook. +category: Web +author: Me +maintainer: example@example.com +copyright: 20XX Me +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +library + exposed-modules: + Shakebook + Shakebook.Aeson + Shakebook.Conventions + Shakebook.Data + Shakebook.Defaults + Shakebook.Feed + Shakebook.Rules + Shakebook.Zipper + other-modules: + Paths_shakebook + hs-source-dirs: + src + default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + aeson + , base >=4.7 && <5 + , comonad + , comonad-extras + , doctemplates + , extra + , feed + , free + , lens + , lens-aeson + , pandoc + , pandoc-types + , relude + , rio + , shake + , slick + , split + , tasty + , text-time + default-language: Haskell2010 + +test-suite shakebook-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_shakebook + hs-source-dirs: + test + default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , comonad + , comonad-extras + , doctemplates + , extra + , feed + , free + , lens + , lens-aeson + , pandoc + , pandoc-types + , relude + , rio + , shake + , shakebook + , slick + , split + , tasty + , text-time + default-language: Haskell2010 diff --git a/src/Shakebook.hs b/src/Shakebook.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook.hs @@ -0,0 +1,8 @@ +module Shakebook ( + + module Shakebook.Data +, module Shakebook.Rules +) where + +import Shakebook.Data +import Shakebook.Rules diff --git a/src/Shakebook/Aeson.hs b/src/Shakebook/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Aeson.hs @@ -0,0 +1,30 @@ +module Shakebook.Aeson where + +import Control.Lens +import Data.Aeson as A +import Data.Aeson.Lens +import RIO hiding (view) +import qualified RIO.HashMap as HML +import qualified RIO.Vector as V + +-- Union two JSON values together. +withJSON :: (ToJSON a) => a -> Value -> Value +withJSON x (Object obj) = Object $ HML.union obj y + where Object y = toJSON x +withJSON _ _ = error "Can ony add a new TOJSON object to objects" + +-- Add a String field to a JSON value. +withStringField :: Text -> Text -> Value -> Value +withStringField f v = _Object . at f ?~ String v + +-- Add an Array field to a JSON value. +withArrayField :: Text -> [Value] -> Value -> Value +withArrayField f v = _Object . at f ?~ Array (V.fromList v) + +-- Add an Object field to a JSON value. +withObjectField :: Text -> Value -> Value -> Value +withObjectField f v = _Object . at f ?~ v + +-- Maybe add an Object field to a JSON value. +withObjectFieldMaybe :: Text -> Maybe Value -> Value -> Value +withObjectFieldMaybe f v = _Object . at f .~ v diff --git a/src/Shakebook/Conventions.hs b/src/Shakebook/Conventions.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Conventions.hs @@ -0,0 +1,280 @@ +{-| Conventions used for common shakebook projects, lenses, enrichments, affixes. +-} + +module Shakebook.Conventions ( + -- * Lenses + viewContent +, viewPostTime +, viewPostTimeRaw +, viewSrcPath +, viewTags +, viewTitle +, viewUrl +, viewAllPostTags +, viewAllPostTimes +, withBaseUrl +, withFullUrl +, withHighlighting +, withNext +, withPages +, withPrettyDate +, withPrevious +, withPosts +, withRecentPosts +, withSrcPath +, withSubsections +, withTagIndex +, withTagLinks +, withTeaser +, withTitle +, withUrl + + -- * Enrichment +, enrichFullUrl +, enrichPrettyDate +, enrichTagLinks +, enrichTeaser +, enrichTypicalUrl + + -- * Affixes + + -- * Extensions +, extendNext +, extendPrevious +, extendNextPrevious +, extendPageNeighbours + + -- * Generations +, genBlogNavbarData +, genLinkData +, genPageData +, genTocNavbarData + +, dateSortPosts +, monthFilterPosts +, sameMonth +, tagFilterPosts +) where + +import Control.Comonad.Cofree +import Control.Comonad.Store +import Control.Comonad.Store.Zipper +import Control.Lens hiding ((:<)) +import Control.Monad.Extra +import Data.Aeson as A +import Data.Aeson.Lens +import Data.Text.Time +import Development.Shake.FilePath +import RIO hiding (view) +import RIO.List +import RIO.List.Partial +import qualified RIO.Text as T +import qualified RIO.Text.Partial as T +import RIO.Time +import qualified RIO.Vector as V +import Shakebook.Aeson +import Shakebook.Zipper +import Text.Pandoc.Highlighting + + +-- View the "content" field of a JSON Value. +viewContent :: Value -> Text +viewContent = view (key "content" . _String) + +-- View the "date" field of a JSON Value as a UTCTime. +viewPostTime :: Value -> UTCTime +viewPostTime = parseISODateTime . view (key "date" . _String) + +-- View the "date" field of a JSON Value as Text. +viewPostTimeRaw :: Value -> Text +viewPostTimeRaw = view (key "date" . _String) + +-- View the "srcPath" field of a JSON Value. +viewSrcPath :: Value -> Text +viewSrcPath = view (key "srcPath" . _String) + +-- View the "tags" field of a JSON Value as a list. +viewTags :: Value -> [Text] +viewTags = toListOf (key "tags" . values . _String) + +-- View the "title" field of a JSON Value. +viewTitle :: Value -> Text +viewTitle = view (key "title" . _String) + +-- View the "url" field of a JSON Value. +viewUrl :: Value -> Text +viewUrl = view (key "url" . _String) + +-- View all post tags for a list of posts. +viewAllPostTags :: [Value] -> [Text] +viewAllPostTags = (>>= viewTags) + +-- View all posts times for a list of posts. +viewAllPostTimes :: [Value] -> [UTCTime] +viewAllPostTimes = fmap viewPostTime + +-- Add "baseUrl" field from input Text. +withBaseUrl :: Text -> Value -> Value +withBaseUrl = withStringField "baseUrl" + +-- Add "fullUrl" field from input Text. +withFullUrl :: Text -> Value -> Value +withFullUrl = withStringField "fullUrl" + +-- Add "highlighting-css" field from input Style. +withHighlighting :: Style -> Value -> Value +withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss + +-- Add "next" field from input Value. +withNext :: Maybe Value -> (Value -> Value) +withNext = withObjectFieldMaybe "next" + +-- Add "pages" field from input [Value]. +withPages :: [Value] -> (Value -> Value) +withPages = withArrayField "pages" + +-- Add "prettydate" field using input Text. +withPrettyDate :: Text -> Value -> Value +withPrettyDate = withStringField "prettydate" + +-- Add "previous" field using input Value. +withPrevious :: Maybe Value -> (Value -> Value) +withPrevious = withObjectFieldMaybe "previous" + +-- Add "posts" field based on input [Value]. +withPosts :: [Value] -> Value -> Value +withPosts = withArrayField "posts" + +-- Add "recentposts" field using input Value. +withRecentPosts :: [Value] -> Value -> Value +withRecentPosts = withArrayField "recent-posts" + +-- Add "srcPath" field based on input Text. +withSrcPath :: Text -> Value -> Value +withSrcPath = withStringField "srcPath" + +-- Add "subsections" field based on inpt [Value]. +withSubsections :: [Value] -> (Value -> Value) +withSubsections = withArrayField "subsections" + +-- Add "tagindex" field based on input [Value]. +withTagIndex :: [Value] -> Value -> Value +withTagIndex = withArrayField "tagindex" + +-- Add "taglinks" field based on input [Value]. +withTagLinks :: [Value] -> Value -> Value +withTagLinks = withArrayField "taglinks" + +-- Add "teaser" field based on input Text. +withTeaser :: Text -> Value -> Value +withTeaser = withStringField "teaser" + +-- Add "title" field based on input Text. +withTitle :: Text -> Value -> Value +withTitle = withStringField "title" + +-- Add "url" field from input Text. +withUrl :: Text -> Value -> Value +withUrl = withStringField "url" + +-- Add both "next" and "previous" fields using `withPostNext` and `withPostPrevious` +extendNextPrevious :: Zipper [] Value -> Zipper [] Value +extendNextPrevious = extendPrevious . extendNext + +-- Extend a Zipper of JSON Values to add "previous" objects. +extendPrevious :: Zipper [] Value -> Zipper [] Value +extendPrevious = extend (liftA2 withPrevious zipperPreviousMaybe extract) + +-- Extend a Zipper of JSON Values to add "next" objects. +extendNext :: Zipper [] Value -> Zipper [] Value +extendNext = extend (liftA2 withNext zipperNextMaybe extract) + +extendPageNeighbours :: Int -> Zipper [] Value -> Zipper [] Value +extendPageNeighbours r = extend (liftA2 withPages (zipperWithin r) extract) + + +-- Assuming a "url" field, enrich via a baseURL +enrichFullUrl :: Text -> Value -> Value +enrichFullUrl base v = withFullUrl (base <> viewUrl v) v + +-- Assuming a "date" field, enrich using withPrettyDate and a format string. +enrichPrettyDate :: (UTCTime -> String) -> Value -> Value +enrichPrettyDate f v = withPrettyDate (T.pack . f . viewPostTime $ v) v + +-- Assuming a "tags" field, enrich using withTagLinks. +enrichTagLinks :: (Text -> Text) -> Value -> Value +enrichTagLinks f v = withTagLinks ((`genLinkData` f) <$> viewTags v) v + +-- Assuming a "content" field with a spitter section, enrich using withTeaser +enrichTeaser :: Text -> Value -> Value +enrichTeaser s v = withTeaser (head (T.splitOn s (viewContent v))) v + +-- Assuming a 'srcPath' field, enrich using withUrl using a typicalHTMLUrl +enrichTypicalUrl :: Value -> Value +enrichTypicalUrl v = withUrl (typicalHTMLUrl (viewSrcPath v)) v + +-- Typical Markdown to HTML path transformation, by dropping a directory and +-- changing the extension. +typicalHTMLPath :: String -> String +typicalHTMLPath = dropDirectory1 . (-<.> "html") + +-- Typical URL transformation, dropping the first directory, chagnging the +-- extension to "html", and adding a preslash. +typicalHTMLUrl :: Text -> Text +typicalHTMLUrl = T.pack . ("/" <>) . typicalHTMLPath . T.unpack + +-- Create link data object with fields "id" and "url" using an id and a function +-- transforming an id into a url. +genLinkData :: Text -> (Text -> Text) -> Value +genLinkData id f = object ["id" A..= String id, "url" A..= String (f id)] + +-- Filter a lists of posts by tag. +tagFilterPosts :: Text -> [Value] -> [Value] +tagFilterPosts tag = filter (elem tag . viewTags) + +-- Sort a lists of posts by date. +dateSortPosts :: [Value] -> [Value] +dateSortPosts = sortOn (Down . viewPostTime) + +-- Check whether two posts were posted in the same month. +sameMonth :: UTCTime -> UTCTime -> Bool +sameMonth a b = y1 == y2 && m1 == m2 where + (y1, m1, _) = f a + (y2, m2, _) = f b + f = toGregorian . utctDay + +monthFilterPosts :: UTCTime -> [Value] -> [Value] +monthFilterPosts time = filter (sameMonth time . viewPostTime) + + +-- Partition a list of posts by the month they were posted. +partitionToMonths :: [Value] -> [[Value]] +partitionToMonths = groupBy (on sameMonth viewPostTime) . dateSortPosts + +-- Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3". +genBlogNavbarData :: Text -- "Top level title, e.g "Blog" + -> Text -- Root page, e.g "/posts" + -> (UTCTime -> Text) -- Formatting function to a UTCTime to a title. + -> (UTCTime -> Text) -- Formatting function to convert a UTCTime to a URL link + -> [Value] + -> Value +genBlogNavbarData a b f g xs = object [ "toc1" A..= object [ + "title" A..= String a + , "url" A..= String b + , "toc2" A..= Array (V.fromList $ map toc2 (partitionToMonths xs)) ] + ] where + toc2 t@(x : _) = object [ "title" A..= String (f (viewPostTime x)) + , "url" A..= String (g (viewPostTime x)) + , "toc3" A..= Array (V.fromList t) ] + +-- Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3". +genTocNavbarData :: Cofree [] Value -> Value +genTocNavbarData (x :< xs) = + object ["toc1" A..= [_Object . at "toc2" ?~ Array (V.fromList $ map toc2 xs) $ x]] where + toc2 (x :< xs) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract xs)) x + +genPageData :: Text -> (Text -> Text) -> Zipper [] [Value] -> Value +genPageData t f xs = withTitle t + . withJSON (genLinkData (T.pack . show $ pos xs + 1) f) + . withPosts (extract xs) $ Object mempty + diff --git a/src/Shakebook/Data.hs b/src/Shakebook/Data.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Data.hs @@ -0,0 +1,96 @@ +module Shakebook.Data where + +import Control.Comonad.Cofree +import Control.Comonad.Store +import Control.Comonad.Store.Zipper +import Control.Monad.Extra +import Data.Aeson as A +import Development.Shake as S +import Development.Shake.FilePath +import RIO hiding (view) +import RIO.List +import qualified RIO.Text as T +import Slick +import Slick.Pandoc +import Shakebook.Conventions +import Shakebook.Zipper +import Text.Pandoc.Options + +type ToC = Cofree [] String + +-- Get a JSON Value of Markdown Data with markdown body as "contents" field +-- and the srcPath as "srcPath" field. +readMarkdownFile' :: ReaderOptions -> WriterOptions -> String -> Action Value +readMarkdownFile' readerOptions writerOptions srcPath = do + docContent <- readFile' srcPath + docData <- markdownToHTMLWithOpts readerOptions writerOptions . T.pack $ docContent + return $ withSrcPath (T.pack srcPath) docData + +loadIfExists :: (FilePath -> Action Value) -> FilePath -> Action Value +loadIfExists f src = ifM (S.doesFileExist src) (f src) (return (Object mempty)) + +getDirectoryMarkdown :: ReaderOptions -> WriterOptions -> FilePath -> [FilePattern] -> Action [Value] +getDirectoryMarkdown readOpts writeOpts dir pat = do + getDirectoryFiles dir pat >>= mapM (readMarkdownFile' readOpts writeOpts . (dir )) + +getEnrichedMarkdown :: ReaderOptions -> WriterOptions -> (Value -> Value) -> FilePath -> [FilePattern] -> Action [Value] +getEnrichedMarkdown readOpts writeOpts f dir pat = fmap f <$> getDirectoryMarkdown readOpts writeOpts dir pat + +genBuildPageAction :: FilePath -- The HTML template + -> (FilePath -> Action Value) -- How to get an initial markdown JSON Object from the out filepath. + -> (Value -> Value) -- Additional modifiers for the value + -> FilePath -- The out filepath + -> Action Value +genBuildPageAction template getData withData out = do + pageT <- compileTemplate' template + dataT <- withData <$> getData out + writeFile' out . T.unpack $ substitute pageT dataT + return dataT + +genIndexPageData :: [Value] + -> Text + -> (Text -> Text) + -> Int + -> Maybe (Zipper [] Value) +genIndexPageData xs g h n = fmap (extend (genPageData g h)) $ paginate n xs + +traverseToSnd :: Functor f => (a -> f b) -> a -> f (a, b) +traverseToSnd f a = (a,) <$> f a + +lower :: Cofree [] Value -> [Value] +lower (_ :< xs) = extract <$> xs + +data SbConfig = SbConfig { + sbSrcDir :: FilePath +, sbOutDir :: FilePath +, sbBaseUrl :: Text +, sbMdRead :: ReaderOptions +, sbHTWrite :: WriterOptions +, sbPPP :: Int +} deriving (Show) + +newtype Shakebook a = Shakebook ( ReaderT SbConfig Rules a ) + deriving (Functor, Applicative, Monad, MonadReader SbConfig) + +newtype ShakebookA a = ShakebookA ( ReaderT SbConfig Action a ) + deriving (Functor, Applicative, Monad, MonadReader SbConfig) + +runShakebook :: SbConfig -> Shakebook a -> Rules a +runShakebook c (Shakebook f) = runReaderT f c + +runShakebookA :: SbConfig -> ShakebookA a -> Action a +runShakebookA c (ShakebookA f) = runReaderT f c + + +loadSortFilterEnrich :: Ord b => [FilePattern] -- Filepattern + -> (Value -> b) -- A value to sortOn e.g (Down . viewPostTime) + -> (Value -> Bool) -- A filtering predicate e.g (elem tag . viewTags) + -> (Value -> Value) -- An initial enrichment. This is pure so can only be data derived from the initial markdown. + -> ShakebookA [(String, Value)] +loadSortFilterEnrich pat s f e = ShakebookA $ ask >>= \SbConfig {..} -> lift $ do + allPosts <- getDirectoryFiles sbSrcDir $ map (-<.> ".md") pat + readPosts <- sequence $ traverseToSnd (readMarkdownFile' sbMdRead sbHTWrite . (sbSrcDir )) <$> allPosts + return $ fmap (second e) $ sortOn (s . snd) $ filter (f . snd) $ readPosts + +loadSortEnrich :: Ord b => [FilePattern] -> (Value -> b) -> (Value -> Value) -> ShakebookA [(String, Value)] +loadSortEnrich pat s e = loadSortFilterEnrich pat s (const True) e diff --git a/src/Shakebook/Defaults.hs b/src/Shakebook/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Defaults.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Shakebook.Defaults where + +import Control.Comonad +import Control.Comonad.Cofree +import Control.Comonad.Store.Class +import Control.Comonad.Store.Zipper +import Control.Monad.Extra +import Data.Aeson as A +import Data.List.Split +import Data.Text.Time +import Development.Shake as S +import Development.Shake.Classes +import Development.Shake.FilePath +import RIO hiding (view) +import qualified RIO.ByteString.Lazy as LBS +import RIO.List +import RIO.List.Partial +import qualified RIO.Map as M +import RIO.Partial +import qualified RIO.Text as T +import RIO.Time +import Shakebook.Aeson +import Shakebook.Data +import Shakebook.Rules +import Shakebook.Conventions +import Shakebook.Zipper +import Text.DocTemplates +import Text.Pandoc.Class +import Text.Pandoc.Definition +import Text.Pandoc.Options +import Text.Pandoc.PDF +import Text.Pandoc.Readers +import Text.Pandoc.Templates +import Text.Pandoc.Walk +import Text.Pandoc.Writers + +monthURLFormat :: UTCTime -> String +monthURLFormat = formatTime defaultTimeLocale "%Y-%m" + +prettyMonthFormat :: UTCTime -> String +prettyMonthFormat = formatTime defaultTimeLocale "%B, %Y" + +prettyTimeFormat :: UTCTime -> String +prettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y" + +monthIndexUrlFormat :: UTCTime -> String +monthIndexUrlFormat t = "/posts/months" monthURLFormat t + +enrichPost :: Value -> Value +enrichPost = enrichTeaser "" + . enrichTagLinks ("/posts/tags/" <>) + . enrichPrettyDate prettyTimeFormat + . enrichTypicalUrl + +--Data models------------------------------------------------------------------- + +markdownReaderOptions :: ReaderOptions +markdownReaderOptions = def { readerExtensions = pandocExtensions } + +html5WriterOptions :: WriterOptions +html5WriterOptions = def { writerHTMLMathMethod = MathJax ""} + +latexWriterOptions :: WriterOptions +latexWriterOptions = def { writerTableOfContents = True + , writerVariables = Context $ M.fromList [ + ("geometry", SimpleVal "margin=3cm") + , ("fontsize", SimpleVal "10") + , ("linkcolor",SimpleVal "blue")] + } + +makePDFLaTeX :: Pandoc -> PandocIO (Either LBS.ByteString LBS.ByteString) +makePDFLaTeX p = do + t <- compileDefaultTemplate "latex" + makePDF "pdflatex" [] writeLaTeX latexWriterOptions { writerTemplate = Just t } p + +handleImages :: (Text -> Text) -> Inline -> Inline +handleImages f (Image attr ins (src,txt)) = + if T.takeEnd 4 src == ".mp4" then Str (f src) + else Image attr ins ("public/" <> src, txt) +handleImages _ x = x + +handleHeaders :: Int -> Block -> Block +handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs +handleHeaders _ x = x + +pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc +pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs + +defaultDocsPatterns :: Cofree [] FilePath -- Rosetree Table of Contents. + -> FilePath + -> (Value -> Value) -- Extra data modifiers. + -> Shakebook () +defaultDocsPatterns toc tmpl withData = Shakebook $ ask >>= \SbConfig {..} -> do + let r = readMarkdownFile' sbMdRead sbHTWrite + lift $ cofreeRuleGen toc ((sbOutDir ) . (-<.> ".html")) ( + \xs -> \out -> do + ys <- mapM r (fmap (sbSrcDir ) toc) + zs <- mapM r (fmap (sbSrcDir ) xs) + void $ genBuildPageAction (sbSrcDir tmpl) + (loadIfExists r . (-<.> ".md") . (sbSrcDir ) . dropDirectory1) + (withData . withJSON (genTocNavbarData (fmap enrichTypicalUrl ys)) . withSubsections (lower (enrichTypicalUrl <$> zs))) + out) + +defaultPostIndexData :: [FilePattern] -> (a -> Value -> Bool) -> (a -> Text) -> (a -> Text -> Text) -> a -> ShakebookA (Zipper [] Value) +defaultPostIndexData pat f t l a = ask >>= \SbConfig {..} -> do + xs <- loadSortFilterEnrich pat (Down . viewPostTime) (f a) enrichPost + let ys = genIndexPageData (snd <$> xs) (t a) (l a) sbPPP + return $ fromJust $ ys + +defaultPagerPattern :: FilePattern + -> FilePath + -> (FilePattern -> Int) + -> (FilePattern -> a) + -> (a -> ShakebookA (Zipper [] Value)) + -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) + -> Shakebook () +defaultPagerPattern fp tmpl f g h w = Shakebook $ ask >>= \x@SbConfig{..} -> lift $ + comonadStoreRuleGen (sbOutDir fp) (f . dropDirectory1) (g . dropDirectory1) (runShakebookA x . (w <=< h)) + (\a -> void <$> genBuildPageAction (sbSrcDir tmpl) (const $ return a) id) + +defaultPostIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook () +defaultPostIndexPatterns pat tmpl extData = do + defaultPagerPattern "posts/index.html" tmpl + (const 0) + (const ()) + (defaultPostIndexData pat (const $ (const True)) + (const "Posts") + (const ("/posts/pages/" <>))) + extData + defaultPagerPattern ("posts/pages/*/index.html") tmpl + ((+ (-1)) . read . (!! 2) . splitOn "/") + (const ()) + (defaultPostIndexData pat (const $ (const True)) + (const "Posts") + (const ("/posts/pages/" <>))) + extData + +defaultTagIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook () +defaultTagIndexPatterns pat tmpl extData = do + defaultPagerPattern ("posts/tags/*/index.html") tmpl + (const 0) + (T.pack . (!! 2) . splitOn "/") + (defaultPostIndexData pat (\x y -> elem x (viewTags y) ) + ("Posts tagged " <>) + (\x y -> ("/posts/tags/" <> x <> "/pages/" <> y))) + extData + defaultPagerPattern ("posts/tags/*/pages/*/index.html") tmpl + ((+ (-1)) . read . (!! 4) . splitOn "/") + (T.pack . (!! 2) . splitOn "/") + (defaultPostIndexData pat (\x y -> elem x (viewTags y)) + ("Posts tagged " <>) + (\x y -> ("/posts/tags/" <> x <> "/pages/" <> y))) + extData + +defaultMonthIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook () +defaultMonthIndexPatterns pat tmpl extData = do + defaultPagerPattern "posts/months/*/index.html" tmpl + (const 0) + (parseISODateTime . T.pack . (!! 2) . splitOn "/") + (defaultPostIndexData pat + (\x y -> sameMonth x (viewPostTime y)) + (("Posts from " <>) . T.pack . prettyMonthFormat) + (\x y -> ("/posts/months/" <> T.pack (monthURLFormat x) <> "/pages" <> y))) + extData + defaultPagerPattern "posts/months/*/pages/*/index.html" tmpl + ((+ (-1)) . read . (!! 4) . splitOn "/") + (parseISODateTime . T.pack . (!! 2) . splitOn "/") + (defaultPostIndexData pat + (\x y -> sameMonth x (viewPostTime y)) + (("Posts from " <>) . T.pack . prettyMonthFormat) + (\x y -> ("/posts/months/" <> T.pack (monthURLFormat x) <> "/pages" <> y))) + extData + +defaultPostsPatterns :: FilePattern -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook () +defaultPostsPatterns pat tmpl extData = Shakebook $ ask >>= \sbc@(SbConfig {..}) -> lift $ + sbOutDir pat %> \out -> do + sortedPosts <- runShakebookA sbc $ loadSortEnrich [pat] (Down . viewPostTime) enrichPost + let i = (-<.> ".md") . dropDirectory1 $ out + let k = fromJust $ elemIndex i (fst <$> sortedPosts) + let z = fromJust $ seek k <$> zipper (snd <$> sortedPosts) + void $ genBuildPageAction (sbSrcDir tmpl) + (const $ runShakebookA sbc $ extract <$> extData z) + id out + + +buildPDF :: Cofree [] String -> String -> FilePath -> ShakebookA () +buildPDF toc meta out = ShakebookA $ ask >>= \SbConfig {..} -> lift $ do + y <- mapM readFile' ((sbSrcDir ) <$> toc) + m <- readFile' $ sbSrcDir meta + Right f <- liftIO . runIOorExplode $ do + k <- mapM (readMarkdown sbMdRead . T.pack) y + a <- readMarkdown sbMdRead . T.pack $ m + let z = walk (handleImages (\x -> "[Video available at " <> sbBaseUrl <> x <> "]")) $ foldr (<>) a $ pushHeaders (-1) k + makePDFLaTeX z + LBS.writeFile out f + +defaultSinglePagePattern :: FilePath -- The output filename e.g "index.html". + -> FilePath -- A tmpl file. + -> (Value -> ShakebookA Value) -- Last minute enrichment. + -> Shakebook () +defaultSinglePagePattern out tmpl withDataM = Shakebook $ ask >>= \sbc@(SbConfig {..}) -> lift $ + sbOutDir out %> void . genBuildPageAction + (sbSrcDir tmpl) + (\fp -> do + x <- readMarkdownFile' sbMdRead sbHTWrite . (-<.> ".md") . (sbSrcDir ) . dropDirectory1 $ fp + runShakebookA sbc $ withDataM x) + id + +defaultStaticsPatterns :: [FilePattern] -> Shakebook () +defaultStaticsPatterns xs = Shakebook $ ask >>= \SbConfig {..} -> lift $ + mconcat $ map (\x -> sbOutDir x %> \y -> copyFileChanged ((sbSrcDir ) . dropDirectory1 $ y) y) xs + +defaultCleanPhony :: Shakebook () +defaultCleanPhony = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "clean" $ do + putInfo $ "Cleaning files in " ++ sbOutDir + removeFilesAfter sbOutDir ["//*"] + +defaultStaticsPhony :: Shakebook () +defaultStaticsPhony = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "statics" $ do + fp <- getDirectoryFiles sbSrcDir ["images//*", "css//*", "js//*", "webfonts//*"] + need $ [sbOutDir x | x <- fp] + +defaultPostsPhony :: [FilePattern] -> Shakebook () +defaultPostsPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "posts" $ do + fp <- getDirectoryFiles sbSrcDir pattern + need [sbOutDir x -<.> ".html" | x <- fp] + +defaultPostIndexPhony :: [FilePattern] -> Shakebook () +defaultPostIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "posts-index" $ do + fp <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern + need [sbOutDir "posts/index.html"] + need [sbOutDir "posts/pages/" ++ show x ++ "/index.html" + | x <- [1..size (fromJust $ paginate sbPPP fp)]] + +defaultTagIndexPhony :: [FilePattern] -> Shakebook () +defaultTagIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "tag-index" $ do + fp <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern + let tags = viewAllPostTags fp + need [sbOutDir "posts/tags" T.unpack x "index.html" | x <- tags] + need [sbOutDir "posts/tags" T.unpack x "pages" show p "index.html" + | x <- tags + , p <- [1..size (fromJust $ paginate sbPPP $ tagFilterPosts x fp)] + ] + +defaultMonthIndexPhony :: [FilePattern] -> Shakebook () +defaultMonthIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "month-index" $ do + fp <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern + let times = viewAllPostTimes fp + need [sbOutDir "posts/months" monthURLFormat t "index.html" | t <- times] + need [sbOutDir "posts/months" monthURLFormat t "pages" show p "index.html" + | t <- times + , p <- [1..length (fromJust $ paginate sbPPP $ monthFilterPosts t fp)] + ] + +defaultDocsPhony :: Cofree [] String -> Shakebook () +defaultDocsPhony toc = Shakebook $ ask >>= \SbConfig {..} -> lift $ + phony "docs" $ do + fp <- getDirectoryFiles sbSrcDir (foldr ((<>) . pure) [] toc) + need $ [ (sbOutDir ) . (-<.> ".html") $ x | x <- fp] diff --git a/src/Shakebook/Feed.hs b/src/Shakebook/Feed.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Feed.hs @@ -0,0 +1,27 @@ +module Shakebook.Feed ( + asAtomEntry +, buildFeed +) where + +import Data.Aeson +import Development.Shake +import RIO +import RIO.List.Partial +import Shakebook.Conventions +import qualified RIO.Text as T +import qualified RIO.Text.Lazy as TL +import Text.Atom.Feed as Atom +import Text.Atom.Feed.Export + +-- Convert a Post to an Atom Entry +asAtomEntry :: Value -> Atom.Entry +asAtomEntry x = (Atom.nullEntry (viewUrl x) (Atom.TextString $ viewTitle x) (viewPostTimeRaw x)) { + Atom.entryContent = Just $ Atom.TextContent (viewContent x) } + +-- Build an Atom Feed from a list of posts. +buildFeed :: Text -> Text -> [Value] -> FilePath -> Action () +buildFeed title baseUrl xs out = do + let fs = asAtomEntry <$> dateSortPosts xs + let t = Atom.nullFeed baseUrl (Atom.TextString title) $ Atom.entryUpdated (head fs) + let (Just a) = textFeed (t { Atom.feedEntries = fs }) + writeFile' out (T.unpack . TL.toStrict $ a) diff --git a/src/Shakebook/Rules.hs b/src/Shakebook/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Rules.hs @@ -0,0 +1,27 @@ +module Shakebook.Rules where + +import Control.Comonad.Cofree +import Control.Comonad.Store +import RIO +import Development.Shake + +comonadStoreRuleGen :: ComonadStore s w + => FilePattern -- The filepattern rule. + -> (FilePattern -> s) -- How to extract a position marker from the filepattern. + -> (FilePattern -> a) -- How to extract an id from the filepattern. + -> (a -> Action (w b)) -- How to turn the id into a searchable store. + -> (b -> FilePath -> Action ()) + -> Rules () +comonadStoreRuleGen fp f g h k = do + fp %> \x -> do + xs <- h (g x) + k (extract (seek (f x) xs)) x + +cofreeRuleGen :: (Traversable w, ComonadCofree f w) + => w FilePath + -> (FilePath -> FilePath) + -> (w FilePath -> FilePath -> Action ()) + -> Rules () +cofreeRuleGen xs h k = do + let f ys = h (extract ys) %> k ys + void . sequence . extend f $ xs diff --git a/src/Shakebook/Zipper.hs b/src/Shakebook/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Shakebook/Zipper.hs @@ -0,0 +1,29 @@ +{-| Zipper utils that weren't in Control.Comonad.Store.Zipper -} + +module Shakebook.Zipper ( + paginate +, zipperNextMaybe +, zipperPreviousMaybe +, zipperWithin +) where + +import Control.Comonad.Store +import Control.Comonad.Store.Zipper +import Data.List.Split +import RIO + +-- Turn a list into a zipper of chunks of length n +paginate :: Int -> [a] -> Maybe (Zipper [] [a]) +paginate n = zipper . chunksOf n + +-- Return the peek of the next element if it exists. +zipperNextMaybe :: Zipper [] a -> Maybe a +zipperNextMaybe xs = if pos xs < size xs-1 then Just (peeks (+1) xs) else Nothing + +-- Return the peek of the previous element if it exists. +zipperPreviousMaybe :: Zipper [] a -> Maybe a +zipperPreviousMaybe xs = if pos xs > 0 then Just (peeks (+ (-1)) xs) else Nothing + +-- Return a list of elements within 'r' hops either side of the zipper target. +zipperWithin :: Int -> Zipper [] a -> [a] +zipperWithin r xs = (`peek` xs) <$> [(max 0 (pos xs - r)) .. (min (size xs -1) (pos xs + r))] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"