{-# LANGUAGE OverloadedStrings #-}

module Web.Hablog.Post where

import qualified Data.Text.Lazy as T
import qualified Text.Blaze.Html5 as H
import qualified Data.Map as M
import qualified Text.RSS as RSS
import           Data.Time (fromGregorian, Day, UTCTime(..), secondsToDiffTime)
import           Network.URI (parseURI)
import qualified Text.Blaze.Html.Renderer.Text as HR

import Web.Hablog.Utils


data Post
  = Post
  { Post -> (Text, Text, Text)
date  :: (T.Text, T.Text, T.Text)
  , Post -> Text
route :: T.Text
  , Post -> Text
title :: T.Text
  , Post -> [Text]
authors :: [T.Text]
  , Post -> [Text]
tags    :: [T.Text]
  , Post -> Html
content :: H.Html
  }

year, month, day :: Post -> T.Text
year :: Post -> Text
year  p :: Post
p = case Post -> (Text, Text, Text)
date Post
p of { (y :: Text
y, _, _) -> Text
y; }
month :: Post -> Text
month p :: Post
p = case Post -> (Text, Text, Text)
date Post
p of { (_, m :: Text
m, _) -> Text
m; }
day :: Post -> Text
day   p :: Post
p = case Post -> (Text, Text, Text)
date Post
p of { (_, _, d :: Text
d) -> Text
d; }

toDay :: Post -> Maybe Day
toDay :: Post -> Maybe Day
toDay post :: Post
post =
  case (ReadS Integer
forall a. Read a => ReadS a
reads ReadS Integer -> ReadS Integer
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Post -> Text
year Post
post, ReadS Int
forall a. Read a => ReadS a
reads ReadS Int -> ReadS Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Post -> Text
month Post
post, ReadS Int
forall a. Read a => ReadS a
reads ReadS Int -> ReadS Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Post -> Text
day Post
post) of
    ([(y :: Integer
y,[])], [(m :: Int
m,[])], [(d :: Int
d,[])]) -> Day -> Maybe Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d)
    _ -> Maybe Day
forall a. Maybe a
Nothing

toPost :: T.Text -> Maybe Post
toPost :: Text -> Maybe Post
toPost fileContent :: Text
fileContent =
  (Text, Text, Text)
-> Text -> Text -> [Text] -> [Text] -> Html -> Post
Post ((Text, Text, Text)
 -> Text -> Text -> [Text] -> [Text] -> Html -> Post)
