{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TypeFamilies, TypeSynonymInstances #-}
module Clckwrks.Page.Monad where

import Control.Applicative           ((<$>))
import Control.Monad                 (foldM)
import Control.Monad.Fail            (MonadFail(fail))
import Control.Monad.Reader          (MonadReader(ask,local), ReaderT(runReaderT))
import Control.Monad.State           (StateT, put, get, modify)
import Control.Monad.Trans           (MonadIO(liftIO))
import qualified Data.Text.Lazy      as LT
import Clckwrks.Acid                 (GetAcidState(..))
import Clckwrks.Monad                (Content(..), ClckT(..), ClckFormT, ClckState(..), ClckPluginsSt(..), mapClckT, runClckT, withRouteClckT, getPreProcessors)
import Clckwrks.URL                  (ClckURL)
import Clckwrks.Page.Acid            (PageState(..))
import Clckwrks.Page.Types           (Markup(..), runPreProcessors)
import Clckwrks.Page.URL             (PageURL(..), PageAdminURL(..))
import Clckwrks.Page.Types           (PageId(..))
import Clckwrks.Plugin               (clckPlugin)
import Control.Monad.Trans           (lift)
import Data.Acid                     (AcidState)
import Data.Data                     (Typeable)
import qualified Data.Text           as T
import qualified Data.Text.Lazy      as TL
import Happstack.Server              (Happstack, Input, ServerPartT)
import HSP.XMLGenerator
import HSP.XML
import Prelude hiding (fail)
import Text.Reform                   (CommonFormError, FormError(..))
import Web.Plugins.Core              (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn)
import Web.Routes                    (RouteT(..), showURL, withRouteT)

data PageConfig = PageConfig
    { PageConfig -> AcidState PageState
pageState        :: AcidState PageState
    , PageConfig -> ClckURL -> [(Text, Maybe Text)] -> Text
pageClckURL      :: ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text
    }

type PageT m = ClckT PageURL (ReaderT PageConfig m)
type PageT' url m = ClckT url (ReaderT PageConfig m)
type PageM   = ClckT PageURL (ReaderT PageConfig (ServerPartT IO))
type PageAdminM = ClckT PageAdminURL (ReaderT PageConfig (ServerPartT IO))


runPageT :: PageConfig -> PageT m a -> ClckT PageURL m a
runPageT :: PageConfig -> PageT m a -> ClckT PageURL m a
runPageT PageConfig
mc PageT m a
m = (ReaderT PageConfig m (a, ClckState) -> m (a, ClckState))
-> PageT m a -> ClckT PageURL m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT ReaderT PageConfig m (a, ClckState) -> m (a, ClckState)
f PageT m a
m
    where
      f :: ReaderT PageConfig m (a, ClckState) -> m (a, ClckState)
f ReaderT PageConfig m (a, ClckState)
r = ReaderT PageConfig m (a, ClckState)
-> PageConfig -> m (a, ClckState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT PageConfig m (a, ClckState)
r PageConfig
mc

runPageT'' :: Monad m =>
               (PageURL -> [(T.Text, Maybe T.Text)] -> T.Text)
            -> PageConfig
            -> PageT m a
            -> ClckT url m a
runPageT'' :: (PageURL -> [(Text, Maybe Text)] -> Text)
-> PageConfig -> PageT m a -> ClckT url m a
runPageT'' PageURL -> [(Text, Maybe Text)] -> Text
showPageURL PageConfig
stripeConfig PageT m a
m = RouteT url (StateT ClckState m) a -> ClckT url m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState m) a -> ClckT url m a)
-> RouteT url (StateT ClckState m) a -> ClckT url m a
forall a b. (a -> b) -> a -> b
$ ((url -> [(Text, Maybe Text)] -> Text)
 -> PageURL -> [(Text, Maybe Text)] -> Text)
