{-# LANGUAGE OverloadedStrings #-}
module Web.Hablog.Present where
import Web.Scotty.Trans
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (catMaybes)
import Data.Either (rights)
import qualified Data.List as L
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Text.Blaze.Html.Renderer.Text as HR
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html5 ((!))
import qualified System.Directory as DIR (getDirectoryContents)
import System.IO.Error (catchIOError)
import qualified Text.RSS as RSS
import Web.Hablog.Html
import Web.Hablog.Types
import Web.Hablog.Config
import qualified Web.Hablog.Post as Post
import qualified Web.Hablog.Page as Page
import Network.URI (URI)
presentHome :: HablogAction ()
presentHome :: HablogAction ()
presentHome = do
[Page]
allPages <- IO [Page] -> ActionT Text (ReaderT Config IO) [Page]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Page]
getAllPages
Config
cfg <- HablogAction Config
getCfg
case (Page -> Bool) -> [Page] -> Maybe Page
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\p :: Page
p -> Page -> FilePath
Page.getPageURL Page
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "home") [Page]
allPages of
Nothing -> HablogAction ()
presentBlog
Just homePage :: Page
homePage -> do
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ()) -> Text -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False "home" "home" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.nav (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "menu" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "pages" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
[Page] -> Html
pagesList [Page]
allPages
Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href "/blog" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ "Blog"
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "content" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Page -> Html
pageContent Page
homePage
presentBlog :: HablogAction ()
presentBlog :: HablogAction ()
presentBlog = do
[Post]
allPosts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
[Page]
allPages <- IO [Page] -> ActionT Text (ReaderT Config IO) [Page]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Page]
getAllPages
Html
tgs <- IO Html -> ActionT Text (ReaderT Config IO) Html
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Html
getTagList
Html
auths <- IO Html -> ActionT Text (ReaderT Config IO) Html
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Html
getAuthorsList
Config
cfg <- HablogAction Config
getCfg
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ()) -> Text -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False "Blog" "blog" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.nav (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "menu" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "pages" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
[Page] -> Html
pagesList [Page]
allPages
Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href "/blog" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ "Blog"
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "main-content" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
[Post] -> Html
postsListHtml [Post]
allPosts
Html -> Html
H.aside (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "aside" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "AllAuthorsList" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.h1 "Authors"
Html
auths
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "AllTagsList" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.h1 "Tags"
Html
tgs
presentRSS :: URI -> HablogAction ()
domain :: URI
domain = do
Config
cfg <- HablogAction Config
getCfg
[Post]
allPosts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
let mime :: Text
mime = "application/rss+xml"
Text -> Text -> HablogAction ()
forall (m :: * -> *) e. Monad m => Text -> Text -> ActionT e m ()
setHeader "content-type" Text
mime
ByteString -> HablogAction ()
forall (m :: * -> *) e. Monad m => ByteString -> ActionT e m ()
raw
(ByteString -> HablogAction ())
-> ([Post] -> ByteString) -> [Post] -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BSLC.pack
(FilePath -> ByteString)
-> ([Post] -> FilePath) -> [Post] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFilter () -> FilePath
RSS.showXML
(CFilter () -> FilePath)
-> ([Post] -> CFilter ()) -> [Post] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSS -> CFilter ()
RSS.rssToXML
(RSS -> CFilter ()) -> ([Post] -> RSS) -> [Post] -> CFilter ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> URI -> FilePath -> [ChannelElem] -> [Item] -> RSS
RSS.RSS (Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Config -> Text
blogTitle Config
cfg) URI
domain "" []
([Item] -> RSS) -> ([Post] -> [Item]) -> [Post] -> RSS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Post -> Item) -> [Post] -> [Item]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Post -> Item
Post.toRSS (Text -> Post -> Item) -> Text -> Post -> Item
forall a b. (a -> b) -> a -> b
$ Config -> Text
blogDomain Config
cfg)
([Post] -> HablogAction ()) -> [Post] -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ [Post]
allPosts
showPostsWhere :: (Post.Post -> Bool) -> HablogAction ()
showPostsWhere :: (Post -> Bool) -> HablogAction ()
showPostsWhere test :: Post -> Bool
test = do
Config
cfg <- HablogAction Config
getCfg
[Post]
allPosts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ()) -> Text -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False "Posts" "blog" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
[Post] -> Html
postsListHtml ([Post] -> Html) -> [Post] -> Html
forall a b. (a -> b) -> a -> b
$ (Post -> Bool) -> [Post] -> [Post]
forall a. (a -> Bool) -> [a] -> [a]
filter Post -> Bool
test [Post]
allPosts
presentPage :: T.Text -> HablogAction ()
presentPage :: Text -> HablogAction ()
presentPage route :: Text
route = do
[Page]
pages <- IO [Page] -> ActionT Text (ReaderT Config IO) [Page]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Page]
getAllPages
(Config -> Page -> Html) -> [Page] -> HablogAction ()
forall a. (Config -> a -> Html) -> [a] -> HablogAction ()
showOrNotFound ([Page] -> Config -> Page -> Html
presentPage' [Page]
pages) ([Page] -> HablogAction ())
-> ([Page] -> [Page]) -> [Page] -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Page -> Bool) -> [Page] -> [Page]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) (FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
route) (FilePath -> Bool) -> (Page -> FilePath) -> Page -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Page -> FilePath
Page.getPageURL) ([Page] -> HablogAction ()) -> [Page] -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ [Page]
pages
presentPage' :: [Page.Page] -> Config -> Page.Page -> H.Html
presentPage' :: [Page] -> Config -> Page -> Html
presentPage' pages :: [Page]
pages cfg :: Config
cfg page :: Page
page = do
Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False (Page -> Text
Page.getPageName Page
page) (Page -> FilePath
Page.getPageURL Page
page) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.nav (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "menu" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Html -> Html
H.ul (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "pages" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
[Page] -> Html
pagesList [Page]
pages
Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href "/blog" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ "Blog"
Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ "content" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
Page -> Html
pageContent Page
page
getAllPages :: IO [Page.Page]
getAllPages :: IO [Page]
getAllPages = (Text -> Maybe Page) -> FilePath -> IO [Page]
forall a. Ord a => (Text -> Maybe a) -> FilePath -> IO [a]
getAllFromDir Text -> Maybe Page
Page.toPage "_pages"
getAllPosts :: IO [Post.Post]
getAllPosts :: IO [Post]
getAllPosts = (Text -> Maybe Post) -> FilePath -> IO [Post]
forall a. Ord a => (Text -> Maybe a) -> FilePath -> IO [a]
getAllFromDir Text -> Maybe Post
Post.toPost "_posts"
getAllFromDir :: Ord a => (T.Text -> Maybe a) -> FilePath -> IO [a]
getAllFromDir :: (Text -> Maybe a) -> FilePath -> IO [a]
getAllFromDir parse :: Text -> Maybe a
parse dir :: FilePath
dir = do
[FilePath]
posts <- ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> [FilePath] -> [FilePath]
forall a. Eq a => a -> [a] -> [a]
L.delete ".." ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> [FilePath]
forall a. Eq a => a -> [a] -> [a]
L.delete ".") (FilePath -> IO [FilePath]
DIR.getDirectoryContents FilePath
dir IO [FilePath] -> (IOError -> IO [FilePath]) -> IO [FilePath]
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\_ -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []))
[Text]
contents <- [Either UnicodeException Text] -> [Text]
forall a b. [Either a b] -> [b]
rights ([Either UnicodeException Text] -> [Text])
-> IO [Either UnicodeException Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Either UnicodeException Text))
-> [FilePath] -> IO [Either UnicodeException Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\x :: FilePath
x -> (ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> IO ByteString -> IO (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BSL.readFile FilePath
x) IO (Either UnicodeException Text)
-> (IOError -> IO (Either UnicodeException Text))
-> IO (Either UnicodeException Text)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` IO (Either UnicodeException Text)
-> IOError -> IO (Either UnicodeException Text)
forall a b. a -> b -> a
const (Either UnicodeException Text -> IO (Either UnicodeException Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> IO (Either UnicodeException Text))
-> Either UnicodeException Text
-> IO (Either UnicodeException Text)
forall a b. (a -> b) -> a -> b
$ UnicodeException -> Either UnicodeException Text
forall a b. a -> Either a b
Left UnicodeException
forall a. HasCallStack => a
undefined)) (FilePath -> IO (Either UnicodeException Text))
-> (FilePath -> FilePath)
-> FilePath
-> IO (Either UnicodeException Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath
dirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"/")FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)) [FilePath]
posts
[a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> ([Maybe a] -> [a]) -> [Maybe a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((a -> a -> Ordering) -> a -> a -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) ([a] -> [a]) -> ([Maybe a] -> [a]) -> [Maybe a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> IO [a]) -> [Maybe a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe a) -> [Text] -> [Maybe a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Maybe a
parse ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
contents)
presentPost :: T.Text -> HablogAction ()
presentPost :: Text -> HablogAction ()
presentPost title :: Text
title = do
[Post]
posts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
(Config -> Post -> Html) -> [Post] -> HablogAction ()
forall a. (Config -> a -> Html) -> [a] -> HablogAction ()
showOrNotFound Config -> Post -> Html
postPage ([Post] -> HablogAction ()) -> [Post] -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ (Post -> Bool) -> [Post] -> [Post]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
title) (Text -> Bool) -> (Post -> Text) -> Post -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post -> Text
path) [Post]
posts
where path :: Post -> Text
path p :: Post
p = Text -> [Text] -> Text
T.intercalate "/" ([Post -> Text
Post.year, Post -> Text
Post.month, Post -> Text
Post.day, Post -> Text
Post.route] [Post -> Text] -> [Post] -> [Text]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Post
p])
showOrNotFound :: (Config -> a -> H.Html) -> [a] -> HablogAction ()
showOrNotFound :: (Config -> a -> Html) -> [a] -> HablogAction ()
showOrNotFound showP :: Config -> a -> Html
showP result :: [a]
result = do
Config
cfg <- HablogAction Config
getCfg
case [a]
result of
(p :: a
p:_) -> Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ()) -> Text -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> a -> Html
showP Config
cfg a
p
[] -> Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ()) -> Text -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Config -> Text -> FilePath -> Html
errorPage Config
cfg "Hablog - 404: not found" "Could not find the page you were looking for."
presentTags :: HablogAction ()
presentTags :: HablogAction ()
presentTags = do
Config
cfg <- HablogAction Config
getCfg
Html
tags <- IO Html -> ActionT Text (ReaderT Config IO) Html
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Html
getTagList
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ())
-> (Html -> Text) -> Html -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HR.renderHtml (Html -> HablogAction ()) -> Html -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False "Posts Tags" "blog" Html
tags
getTagList :: IO H.Html
getTagList :: IO Html
getTagList = Html -> IO Html
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> IO Html) -> ([Post] -> Html) -> [Post] -> IO Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Html
tagsList ([Text] -> Html) -> ([Post] -> [Text]) -> [Post] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Post] -> [Text]
getAllTags ([Post] -> IO Html) -> IO [Post] -> IO Html
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Post]
getAllPosts
getPageList :: [Page.Page] -> H.Html
getPageList :: [Page] -> Html
getPageList = Html -> Html
H.ul (Html -> Html) -> ([Page] -> Html) -> [Page] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Page] -> Html
pagesList
getAuthorsList :: IO H.Html
getAuthorsList :: IO Html
getAuthorsList = Html -> IO Html
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Html -> IO Html) -> ([Post] -> Html) -> [Post] -> IO Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Html
authorsList ([Text] -> Html) -> ([Post] -> [Text]) -> [Post] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Post] -> [Text]
getAllAuthors ([Post] -> IO Html) -> IO [Post] -> IO Html
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Post]
getAllPosts
presentTag :: T.Text -> HablogAction ()
presentTag :: Text -> HablogAction ()
presentTag tag :: Text
tag = do
Config
cfg <- HablogAction Config
getCfg
[Post]
posts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ())
-> (Html -> Text) -> Html -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HR.renderHtml (Html -> Text) -> (Html -> Html) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False Text
tag "blog" (Html -> HablogAction ()) -> Html -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ [Post] -> Html
postsListHtml ([Post] -> Html) -> [Post] -> Html
forall a b. (a -> b) -> a -> b
$ (Post -> Bool) -> [Post] -> [Post]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Post -> Bool
hasTag Text
tag) [Post]
posts
presentAuthors :: HablogAction ()
presentAuthors :: HablogAction ()
presentAuthors = do
Config
cfg <- HablogAction Config
getCfg
Html
authors <- IO Html -> ActionT Text (ReaderT Config IO) Html
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Html
getAuthorsList
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ())
-> (Html -> Text) -> Html -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HR.renderHtml (Html -> HablogAction ()) -> Html -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False "Posts Authors" "blog" Html
authors
presentAuthor :: T.Text -> HablogAction ()
presentAuthor :: Text -> HablogAction ()
presentAuthor auth :: Text
auth = do
Config
cfg <- HablogAction Config
getCfg
[Post]
posts <- IO [Post] -> ActionT Text (ReaderT Config IO) [Post]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Post]
getAllPosts
Text -> HablogAction ()
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
html (Text -> HablogAction ())
-> ([Post] -> Text) -> [Post] -> HablogAction ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
HR.renderHtml (Html -> Text) -> ([Post] -> Html) -> [Post] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Bool -> Text -> FilePath -> Html -> Html
template Config
cfg Bool
False Text
auth "blog" (Html -> Html) -> ([Post] -> Html) -> [Post] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Post] -> Html
postsListHtml ([Post] -> HablogAction ()) -> [Post] -> HablogAction ()
forall a b. (a -> b) -> a -> b
$ (Post -> Bool) -> [Post] -> [Post]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Post -> Bool
hasAuthor Text
auth) [Post]
posts
getPageFromFile :: T.Text -> IO (Maybe Page.Page)
getPageFromFile :: Text -> IO (Maybe Page)
getPageFromFile title :: Text
title = do
let path :: FilePath
path = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["_pages/", Text
title]
(Text -> Maybe Page) -> FilePath -> IO (Maybe Page)
forall a. (Text -> Maybe a) -> FilePath -> IO (Maybe a)
getFromFile Text -> Maybe Page
Page.toPage FilePath
path
getPostFromFile :: T.Text -> T.Text -> IO (Maybe Post.Post)
getPostFromFile :: Text -> Text -> IO (Maybe Post)
getPostFromFile date :: Text
date title :: Text
title = do
let postPath :: FilePath
postPath = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ["_posts/", Text
date, "-", Text
title, ".md"]
(Text -> Maybe Post) -> FilePath -> IO (Maybe Post)
forall a. (Text -> Maybe a) -> FilePath -> IO (Maybe a)
getFromFile Text -> Maybe Post
Post.toPost FilePath
postPath
getFromFile :: (T.Text -> Maybe a) -> String -> IO (Maybe a)
getFromFile :: (Text -> Maybe a) -> FilePath -> IO (Maybe a)
getFromFile constructor :: Text -> Maybe a
constructor path :: FilePath
path = do
Either UnicodeException Text
fileContent <- (ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> IO ByteString -> IO (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BSL.readFile FilePath
path) IO (Either UnicodeException Text)
-> (IOError -> IO (Either UnicodeException Text))
-> IO (Either UnicodeException Text)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` IO (Either UnicodeException Text)
-> IOError -> IO (Either UnicodeException Text)
forall a b. a -> b -> a
const (Either UnicodeException Text -> IO (Either UnicodeException Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> IO (Either UnicodeException Text))
-> Either UnicodeException Text
-> IO (Either UnicodeException Text)
forall a b. (a -> b) -> a -> b
$ UnicodeException -> Either UnicodeException Text
forall a b. a -> Either a b
Left UnicodeException
forall a. HasCallStack => a
undefined)
let cont :: Maybe Text
cont = case Either UnicodeException Text
fileContent of
Left _ -> Maybe Text
forall a. Maybe a
Nothing
Right x :: Text
x -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
let content :: Maybe a
content = Text -> Maybe a
constructor (Text -> Maybe a) -> Maybe Text -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
cont
Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
content
getAllTags :: [Post.Post] -> [T.Text]
getAllTags :: [Post] -> [Text]
getAllTags = (Post -> [Text]) -> [Post] -> [Text]
getAll Post -> [Text]
Post.tags
hasTag :: T.Text -> Post.Post -> Bool
hasTag :: Text -> Post -> Bool
hasTag tag :: Text
tag = ([][Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([Text] -> Bool) -> (Post -> [Text]) -> Post -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
tag) ([Text] -> [Text]) -> (Post -> [Text]) -> Post -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post -> [Text]
Post.tags
getAllAuthors :: [Post.Post] -> [T.Text]
getAllAuthors :: [Post] -> [Text]
getAllAuthors = (Post -> [Text]) -> [Post] -> [Text]
getAll Post -> [Text]
Post.authors
getAll :: (Post.Post -> [T.Text]) -> [Post.Post] -> [T.Text]
getAll :: (Post -> [Text]) -> [Post] -> [Text]
getAll f :: Post -> [Text]
f = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort ([Text] -> [Text]) -> ([Post] -> [Text]) -> [Post] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
T.unwords ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> ([Text] -> Text) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
head) ([[Text]] -> [Text]) -> ([Post] -> [[Text]]) -> [Post] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]]
forall a. Eq a => [a] -> [[a]]
L.group ([Text] -> [[Text]]) -> ([Post] -> [Text]) -> [Post] -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort ([Text] -> [Text]) -> ([Post] -> [Text]) -> [Post] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Post -> [Text]) -> [Post] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Post -> [Text]
f
hasAuthor :: T.Text -> Post.Post -> Bool
hasAuthor :: Text -> Post -> Bool
hasAuthor auth :: Text
auth myPost :: Post
myPost = Text
auth Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Post -> [Text]
Post.authors Post
myPost