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
, fromYearMonthPair
, toYearMonthPair
) 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.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 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, Hashable, ToJSON)
newtype Tag = Tag Text
deriving (Show, Eq, Ord, Data, Typeable, Hashable)
newtype Posted = Posted UTCTime
deriving (Show, Eq, Ord, Data, Typeable, Hashable)
newtype YearMonth = YearMonth (Integer, Int)
deriving (Show, Eq, Ord, Data, Typeable, Hashable)
newtype SrcFile = SrcFile Text
deriving (Show, Eq, Ord, Data, Typeable, Hashable)
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))
toYearMonthPair :: UTCTime -> (Integer, Int)
toYearMonthPair = (\(a, b, _) -> (a, b)) . toGregorian . utctDay
fromYearMonthPair :: (Integer, Int) -> UTCTime
fromYearMonthPair (y,m) = UTCTime (fromGregorian y m 1) 0
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 = Ix.toZipperDesc (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)
=> 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