shakebook 0.9.1.0 → 0.11.0.0
raw patch · 15 files changed
+710/−510 lines, 15 filesdep +aeson-better-errorsdep +binarydep +composite-aesondep −withindep ~aesondep ~pandocdep ~shake-plus
Dependencies added: aeson-better-errors, binary, composite-aeson, composite-base, lucid, lucid-cdn, mtl, path, shake-plus-extended, vinyl
Dependencies removed: within
Dependency ranges changed: aeson, pandoc, shake-plus
Files
- ChangeLog.md +8/−1
- shakebook.cabal +33/−11
- src/Shakebook.hs +6/−1
- src/Shakebook/Aeson.hs +44/−0
- src/Shakebook/Composite.hs +34/−0
- src/Shakebook/Conduit.hs +6/−6
- src/Shakebook/Conventions.hs +379/−229
- src/Shakebook/Defaults.hs +15/−15
- src/Shakebook/Feed.hs +8/−18
- src/Shakebook/Mustache.hs +15/−9
- src/Shakebook/Pandoc.hs +10/−50
- src/Shakebook/Sitemap.hs +11/−19
- src/Shakebook/Url.hs +15/−0
- src/Shakebook/Utils.hs +14/−0
- test/Spec.hs +112/−151
ChangeLog.md view
@@ -1,8 +1,15 @@ # Changelog for Shakebook +## (v0.10.0.0)++* Add [lucid](https://hackage.haskell.org/package/lucid).+* Add [lucid-cdn](https://hackage.haskell.org/package/lucid-cdn).+* Add `withCdnImports` to `Shakebook.Conventions`.+* Add `defaultCdnImports` to `Shakebook.Defaults`.+ ## (v0.9.1.0) -* Add [ixset-typed-conversions] for producing `Zipper`s and `HashMap`s.+* Add [ixset-typed-conversions](https://hackage.haskell.org/package/ixset-typed-conversions) for producing `Zipper`s and `HashMap`s. ## (v0.9.0.0)
shakebook.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: shakebook-version: 0.9.1.0+version: 0.11.0.0 synopsis: Shake-based technical documentation generator; HTML & PDF description: Shakebook is a documentation generator aimed at covering all the bases for mathematical, technical and scientific diagrams and typesetting. Shakebook provides combinators for taking markdown files and combining them into documents, but allowing the user to control how. Shakebook provides general combinators for templating single pages, cofree comonads for representing tables of contents, and zipper comonads for representing pagers. category: Web@@ -22,6 +22,8 @@ library exposed-modules: Shakebook+ Shakebook.Aeson+ Shakebook.Composite Shakebook.Conduit Shakebook.Conventions Shakebook.Defaults@@ -29,19 +31,25 @@ Shakebook.Mustache Shakebook.Pandoc Shakebook.Sitemap+ Shakebook.Url+ Shakebook.Utils 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+ default-extensions: BangPatterns BinaryLiterals BlockArguments 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 TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -Wredundant-constraints build-depends:- aeson >=1.5.2.0+ aeson+ , aeson-better-errors , aeson-with >=0.1.1.0 , base >=4.7 && <5+ , binary , binary-instances , comonad , comonad-extras+ , composite-aeson >=0.7.3.0+ , composite-base >=0.7.3.0 , doctemplates , feed , free@@ -51,17 +59,22 @@ , ixset-typed-conversions , lens , lens-aeson+ , lucid+ , lucid-cdn >=0.1.1.0+ , mtl , mustache- , pandoc >=2.10+ , pandoc , pandoc-types+ , path , path-extensions >=0.1.0.1 , rio- , shake-plus >=0.2.0.0+ , shake-plus >=0.3.0.0+ , shake-plus-extended >=0.2.0.0 , sitemap-gen , slick >=1.0.1.1 , split , text-time- , within >=0.2.0.0+ , vinyl , zipper-extra >=0.1.3.0 default-language: Haskell2010 @@ -72,15 +85,19 @@ 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+ default-extensions: BangPatterns BinaryLiterals BlockArguments 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 TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson >=1.5.2.0+ aeson+ , aeson-better-errors , aeson-with >=0.1.1.0 , base >=4.7 && <5+ , binary , binary-instances , comonad , comonad-extras+ , composite-aeson >=0.7.3.0+ , composite-base >=0.7.3.0 , doctemplates , feed , free@@ -90,12 +107,17 @@ , ixset-typed-conversions , lens , lens-aeson+ , lucid+ , lucid-cdn >=0.1.1.0+ , mtl , mustache- , pandoc >=2.10+ , pandoc , pandoc-types+ , path , path-extensions >=0.1.0.1 , rio- , shake-plus >=0.2.0.0+ , shake-plus >=0.3.0.0+ , shake-plus-extended >=0.2.0.0 , shakebook , sitemap-gen , slick >=1.0.1.1@@ -103,6 +125,6 @@ , tasty , tasty-golden , text-time- , within >=0.2.0.0+ , vinyl , zipper-extra >=0.1.3.0 default-language: Haskell2010
src/Shakebook.hs view
@@ -15,6 +15,7 @@ , module Control.Comonad.Zipper.Extra , module Data.Aeson , module Development.Shake.Plus+, module Shakebook.Aeson , module Shakebook.Conduit , module Shakebook.Conventions , module Shakebook.Defaults@@ -22,6 +23,7 @@ , module Shakebook.Mustache , module Shakebook.Pandoc , module Shakebook.Sitemap+, module Shakebook.Url , module Text.Pandoc.Highlighting ) where @@ -31,11 +33,14 @@ import Control.Comonad.Zipper.Extra import Data.Aeson import Development.Shake.Plus+import Shakebook.Aeson+import Shakebook.Composite() import Shakebook.Conduit import Shakebook.Conventions import Shakebook.Defaults-import Shakebook.Feed+import Shakebook.Feed hiding (Link) import Shakebook.Mustache import Shakebook.Pandoc import Shakebook.Sitemap+import Shakebook.Url import Text.Pandoc.Highlighting
+ src/Shakebook/Aeson.hs view
@@ -0,0 +1,44 @@+module Shakebook.Aeson where++import Composite.Aeson+import Control.Monad.Except+import Data.Aeson+import Data.Aeson.BetterErrors+import Lucid+import Path+import RIO+import qualified RIO.Text as T+import qualified RIO.Text.Lazy as LT+import Text.Pandoc.Highlighting++newtype AesonParseException a = AesonParseException a+ deriving (Eq, Show, Ord)+++instance (Typeable a, Show a) => Exception (AesonParseException a)++parseValue' :: MonadThrow m => JsonFormat Void x -> Value -> m x+parseValue' f v = do+ let a = parseValue (fromJsonWithFormat f) v+ either (throwM . AesonParseException) return a++data WriteOnlyJsonField = WriteOnlyJsonField+ deriving Show++lucidJsonFormat :: JsonFormat e (Html ())+lucidJsonFormat = jsonFormatWithoutCustomError $ JsonFormat $ JsonProfunctor (String . LT.toStrict . renderText) (throwCustomError WriteOnlyJsonField)++styleJsonFormat :: JsonFormat e Style+styleJsonFormat = jsonFormatWithoutCustomError $ JsonFormat $ JsonProfunctor (String . T.pack . styleToCss) (throwCustomError WriteOnlyJsonField)++relFileJsonFormat :: JsonFormat e (Path Rel File)+relFileJsonFormat = aesonJsonFormat++relDirJsonFormat :: JsonFormat e (Path Rel Dir)+relDirJsonFormat = aesonJsonFormat++absFileJsonFormat :: JsonFormat e (Path Abs File)+absFileJsonFormat = aesonJsonFormat++absDirJsonFormat :: JsonFormat e (Path Abs Dir)+absDirJsonFormat = aesonJsonFormat
+ src/Shakebook/Composite.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE UndecidableInstances #-}+module Shakebook.Composite where++import Composite.Record+import Development.Shake.Plus hiding ((:->))+import RIO++instance Hashable a => Hashable (s :-> a) where+ hashWithSalt n x = hashWithSalt n $ getVal x++instance Binary a => Binary (s :-> a) where+ put = put . getVal+ get = fmap (runIdentity . val) get++instance NFData (s :-> a) where+ rnf x = seq x ()++instance Binary (Record '[])++instance (Binary a, Binary (Record xs), x ~ (s :-> a)) => Binary (Record (x : xs)) where+ put (x :*: xs) = put x >> put xs+ get = liftA2 (:*:) get get++instance NFData (Record '[]) where+ rnf RNil = ()++instance (NFData a, NFData (Record xs), x ~ (s :-> a)) => NFData (Record (x : xs)) where+ rnf (x :*: xs) = rnf x `seq` rnf xs++instance Hashable (Record '[]) where+ hashWithSalt n RNil = n `hashWithSalt` ()++instance (Hashable a, Hashable (Record xs), x ~ (s :-> a)) => Hashable (Record (x : xs)) where+ hashWithSalt n (x :*: xs) = n `hashWithSalt` x `hashWithSalt` xs
src/Shakebook/Conduit.hs view
@@ -13,12 +13,12 @@ , addRemoteJSONOracleCache ) where -import Data.Aeson-import Data.Binary.Instances.Aeson()-import Development.Shake.Plus-import RIO-import qualified RIO.Text as T-import Network.HTTP.Simple+import Data.Aeson+import Data.Binary.Instances.Aeson ()+import Development.Shake.Plus+import Network.HTTP.Simple+import RIO+import qualified RIO.Text as T -- | Remote json lookup for an oracle, this should contain a URL as Text. newtype RemoteJSONLookup = RemoteJSONLookup Text
src/Shakebook/Conventions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} {- | Module : Shakebook.Conventions Copyright : Copyright (C) 2020 Daniel Firth@@ -8,299 +10,447 @@ Conventions used in Shakebook projects, common lenses, generators, and indexing wrappers over Values. -} module Shakebook.Conventions (- -- * Lenses- viewImage-, viewModified-, viewPostTime-, viewPostTimeRaw-, viewTags-, viewTitle-, viewAllPostTags-, viewAllPostTimes-, withBaseUrl-, withFullUrl-, withHighlighting-, withModified-, withNext-, withPages-, withPrettyDate-, withPrevious-, withPosts-, withRecentPosts-, withSocialLinks-, withSiteTitle-, withSubsections-, withTagIndex-, withTagLinks-, withTeaser-, withTitle+ -- * Fields+ FCdnImports+, FContent+, FDescription+, FHighlighting+, FItems+, FPageLinks+, FPosted+, FImage+, FModified+, FNext+, FRecentPosts+, FPrettyDate+, FPrevious+, FSiteTitle+, FSocial+, FSrcPath+, FSubsections+, FTags+, FTagLinks+, FTeaser+, FTitle+, FToc+, FUrl+, FPageNo - -- * Enrichments-, enrichPrettyDate-, enrichTagLinks-, enrichTeaser - -- * Extensions-, extendNext-, extendPrevious-, extendNextPrevious-, extendPageNeighbours+, fCdnImports+, fContent+, fDescription+, fHighlighting+, fItems+, fPageLinks+, fPosted+, fImage+, fModified+, fNext+, fRecentPosts+, fPrettyDate+, fPrevious+, fSiteTitle+, fSocial+, fSrcPath+, fSubsections+, fTags+, fTagLinks+, fTeaser+, fTitle+, fToc+, fUrl+, fPageNo+, fId -- * Generations-, genBlogNavbarData-, genIndexPageData-, genLinkData-, genPageData-, genTocNavbarData+, genBlogNav+, genDocNav+, addDerivedUrl+, asSitemapUrl+, asAtomEntry+, addTagLinks+, addPrettyDate+, addTeaser -- * Indexing-, Post(..)+, Link , Tag(..) , Posted(..) , YearMonth(..)-, SrcFile(..)-, postIndex-, postZipper , fromYearMonthPair , toYearMonthPair++ -- * Stages+, RawPost+, Stage1Post+, RawDoc+, Stage1Doc++ -- * Oracles+, BlogNav(..)+, DocNav(..)+, IndexRoot(..)+, IndexPages(..)+, RecentPosts(..)+, PostsFilter(..)+, indexFilter+, defaultIndexRoots+, defaultIndexPages++ -- * Formatting+, basicMDJsonFormatRecord+, basicMDJsonFormat+, rawDocJsonFormat+, rawPostJsonFormat+, rawSingleJsonFormat+, stage1PostJsonFormat+, stage1DocJsonFormat+, finalPostJsonFormat+, mainPageJsonFormat+, indexPageJsonFormatRecord+, postIndexPageJsonFormat+, finalDocJsonFormat++ -- * Templates+, TMain+, TDoc+, TPost+, TPostIndex+, Enriched ) where +import Composite.Aeson+import Composite.Record+import Composite.TH import Control.Comonad.Cofree import Control.Comonad.Store-import Control.Comonad.Zipper.Extra-import Control.Lens hiding ((:<), Indexable)-import Data.Aeson as A-import Data.Aeson.Lens-import Data.Aeson.With+import Data.Binary.Instances.Time () import Data.Hashable.Time-import Data.IxSet.Typed as Ix-import Data.IxSet.Typed.Conversions as Ix-import Data.Text.Time-import Development.Shake.Plus-import RIO hiding (view)+import Data.IxSet.Typed as Ix+import Development.Shake.Plus hiding ((:->))+import Lucid+import RIO import RIO.List import RIO.List.Partial-import qualified RIO.HashMap as HM-import qualified RIO.Text as T-import qualified RIO.Text.Partial as T+import qualified RIO.Text as T+import qualified RIO.Text.Partial as T import RIO.Time-import qualified RIO.Vector as V-import Shakebook.Pandoc+import Shakebook.Aeson+import Shakebook.Defaults+import qualified Shakebook.Feed as Atom+import Shakebook.Sitemap import Text.Pandoc.Highlighting+import Control.Comonad.Zipper.Extra --- | View the "image" field of a JSON value.-viewImage :: ToJSON a => a -> Text-viewImage = view' (key "image" . _String)+withLensesAndProxies [d|+ type FId = "id" :-> Text+ type FUrl = "url" :-> Text+ |] --- | View the "modified" field of a JSON value.-viewModified :: ToJSON a => a -> UTCTime-viewModified = parseISODateTime . view' (key "modified" . _String)+type Link = '[FId, FUrl] --- | View the "date" field of a JSON Value as a UTCTime.-viewPostTime :: ToJSON a => a -> UTCTime-viewPostTime = parseISODateTime . view' (key "date" . _String)+withLensesAndProxies [d|+ type FCdnImports = "cdn-imports" :-> Text+ type FContent = "content" :-> Text+ type FDescription = "description" :-> Text+ type FHighlighting = "highlighting" :-> Style+ type FImage = "image" :-> Maybe Text --- | View the "date" field of a JSON Value as Text.-viewPostTimeRaw :: ToJSON a => a -> Text-viewPostTimeRaw = view' (key "date" . _String)+ type FModified = "modified" :-> UTCTime+ type FNext = "next" :-> Text+ type FPageNo = "pageno" :-> Int+ type FPageLinks = "page-links" :-> [Record Link]+ type FPrettyDate = "pretty-date" :-> UTCTime+ type FPrevious = "previous" :-> Text+ type FPosted = "posted" :-> UTCTime+ type FItems x = "items" :-> [Record x]+ type FRecentPosts x = "recent-posts" :-> [Record x]+ type FSiteTitle = "site-title" :-> Text+ type FSrcPath = "src-path" :-> Path Rel File+ type FSocial = "social" :-> [Record Link]+ type FSubsections x = "subsections" :-> [Record x]+ type FTags = "tags" :-> [Text]+ type FTagLinks = "tag-links" :-> [Record Link]+ type FTeaser = "teaser" :-> Text+ type FTitle = "title" :-> Text+ type FToc = "toc" :-> Text --- | View the "tags" field of a JSON Value as a list.-viewTags :: ToJSON a => a -> [Text]-viewTags = toListOf' (key "tags" . values . _String)+ |] --- | View the "title" field of a JSON Value.-viewTitle :: ToJSON a => a -> Text-viewTitle = view' (key "title" . _String)+-- | Tag indices for a `Post` for use with `IxSet`.+newtype Tag = Tag Text+ deriving (Show, Eq, Ord, Data, Typeable, Hashable, Binary, NFData, Generic) --- | View all post tags for a list of posts.-viewAllPostTags :: ToJSON a => [a] -> [Text]-viewAllPostTags = (>>= viewTags)+-- | Posted index for a `Post` for use with `IxSet`.+newtype Posted = Posted UTCTime+ deriving (Show, Eq, Ord, Data, Typeable, Hashable, Generic, NFData) --- | View all posts times for a list of posts.-viewAllPostTimes :: ToJSON a => [a] -> [UTCTime]-viewAllPostTimes = fmap viewPostTime+-- | YearMonth (yyyy, mm) index for a `Post` for use with `IxSet`.+newtype YearMonth = YearMonth (Integer, Int)+ deriving (Show, Eq, Ord, Data, Typeable, Hashable, Binary, NFData, Generic) --- | Add "base-url" field from input Text.-withBaseUrl :: Text -> Value -> Value-withBaseUrl = withStringField "base-url"+toYearMonthPair :: UTCTime -> (Integer, Int)+toYearMonthPair = (\(a, b, _) -> (a, b)) . toGregorian . utctDay --- | Add "full-url" field from input Text.-withFullUrl :: Text -> Value -> Value-withFullUrl = withStringField "full-url"+fromYearMonthPair :: (Integer, Int) -> UTCTime+fromYearMonthPair (y,m) = UTCTime (fromGregorian y m 1) 0 --- | Add "highlighting-css" field from input Style.-withHighlighting :: Style -> Value -> Value-withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss+-- | Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".+genBlogNav :: (IsIndexOf YearMonth ixs, RElem FPosted xs, RElem FUrl xs, RElem FTitle xs, MonadAction m)+ => Text -- ^ "Top level title, e.g "Blog"+ -> (UTCTime -> Text) -- ^ Formatting function to a UTCTime to a title.+ -> IxSet ixs (Record xs)+ -> HtmlT m ()+genBlogNav a f xs = do+ ul_ $+ li_ $ do+ b <- lift $ askOracle $ IndexRoot AllPosts+ a_ [href_ b] (toHtml a)+ ul_ $ forM_ (groupDescBy xs) $ \(YearMonth(y, m), xs') -> do+ k <- lift $ askOracle $ IndexRoot $ ByYearMonth $ YearMonth (y, m)+ li_ $ a_ [href_ k] (toHtml . f $ fromYearMonthPair (y, m))+ ul_ $ forM (sortOn (Down . view fPosted) xs') $ \x ->+ li_ $ a_ [href_ $ view fUrl x] (toHtml $ view fTitle x) --- | Add "modified" field from input UTCTime.-withModified :: UTCTime -> Value -> Value-withModified = withStringField "modified" . T.pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)+-- | Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3".+genDocNav :: (RElem FUrl xs, RElem FTitle xs) => Cofree [] (Record xs) -> Html ()+genDocNav (x :< xs) = ul_ $ li_ $ do+ a_ [href_ $ view fUrl x] (toHtml $ view fTitle x)+ forM_ xs genDocNav --- | Add "next" field from input Value.-withNext :: ToJSON a => a -> Value -> Value-withNext = withValue "next"+asSitemapUrl :: (RElem FUrl xs, RElem FPosted xs) => Text -> Record xs -> SitemapUrl+asSitemapUrl baseUrl x = SitemapUrl {+ sitemapLocation = baseUrl <> view fUrl x+ , sitemapLastModified = Just (view fPosted x)+ , sitemapChangeFrequency = Nothing+ , sitemapPriority = Nothing+} --- | Add "pages" field from input [Value].-withPages :: ToJSON a => [a] -> Value -> Value-withPages = withArrayField "pages"+-- | Convert a Post to an Atom Entry+asAtomEntry :: (RElem FContent xs, RElem FPosted xs, RElem FUrl xs, RElem FTitle xs) => Record xs -> Atom.Entry+asAtomEntry x = (Atom.nullEntry (view fUrl x)+ (Atom.TextString $ view fTitle x)+ (T.pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing) $ view fPosted x)) {+ Atom.entryContent = Just $ Atom.TextContent (view fContent x)+ } --- | Add "prettydate" field using input Text.-withPrettyDate :: Text -> Value -> Value-withPrettyDate = withStringField "pretty-date"+addDerivedUrl :: (MonadThrow m, RElem FSrcPath xs) => (Path Rel File -> m Text) -> Record xs -> m (Record (FUrl : xs))+addDerivedUrl f xs = f (view fSrcPath xs) >>= \x -> return $ x :*: xs --- | Add "previous" field using input Value.-withPrevious :: ToJSON a => a -> Value -> Value-withPrevious = withValue "previous"+--- Stage 0 Types --- | Add "posts" field based on input [Value].-withPosts :: ToJSON a => [a] -> Value -> Value-withPosts = withArrayField "posts"+-- "Basic Markdown" - These two fields are always populated by the markdown loader - the source path and the main body content.+type BasicMD = FSrcPath : FContent : '[] --- | Add "recent-posts" field using input Value.-withRecentPosts :: ToJSON a => [a] -> Value -> Value-withRecentPosts = withArrayField "recent-posts"+basicMDJsonFormatRecord :: JsonFormatRecord e BasicMD+basicMDJsonFormatRecord = field relFileJsonFormat+ :& field textJsonFormat+ :& RNil --- | Add "site-title" field from input Text.-withSiteTitle :: Text -> Value -> Value-withSiteTitle = withStringField "site-title"+basicMDJsonFormat :: JsonFormat e (Record BasicMD)+basicMDJsonFormat = recordJsonFormat basicMDJsonFormatRecord --- | Add "social-links" field based on input [Value].-withSocialLinks :: ToJSON a => [a] -> Value -> Value-withSocialLinks = withArrayField "social-links"+-- A 'RawDoc' contains three mandatory fields - title, description and modified.+type RawDoc = FDescription : FTitle : FModified : BasicMD --- | Add "subsections" field based on input [Value].-withSubsections :: ToJSON a => [a] -> Value -> Value-withSubsections = withArrayField "subsections"+rawDocJsonFormatRecord :: JsonFormatRecord e RawDoc+rawDocJsonFormatRecord = field aesonJsonFormat+ :& field defaultJsonFormat+ :& field iso8601DateTimeJsonFormat+ :& basicMDJsonFormatRecord --- | Add "tag-index" field based on input [Value].-withTagIndex :: ToJSON a => [a] -> Value -> Value-withTagIndex = withArrayField "tag-index"+rawDocJsonFormat :: JsonFormat e (Record RawDoc)+rawDocJsonFormat = recordJsonFormat rawDocJsonFormatRecord --- | Add "tag-links" field based on input [Value].-withTagLinks :: ToJSON a => [a] -> Value -> Value-withTagLinks = withArrayField "tag-links"+-- A `RawPost` contains three mandatory fields, title, tags, and posted, and an optional image field.+type RawPost = FTitle : FImage : FTags : FPosted : BasicMD --- | Add "teaser" field based on input Text.-withTeaser :: Text -> Value -> Value-withTeaser = withStringField "teaser"+rawPostJsonFormatRecord :: JsonFormatRecord e RawPost+rawPostJsonFormatRecord = field textJsonFormat+ :& optionalField textJsonFormat+ :& field (listJsonFormat textJsonFormat)+ :& field (dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%F" "yyyy-mm-dd" :| []))+ :& basicMDJsonFormatRecord --- | Add "title" field based on input Text.-withTitle :: Text -> Value -> Value-withTitle = withStringField "title"+rawPostJsonFormat :: JsonFormat e (Record RawPost)+rawPostJsonFormat = recordJsonFormat rawPostJsonFormatRecord --- | Assuming a "date" field, enrich using withPrettyDate and a format string.-enrichPrettyDate :: (UTCTime -> Text) -> Value -> Value-enrichPrettyDate f v = withPrettyDate (f . viewPostTime $ v) v+-- A `RawSingle` is a post without any tags or date information.+type RawSingle = FTitle : FImage : BasicMD --- | Assuming a "tags" field, enrich using withTagLinks.-enrichTagLinks :: (Text -> Text) -> Value -> Value-enrichTagLinks f v = withTagLinks ((genLinkData <*> f) <$> viewTags v) v+rawSingleJsonFormatRecord :: JsonFormatRecord e RawSingle+rawSingleJsonFormatRecord = field textJsonFormat+ :& optionalField textJsonFormat+ :& basicMDJsonFormatRecord --- | 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+rawSingleJsonFormat :: JsonFormat e (Record RawSingle)+rawSingleJsonFormat = recordJsonFormat rawSingleJsonFormatRecord --- | Add both "next" and "previous" fields using `withPostNext` and `withPostPrevious`-extendNextPrevious :: Zipper [] Value -> Zipper [] Value-extendNextPrevious = extendPrevious . extendNext+--- Stage 1 Types --- | Extend a Zipper of Values to add "previous" objects.-extendPrevious :: Zipper [] Value -> Zipper [] Value-extendPrevious = extend (liftA2 withPrevious zipperPreviousMaybe extract)+-- Simple link object, used in a list for tags and social links. --- | Extend a Zipper of Values to add "next" objects.-extendNext :: Zipper [] Value -> Zipper [] Value-extendNext = extend (liftA2 withNext zipperNextMaybe extract)+linkJsonFormatRecord :: JsonFormatRecord e Link+linkJsonFormatRecord = field textJsonFormat :& field textJsonFormat :& RNil --- | Extend a Zipper of Values to add list of "pages" within r hops either side of the focus.-extendPageNeighbours :: Int -> Zipper [] Value -> Zipper [] Value-extendPageNeighbours r = extend (liftA2 withPages (zipperWithin r) extract)+linkJsonFormat :: JsonFormat e (Record Link)+linkJsonFormat = recordJsonFormat linkJsonFormatRecord --- | Create link data object with fields "id" and "url" using an id and a function--- | transforming an id into a url.-genLinkData :: Text -> Text -> Value-genLinkData x u = object ["id" A..= String x, "url" A..= String u]+type URLised x = FUrl : x --- | Indexable Post Type-newtype Post = Post { unPost :: Value }- deriving (Show, Eq, Ord, Data, Typeable, Hashable, ToJSON)+urlisedXJsonFormatRecord :: JsonFormatRecord e x -> JsonFormatRecord e (URLised x)+urlisedXJsonFormatRecord x = field textJsonFormat :& x --- | Tag indices for a `Post` for use with `IxSet`.-newtype Tag = Tag Text- deriving (Show, Eq, Ord, Data, Typeable, Hashable)+type Stage1Post = FPrettyDate : FTagLinks : FTeaser : URLised RawPost --- | Posted index for a `Post` for use with `IxSet`.-newtype Posted = Posted UTCTime- deriving (Show, Eq, Ord, Data, Typeable, Hashable)+stage1PostJsonFormatRecord :: JsonFormatRecord e Stage1Post+stage1PostJsonFormatRecord = field (dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%A, %B %d, %Y" "yyyy-mm-dd" :| []))+ :& field (listJsonFormat linkJsonFormat)+ :& field textJsonFormat+ :& urlisedXJsonFormatRecord rawPostJsonFormatRecord --- | YearMonth (yyyy, mm) index for a `Post` for use with `IxSet`.-newtype YearMonth = YearMonth (Integer, Int)- deriving (Show, Eq, Ord, Data, Typeable, Hashable)+stage1PostJsonFormat :: JsonFormat e (Record Stage1Post)+stage1PostJsonFormat = recordJsonFormat stage1PostJsonFormatRecord --- | SrcFile index for a `Post` for use with `IxSet`.-newtype SrcFile = SrcFile Text- deriving (Show, Eq, Ord, Data, Typeable, Hashable)+type Stage1Doc = URLised RawDoc -instance Indexable '[Tag, Posted, YearMonth, SrcFile] Post where- indices = ixList (ixFun (fmap Tag . viewTags))- (ixFun (pure . Posted . viewPostTime))- (ixFun (pure . YearMonth . toYearMonthPair . viewPostTime))- (ixFun (pure . SrcFile . viewSrcPath))+stage1DocJsonFormatRecord :: JsonFormatRecord e Stage1Doc+stage1DocJsonFormatRecord = urlisedXJsonFormatRecord rawDocJsonFormatRecord -toYearMonthPair :: UTCTime -> (Integer, Int)-toYearMonthPair = (\(a, b, _) -> (a, b)) . toGregorian . utctDay+stage1DocJsonFormat :: JsonFormat e (Record Stage1Doc)+stage1DocJsonFormat = recordJsonFormat stage1DocJsonFormatRecord -fromYearMonthPair :: (Integer, Int) -> UTCTime-fromYearMonthPair (y,m) = UTCTime (fromGregorian y m 1) 0+--- Stage 2 Types --- | Take a Value loading function and a filepattern and return an indexable set of Posts.-postIndex :: MonadAction m- => (Within Rel (Path Rel File) -> m Value)- -> Within Rel [FilePattern]- -> m (Ix.IxSet '[Tag, Posted, YearMonth, SrcFile] Post)-postIndex rd fp = do- xs <- batchLoadWithin' fp rd- return (Ix.fromList $ Post <$> HM.elems xs)+-- Enrichment provides fields most pages display or can otherwise be safely ignored such as highlighting, json imports and social links.+type Enriched x = FSocial : FCdnImports : FHighlighting : FSiteTitle : x --- | Create a `Zipper [] Post` from an `IxSet xs Post` by ordering by `Posted`.-postZipper :: (MonadThrow m, Ix.IsIndexOf Posted xs) => Ix.IxSet xs Post -> m (Zipper [] Post)-postZipper = Ix.toZipperDesc (Proxy :: Proxy Posted)+enrichedXJsonFormatRecord :: JsonFormatRecord e x -> JsonFormatRecord e (Enriched x)+enrichedXJsonFormatRecord x = field (listJsonFormat linkJsonFormat)+ :& field textJsonFormat+ :& field styleJsonFormat+ :& field defaultJsonFormat+ :& x --- | Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".-genBlogNavbarData :: IsIndexOf YearMonth ixs => 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- -> IxSet ixs Post- -> 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 (uncurry toc2) $ groupDescBy xs)]- ] where- toc2 _ [] = object []- toc2 (YearMonth (_, _)) t@(x : _) = object [ "title" A..= String (f (viewPostTime x))- , "url" A..= String (g (viewPostTime x))- , "toc3" A..= Array (V.fromList $ sortOn (Down . viewPostTime) (unPost <$> t)) ]+type FinalDoc = FToc : FSubsections Stage1Doc : Enriched Stage1Doc --- | 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 (y :< ys) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract ys)) y+finalDocJsonFormatRecord :: JsonFormatRecord e FinalDoc+finalDocJsonFormatRecord = field textJsonFormat+ :& field (listJsonFormat stage1DocJsonFormat)+ :& enrichedXJsonFormatRecord stage1DocJsonFormatRecord -genPageData :: ToJSON a => Text -> (Text -> Text) -> Zipper [] [a] -> Value-genPageData t f xs = let x = T.pack . show $ pos xs + 1- in withTitle t- . withJSON (genLinkData x (f x))- . withPosts (extract xs) $ Object mempty+finalDocJsonFormat :: JsonFormat e (Record FinalDoc)+finalDocJsonFormat = recordJsonFormat finalDocJsonFormatRecord -genIndexPageData :: (MonadThrow m, ToJSON a)- => Text- -> (Text -> Text)- -> Int- -> [a]- -> m (Zipper [] Value)-genIndexPageData g h n xs = do- zs <- paginate' n $ sortOn (Down . viewPostTime) xs- return $ extend (genPageData g h) zs+type FinalPost = FToc : Enriched Stage1Post++finalPostJsonFormatRecord :: JsonFormatRecord e FinalPost+finalPostJsonFormatRecord = field textJsonFormat+ :& enrichedXJsonFormatRecord stage1PostJsonFormatRecord++finalPostJsonFormat :: JsonFormat e (Record FinalPost)+finalPostJsonFormat = recordJsonFormat finalPostJsonFormatRecord++type IndexPage x = Enriched (FPageLinks : FToc : FTitle : FUrl : FItems x : FPageNo : '[])++indexPageJsonFormatRecord :: JsonFormat e (Record x) -> JsonFormatRecord e (IndexPage x)+indexPageJsonFormatRecord x = enrichedXJsonFormatRecord $ field (listJsonFormat linkJsonFormat)+ :& field textJsonFormat+ :& field textJsonFormat+ :& field textJsonFormat+ :& field (listJsonFormat x)+ :& field integralJsonFormat+ :& RNil++type PostIndexPage = IndexPage Stage1Post++postIndexPageJsonFormat :: JsonFormat e (Record PostIndexPage)+postIndexPageJsonFormat = recordJsonFormat $ indexPageJsonFormatRecord stage1PostJsonFormat++type MainPage = FRecentPosts Stage1Post : Enriched RawSingle++mainPageJsonFormatRecord :: JsonFormatRecord e MainPage+mainPageJsonFormatRecord = field (listJsonFormat stage1PostJsonFormat)+ :& enrichedXJsonFormatRecord rawSingleJsonFormatRecord++mainPageJsonFormat :: JsonFormat e (Record MainPage)+mainPageJsonFormat = recordJsonFormat mainPageJsonFormatRecord++addTagLinks :: (MonadAction m, RElem FTags xs) => Record xs -> m (Record (FTagLinks : xs))+addTagLinks xs = do+ ks <- forM (view fTags xs) $ \x -> do+ u <- askOracle . IndexRoot . ByTag . Tag $ x+ return (x :*: u :*: RNil)+ return $ ks :*: xs++addTeaser :: RElem FContent xs => Record xs -> Record (FTeaser : xs)+addTeaser xs = head (T.splitOn "<!-- more -->" (view fContent xs)) :*: xs++addPrettyDate :: RElem FPosted xs => Record xs -> Record (FPrettyDate : xs)+addPrettyDate xs = view fPosted xs :*: xs+++instance Ix.Indexable '[Tag, Posted, YearMonth] (Record Stage1Post) where+ indices = Ix.ixList (Ix.ixFun (fmap Tag . view fTags))+ (Ix.ixFun (pure . Posted . view fPosted))+ (Ix.ixFun (pure . YearMonth . toYearMonthPair . view fPosted))++newtype BlogNav = BlogNav ()+ deriving (Eq, Show, Generic, Binary, Hashable, NFData)++type instance RuleResult BlogNav = Text++newtype DocNav = DocNav ()+ deriving (Eq, Show, Generic, Binary, Hashable, NFData)++type instance RuleResult DocNav = Text++newtype RecentPosts = RecentPosts ()+ deriving (Eq, Show, Generic, Binary, Hashable, NFData)++type instance RuleResult RecentPosts = [Record Stage1Post]++data PostsFilter = AllPosts | ByTag Tag | ByYearMonth YearMonth+ deriving (Eq, Show, Generic)++instance NFData PostsFilter+instance Hashable PostsFilter+instance Binary PostsFilter++newtype IndexRoot = IndexRoot PostsFilter+ deriving (Eq, Show, Generic, Binary, Hashable, NFData)++type instance RuleResult IndexRoot = Text++newtype IndexPages = IndexPages PostsFilter+ deriving (Eq, Show, Generic, Binary, Hashable, NFData)++type instance RuleResult IndexPages = [Record (FUrl : FItems Stage1Post : FPageNo : '[])]++type TMain = "templates/index.html" :-> Record MainPage+type TDoc = "templates/docs.html" :-> Record FinalDoc+type TPost = "templates/post.html" :-> Record FinalPost+type TPostIndex = "templates/post-list.html" :-> Record PostIndexPage++indexFilter :: (Indexable ixs a, IsIndexOf Tag ixs,+ IsIndexOf YearMonth ixs) =>+ PostsFilter -> IxSet ixs a -> IxSet ixs a++indexFilter x = case x of+ AllPosts -> id+ ByTag t -> (Ix.@+ [t])+ ByYearMonth t -> (Ix.@+ [t])++defaultIndexRoots :: MonadAction m => IndexRoot -> m Text+defaultIndexRoots (IndexRoot x) = case x of+ AllPosts -> return "/posts/"+ ByTag (Tag t) -> (<> "tags/" <> t <> "/") <$> askOracle (IndexRoot AllPosts)+ ByYearMonth (YearMonth (y, m)) -> (<> "months/" <> defaultMonthUrlFormat (fromYearMonthPair (y, m)) <> "/") <$> askOracle (IndexRoot AllPosts)++defaultIndexPages :: (MonadAction m, MonadThrow m, Indexable xs (Record Stage1Post), IsIndexOf YearMonth xs, IsIndexOf Tag xs, IsIndexOf Posted xs) => IxSet xs (Record Stage1Post) -> Int -> IndexPages -> m [Record (FUrl : FItems Stage1Post : FPageNo : '[])]+defaultIndexPages postIx postsPerPage (IndexPages x) = do+ r <- askOracle $ IndexRoot x+ let k = Ix.toDescList (Proxy @Posted) . indexFilter x $ postIx+ p <- paginate' postsPerPage k+ return $ unzipper $ extend (\a -> r <> "pages/" <> T.pack (show $ pos a + 1) :*: extract a :*: pos a + 1:*: RNil) p
src/Shakebook/Defaults.hs view
@@ -7,19 +7,17 @@ Seom sensible default settings for certain shakebook functions. -}--{-# LANGUAGE TemplateHaskell #-} module Shakebook.Defaults where -import Data.Aeson as A-import Development.Shake.Plus+import Lucid+import Lucid.CDN import RIO-import qualified RIO.Map as M-import qualified RIO.Text as T+import qualified RIO.Map as M+import qualified RIO.Text as T import RIO.Time-import Shakebook.Conventions import Text.DocTemplates import Text.Pandoc.Definition+import Text.Pandoc.Highlighting import Text.Pandoc.Options defaultMonthUrlFormat :: UTCTime -> Text@@ -34,10 +32,8 @@ defaultMonthUrlFragment :: UTCTime -> Text defaultMonthUrlFragment t = "/posts/months/" <> defaultMonthUrlFormat t -defaultEnrichPost :: Value -> Value-defaultEnrichPost = enrichTeaser "<!--more-->"- . enrichTagLinks ("/posts/tags/" <>)- . enrichPrettyDate defaultPrettyTimeFormat+defaultHighlighting :: Style+defaultHighlighting = pygments defaultMarkdownReaderOptions :: ReaderOptions defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions }@@ -56,7 +52,11 @@ defaultVideoReplacement :: Text -> Text -> Inline defaultVideoReplacement baseUrl x = Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" -defaultPagePaths :: MonadThrow m => [Int] -> m [Path Rel File]-defaultPagePaths xs = do- xs' <- mapM (parseRelDir . show) xs- return $ fmap (\i -> $(mkRelDir "pages") </> i </> $(mkRelFile "index.html")) xs'+defaultCdnImports :: Html ()+defaultCdnImports = do+ bootstrapCSS_5_0_0_alpha1+ bootstrapJS_5_0_0_alpha1+ fontawesome_4_7_0+ mathjax_3_0_5+ jquery_3_5_1+ popper_2_4_4
src/Shakebook/Feed.hs view
@@ -8,31 +8,21 @@ Utilities from "Text.Atom.Feed" lifted to `MonadAction` and `FileLike`. -} module Shakebook.Feed (- asAtomEntry+ module Text.Atom.Feed , buildFeed ) where -import Data.Aeson import Development.Shake.Plus import RIO-import RIO.List import RIO.List.Partial-import qualified RIO.Text.Lazy as TL-import Shakebook.Conventions-import Shakebook.Pandoc-import Text.Atom.Feed as Atom+import qualified RIO.Text.Lazy as LT+import Text.Atom.Feed import Text.Atom.Feed.Export --- | Convert a Post to an Atom Entry-asAtomEntry :: ToJSON a => a -> 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 :: (MonadAction m, FileLike b a, ToJSON a) => Text -> Text -> [a] -> a -> m ()+-- | Build an Atom Feed from a title, a baseUrl and a list of entries.+buildFeed :: MonadAction m => Text -> Text -> [Entry] -> Path b File -> m () buildFeed title baseUrl xs out = do- let fs = asAtomEntry <$> sortOn (Down . viewPostTime) xs- let t = Atom.nullFeed baseUrl (Atom.TextString title) $ Atom.entryUpdated (head fs)- case textFeed (t { Atom.feedEntries = fs }) of- Just a -> writeFile' out $ TL.toStrict a+ let t = nullFeed baseUrl (TextString title) $ entryUpdated (head xs)+ case textFeed (t { feedEntries = xs }) of+ Just a -> writeFile' out $ LT.toStrict a Nothing -> return ()
src/Shakebook/Mustache.hs view
@@ -15,26 +15,32 @@ , compileTemplate' ) where +import Composite.Aeson+import Composite.Record import Data.Aeson-import Development.Shake.Plus+import Development.Shake.Plus hiding ((:->))+import GHC.TypeLits (KnownSymbol) import RIO+import qualified RIO.Text as T import qualified Slick.Mustache import Text.Mustache -- | Lifted version of `Slick.Mustache.compileTemplate'` with well-typed `Path`.-compileTemplate' :: (MonadAction m, FileLike b a) => a -> m Template-compileTemplate' = liftAction . Slick.Mustache.compileTemplate' . toFilePath . toFile+compileTemplate' :: MonadAction m => Path b File -> m Template+compileTemplate' = liftAction . Slick.Mustache.compileTemplate' . toFilePath -- | Build a single page straight from a template.-buildPageAction :: (MonadAction m, FileLike b a, FileLike b' a')- => a -- ^ The HTML templatate.+buildPageAction :: MonadAction m+ => Path b File -- ^ The HTML templatate. -> Value -- ^ A JSON value.- -> a' -- ^ The out filepath.+ -> Path b' File -- ^ The out filepath. -> m () buildPageAction template value out = do pageT <- compileTemplate' template writeFile' out $ substitute pageT value --buildPageAction' :: (MonadAction m, FileLike b a) => a -> Value -> a -> m ()-buildPageAction' = buildPageAction+buildPageAction' :: (MonadAction m, MonadThrow m, KnownSymbol s) => Path Rel Dir -> (s :-> xs) -> JsonFormat e xs -> Path b File -> m ()+buildPageAction' d xs f o = do+ let (t, v) = valWithName xs+ t' <- parseRelFile $ T.unpack t+ buildPageAction (d </> t') (toJsonWithFormat f v) o
src/Shakebook/Pandoc.hs view
@@ -7,8 +7,6 @@ Pandoc utilities lifted to `MonadAction`. -}-{-# LANGUAGE TemplateHaskell #-}- module Shakebook.Pandoc ( -- * runPandocA runPandocA@@ -33,20 +31,13 @@ , prefixAllImages , progressivelyDemoteHeaders , replaceUnusableImages---- * Lenses-, viewContent-, viewSrcPath-, viewUrl ) where import Control.Comonad import Control.Comonad.Cofree import Data.Aeson-import Data.Aeson.Lens import Data.Aeson.With-import Development.Shake.Plus-import Path.Extensions+import Development.Shake.Plus hiding ((:->)) import RIO import qualified RIO.ByteString.Lazy as LBS import qualified RIO.Text as T@@ -67,29 +58,29 @@ displayException (PandocActionException s) = s -- | Natural transformation from `PandocIO` to a `MonadAction`-runPandocA :: (MonadAction m, MonadThrow m ) => PandocIO a -> m a+runPandocA :: (MonadAction m, MonadThrow m) => PandocIO a -> m a runPandocA p = do result <- liftIO $ runIO p either throwM return result -- | Run a Pandoc reader as a Shake action.-readFilePandoc :: (MonadAction m, MonadThrow m, FileLike b a) => (ReaderOptions -> Text -> PandocIO Pandoc) -> ReaderOptions -> a -> m Pandoc+readFilePandoc :: (MonadAction m, MonadThrow m) => (ReaderOptions -> Text -> PandocIO Pandoc) -> ReaderOptions -> Path b File -> m Pandoc readFilePandoc run ropts src = readFile' src >>= runPandocA . run ropts -- | Read a markdown file and return a `Pandoc` as an Action.-readMarkdownFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc+readMarkdownFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc readMarkdownFile = readFilePandoc readMarkdown -- | Read a mediawiki file and return a `Pandoc` as an Action.-readMediaWikiFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc+readMediaWikiFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc readMediaWikiFile = readFilePandoc readMediaWiki -- | Read a LaTeX file and return a `Pandoc` as an Action.-readLaTeXFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc+readLaTeXFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc readLaTeXFile = readFilePandoc readLaTeX -- | Read a CSV file and return a `Pandoc` as an Action.-readCSVFile :: (MonadAction m, MonadThrow m, FileLike b a) => ReaderOptions -> a -> m Pandoc+readCSVFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc readCSVFile = readFilePandoc readCSV -- | Find all the images in a `Pandoc` data structure and call `Development.Shake.Plus.need` on them.@@ -138,34 +129,6 @@ flattenMeta :: MonadAction m => (Pandoc -> PandocIO Text) -> Meta -> m Value flattenMeta opts meta = liftAction $ Slick.Pandoc.flattenMeta opts meta --- | View the "content" field of a JSON value.-viewContent :: ToJSON a => a -> Text-viewContent = view' (key "content" . _String)---- | Add "content" field from input Text.-withContent :: Text -> Value -> Value-withContent = withStringField "content"---- | View the "src-path" field of a JSON Value.-viewSrcPath :: ToJSON a => a -> Text-viewSrcPath = view' (key "src-path" . _String)---- | Add "src-path" field based on input Text.-withSrcPath :: Text -> Value -> Value-withSrcPath = withStringField "src-path"---- | View the "url" field of a JSON Value.-viewUrl :: ToJSON a => a -> Text-viewUrl = view' (key "url" . _String)---- | Add "url" field from input Text.-withUrl :: Text -> Value -> Value-withUrl = withStringField "url"---- | Add a leading slash to a `Path Rel File` to turn it into a url as `Text`.-toGroundedUrl :: Path Rel File -> Text-toGroundedUrl = T.pack . toFilePath . ($(mkAbsDir "/") </>)- {-| Get a JSON Value of Markdown Data with markdown body as "contents" field and the srcPath as "srcPath" field.@@ -173,14 +136,11 @@ loadMarkdownAsJSON :: (MonadAction m, MonadThrow m) => ReaderOptions -> WriterOptions- -> Within Rel (Path Rel File)+ -> Path b File -> m Value loadMarkdownAsJSON ropts wopts srcPath = do pdoc@(Pandoc meta _) <- readMarkdownFile ropts srcPath meta' <- flattenMeta (writeHtml5String wopts) meta outText <- runPandocA $ writeHtml5String wopts pdoc- supposedUrl <- toGroundedUrl <$> withHtmlExtension (extract srcPath)- return $ withContent outText- . withSrcPath (T.pack . toFilePath $ extract srcPath)- . withUrl supposedUrl $ meta'-+ return $ withStringField "src-path" (T.pack $ toFilePath srcPath)+ $ withStringField "content" outText meta'
src/Shakebook/Sitemap.hs view
@@ -1,29 +1,21 @@ {- | Module : Shakebook.Sitemap Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech+ Maintainer : Daniel Firth <dan.firth@homotopic.tech> License : MIT Stability : experimental Utilities from "Web.Sitemap.Gen" lifted to `MonadAction` and `FileLike`. -}-module Shakebook.Sitemap where--import Data.Aeson-import Development.Shake.Plus-import RIO-import qualified RIO.ByteString.Lazy as LBS-import Shakebook.Conventions-import Shakebook.Pandoc-import Web.Sitemap.Gen+module Shakebook.Sitemap (+ module Web.Sitemap.Gen+, buildSitemap+)where -asSitemapUrl :: Text -> Value -> SitemapUrl-asSitemapUrl baseUrl x = SitemapUrl {- sitemapLocation = baseUrl <> viewUrl x- , sitemapLastModified = Just (viewPostTime x)- , sitemapChangeFrequency = Nothing- , sitemapPriority = Nothing }+import Development.Shake.Plus+import RIO+import qualified RIO.ByteString.Lazy as LBS+import Web.Sitemap.Gen -buildSitemap :: (MonadAction m, FileLike b a, ToJSON v) => Text -> [v] -> a -> m ()-buildSitemap baseUrl xs out = do- LBS.writeFile (toFilePath . toFile $ out) $ renderSitemap $ Sitemap $ fmap (asSitemapUrl baseUrl) (toJSON <$> xs)+buildSitemap :: MonadAction m => [SitemapUrl] -> Path b File -> m ()+buildSitemap xs out = LBS.writeFile (toFilePath out) $ renderSitemap $ Sitemap xs
+ src/Shakebook/Url.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module Shakebook.Url where++import Path+import RIO+import qualified RIO.Text as T++toGroundedUrl :: Path Rel b -> Text+toGroundedUrl = T.pack . toFilePath . ($(mkAbsDir "/") </>)++fromGroundedUrlD :: MonadThrow m => Text -> m (Path Rel Dir)+fromGroundedUrlD = parseAbsDir . T.unpack >=> stripProperPrefix $(mkAbsDir "/")++fromGroundedUrlF :: MonadThrow m => Text -> m (Path Rel File)+fromGroundedUrlF = parseAbsFile . T.unpack >=> stripProperPrefix $(mkAbsDir "/")
+ src/Shakebook/Utils.hs view
@@ -0,0 +1,14 @@+module Shakebook.Utils where++import Data.List.Split+import Path+import RIO++(</$>) :: Functor f => Path b Dir -> f (Path Rel t) -> f (Path b t)+(</$>) d = fmap (d </>)++changeDir :: MonadThrow m => Path b Dir -> Path b' Dir -> Path b t -> m (Path b' t)+changeDir src dst fp = (dst </>) <$> stripProperPrefix src fp++splitPath :: Path b t -> [String]+splitPath = splitOn "/" . toFilePath
test/Spec.hs view
@@ -1,18 +1,22 @@ {-# LANGUAGE TemplateHaskell #-} -import Data.Aeson.With-import qualified Data.IxSet.Typed as Ix-import qualified Data.IxSet.Typed.Conversions as Ix+import Composite.Record+import qualified Data.IxSet.Typed as Ix+import qualified Data.IxSet.Typed.Conversions as Ix import Data.List.Split import Data.Text.Time+import Development.Shake.Plus.Extended+import Lucid+import Lucid.Base import Path.Extensions import RIO-import qualified RIO.HashMap as HM import RIO.List import RIO.List.Partial import RIO.Partial-import qualified RIO.Text as T-import Shakebook+import qualified RIO.Text as T+import qualified RIO.Text.Lazy as LT+import Shakebook hiding ((:->))+import Shakebook.Utils import Test.Tasty import Test.Tasty.Golden @@ -29,200 +33,157 @@ siteTitle = "Blanky Site" tableOfContents :: Cofree [] (Path Rel File)-tableOfContents = $(mkRelFile "docs/index.md") :< [- $(mkRelFile "docs/1/index.md") :< []- , $(mkRelFile "docs/2/index.md") :< [- $(mkRelFile "docs/2/champ.md") :< []+tableOfContents = $(mkRelFile "docs/index.html") :< [+ $(mkRelFile "docs/1/index.html") :< []+ , $(mkRelFile "docs/2/index.html") :< [+ $(mkRelFile "docs/2/champ.html") :< []+ ] ]- ] numRecentPosts :: Int numRecentPosts = 3 -numPageNeighbours :: Int-numPageNeighbours = 1- postsPerPage :: Int postsPerPage = 5 -mySocial :: [Value]-mySocial = uncurry genLinkData <$> [("twitter", "http://twitter.com/blanky-site-nowhere")- ,("youtube", "http://youtube.com/blanky-site-nowhere")- ,("gitlab", "http://gitlab.com/blanky-site-nowhere")]--myBlogNav :: Ix.IsIndexOf YearMonth xs => Ix.IxSet xs Post -> Value-myBlogNav = genBlogNavbarData "Blog" "/posts/" defaultPrettyMonthFormat defaultMonthUrlFragment+mySocial :: [Record Link]+mySocial = ["twitter" :*: "http://twitter.com/blanky-site-nowhere" :*: RNil+ ,"youtube" :*: "http://youtube.com/blanky-site-nowhere" :*: RNil+ ,"gitlab" :*: "http://gitlab.com/blanky-site-nowhere" :*: RNil] -myDocNav :: Cofree [] Value -> Value-myDocNav = genTocNavbarData+addUrl :: (MonadThrow m, RElem FSrcPath xs) => Record xs -> m (Record (FUrl : xs))+addUrl = addDerivedUrl (fmap toGroundedUrl . withHtmlExtension <=< stripProperPrefix sourceFolder) -myIndex :: MonadThrow m => [Post] -> m (Zipper [] Value)-myIndex = genIndexPageData "Posts" ("/posts/pages/" <>) postsPerPage+stage1Post :: (MonadAction m, MonadThrow m) => Record RawPost -> m (Record Stage1Post)+stage1Post = addUrl >=> return . addTeaser >=> addTagLinks >=> return . addPrettyDate -myTagIndex :: MonadThrow m => Tag -> [Post] -> m (Zipper [] Value)-myTagIndex (Tag t) = genIndexPageData ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage+stage1Doc :: MonadThrow m => Record RawDoc -> m (Record Stage1Doc)+stage1Doc = addUrl -myMonthIndex :: MonadThrow m => YearMonth -> [Post] -> m (Zipper [] Value)-myMonthIndex (YearMonth (y, m)) =- let t' = fromYearMonthPair (y, m)- in genIndexPageData (("Posts from " <>) . defaultPrettyMonthFormat $ t')- (("/posts/months/" <> defaultMonthUrlFormat t' <> "/pages/") <>)- postsPerPage+enrichPage :: Record x -> Record (Enriched x)+enrichPage x = mySocial :*: (LT.toStrict . renderText $ defaultCdnImports) :*: defaultHighlighting :*: siteTitle :*: x -rules :: HasLogFunc r => ShakePlus r ()+rules :: ShakePlus SimpleSPlusEnv () rules = do - readMDC <- newCache $ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions-- postsIx <- newCache $ postIndex $ readMDC >=> return . defaultEnrichPost-- blogNav <- newCache $ postsIx >=> return . myBlogNav-- postsZ <- newCache $ postsIx >=> postZipper-- blogIndex <- newCache $ postsIx >=> myIndex . Ix.toList-- blogTagIndex <- newCache $ postsIx >=> flip Ix.toHashMapByM myTagIndex-- blogMonthIndex <- newCache $ postsIx >=> flip Ix.toHashMapByM myMonthIndex+ readMD <- newCache $ \x -> do+ logInfo $ "Loading " <> displayShow (toFilePath x)+ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions x - let o' = (`within` outputFolder)- s' = (`within` sourceFolder)+ readRawSingle <- newCache $ readMD >=> parseValue' rawSingleJsonFormat+ readRawPost <- newCache $ readMD >=> parseValue' rawPostJsonFormat+ readRawDoc <- newCache $ readMD >=> parseValue' rawDocJsonFormat - myPosts = s' ["posts/*.md"]+ readStage1Post <- newCache $ readRawPost >=> stage1Post+ readStage1Doc <- newCache $ readRawDoc >=> stage1Doc - myBuildPage tmpl v out = do- rs <- postsZ myPosts- let v' = withHighlighting pygments- . withSocialLinks mySocial- . withSiteTitle siteTitle- . withRecentPosts (take numRecentPosts (unzipper rs)) $ v- buildPageAction' (s' tmpl) v' out+ postIx' <- newCache $ \() -> batchLoadIndex' (Proxy @[Tag, Posted, YearMonth]) readStage1Post sourceFolder ["posts/*.md"] - myBuildBlogPage tmpl v out = do- k <- blogNav myPosts- myBuildPage tmpl (withJSON k v) out+ void $ addOracle defaultIndexRoots+ void $ addOracleCache $ \y -> postIx' () >>= \x -> defaultIndexPages x postsPerPage y - myBuildPostListPage z out = do- let v = extract . extendPageNeighbours numPageNeighbours $ z- myBuildBlogPage $(mkRelFile "templates/post-list.html") v out+ let correspondingMD = withMdExtension . (sourceFolder </>)+ getDoc = correspondingMD >=> readStage1Doc - o' "index.html" %^> \out -> do- src <- blinkAndMapM sourceFolder withMdExtension out- v <- readMDC src- myBuildPage $(mkRelFile "templates/index.html") v out+ void $ addOracleCache $ \(BlogNav ()) -> LT.toStrict . renderText <$> ((commuteHtmlT . genBlogNav "Blog" defaultPrettyMonthFormat) =<< postIx' ())+ void $ addOracleCache $ \(DocNav ()) -> LT.toStrict . renderText . genDocNav <$> mapM getDoc tableOfContents+ void $ addOracleCache $ \(RecentPosts ()) -> take numRecentPosts . Ix.toDescList (Proxy @Posted) <$> postIx' () - o' "posts/*.html" %^> \out -> do- src <- blinkAndMapM sourceFolder withMdExtension out- xs <- postsZ myPosts- xs' <- seekOnThrow viewSrcPath (T.pack . toFilePath . extract $ src) xs- myBuildBlogPage $(mkRelFile "templates/post.html") (toJSON $ extract xs') out+ "index.html" /%> \(dir, fp) -> do+ v <- readRawSingle =<< correspondingMD fp+ xs <- askOracle $ RecentPosts ()+ let (v' :: TMain) = Val $ xs :*: enrichPage v+ buildPageAction' sourceFolder v' mainPageJsonFormat $ dir </> fp - toc' <- mapM (mapM withHtmlExtension) $ fmap o' tableOfContents- void . sequence . flip extend toc' $ \xs -> (toFilePath <$> extract xs) %^> \out -> do- let getDoc = readMDC <=< blinkAndMapM sourceFolder withMdExtension- ys <- mapM getDoc toc'- zs <- mapM getDoc (fmap extract . unwrap $ xs)- v <- getDoc out- let v' = withJSON (myDocNav ys) . withSubsections zs $ v- myBuildPage $(mkRelFile "templates/docs.html") v' out+ "posts/*.html" /%> \(dir, fp) -> do+ src <- correspondingMD fp+ xs <- postIx' () >>= Ix.toZipperDesc (Proxy @Posted) >>= seekOnThrow (view fSrcPath) src+ nav <- askOracle $ BlogNav ()+ let (v :: TPost) = Val $ nav :*: enrichPage (extract xs)+ buildPageAction' sourceFolder v finalPostJsonFormat $ dir </> fp - o' "posts/index.html" %^>- copyFileChanged (o' ($(mkRelFile "posts/pages/1/index.html") :: Path Rel File))+ sequence_ $ tableOfContents =>> \xs ->+ (toFilePath . extract $ xs) /%> \(dir, fp) -> do+ nav <- askOracle $ DocNav ()+ subs <- mapM getDoc (fmap extract . unwrap $ xs)+ v <- getDoc fp+ let (v' :: TDoc) = Val $ nav :*: subs :*: enrichPage v+ buildPageAction' sourceFolder v' finalDocJsonFormat $ dir </> fp - o' "posts/pages/*/index.html" %^> \out -> do- let n = read . (!! 2) . splitOn "/" . toFilePath . extract $ out- xs <- blogIndex myPosts- myBuildPostListPage (seek (n -1) xs) out+ let buildPostIndex title query pageno out = do+ nav <- askOracle $ BlogNav ()+ xs <- askOracle query+ xs' <- zipper' $ sortOn (Down . view fPageNo) xs+ let links = fmap (\x -> T.pack (show (view fPageNo x)) :*: view fUrl x :*: RNil) (unzipper xs')+ let (v :: TPostIndex) = Val $ enrichPage (links :*: nav :*: title :*: extract (seek (pageno - 1) xs'))+ buildPageAction' sourceFolder v postIndexPageJsonFormat out - o' "posts/tags/*/index.html" %^> \out -> do- let t = (!! 2) . splitOn "/" . toFilePath . extract $ out- i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html"- copyFileChanged (o' i) out+ "posts/pages/*/index.html" /%> \(dir, fp) -> do+ let n = read . (!! 2) $ splitPath fp+ buildPostIndex "Posts" (IndexPages AllPosts) n $ dir </> fp - o' "posts/tags/*/pages/*/index.html" %^> \out -> do- let zs = splitOn "/" . toFilePath . extract $ out- let t = Tag $ T.pack $ zs !! 2- let n = read $ zs !! 4- xs <- blogTagIndex myPosts- case HM.lookup t xs of- Nothing -> logError $ "Attempting to lookup non-existant tag " <> displayShow t- Just x -> myBuildPostListPage (seek (n - 1) x) out+ "posts/tags/*/pages/*/index.html" /%> \(dir, fp) -> do+ let fp' = splitPath fp+ let t = T.pack $ fp' !! 2+ let n = read $ fp' !! 4+ buildPostIndex ("Posts tagged " <> t) (IndexPages (ByTag (Tag t))) n $ dir </> fp - o' "posts/months/*/index.html" %^> \out -> do- let t = (!! 2) . splitOn "/" . toFilePath . extract $ out- i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html"- copyFileChanged (o' i) out+ "posts/months/*/pages/*/index.html" /%> \(dir, fp) -> do+ let out' = splitPath fp+ let t = parseISODateTime $ T.pack $ out' !! 2+ let t' = YearMonth $ toYearMonthPair t+ let n = read $ out' !! 4+ buildPostIndex ("Posts from " <> defaultPrettyMonthFormat t) (IndexPages $ ByYearMonth t') n $ dir </> fp - o' "posts/months/*/pages/*/index.html" %^> \out -> do- let zs = splitOn "/" . toFilePath . extract $ out- let t = YearMonth $ toYearMonthPair $ parseISODateTime $ T.pack $ zs !! 2- let n = read $ zs !! 4- xs <- blogMonthIndex myPosts- case HM.lookup t xs of- Nothing -> logError $ "Attempting to lookup non-existant month " <> displayShow t- Just x -> myBuildPostListPage (seek (n - 1) x) out+ ["posts/index.html", "posts/tags/*/index.html", "posts/months/*/index.html"] /|%> \(dir, fp) -> do+ copyFileChanged (dir </> parent fp </> $(mkRelFile "pages/1/index.html")) (dir </> fp) - o' ["css//*", "js//*", "webfonts//*", "images//*"] |%^> \out ->- copyFileChanged (blinkLocalDir sourceFolder out) out+ ["css//*", "js//*", "webfonts//*", "images//*"] /|%> \(dir, fp) ->+ copyFileChanged (sourceFolder </> fp) (dir </> fp) - o' "sitemap.xml" %^> \out -> do- xs <- postsZ myPosts- buildSitemap baseUrl (unzipper xs) out+ "sitemap.xml" /%> \(dir, fp) -> do+ xs <- postIx' ()+ let xs' = Ix.toDescList (Proxy @Posted) xs+ buildSitemap (asSitemapUrl baseUrl <$> xs') $ dir </> fp let simplePipeline f = getDirectoryFiles sourceFolder >=> mapM f >=> needIn outputFolder verbatimPipeline = simplePipeline return phony "statics" $ verbatimPipeline ["css//*", "js//*", "webfonts//*", "images//*"] - phony "index" $ needIn outputFolder [$(mkRelFile "index.html") :: Path Rel File]-- phony "post-index" $ do- ps <- blogIndex myPosts- fs <- defaultPagePaths [1..size ps]- let postFolder = (outputFolder </> $(mkRelDir "posts") :: Path Rel Dir)- needIn postFolder ($(mkRelFile "index.html") : fs)+ phony "index" $ needIn outputFolder [$(mkRelFile "index.html")] - phony "by-tag-index" $ do- ps <- blogTagIndex myPosts- void $ flip HM.traverseWithKey ps $ \(Tag t) z -> do- u <- parseRelDir $ T.unpack t- fs <- defaultPagePaths [1..size z]- let tagFolder = outputFolder </> $(mkRelDir "posts/tags") </> u- needIn tagFolder ($(mkRelFile "index.html") : fs)+ phony "docs" $ mapM withHtmlExtension tableOfContents >>= needIn outputFolder - phony "by-month-index" $ do- ps <- blogMonthIndex myPosts- void $ flip HM.traverseWithKey ps $ \(YearMonth t) z -> do- u <- parseRelDir $ T.unpack $ defaultMonthUrlFormat $ fromYearMonthPair $ t- fs <- defaultPagePaths [1..size z]- let monthFolder = outputFolder </> $(mkRelDir "posts/months") </> u- needIn monthFolder ($(mkRelFile "index.html") : fs)+ phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"] - phony "docs" $- mapM withHtmlExtension tableOfContents >>= needIn outputFolder+ let phonyIndex x = do+ k <- askOracle $ IndexRoot x+ ps <- askOracle $ IndexPages x+ xs <- mapM fromGroundedUrlD $ k : (view fUrl <$> ps)+ needIn outputFolder $ fmap (</> $(mkRelFile "index.html")) xs - phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"]+ phony "post-index" $ do+ phonyIndex AllPosts+ xs <- postIx' ()+ forM_ (Ix.indexKeys xs) $ \t -> phonyIndex $ ByTag t+ forM_ (Ix.indexKeys xs) $ \t -> phonyIndex $ ByYearMonth t phony "clean" $ do logInfo $ "Cleaning files in " <> displayShow outputFolder removeFilesAfter outputFolder ["//*"] - phony "sitemap" $ needIn outputFolder [$(mkRelFile "sitemap.xml") :: Path Rel File]+ phony "sitemap" $ needIn outputFolder [$(mkRelFile "sitemap.xml")] + phony "all" $ need ["index", "posts", "post-index", "docs", "statics", "sitemap"]+ tests :: [FilePath] -> TestTree tests xs = testGroup "Rendering Tests" $- map ( \x -> goldenVsFile x x- (replace "golden" "public" x)- (return ())) xs- where replace fr to' = intercalate to' . splitOn fr+ map (\x -> goldenVsFile x x (replace "golden" "public" x) (return ())) xs where+ replace fr to' = intercalate to' . splitOn fr main :: IO () main = do- xs <- findByExtension [".html", ".xml"] "test/golden"- logOptions' <- logOptionsHandle stdout True- (lf, dlf) <- newLogFunc (setLogMinLevel LevelInfo logOptions')- shake shakeOptions $ want ["clean"] >> runShakePlus lf rules- shake shakeOptions $ want ["index", "docs", "posts", "post-index", "by-tag-index", "by-month-index", "sitemap"] >> runShakePlus lf rules- defaultMain $ tests xs- dlf+ runSimpleShakePlus outputFolder $ want ["clean"] >> rules+ runSimpleShakePlus outputFolder $ want ["all"] >> rules+ findByExtension [".html", ".xml"] "test/golden" >>= defaultMain . tests