{-# LANGUAGE OverloadedStrings #-}
module Clckwrks.Page.Route where

import Clckwrks                     (Role(..), requiresRole_)
import Clckwrks.Monad               ( ClckState(plugins), query
                                    , update, setUnique, themeTemplate, nestURL
                                    )
import Clckwrks.Page.Types          (Page(..), PageId(..), toSlug)
import Clckwrks.Page.Acid           (GetPageTitle(..), IsPublishedPage(..), PageById(..))
import Clckwrks.Page.Admin.EditFeedConfig (editFeedConfig)
import Clckwrks.Page.Admin.EditPage (editPage)
import Clckwrks.Page.Admin.NewPage  (newPage)
import Clckwrks.Page.Admin.Pages    (pages)
import Clckwrks.Page.Admin.PreviewPage (previewPage)
import Clckwrks.Page.Atom           (handleAtomFeed)
import Clckwrks.Page.Monad          (PageConfig(pageClckURL), PageM, clckT2PageT, markupToContent)
import Clckwrks.Page.Types          (PageKind(PlainPage, Post))
import Clckwrks.Page.BlogPage       (blog)
import Clckwrks.Page.URL            (PageURL(..), PageAdminURL(..))
import Control.Applicative          ((<$>))
import Control.Monad.Reader         (ask)
import Control.Monad.State          (get)
import Data.Text                    (Text)
import qualified Data.Set           as Set
import Happstack.Server             ( Response, Happstack, escape, notFound, toResponse
                                    , ok, internalServerError
                                    )
import HSP.XMLGenerator             (unXMLGenT)
import Web.Routes.Happstack         (seeOtherURL)
import Web.Plugins.Core             (getTheme)

checkAuth :: PageURL
          -> PageM PageURL
checkAuth :: PageURL -> PageM PageURL
checkAuth PageURL
url =
    do ClckURL -> [(Text, Maybe Text)] -> Text
showFn <- PageConfig -> ClckURL -> [(Text, Maybe Text)] -> Text
pageClckURL (PageConfig -> ClckURL -> [(Text, Maybe Text)] -> Text)
-> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) PageConfig
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (ClckURL -> [(Text, Maybe Text)] -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) PageConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
       let requiresRole :: Set Role
-> url -> ClckT u (ReaderT PageConfig (ServerPartT IO)) url
requiresRole = (ClckURL -> [(Text, Maybe Text)] -> Text)
-> Set Role
-> url
-> ClckT u (ReaderT PageConfig (ServerPartT IO)) url
forall (m :: * -> *) url u.
Happstack m =>
(ClckURL -> [(Text, Maybe Text)] -> Text)
-> Set Role -> url -> ClckT u m url
requiresRole_ ClckURL -> [(Text, Maybe Text)] -> Text
showFn
       case PageURL
url of
         ViewPage{}     -> PageURL -> PageM PageURL
forall (m :: * -> *) a. Monad m => a -> m a
return PageURL
url
         ViewPageSlug{} -> PageURL -> PageM PageURL
forall (m :: * -> *) a. Monad m => a -> m a
return PageURL
url
         Blog{}         -> PageURL -> PageM PageURL
forall (m :: * -> *) a. Monad m => a -> m a
return PageURL
url
         AtomFeed{}     -> PageURL -> PageM PageURL
forall (m :: * -> *) a. Monad m => a -> m a
return PageURL
url
         PageAdmin {}   -> Set Role -> PageURL -> PageM PageURL
forall url u.
Set Role
-> url -> ClckT u (ReaderT PageConfig (ServerPartT IO)) url
requiresRole (Role -> Set Role
forall a. a -> Set a
Set.singleton Role
Administrator) PageURL
url

-- | routes for 'AdminURL'
routePageAdmin :: PageAdminURL -> PageM Response
routePageAdmin :: PageAdminURL -> PageM Response
routePageAdmin PageAdminURL
url =
    case PageAdminURL
url of
      (EditPage PageId
pid)    -> PageURL -> PageId -> PageM Response
editPage (PageAdminURL -> PageURL
PageAdmin PageAdminURL
url) PageId
pid
      PageAdminURL
NewPage           -> PageKind -> PageM Response
newPage PageKind
PlainPage
      PageAdminURL
