module Shakebook.Conventions (
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
, enrichPrettyDate
, enrichTagLinks
, enrichTeaser
, extendNext
, extendPrevious
, extendNextPrevious
, extendPageNeighbours
, genBlogNavbarData
, genIndexPageData
, genLinkData
, genPageData
, genTocNavbarData
, Post(..)
, Tag(..)
, Posted(..)
, YearMonth(..)
, SrcFile(..)
, postIndex
, postZipper
) where
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.IxSet.Typed as Ix
import Data.Text.Time
import Development.Shake.Plus
import RIO hiding (view)
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 RIO.Time
import qualified RIO.Vector as V
import Shakebook.Pandoc
import Text.Pandoc.Highlighting
viewImage :: ToJSON a => a -> Text
viewImage = view' (key "image" . _String)
viewModified :: ToJSON a => a -> UTCTime
viewModified = parseISODateTime . view' (key "modified" . _String)
viewPostTime :: ToJSON a => a -> UTCTime
viewPostTime = parseISODateTime . view' (key "date" . _String)
viewPostTimeRaw :: ToJSON a => a -> Text
viewPostTimeRaw = view' (key "date" . _String)
viewTags :: ToJSON a => a -> [Text]
viewTags = toListOf' (key "tags" . values . _String)
viewTitle :: ToJSON a => a -> Text
viewTitle = view' (key "title" . _String)
viewAllPostTags :: ToJSON a => [a] -> [Text]
viewAllPostTags = (>>= viewTags)
viewAllPostTimes :: ToJSON a => [a] -> [UTCTime]
viewAllPostTimes = fmap viewPostTime
withBaseUrl :: Text -> Value -> Value
withBaseUrl = withStringField "base-url"
withFullUrl :: Text -> Value -> Value
withFullUrl = withStringField "full-url"
withHighlighting :: Style -> Value -> Value
withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss
withModified :: UTCTime -> Value -> Value
withModified = withStringField "modified" . T.pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
withNext :: ToJSON a => a -> Value -> Value
withNext = withValue "next"
withPages :: ToJSON a => [a] -> Value -> Value
withPages = withArrayField "pages"
withPrettyDate :: Text -> Value -> Value
withPrettyDate = withStringField "pretty-date"
withPrevious :: ToJSON a => a -> Value -> Value
withPrevious = withValue "previous"
withPosts :: ToJSON a => [a] -> Value -> Value
withPosts = withArrayField "posts"
withRecentPosts :: ToJSON a => [a] -> Value -> Value
withRecentPosts = withArrayField "recent-posts"
withSiteTitle :: Text -> Value -> Value
withSiteTitle = withStringField "site-title"
withSocialLinks :: ToJSON a => [a] -> Value -> Value
withSocialLinks = withArrayField "social-links"
withSubsections :: ToJSON a => [a] -> Value -> Value
withSubsections = withArrayField "subsections"
withTagIndex :: ToJSON a => [a] -> Value -> Value
withTagIndex = withArrayField "tag-index"
withTagLinks :: ToJSON a => [a] -> Value -> Value
withTagLinks = withArrayField "tag-links"
withTeaser :: Text -> Value -> Value
withTeaser = withStringField "teaser"
withTitle :: Text -> Value -> Value
withTitle = withStringField "title"
enrichPrettyDate :: (UTCTime -> Text) -> Value -> Value
enrichPrettyDate f v = withPrettyDate (f . viewPostTime $ v) v
enrichTagLinks :: (Text -> Text) -> Value -> Value
enrichTagLinks f v = withTagLinks ((genLinkData <*> f) <$> viewTags v) v
enrichTeaser :: Text -> Value -> Value
enrichTeaser s v = withTeaser (head (T.splitOn s (viewContent v))) v
extendNextPrevious :: Zipper [] Value -> Zipper [] Value
extendNextPrevious = extendPrevious . extendNext
extendPrevious :: Zipper [] Value -> Zipper [] Value
extendPrevious = extend (liftA2 withPrevious zipperPreviousMaybe extract)
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)
genLinkData :: Text -> Text -> Value
genLinkData x u = object ["id" A..= String x, "url" A..= String u]
newtype Post = Post { unPost :: Value }
deriving (Show, Eq, Ord, Data, Typeable, ToJSON)
newtype Tag = Tag Text
deriving (Show, Eq, Ord, Data, Typeable)
newtype Posted = Posted UTCTime
deriving (Show, Eq, Ord, Data, Typeable)
newtype YearMonth = YearMonth (Integer, Int)
deriving (Show, Eq, Ord, Data, Typeable)
newtype SrcFile = SrcFile Text
deriving (Show, Eq, Ord, Data, Typeable)
instance Indexable '[Tag, Posted, YearMonth, SrcFile] Post where
indices = ixList (ixFun (fmap Tag . viewTags))
(ixFun (pure . Posted . viewPostTime))
(ixFun (pure . YearMonth . (\(a,b,_) -> (a,b)) . toGregorian . utctDay . viewPostTime))
(ixFun (pure . SrcFile . viewSrcPath))
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)
postZipper :: (MonadThrow m, Ix.IsIndexOf Posted xs) => Ix.IxSet xs Post -> m (Zipper [] Post)
postZipper = zipper' . Ix.toDescList (Proxy :: Proxy Posted)
genBlogNavbarData :: IsIndexOf YearMonth ixs => Text
-> Text
-> (UTCTime -> Text)
-> (UTCTime -> Text)
-> 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)) ]
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
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
genIndexPageData :: (MonadThrow m, ToJSON a)
=> [a]
-> Text
-> (Text -> Text)
-> Int
-> m (Zipper [] Value)
genIndexPageData xs g h n = do
zs <- paginate' n $ sortOn (Down . viewPostTime) xs
return $ extend (genPageData g h) zs