-> RouteT PageURL (StateT ClckState m) a
-> RouteT url (StateT ClckState m) a
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (url -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
forall url'.
(url' -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT PageURL (StateT ClckState m) a
 -> RouteT url (StateT ClckState m) a)
-> RouteT PageURL (StateT ClckState m) a
-> RouteT url (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ ClckT PageURL m a -> RouteT PageURL (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT (ClckT PageURL m a -> RouteT PageURL (StateT ClckState m) a)
-> ClckT PageURL m a -> RouteT PageURL (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ PageConfig -> PageT m a -> ClckT PageURL m a
forall (m :: * -> *) a.
PageConfig -> PageT m a -> ClckT PageURL m a
runPageT PageConfig
stripeConfig (PageT m a -> ClckT PageURL m a) -> PageT m a -> ClckT PageURL m a
forall a b. (a -> b) -> a -> b
$ PageT m a
m
    where
      flattenURL ::   ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> (PageURL -> [(T.Text, Maybe T.Text)] -> T.Text))
      flattenURL :: (url' -> [(Text, Maybe Text)] -> Text)
-> PageURL -> [(Text, Maybe Text)] -> Text
flattenURL url' -> [(Text, Maybe Text)] -> Text
_ PageURL
u [(Text, Maybe Text)]
p = PageURL -> [(Text, Maybe Text)] -> Text
showPageURL PageURL
u [(Text, Maybe Text)]
p


-- withRouteClckT ?
flattenURLClckT :: (url1 -> [(T.Text, Maybe T.Text)] -> T.Text)
                -> ClckT url1 m a
                -> ClckT url2 m a
flattenURLClckT :: (url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 m a -> ClckT url2 m a
flattenURLClckT url1 -> [(Text, Maybe Text)] -> Text
showClckURL ClckT url1 m a
m = RouteT url2 (StateT ClckState m) a -> ClckT url2 m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url2 (StateT ClckState m) a -> ClckT url2 m a)
-> RouteT url2 (StateT ClckState m) a -> ClckT url2 m a
forall a b. (a -> b) -> a -> b
$ ((url2 -> [(Text, Maybe Text)] -> Text)
 -> url1 -> [(Text, Maybe Text)] -> Text)
-> RouteT url1 (StateT ClckState m) a
-> RouteT url2 (StateT ClckState m) a
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (url2 -> [(Text, Maybe Text)] -> Text)
-> url1 -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT url1 (StateT ClckState m) a
 -> RouteT url2 (StateT ClckState m) a)
-> RouteT url1 (StateT ClckState m) a
-> RouteT url2 (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ ClckT url1 m a -> RouteT url1 (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT url1 m a
m
    where
      flattenURL :: (url2 -> [(Text, Maybe Text)] -> Text)
-> url1 -> [(Text, Maybe Text)] -> Text
flattenURL url2 -> [(Text, Maybe Text)] -> Text
_ = \url1
u [(Text, Maybe Text)]
p -> url1 -> [(Text, Maybe Text)] -> Text
showClckURL url1
u [(Text, Maybe Text)]
p

clckT2PageT :: (Functor m, MonadIO m, MonadFail m, Typeable url1) =>
             ClckT url1 m a
          -> PageT m a
clckT2PageT :: ClckT url1 m a -> PageT m a
clckT2PageT ClckT url1 m a
m =
    do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT PageURL (ReaderT PageConfig m) ClckState
-> ClckT PageURL (ReaderT PageConfig m) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT PageURL (ReaderT PageConfig m) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       ~(Just url1 -> [(Text, Maybe Text)] -> Text
clckShowFn) <- ClckPlugins
-> Text
-> ClckT
     PageURL
     (ReaderT PageConfig m)
     (Maybe (url1 -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
p (Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
clckPlugin)
       (url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 (ReaderT PageConfig m) a -> PageT m a
forall url1 (m :: * -> *) a url2.
(url1 -> [(Text, Maybe Text)] -> Text)
-> ClckT url1 m a -> ClckT url2 m a
flattenURLClckT url1 -> [(Text, Maybe Text)] -> Text
clckShowFn (ClckT url1 (ReaderT PageConfig m) a -> PageT m a)
-> ClckT url1 (ReaderT PageConfig m) a -> PageT m a
forall a b. (a -> b) -> a -> b
$ (m (a, ClckState) -> ReaderT PageConfig m (a, ClckState))
-> ClckT url1 m a -> ClckT url1 (ReaderT PageConfig m) a
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
forall (m :: * -> *) a.
Monad m =>
m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
addReaderT ClckT url1 m a
m
    where
      addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
      addReaderT :: m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
addReaderT m (a, ClckState)
m =
          do (a
a, ClckState
cs) <- m (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (a, ClckState)
m
             (a, ClckState) -> ReaderT PageConfig m (a, ClckState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, ClckState
cs)

data PageFormError
    = PageCFE (CommonFormError [Input])
    | PageErrorInternal
      deriving Int -> PageFormError -> ShowS
[PageFormError] -> ShowS
PageFormError -> String
(Int -> PageFormError -> ShowS)
-> (PageFormError -> String)
-> ([PageFormError] -> ShowS)
-> Show PageFormError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PageFormError] -> ShowS
$cshowList :: [PageFormError] -> ShowS
show :: PageFormError -> String
$cshow :: PageFormError -> String
showsPrec :: Int -> PageFormError -> ShowS
$cshowsPrec :: Int -> PageFormError -> ShowS
Show

instance FormError PageFormError where
    type ErrorInputType PageFormError = [Input]
    commonFormError :: CommonFormError (ErrorInputType PageFormError) -> PageFormError
commonFormError = CommonFormError [Input] -> PageFormError
CommonFormError (ErrorInputType PageFormError) -> PageFormError
PageCFE

instance (Functor m, Monad m) => EmbedAsChild (PageT m) PageFormError where
    asChild :: PageFormError -> GenChildList (PageT m)
asChild PageFormError
e = String -> GenChildList (PageT m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (PageFormError -> String
forall a. Show a => a -> String
show PageFormError
e)

type PageForm = ClckFormT PageFormError PageM

instance (Monad m) => MonadReader PageConfig (PageT' url m) where
    ask :: PageT' url m PageConfig
ask = RouteT url (StateT ClckState (ReaderT PageConfig m)) PageConfig
-> PageT' url m PageConfig
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState (ReaderT PageConfig m)) PageConfig
 -> PageT' url m PageConfig)
-> RouteT url (StateT ClckState (ReaderT PageConfig m)) PageConfig
-> PageT' url m PageConfig
forall a b. (a -> b) -> a -> b
$ RouteT url (StateT ClckState (ReaderT PageConfig m)) PageConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (PageConfig -> PageConfig) -> PageT' url m a -> PageT' url m a
local PageConfig -> PageConfig
f (ClckT RouteT url (StateT ClckState (ReaderT PageConfig m)) a
m) = RouteT url (StateT ClckState (ReaderT PageConfig m)) a
-> PageT' url m a
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState (ReaderT PageConfig m)) a
 -> PageT' url m a)
-> RouteT url (StateT ClckState (ReaderT PageConfig m)) a
-> PageT' url m a
forall a b. (a -> b) -> a -> b
$ (PageConfig -> PageConfig)
-> RouteT url (StateT ClckState (ReaderT PageConfig m)) a
-> RouteT url (StateT ClckState (ReaderT PageConfig m)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local PageConfig -> PageConfig
f RouteT url (StateT ClckState (ReaderT PageConfig m)) a
m

instance (Functor m, Monad m) => GetAcidState (PageT' url m) PageState where
    getAcidState :: PageT' url m (AcidState PageState)
getAcidState =
        PageConfig -> AcidState PageState
pageState (PageConfig -> AcidState PageState)
-> ClckT url (ReaderT PageConfig m) PageConfig
-> PageT' url m (AcidState PageState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url (ReaderT PageConfig m) PageConfig
forall r (m :: * -> *). MonadReader r m => m r
ask

instance (IsName n TL.Text) => EmbedAsAttr PageM (Attr n PageURL) where
        asAttr :: Attr n PageURL -> GenAttributeList PageM
asAttr (n
n := PageURL
u) =
            do Text
url <- URL (XMLGenT PageM) -> XMLGenT PageM Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (XMLGenT PageM)
PageURL
u
               Attribute -> GenAttributeList PageM
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList PageM)
-> Attribute -> GenAttributeList PageM
forall a b. (a -> b) -> a -> b
$ (NSName, AttrValue) -> Attribute
MkAttr (n -> NSName
forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal (Text -> Text
TL.fromStrict Text
url))

instance (IsName n TL.Text) => EmbedAsAttr PageM (Attr n ClckURL) where
        asAttr :: Attr n ClckURL -> GenAttributeList PageM
asAttr (n
n := ClckURL
url) =
            do ClckURL -> [(Text, Maybe Text)] -> Text
showFn <- PageConfig -> ClckURL -> [(Text, Maybe Text)] -> Text
pageClckURL (PageConfig -> ClckURL -> [(Text, Maybe Text)] -> Text)
-> XMLGenT PageM PageConfig
-> XMLGenT PageM (ClckURL -> [(Text, Maybe Text)] -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLGenT PageM PageConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
               Attribute -> GenAttributeList PageM
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList PageM)
-> Attribute -> GenAttributeList PageM
forall a b. (a -> b) -> a -> b
$ (NSName, AttrValue) -> Attribute
MkAttr (n -> NSName
forall n s. IsName n s => n -> Name s
toName n
n, Text -> AttrValue
pAttrVal (Text -> Text
TL.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckURL -> [(Text, Maybe Text)] -> Text
showFn ClckURL
url []))


-- | convert 'Markup' to 'Content' that can be embedded. Generally by running the pre-processors needed.
-- markupToContent :: (Functor m, MonadIO m, Happstack m) => Markup -> ClckT url m Content
markupToContent :: (Functor m, MonadIO m, MonadFail m, Happstack m) =>
                   Markup
                -> ClckT url m Content
markupToContent :: Markup -> ClckT url m Content
markupToContent Markup{[PreProcessor]
Text
Trust
trust :: Markup -> Trust
markup :: Markup -> Text
preProcessors :: Markup -> [PreProcessor]
trust :: Trust
markup :: Text
preProcessors :: [PreProcessor]
..} =
    do ClckState
clckState <- ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       [Text -> ClckT ClckURL (ClckT url m) Text]
transformers <- ClckPlugins
-> forall (mm :: * -> *).
   (Functor mm, MonadIO mm, Happstack mm) =>
   ClckT url m [Text -> ClckT ClckURL mm Text]
forall (m :: * -> *) theme n hook config url.
MonadIO m =>
Plugins theme n hook config ClckPluginsSt
-> forall (mm :: * -> *).
   (Functor mm, MonadIO mm, Happstack mm) =>
   ClckT url m [Text -> ClckT ClckURL mm Text]
getPreProcessors (ClckState -> ClckPlugins
plugins ClckState
clckState)
       ~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckRouteFn) <- ClckPlugins
-> Text
-> ClckT url m (Maybe (ClckURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn (ClckState -> ClckPlugins
plugins ClckState
clckState) (Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
  ClckURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
clckPlugin)
       (Text
markup', ClckState
clckState') <- (ClckURL -> [(Text, Maybe Text)] -> Text)
-> ClckState
-> ClckT ClckURL (ClckT url m) Text
-> ClckT url m (Text, ClckState)
forall (m :: * -> *) url a.
Monad m =>
(url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m (a, ClckState)
runClckT ClckURL -> [(Text, Maybe Text)] -> Text
clckRouteFn ClckState
clckState ((Text
 -> (Text -> ClckT ClckURL (ClckT url m) Text)
 -> ClckT ClckURL (ClckT url m) Text)
-> Text
-> [Text -> ClckT ClckURL (ClckT url m) Text]
-> ClckT ClckURL (ClckT url m) Text
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Text
txt Text -> ClckT ClckURL (ClckT url m) Text
pp -> Text -> ClckT ClckURL (ClckT url m) Text
pp Text
txt) (Text -> Text
TL.fromStrict Text
markup) [Text -> ClckT ClckURL (ClckT url m) Text]
transformers)
       ClckState -> ClckT url m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ClckState
clckState'
       Either Text Text
e <- IO (Either Text Text) -> ClckT url m (Either Text Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text Text) -> ClckT url m (Either Text Text))
-> IO (Either Text Text) -> ClckT url m (Either Text Text)
forall a b. (a -> b) -> a -> b
$ [PreProcessor] -> Trust -> Text -> IO (Either Text Text)
forall (m :: * -> *).
MonadIO m =>
[PreProcessor] -> Trust -> Text -> m (Either Text Text)
runPreProcessors [PreProcessor]
preProcessors Trust
trust (Text -> Text
TL.toStrict Text
markup')
       case Either Text Text
e of
         (Left Text
err)   -> Content -> ClckT url m Content
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Content
PlainText Text
err)
         (Right Text
html) -> Content -> ClckT url m Content
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Content
TrustedHtml Text
html)

{-
-- | update the 'currentPage' field of 'ClckState'
setCurrentPage :: (MonadIO m) => PageId -> PageT m ()
setCurrentPage pid =
    modify $ \s -> s { pageCurrent = pid }
-}