{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.Page.Atom where

import Control.Monad.Trans     (lift, liftIO)
import Clckwrks.Authenticate.API (Username(..), getUsername)
import Clckwrks.Monad          (Clck, Content(..), query, withAbs)
import Clckwrks.Page.Acid
import Clckwrks.Page.Monad     (PageM, markupToContent, clckT2PageT)
import Clckwrks.Page.Types
import Clckwrks.ProfileData.Acid
import Clckwrks.Page.URL
import Control.Monad.Fail      (MonadFail(fail))
import Data.Maybe              (fromMaybe)
import Data.Monoid             ((<>))
import Data.String             (fromString)
import qualified Data.Text     as Text
import Data.Text.Lazy          (Text)
import qualified Data.Text.Lazy.Encoding as TL
import Data.Time               (UTCTime)
import Data.Time.Clock.POSIX   (posixSecondsToUTCTime)
import Data.Time.Format        (formatTime)
import Data.UUID               (toString)
import Happstack.Server        (Happstack, Response, ok, ServerPartT, toResponseBS)
import HSP.XMLGenerator
import HSP.XML                 (XML, cdata, renderXML, fromStringLit)
import Language.Haskell.HSX.QQ (hsx)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Prelude hiding (fail)
import Web.Routes              (showURL)

atom :: FeedConfig  -- ^ feed configuration
     -> [Page]      -- ^ pages to publish in feed
     -> PageM XML
atom :: FeedConfig -> [Page] -> PageM XML
atom FeedConfig{Text
UUID
feedAuthorName :: FeedConfig -> Text
feedLink :: FeedConfig -> Text
feedTitle :: FeedConfig -> Text
feedUUID :: FeedConfig -> UUID
feedAuthorName :: Text
feedLink :: Text
feedTitle :: Text
feedUUID :: UUID
..} [Page]
pages =
    do Text
blogURL <- ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *) url a.
Happstack m =>
ClckT url m a -> ClckT url m a
withAbs (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
 -> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text)
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall a b. (a -> b) -> a -> b
$ URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
PageURL
Blog
       Text
atomURL <- ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *) url a.
Happstack m =>
ClckT url m a -> ClckT url m a
withAbs (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
 -> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text)
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall a b. (a -> b) -> a -> b
$ URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
PageURL
AtomFeed
       XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
 -> PageM XML)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall a b. (a -> b) -> a -> b
$ [hsx|
                   <feed xmlns="http://www.w3.org/2005/Atom">
                    <title><% feedTitle %></title>
                    <link type="text/html" href=blogURL />
                    <link rel="self" type="application/atom+xml" href=atomURL />
                    <author>
                     <name><% feedAuthorName %></name>
                    </author>
                    <updated><% atomDate $ mostRecentUpdate pages %></updated>
                    <id><% "urn:uuid:" ++ toString feedUUID %></id>
                    <% mapM entry pages %>
                   </feed> |]

mostRecentUpdate :: [Page]  -- ^ pages to consider
                 -> UTCTime -- ^ most recent updated time
mostRecentUpdate :: [Page] -> UTCTime
mostRecentUpdate []    = POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0
mostRecentUpdate [Page]
pages =
    [UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([UTCTime] -> UTCTime) -> [UTCTime] -> UTCTime
forall a b. (a -> b) -> a -> b
$ (Page -> UTCTime) -> [Page] -> [UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map Page -> UTCTime
pageUpdated [Page]
pages

entry :: Page
      -> PageM XML
entry :: Page -> PageM XML
entry Page{Maybe Markup
Maybe Slug
Text
UTCTime
ThemeStyleId
UUID
UserId
PageId
Markup
PublishStatus
PageKind
pageThemeStyleId :: Page -> ThemeStyleId
pageUUID :: Page -> UUID
pageKind :: Page -> PageKind
pageStatus :: Page -> PublishStatus
pageDate :: Page -> UTCTime
pageExcerpt :: Page -> Maybe Markup
pageSrc :: Page -> Markup
pageSlug :: Page -> Maybe Slug
pageTitle :: Page -> Text
pageAuthor :: Page -> UserId
pageId :: Page -> PageId
pageThemeStyleId :: ThemeStyleId
pageUUID :: UUID
pageKind :: PageKind
pageStatus :: PublishStatus
pageUpdated :: UTCTime
pageDate :: UTCTime
pageExcerpt :: Maybe Markup
pageSrc :: Markup
pageSlug :: Maybe Slug
pageTitle :: Text
pageAuthor :: UserId
pageId :: PageId
pageUpdated :: Page -> UTCTime
..} =
  do Text
viewPageSlug <- ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *) url a.
Happstack m =>
ClckT url m a -> ClckT url m a
withAbs (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
 -> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text)
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall a b. (a -> b) -> a -> b
$ URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL (PageId -> Slug -> PageURL
ViewPageSlug PageId
pageId (Text -> Maybe Slug -> Slug
toSlug Text
pageTitle Maybe Slug
pageSlug))
     XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
 -> PageM XML)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall a b. (a -> b) -> a -> b