NewPost           -> PageKind -> PageM Response
newPage PageKind
Post
      (PreviewPage PageId
pid) -> PageId -> PageM Response
previewPage PageId
pid -- FIXME
      PageAdminURL
EditFeedConfig    -> PageURL -> PageM Response
editFeedConfig (PageAdminURL -> PageURL
PageAdmin PageAdminURL
url)
      PageAdminURL
Pages             -> PageM Response
pages

routePage :: PageURL
          -> PageM Response
routePage :: PageURL -> PageM Response
routePage PageURL
url' =
    do PageURL
url <- PageURL -> PageM PageURL
checkAuth PageURL
url'
       Integer -> ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) ()
forall (m :: * -> *) url.
(Functor m, MonadIO m) =>
Integer -> ClckT url m ()
setUnique Integer
0
       case PageURL
url of
         (ViewPage PageId
pid) ->
           do Maybe (Text, Maybe Slug)
r <- GetPageTitle
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (EventResult GetPageTitle)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query (PageId -> GetPageTitle
GetPageTitle PageId
pid)
              case Maybe (Text, Maybe Slug)
r of
                Maybe (Text, Maybe Slug)
Nothing ->
                    Response -> PageM Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> PageM Response) -> Response -> PageM Response
forall a b. (a -> b) -> a -> b
$ [Char] -> Response
forall a. ToMessage a => a -> Response
toResponse ([Char]
"Invalid PageId " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (PageId -> Integer
unPageId PageId
pid))
                (Just (Text
title, Maybe Slug
slug)) ->
                    URL (ClckT PageURL (ReaderT PageConfig (ServerPartT IO)))
-> PageM Response
forall (m :: * -> *).
(MonadRoute m, FilterMonad Response m) =>
URL m -> m Response
seeOtherURL (PageId -> Slug -> PageURL
ViewPageSlug PageId
pid (Text -> Maybe Slug -> Slug
toSlug Text
title Maybe Slug
slug))

         (ViewPageSlug PageId
pid Slug
_slug) ->
           do Bool
published <- IsPublishedPage
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (EventResult IsPublishedPage)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query (PageId -> IsPublishedPage
IsPublishedPage PageId
pid)
              if Bool
published
                 then do ClckState
cs <- ClckT PageURL (ReaderT PageConfig (ServerPartT IO)) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
                         ~(Just Page
page) <- PageById
-> ClckT
     PageURL
     (ReaderT PageConfig (ServerPartT IO))
     (EventResult PageById)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query (PageId -> PageById
PageById PageId
pid)
                         let ttl :: Text
ttl = Page -> Text
pageTitle Page
page
                         Content
bdy <- 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 (Page -> Markup
pageSrc Page
page)
                         ClckT ClckURL (ServerPartT IO) Response -> PageM Response
forall (m :: * -> *) url1 a.
(Functor m, MonadIO m, MonadFail m, Typeable url1) =>
ClckT url1 m a -> PageT m a
clckT2PageT (ClckT ClckURL (ServerPartT IO) Response -> PageM Response)
-> ClckT ClckURL (ServerPartT IO) Response -> PageM Response
forall a b. (a -> b) -> a -> b
$ ClckPlugins
-> ThemeStyleId
-> Text
-> ()
-> Content
-> ClckT ClckURL (ServerPartT IO) Response
forall headers body.
(EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers,
 EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>
ClckPlugins
-> ThemeStyleId
-> Text
-> headers
-> body
-> ClckT ClckURL (ServerPartT IO) Response
themeTemplate (ClckState -> ClckPlugins
plugins ClckState
cs) (Page -> ThemeStyleId
pageThemeStyleId Page
page) Text
ttl () Content
bdy
                 else do Response -> PageM Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> PageM Response) -> Response -> PageM Response
forall a b. (a -> b) -> a -> b
$ [Char] -> Response
forall a. ToMessage a => a -> Response
toResponse ([Char]
"Invalid PageId " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (PageId -> Integer
unPageId PageId
pid))

         (PageURL
Blog) -> PageM Response
blog

         PageURL
AtomFeed ->
             do PageM Response
handleAtomFeed

         (PageAdmin PageAdminURL
adminURL) -> PageAdminURL -> PageM Response
routePageAdmin PageAdminURL
adminURL