-> Maybe (Text, Text, Text)
-> Maybe (Text -> Text -> [Text] -> [Text] -> Html -> Post)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,,) (Text -> Text -> Text -> (Text, Text, Text))
-> Maybe Text -> Maybe (Text -> Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
yyyy Maybe (Text -> Text -> (Text, Text, Text))
-> Maybe Text -> Maybe (Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
mm Maybe (Text -> (Text, Text, Text))
-> Maybe Text -> Maybe (Text, Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text
dd)
       Maybe (Text -> Text -> [Text] -> [Text] -> Html -> Post)
-> Maybe Text -> Maybe (Text -> [Text] -> [Text] -> Html -> Post)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "route" Map Text Text
header
       Maybe (Text -> [Text] -> [Text] -> Html -> Post)
-> Maybe Text -> Maybe ([Text] -> [Text] -> Html -> Post)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "title" Map Text Text
header
       Maybe ([Text] -> [Text] -> Html -> Post)
-> Maybe [Text] -> Maybe ([Text] -> Html -> Post)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((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
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==',') (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "authors" Map Text Text
header)
       Maybe ([Text] -> Html -> Post)
-> Maybe [Text] -> Maybe (Html -> Post)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==',') (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "tags" Map Text Text
header)
       Maybe (Html -> Post) -> Maybe Html -> Maybe Post
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Html -> Maybe Html
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Html
createBody (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Text
getContent Text
fileContent)
    where
        header :: Map Text Text
header = Text -> Map Text Text
getHeader Text
fileContent
        dt :: Maybe [Text]
dt     = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='-') (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup "date" Map Text Text
header
        yyyy :: Maybe Text
yyyy   = Maybe [Text]
dt Maybe [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> Int -> Maybe Text
forall a. [a] -> Int -> Maybe a
`at` 0)
        mm :: Maybe Text
mm     = Maybe [Text]
dt Maybe [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> Int -> Maybe Text
forall a. [a] -> Int -> Maybe a
`at` 1)
        dd :: Maybe Text
dd     = Maybe [Text]
dt Maybe [Text] -> ([Text] -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> Int -> Maybe Text
forall a. [a] -> Int -> Maybe a
`at` 2)

getPath :: Post -> T.Text
getPath :: Post -> Text
getPath post :: Post
post =
  [Text] -> Text
T.concat ["post/", Post -> Text
year Post
post, "/", Post -> Text
month Post
post, "/", Post -> Text
day Post
post, "/", Post -> Text
route Post
post]

getDate :: Post -> T.Text
getDate :: Post -> Text
getDate post :: Post
post =
  [Text] -> Text
T.concat [Post -> Text
day Post
post, "/", Post -> Text
month Post
post, "/", Post -> Text
year Post
post]

eqY, eqM, eqD :: T.Text -> Post -> Bool
eqY :: Text -> Post -> Bool
eqY y :: Text
y p :: Post
p = Text
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
year  Post
p
eqM :: Text -> Post -> Bool
eqM m :: Text
m p :: Post
p = Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
month Post
p
eqD :: Text -> Post -> Bool
eqD d :: Text
d p :: Post
p = Text
d Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
day   Post
p

eqYM :: (T.Text, T.Text) -> Post -> Bool
eqYM :: (Text, Text) -> Post -> Bool
eqYM (y :: Text
y,m :: Text
m) p :: Post
p = Text -> Post -> Bool
eqY Text
y Post
p Bool -> Bool -> Bool
&& Text -> Post -> Bool
eqM Text
m Post
p

eqDate :: (T.Text, T.Text, T.Text) -> Post -> Bool
eqDate :: (Text, Text, Text) -> Post -> Bool
eqDate dt :: (Text, Text, Text)
dt p :: Post
p = (Text, Text, Text)
dt (Text, Text, Text) -> (Text, Text, Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> (Text, Text, Text)
date Post
p

instance Show Post where
  show :: Post -> String
show post :: Post
post =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ["post/", Post -> Text
year Post
post, "/", Post -> Text
month Post
post, "/", Post -> Text
day Post
post, "/", Post -> Text
route Post
post]

instance Eq Post where
  == :: Post -> Post -> Bool
(==) p1 :: Post
p1 p2 :: Post
p2 = Post -> Text
route Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
route Post
p2


instance Ord Post where
  compare :: Post -> Post -> Ordering
compare p1 :: Post
p1 p2 :: Post
p2
    | Post -> Text
year Post
p1 Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
< Post -> Text
year Post
p2 = Ordering
LT
    | Post -> Text
year Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
year Post
p2 Bool -> Bool -> Bool
&& Post -> Text
month Post
p1 Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
< Post -> Text
month Post
p2 = Ordering
LT
    | Post -> Text
year Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
year Post
p2 Bool -> Bool -> Bool
&& Post -> Text
month Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
month Post
p2 Bool -> Bool -> Bool
&& Post -> Text
day Post
p1 Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
< Post -> Text
day Post
p2 = Ordering
LT
    | Post -> Text
year Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
year Post
p2 Bool -> Bool -> Bool
&& Post -> Text
month Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
month Post
p2 Bool -> Bool -> Bool
&& Post -> Text
day Post
p1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Post -> Text
day Post
p2 = Ordering
EQ
    | Bool
otherwise = Ordering
GT


toRSS :: T.Text -> Post -> RSS.Item
toRSS :: Text -> Post -> Item
toRSS domain :: Text
domain post :: Post
post =
  [ String -> ItemElem
RSS.Title (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Post -> Text
title Post
post)
  ] Item -> Item -> Item
forall a. [a] -> [a] -> [a]
++ (Text -> ItemElem) -> [Text] -> Item
forall a b. (a -> b) -> [a] -> [b]
map (String -> ItemElem
RSS.Author (String -> ItemElem) -> (Text -> String) -> Text -> ItemElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Post -> [Text]
authors Post
post)
    Item -> Item -> Item
forall a. [a] -> [a] -> [a]
++ (Text -> ItemElem) -> [Text] -> Item
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String -> String -> ItemElem
RSS.Category Maybe String
forall a. Maybe a
Nothing (String -> ItemElem) -> (Text -> String) -> Text -> ItemElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Post -> [Text]
tags Post
post)
    Item -> Item -> Item
forall a. [a] -> [a] -> [a]
++ [ UTCTime -> ItemElem
RSS.PubDate (UTCTime -> ItemElem) -> UTCTime -> ItemElem
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime Day
d (Integer -> DiffTime
secondsToDiffTime 0)
       | Just d :: Day
d <- [Post -> Maybe Day
toDay Post
post]
       ]
    Item -> Item -> Item
forall a. [a] -> [a] -> [a]
++ [ Link -> ItemElem
RSS.Link Link
r
       | Just r :: Link
r <- (Maybe Link -> [Maybe Link] -> [Maybe Link]
forall a. a -> [a] -> [a]
:[]) (Maybe Link -> [Maybe Link]) -> Maybe Link -> [Maybe Link]
forall a b. (a -> b) -> a -> b
$ String -> Maybe Link
parseURI (String -> Maybe Link) -> String -> Maybe Link
forall a b. (a -> b) -> a -> b
$
           Text -> String
T.unpack (Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Post -> Text
getPath Post
post)
       ]
    Item -> Item -> Item
forall a. [a] -> [a] -> [a]
++ [ String -> ItemElem
RSS.Description
       (String -> ItemElem) -> (Text -> String) -> Text -> ItemElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
       (Text -> ItemElem) -> Text -> ItemElem
forall a b. (a -> b) -> a -> b
$ Html -> Text
HR.renderHtml (Post -> Html
content Post
post)
       ]