$ [hsx| <entry>
                   <title><% pageTitle %></title>
                   <link href=viewPageSlug />
                   <id><% "urn:uuid:" ++ toString pageUUID %></id>
                   <% author %>
                   <updated><% atomDate pageUpdated %></updated>
                   <% atomContent pageSrc %>
                 </entry> |]
    where
      author :: XMLGenT PageM XML
      author :: XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
author =
          do Maybe Username
mu <- ClckT
  PageURL (ReaderT PageConfig (ServerPartT IO)) (Maybe Username)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
     (Maybe Username)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClckT
   PageURL (ReaderT PageConfig (ServerPartT IO)) (Maybe Username)
 -> XMLGenT
      (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
      (Maybe Username))
-> ClckT
     PageURL (ReaderT PageConfig (ServerPartT IO)) (Maybe Username)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
     (Maybe Username)
forall a b. (a -> b) -> a -> b
$ ClckT () (ServerPartT IO) (Maybe Username)
-> ClckT
     PageURL (ReaderT PageConfig (ServerPartT IO)) (Maybe Username)
forall (m :: * -> *) url1 a.
(Functor m, MonadIO m, MonadFail m, Typeable url1) =>
ClckT url1 m a -> PageT m a
clckT2PageT ((UserId -> ClckT () (ServerPartT IO) (Maybe Username)
forall url. UserId -> Clck url (Maybe Username)
getUsername UserId
pageAuthor) :: Clck () (Maybe Username))
             case Maybe Username
mu of
               Maybe Username
Nothing -> XML
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML
 -> XMLGenT
      (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML)
-> XML
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
forall a b. (a -> b) -> a -> b
$ Text -> XML
cdata Text
""
               (Just (Username Text
n))
                   | Text -> Bool
Text.null Text
n ->
                       XML
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML
 -> XMLGenT
      (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML)
-> XML
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
forall a b. (a -> b) -> a -> b
$ Text -> XML
cdata Text
""
                   | Bool
otherwise -> [hsx|
                       <author>
                        <name><% n %></name>
                       </author> |]

atomDate :: UTCTime -> String
atomDate :: UTCTime -> [Char]
atomDate UTCTime
time =
    TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%dT%H:%M:%SZ" UTCTime
time

atomContent :: Markup -> PageM XML
atomContent :: Markup -> PageM XML
atomContent Markup
markup =
    do Content
c <- Markup
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) Content
forall (m :: * -> *) url.
(Functor m, MonadIO m, MonadFail m, Happstack m) =>
Markup -> ClckT url m Content
markupToContent Markup
markup
       case Content
c of
         (PlainText Text
txt) ->
              XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
 -> PageM XML)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall a b. (a -> b) -> a -> b
$ [hsx| <content type="text"><% txt %></content> |]
         (TrustedHtml Text
html) ->
              XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
 -> PageM XML)
-> XMLGenT
     (ClckT PageURL (ReaderT PageConfig (ServerPartT IO))) XML
-> PageM XML
forall a b. (a -> b) -> a -> b
$ [hsx| <content type="html"><% html %></content> |]

handleAtomFeed :: PageM Response
handleAtomFeed :: PageM Response
handleAtomFeed =
    do [Page]
ps         <- AllPosts
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (EventResult AllPosts)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query AllPosts
AllPosts
       FeedConfig
feedConfig <- GetFeedConfig
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (EventResult GetFeedConfig)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetFeedConfig
GetFeedConfig
       XML
xml <- FeedConfig -> [Page] -> PageM XML
atom FeedConfig
feedConfig [Page]
ps
       Response -> PageM Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok (Response -> PageM Response) -> Response -> PageM Response
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Response
toResponseBS ByteString
"application/atom+xml;charset=utf-8" ((Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ XML -> Text
renderXML XML
xml))