{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, TypeFamilies, RankNTypes, RecordWildCards, ScopedTypeVariables, UndecidableInstances, OverloadedStrings, TemplateHaskell #-}
module Clckwrks.Monad
    ( Clck
    , ClckPlugins
    , ClckPluginsSt(cpsAcid)
    , initialClckPluginsSt
    , ClckT(..)
    , ClckForm
    , ClckFormT
    , ClckFormError(..)
    , ChildType(..)
    , ClckwrksConfig(..)
    , TLSSettings(..)
    , AttributeType(..)
    , Theme(..)
    , ThemeStyle(..)
    , ThemeStyleId(..)
    , ThemeName
    , getThemeStyles
    , themeTemplate
    , calcBaseURI
    , calcTLSBaseURI
    , evalClckT
    , execClckT
    , runClckT
    , mapClckT
    , withRouteClckT
    , ClckState(..)
    , Content(..)
--    , markupToContent
--    , addPreProcessor
    , addAdminMenu
    , appendRequestInit
    , getNavBarLinks
    , addPreProc
    , addNavBarCallback
    , getPreProcessors
--     , getPrefix
    , getEnableAnalytics
    , googleAnalytics
    , getUnique
    , setUnique
    , setRedirectCookie
    , getRedirectCookie
    , query
    , update
    , nestURL
    , withAbs
    , withAbs'
    , segments
    , transform
    , module HSP.XML
    , module HSP.XMLGenerator
    )
where

import Clckwrks.Admin.URL            (AdminURL(..))
import Clckwrks.Acid                 (Acid(..), CoreState, GetAcidState(..), GetUACCT(..))
import Clckwrks.ProfileData.Acid     (ProfileDataState, GetRoles(..), HasRole(..))
import Clckwrks.ProfileData.Types    (Role(..))
import Clckwrks.NavBar.Acid          (NavBarState)
import Clckwrks.NavBar.Types         (NavBarLinks(..))
import Clckwrks.Types                (NamedLink(..), Prefix, Trust(Trusted))
import Clckwrks.Unauthorized         (unauthorizedPage)
import Clckwrks.URL                  (ClckURL(..))
import Control.Applicative           (Alternative, Applicative, (<$>), (<|>), many, optional)
#if MIN_VERSION_base (4,9,0) && !MIN_VERSION_base (4,13,0)
import Control.Monad.Fail            (MonadFail)
#endif
import Control.Monad                 (MonadPlus, foldM)
import Control.Monad.State           (MonadState, StateT, evalStateT, execStateT, get, mapStateT, modify, put, runStateT)
import Control.Monad.Reader          (MonadReader, ReaderT, mapReaderT)
import Control.Monad.Trans           (MonadIO(liftIO), MonadTrans(lift))
import Control.Concurrent.STM        (TVar, readTVar, writeTVar, atomically)
import Data.Acid                     (AcidState, EventState, EventResult, QueryEvent, UpdateEvent)
import Data.Acid.Advanced            (query', update')
import Data.Attoparsec.Text.Lazy     (Parser, parseOnly, char, asciiCI, try, takeWhile, takeWhile1)
import qualified Data.HashMap.Lazy   as HashMap

import qualified Data.List           as List
import qualified Data.Map            as Map
import Data.Monoid                   ((<>), mappend, mconcat)
import qualified Data.Serialize      as S
import Data.Traversable              (sequenceA)
import qualified Data.Vector         as Vector
import Data.ByteString.Lazy          as LB (ByteString)
import Data.ByteString.Lazy.UTF8     as LB (toString)
import Data.Data                     (Data, Typeable)
import Data.Map                      (Map)
import Data.Maybe                    (fromJust)
import Data.SafeCopy                 (SafeCopy(..), Contained, deriveSafeCopy, base, contain)
import Data.Set                      (Set)
import qualified Data.Set            as Set
import Data.Sequence                 (Seq)
import qualified Data.Text           as T
import qualified Data.Text           as Text
import qualified Data.Text.Lazy      as TL
import           Data.Text.Lazy.Builder (Builder, fromText)
import qualified Data.Text.Lazy.Builder as B
import Data.Time.Clock               (UTCTime)
import Data.Time.Format              (formatTime)
import Data.UserId                   (UserId(..))
import Happstack.Server              ( CookieLife(Session), Happstack, ServerMonad(..), FilterMonad(..)
                                     , WebMonad(..), Input, Request(..), Response, HasRqData(..)
                                     , ServerPart, ServerPartT, UnWebT, addCookie, expireCookie, escape
                                     , internalServerError, lookCookieValue, mapServerPartT, mkCookie
                                     , toResponse
                                     )
import Happstack.Server.HSP.HTML     () -- ToMessage XML instance
import Happstack.Server.XMLGenT      () -- instance Happstack XMLGenT
import Happstack.Server.Internal.Monads (FilterFun)
-- import HSP                           hiding (Request, escape)
import HSP.Google.Analytics          (UACCT, universalAnalytics)
-- import HSP.ServerPartT               ()
import HSP.XML
import HSP.XMLGenerator
import HSP.JMacro                    (IntegerSupply(..))
import Language.Javascript.JMacro
import Prelude                       hiding (takeWhile)
import Data.Time.Locale.Compat       (defaultTimeLocale) -- can import from time directly when time-1.4/ghc 7.8 is not important anymore
import Text.Blaze.Html               (Html)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Reform                   (CommonFormError, Form, FormError(..))
import Web.Routes                    (URL, MonadRoute(askRouteFn), RouteT(RouteT, unRouteT), mapRouteT, showURL, withRouteT)
import Web.Plugins.Core              (Plugins, getConfig, getPluginsSt, modifyPluginsSt, getTheme)
import qualified Web.Routes          as R
import Web.Routes.Happstack          (seeOtherURL) -- imported so that instances are scope even though we do not use them here
import Web.Routes.XMLGenT            () -- imported so that instances are scope even though we do not use them here

------------------------------------------------------------------------------
-- Theme
------------------------------------------------------------------------------

type ThemeName = T.Text

newtype ThemeStyleId = ThemeStyleId { ThemeStyleId -> Int
unThemeStyleId :: Int }
    deriving (ThemeStyleId -> ThemeStyleId -> Bool
(ThemeStyleId -> ThemeStyleId -> Bool)
-> (ThemeStyleId -> ThemeStyleId -> Bool) -> Eq ThemeStyleId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThemeStyleId -> ThemeStyleId -> Bool
$c/= :: ThemeStyleId -> ThemeStyleId -> Bool
== :: ThemeStyleId -> ThemeStyleId -> Bool
$c== :: ThemeStyleId -> ThemeStyleId -> Bool
Eq, Eq ThemeStyleId
Eq ThemeStyleId
-> (ThemeStyleId -> ThemeStyleId -> Ordering)
-> (ThemeStyleId -> ThemeStyleId -> Bool)
-> (ThemeStyleId -> ThemeStyleId -> Bool)
-> (ThemeStyleId -> ThemeStyleId -> Bool)
-> (ThemeStyleId -> ThemeStyleId -> Bool)
-> (ThemeStyleId -> ThemeStyleId -> ThemeStyleId)
-> (ThemeStyleId -> ThemeStyleId -> ThemeStyleId)
-> Ord ThemeStyleId
ThemeStyleId -> ThemeStyleId -> Bool
ThemeStyleId -> ThemeStyleId -> Ordering
ThemeStyleId -> ThemeStyleId -> ThemeStyleId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ThemeStyleId -> ThemeStyleId -> ThemeStyleId
$cmin :: ThemeStyleId -> ThemeStyleId -> ThemeStyleId
max :: ThemeStyleId -> ThemeStyleId -> ThemeStyleId
$cmax :: ThemeStyleId -> ThemeStyleId -> ThemeStyleId
>= :: ThemeStyleId -> ThemeStyleId -> Bool
$c>= :: ThemeStyleId -> ThemeStyleId -> Bool
> :: ThemeStyleId -> ThemeStyleId -> Bool
$c> :: ThemeStyleId -> ThemeStyleId -> Bool
<= :: ThemeStyleId -> ThemeStyleId -> Bool
$c<= :: ThemeStyleId -> ThemeStyleId -> Bool
< :: ThemeStyleId -> ThemeStyleId -> Bool
$c< :: ThemeStyleId -> ThemeStyleId -> Bool
compare :: ThemeStyleId -> ThemeStyleId -> Ordering
$ccompare :: ThemeStyleId -> ThemeStyleId -> Ordering
$cp1Ord :: Eq ThemeStyleId
Ord, ReadPrec [ThemeStyleId]
ReadPrec ThemeStyleId
Int -> ReadS ThemeStyleId
ReadS [ThemeStyleId]
(Int -> ReadS ThemeStyleId)
-> ReadS [ThemeStyleId]
-> ReadPrec ThemeStyleId
-> ReadPrec [ThemeStyleId]
-> Read ThemeStyleId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ThemeStyleId]
$creadListPrec :: ReadPrec [ThemeStyleId]
readPrec :: ReadPrec ThemeStyleId
$creadPrec :: ReadPrec ThemeStyleId
readList :: ReadS [ThemeStyleId]
$creadList :: ReadS [ThemeStyleId]
readsPrec :: Int -> ReadS ThemeStyleId
$creadsPrec :: Int -> ReadS ThemeStyleId
Read, Int -> ThemeStyleId -> ShowS
[ThemeStyleId] -> ShowS
ThemeStyleId -> String
(Int -> ThemeStyleId -> ShowS)
-> (ThemeStyleId -> String)
-> ([ThemeStyleId] -> ShowS)
-> Show ThemeStyleId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThemeStyleId] -> ShowS
$cshowList :: [ThemeStyleId] -> ShowS
show :: ThemeStyleId -> String
$cshow :: ThemeStyleId -> String
showsPrec :: Int -> ThemeStyleId -> ShowS
$cshowsPrec :: Int -> ThemeStyleId -> ShowS
Show, Typeable ThemeStyleId
DataType
Constr
Typeable ThemeStyleId
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ThemeStyleId -> c ThemeStyleId)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ThemeStyleId)
-> (ThemeStyleId -> Constr)
-> (ThemeStyleId -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ThemeStyleId))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ThemeStyleId))
-> ((forall b. Data b => b -> b) -> ThemeStyleId -> ThemeStyleId)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r)
-> (forall u. (forall d. Data d => d -> u) -> ThemeStyleId -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ThemeStyleId -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId)
-> Data ThemeStyleId
ThemeStyleId -> DataType
ThemeStyleId -> Constr
(forall b. Data b => b -> b) -> ThemeStyleId -> ThemeStyleId
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ThemeStyleId -> c ThemeStyleId
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ThemeStyleId
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ThemeStyleId -> u
forall u. (forall d. Data d => d -> u) -> ThemeStyleId -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ThemeStyleId
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ThemeStyleId -> c ThemeStyleId
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ThemeStyleId)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ThemeStyleId)
$cThemeStyleId :: Constr
$tThemeStyleId :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
gmapMp :: (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
gmapM :: (forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ThemeStyleId -> m ThemeStyleId
gmapQi :: Int -> (forall d. Data d => d -> u) -> ThemeStyleId -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ThemeStyleId -> u
gmapQ :: (forall d. Data d => d -> u) -> ThemeStyleId -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ThemeStyleId -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ThemeStyleId -> r
gmapT :: (forall b. Data b => b -> b) -> ThemeStyleId -> ThemeStyleId
$cgmapT :: (forall b. Data b => b -> b) -> ThemeStyleId -> ThemeStyleId
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ThemeStyleId)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ThemeStyleId)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ThemeStyleId)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ThemeStyleId)
dataTypeOf :: ThemeStyleId -> DataType
$cdataTypeOf :: ThemeStyleId -> DataType
toConstr :: ThemeStyleId -> Constr
$ctoConstr :: ThemeStyleId -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ThemeStyleId
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ThemeStyleId
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ThemeStyleId -> c ThemeStyleId
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ThemeStyleId -> c ThemeStyleId
$cp1Data :: Typeable ThemeStyleId
Data, Typeable)

instance SafeCopy ThemeStyleId where
    getCopy :: Contained (Get ThemeStyleId)
getCopy = Get ThemeStyleId -> Contained (Get ThemeStyleId)
forall a. a -> Contained a
contain (Get ThemeStyleId -> Contained (Get ThemeStyleId))
-> Get ThemeStyleId -> Contained (Get ThemeStyleId)
forall a b. (a -> b) -> a -> b
$ Int -> ThemeStyleId
ThemeStyleId (Int -> ThemeStyleId) -> Get Int -> Get ThemeStyleId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall t. Serialize t => Get t
S.get
    putCopy :: ThemeStyleId -> Contained Put
putCopy (ThemeStyleId Int
i) = Put -> Contained Put
forall a. a -> Contained a
contain (Put -> Contained Put) -> Put -> Contained Put
forall a b. (a -> b) -> a -> b
$ Putter Int
forall t. Serialize t => Putter t
S.put Int
i
    errorTypeName :: Proxy ThemeStyleId -> String
errorTypeName Proxy ThemeStyleId
_ = String
"ThemeStyleId"

data ThemeStyle = ThemeStyle
    { ThemeStyle -> Text
themeStyleName        :: T.Text
    , ThemeStyle -> Text
themeStyleDescription :: T.Text
    , ThemeStyle -> Maybe String
themeStylePreview     :: Maybe FilePath
    , ThemeStyle
-> forall headers body.
   (EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers,
    EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>
   Text
   -> headers -> body -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
themeStyleTemplate    :: forall headers body.
                               ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers
                               , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>
                               T.Text
                            -> headers
                            -> body
                            -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
    }

data Theme = Theme
    { Theme -> Text
themeName      :: ThemeName
    , Theme -> [ThemeStyle]
themeStyles    :: [ThemeStyle]
    , Theme -> IO String
themeDataDir   :: IO FilePath
    }

themeTemplate :: ( EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers
                 , EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body
                 ) =>
                 ClckPlugins
              -> ThemeStyleId
              -> T.Text
              -> headers
              -> body
              -> ClckT ClckURL (ServerPartT IO) Response
themeTemplate :: ClckPlugins
-> ThemeStyleId
-> Text
-> headers
-> body
-> ClckT ClckURL (ServerPartT IO) Response
themeTemplate ClckPlugins
plugins ThemeStyleId
tsid Text
ttl headers
hdrs body
bdy =
    do Maybe Theme
mTheme <- ClckPlugins -> ClckT ClckURL (ServerPartT IO) (Maybe Theme)
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m (Maybe theme)
getTheme ClckPlugins
plugins
       case Maybe Theme
mTheme of
         Maybe Theme
Nothing -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape (ClckT ClckURL (ServerPartT IO) Response
 -> ClckT ClckURL (ServerPartT IO) Response)
-> ClckT ClckURL (ServerPartT IO) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ Response -> ClckT ClckURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ClckT ClckURL (ServerPartT IO) Response)
-> Response -> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> Response) -> Text -> Response
forall a b. (a -> b) -> a -> b
$ (Text
"No theme package is loaded." :: T.Text)
         (Just Theme
theme) ->
             case ThemeStyleId -> [ThemeStyle] -> Maybe ThemeStyle
forall a. ThemeStyleId -> [a] -> Maybe a
lookupThemeStyle ThemeStyleId
tsid (Theme -> [ThemeStyle]
themeStyles Theme
theme) of
               Maybe ThemeStyle
Nothing -> ClckT ClckURL (ServerPartT IO) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape (ClckT ClckURL (ServerPartT IO) Response
 -> ClckT ClckURL (ServerPartT IO) Response)
-> ClckT ClckURL (ServerPartT IO) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ Response -> ClckT ClckURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError (Response -> ClckT ClckURL (ServerPartT IO) Response)
-> Response -> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ Text -> Response
forall a. ToMessage a => a -> Response
toResponse (Text -> Response) -> Text -> Response
forall a b. (a -> b) -> a -> b
$ (Text
"The current theme does not seem to contain any theme styles." :: T.Text)
               (Just ThemeStyle
themeStyle) ->
                  (XML -> Response)
-> ClckT ClckURL (ServerPartT IO) XML
-> ClckT ClckURL (ServerPartT IO) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap XML -> Response
forall a. ToMessage a => a -> Response
toResponse (ClckT ClckURL (ServerPartT IO) XML
 -> ClckT ClckURL (ServerPartT IO) Response)
-> ClckT ClckURL (ServerPartT IO) XML
-> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
-> ClckT ClckURL (ServerPartT IO) XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
 -> ClckT ClckURL (ServerPartT IO) XML)
-> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
-> ClckT ClckURL (ServerPartT IO) XML
forall a b. (a -> b) -> a -> b
$ ((ThemeStyle
-> Text
-> headers
-> body
-> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
ThemeStyle
-> forall headers body.
   (EmbedAsChild (ClckT ClckURL (ServerPartT IO)) headers,
    EmbedAsChild (ClckT ClckURL (ServerPartT IO)) body) =>
   Text
   -> headers -> body -> XMLGenT (ClckT ClckURL (ServerPartT IO)) XML
themeStyleTemplate ThemeStyle
themeStyle) Text
ttl headers
hdrs body
bdy)

lookupThemeStyle :: ThemeStyleId -> [a] -> Maybe a
lookupThemeStyle :: ThemeStyleId -> [a] -> Maybe a
lookupThemeStyle                   ThemeStyleId
_ [] = Maybe a
forall a. Maybe a
Nothing
lookupThemeStyle (ThemeStyleId Int
0) (a
t:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
t
lookupThemeStyle (ThemeStyleId Int
n) (a
t':[a]
ts) = Int -> [a] -> Maybe a
lookupThemeStyle' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
ts
    where
      lookupThemeStyle' :: Int -> [a] -> Maybe a
lookupThemeStyle'  Int
_ [] = a -> Maybe a
forall a. a -> Maybe a
Just a
t'
      lookupThemeStyle' Int
0 (a
t:[a]
ts) = a -> Maybe a
forall a. a -> Maybe a
Just a
t
      lookupThemeStyle' Int
n (a
_:[a]
ts) = Int -> [a] -> Maybe a
lookupThemeStyle' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
ts

getThemeStyles :: (MonadIO m) => ClckPlugins -> m [(ThemeStyleId, ThemeStyle)]
getThemeStyles :: ClckPlugins -> m [(ThemeStyleId, ThemeStyle)]
getThemeStyles ClckPlugins
plugins =
    do Maybe Theme
mTheme <- ClckPlugins -> m (Maybe Theme)
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m (Maybe theme)
getTheme ClckPlugins
plugins
       case Maybe Theme
mTheme of
         Maybe Theme
Nothing -> [(ThemeStyleId, ThemeStyle)] -> m [(ThemeStyleId, ThemeStyle)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         (Just Theme
theme) -> [(ThemeStyleId, ThemeStyle)] -> m [(ThemeStyleId, ThemeStyle)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ThemeStyleId, ThemeStyle)] -> m [(ThemeStyleId, ThemeStyle)])
-> [(ThemeStyleId, ThemeStyle)] -> m [(ThemeStyleId, ThemeStyle)]
forall a b. (a -> b) -> a -> b
$ [ThemeStyleId] -> [ThemeStyle] -> [(ThemeStyleId, ThemeStyle)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> ThemeStyleId) -> [Int] -> [ThemeStyleId]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ThemeStyleId
ThemeStyleId [Int
0..]) (Theme -> [ThemeStyle]
themeStyles Theme
theme)

------------------------------------------------------------------------------
-- ClckwrksConfig
------------------------------------------------------------------------------


data TLSSettings = TLSSettings
    { TLSSettings -> Int
clckTLSPort :: Int
    , TLSSettings -> String
clckTLSCert :: FilePath
    , TLSSettings -> String
clckTLSKey  :: FilePath
    , TLSSettings -> Maybe String
clckTLSCA   :: Maybe FilePath
    }

data ClckwrksConfig = ClckwrksConfig
    { ClckwrksConfig -> String
clckHostname        :: String         -- ^ external name of the host
    , ClckwrksConfig -> Int
clckPort            :: Int            -- ^ port to listen on
    , ClckwrksConfig -> Maybe TLSSettings
clckTLS             :: Maybe TLSSettings -- ^ HTTPS
    , ClckwrksConfig -> Bool
clckHidePort        :: Bool           -- ^ hide port number in URL (useful when running behind a reverse proxy)
    , ClckwrksConfig -> String
clckJQueryPath      :: FilePath       -- ^ path to @jquery.js@ on disk
    , ClckwrksConfig -> String
clckJQueryUIPath    :: FilePath       -- ^ path to @jquery-ui.js@ on disk
    , ClckwrksConfig -> String
clckJSTreePath      :: FilePath       -- ^ path to @jstree.js@ on disk
    , ClckwrksConfig -> String
clckJSON2Path       :: FilePath       -- ^ path to @JSON2.js@ on disk
    , ClckwrksConfig -> Maybe String
clckTopDir          :: Maybe FilePath -- ^ path to top-level directory for all acid-state files/file uploads/etc
    , ClckwrksConfig -> Bool
clckEnableAnalytics :: Bool           -- ^ enable google analytics
    , ClckwrksConfig
-> Text
-> ClckState
-> ClckwrksConfig
-> IO (ClckState, ClckwrksConfig)
clckInitHook        :: T.Text -> ClckState -> ClckwrksConfig -> IO (ClckState, ClckwrksConfig) -- ^ init hook
    }

-- | calculate the baseURI from the 'clckHostname', 'clckPort' and 'clckHidePort' options
calcBaseURI :: ClckwrksConfig -> T.Text
calcBaseURI :: ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
c =
    String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ClckwrksConfig -> String
clckHostname ClckwrksConfig
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ if ((ClckwrksConfig -> Int
clckPort ClckwrksConfig
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
80) Bool -> Bool -> Bool
&& (ClckwrksConfig -> Bool
clckHidePort ClckwrksConfig
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False)) then (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (ClckwrksConfig -> Int
clckPort ClckwrksConfig
c)) else String
""

calcTLSBaseURI  :: ClckwrksConfig -> Maybe T.Text
calcTLSBaseURI :: ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
c =
    case ClckwrksConfig -> Maybe TLSSettings
clckTLS ClckwrksConfig
c of
      Maybe TLSSettings
Nothing -> Maybe Text
forall a. Maybe a
Nothing
      (Just TLSSettings
tlsSettings) ->
          Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"https://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ClckwrksConfig -> String
clckHostname ClckwrksConfig
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ if ((ClckwrksConfig -> Int
clckPort ClckwrksConfig
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
443) Bool -> Bool -> Bool
&& (ClckwrksConfig -> Bool
clckHidePort ClckwrksConfig
c Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False)) then (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show (TLSSettings -> Int
clckTLSPort TLSSettings
tlsSettings)) else String
""

------------------------------------------------------------------------------
-- ClckState
------------------------------------------------------------------------------


data ClckState = ClckState
    { ClckState -> Acid
acidState        :: Acid
    , ClckState -> TVar Integer
uniqueId         :: TVar Integer -- only unique for this request
    , ClckState -> [(Text, [(Set Role, Text, Text)])]
adminMenus       :: [(T.Text, [(Set Role, T.Text, T.Text)])]
    , ClckState -> Bool
enableAnalytics  :: Bool          -- ^ enable Google Analytics
    , ClckState -> ClckPlugins
plugins          :: ClckPlugins
    , ClckState -> ServerPart ()
requestInit      :: ServerPart () -- ^ an action which gets called at the beginning of each request
    }

------------------------------------------------------------------------------
-- ClckT
------------------------------------------------------------------------------

newtype ClckT url m a = ClckT { ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT :: RouteT url (StateT ClckState m) a }
#if MIN_VERSION_base(4,9,0)
    deriving (a -> ClckT url m b -> ClckT url m a
(a -> b) -> ClckT url m a -> ClckT url m b
(forall a b. (a -> b) -> ClckT url m a -> ClckT url m b)
-> (forall a b. a -> ClckT url m b -> ClckT url m a)
-> Functor (ClckT url m)
forall a b. a -> ClckT url m b -> ClckT url m a
forall a b. (a -> b) -> ClckT url m a -> ClckT url m b
forall url (m :: * -> *) a b.
Functor m =>
a -> ClckT url m b -> ClckT url m a
forall url (m :: * -> *) a b.
Functor m =>
(a -> b) -> ClckT url m a -> ClckT url m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ClckT url m b -> ClckT url m a
$c<$ :: forall url (m :: * -> *) a b.
Functor m =>
a -> ClckT url m b -> ClckT url m a
fmap :: (a -> b) -> ClckT url m a -> ClckT url m b
$cfmap :: forall url (m :: * -> *) a b.
Functor m =>
(a -> b) -> ClckT url m a -> ClckT url m b
Functor, Functor (ClckT url m)
a -> ClckT url m a
Functor (ClckT url m)
-> (forall a. a -> ClckT url m a)
-> (forall a b.
    ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b)
-> (forall a b c.
    (a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c)
-> (forall a b. ClckT url m a -> ClckT url m b -> ClckT url m b)
-> (forall a b. ClckT url m a -> ClckT url m b -> ClckT url m a)
-> Applicative (ClckT url m)
ClckT url m a -> ClckT url m b -> ClckT url m b
ClckT url m a -> ClckT url m b -> ClckT url m a
ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b
(a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c
forall a. a -> ClckT url m a
forall a b. ClckT url m a -> ClckT url m b -> ClckT url m a
forall a b. ClckT url m a -> ClckT url m b -> ClckT url m b
forall a b. ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b
forall a b c.
(a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c
forall url (m :: * -> *). Monad m => Functor (ClckT url m)
forall url (m :: * -> *) a. Monad m => a -> ClckT url m a
forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m a
forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m b
forall url (m :: * -> *) a b.
Monad m =>
ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b
forall url (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ClckT url m a -> ClckT url m b -> ClckT url m a
$c<* :: forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m a
*> :: ClckT url m a -> ClckT url m b -> ClckT url m b
$c*> :: forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m b
liftA2 :: (a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c
$cliftA2 :: forall url (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ClckT url m a -> ClckT url m b -> ClckT url m c
<*> :: ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b
$c<*> :: forall url (m :: * -> *) a b.
Monad m =>
ClckT url m (a -> b) -> ClckT url m a -> ClckT url m b
pure :: a -> ClckT url m a
$cpure :: forall url (m :: * -> *) a. Monad m => a -> ClckT url m a
$cp1Applicative :: forall url (m :: * -> *). Monad m => Functor (ClckT url m)
Applicative, Applicative (ClckT url m)
ClckT url m a
Applicative (ClckT url m)
-> (forall a. ClckT url m a)
-> (forall a. ClckT url m a -> ClckT url m a -> ClckT url m a)
-> (forall a. ClckT url m a -> ClckT url m [a])
-> (forall a. ClckT url m a -> ClckT url m [a])
-> Alternative (ClckT url m)
ClckT url m a -> ClckT url m a -> ClckT url m a
ClckT url m a -> ClckT url m [a]
ClckT url m a -> ClckT url m [a]
forall a. ClckT url m a
forall a. ClckT url m a -> ClckT url m [a]
forall a. ClckT url m a -> ClckT url m a -> ClckT url m a
forall url (m :: * -> *). MonadPlus m => Applicative (ClckT url m)
forall url (m :: * -> *) a. MonadPlus m => ClckT url m a
forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m [a]
forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m a -> ClckT url m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: ClckT url m a -> ClckT url m [a]
$cmany :: forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m [a]
some :: ClckT url m a -> ClckT url m [a]
$csome :: forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m [a]
<|> :: ClckT url m a -> ClckT url m a -> ClckT url m a
$c<|> :: forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m a -> ClckT url m a
empty :: ClckT url m a
$cempty :: forall url (m :: * -> *) a. MonadPlus m => ClckT url m a
$cp1Alternative :: forall url (m :: * -> *). MonadPlus m => Applicative (ClckT url m)
Alternative, Applicative (ClckT url m)
a -> ClckT url m a
Applicative (ClckT url m)
-> (forall a b.
    ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b)
-> (forall a b. ClckT url m a -> ClckT url m b -> ClckT url m b)
-> (forall a. a -> ClckT url m a)
-> Monad (ClckT url m)
ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b
ClckT url m a -> ClckT url m b -> ClckT url m b
forall a. a -> ClckT url m a
forall a b. ClckT url m a -> ClckT url m b -> ClckT url m b
forall a b. ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b
forall url (m :: * -> *). Monad m => Applicative (ClckT url m)
forall url (m :: * -> *) a. Monad m => a -> ClckT url m a
forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m b
forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ClckT url m a
$creturn :: forall url (m :: * -> *) a. Monad m => a -> ClckT url m a
>> :: ClckT url m a -> ClckT url m b -> ClckT url m b
$c>> :: forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> ClckT url m b -> ClckT url m b
>>= :: ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b
$c>>= :: forall url (m :: * -> *) a b.
Monad m =>
ClckT url m a -> (a -> ClckT url m b) -> ClckT url m b
$cp1Monad :: forall url (m :: * -> *). Monad m => Applicative (ClckT url m)
Monad, Monad (ClckT url m)
Monad (ClckT url m)
-> (forall a. IO a -> ClckT url m a) -> MonadIO (ClckT url m)
IO a -> ClckT url m a
forall a. IO a -> ClckT url m a
forall url (m :: * -> *). MonadIO m => Monad (ClckT url m)
forall url (m :: * -> *) a. MonadIO m => IO a -> ClckT url m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ClckT url m a
$cliftIO :: forall url (m :: * -> *) a. MonadIO m => IO a -> ClckT url m a
$cp1MonadIO :: forall url (m :: * -> *). MonadIO m => Monad (ClckT url m)
MonadIO, Monad (ClckT url m)
Monad (ClckT url m)
-> (forall a. String -> ClckT url m a) -> MonadFail (ClckT url m)
String -> ClckT url m a
forall a. String -> ClckT url m a
forall url (m :: * -> *). MonadFail m => Monad (ClckT url m)
forall url (m :: * -> *) a. MonadFail m => String -> ClckT url m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> ClckT url m a
$cfail :: forall url (m :: * -> *) a. MonadFail m => String -> ClckT url m a
$cp1MonadFail :: forall url (m :: * -> *). MonadFail m => Monad (ClckT url m)
MonadFail, Monad (ClckT url m)
Alternative (ClckT url m)
ClckT url m a
Alternative (ClckT url m)
-> Monad (ClckT url m)
-> (forall a. ClckT url m a)
-> (forall a. ClckT url m a -> ClckT url m a -> ClckT url m a)
-> MonadPlus (ClckT url m)
ClckT url m a -> ClckT url m a -> ClckT url m a
forall a. ClckT url m a
forall a. ClckT url m a -> ClckT url m a -> ClckT url m a
forall url (m :: * -> *). MonadPlus m => Monad (ClckT url m)
forall url (m :: * -> *). MonadPlus m => Alternative (ClckT url m)
forall url (m :: * -> *) a. MonadPlus m => ClckT url m a
forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m a -> ClckT url m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: ClckT url m a -> ClckT url m a -> ClckT url m a
$cmplus :: forall url (m :: * -> *) a.
MonadPlus m =>
ClckT url m a -> ClckT url m a -> ClckT url m a
mzero :: ClckT url m a
$cmzero :: forall url (m :: * -> *) a. MonadPlus m => ClckT url m a
$cp2MonadPlus :: forall url (m :: * -> *). MonadPlus m => Monad (ClckT url m)
$cp1MonadPlus :: forall url (m :: * -> *). MonadPlus m => Alternative (ClckT url m)
MonadPlus, Monad (ClckT url m)
ClckT url m Request
Monad (ClckT url m)
-> ClckT url m Request
-> (forall a.
    (Request -> Request) -> ClckT url m a -> ClckT url m a)
-> ServerMonad (ClckT url m)
(Request -> Request) -> ClckT url m a -> ClckT url m a
forall a. (Request -> Request) -> ClckT url m a -> ClckT url m a
forall url (m :: * -> *). ServerMonad m => Monad (ClckT url m)
forall url (m :: * -> *). ServerMonad m => ClckT url m Request
forall url (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> ClckT url m a -> ClckT url m a
forall (m :: * -> *).
Monad m
-> m Request
-> (forall a. (Request -> Request) -> m a -> m a)
-> ServerMonad m
localRq :: (Request -> Request) -> ClckT url m a -> ClckT url m a
$clocalRq :: forall url (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> ClckT url m a -> ClckT url m a
askRq :: ClckT url m Request
$caskRq :: forall url (m :: * -> *). ServerMonad m => ClckT url m Request
$cp1ServerMonad :: forall url (m :: * -> *). ServerMonad m => Monad (ClckT url m)
ServerMonad, ClckT url m RqEnv
Errors String -> ClckT url m a
ClckT url m RqEnv
-> (forall a. (RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a)
-> (forall a. Errors String -> ClckT url m a)
-> HasRqData (ClckT url m)
(RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a
forall a. Errors String -> ClckT url m a
forall a. (RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a
forall url (m :: * -> *).
(Monad m, HasRqData m) =>
ClckT url m RqEnv
forall url (m :: * -> *) a.
(Monad m, HasRqData m) =>
Errors String -> ClckT url m a
forall url (m :: * -> *) a.
(Monad m, HasRqData m) =>
(RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a
forall (m :: * -> *).
m RqEnv
-> (forall a. (RqEnv -> RqEnv) -> m a -> m a)
-> (forall a. Errors String -> m a)
-> HasRqData m
rqDataError :: Errors String -> ClckT url m a
$crqDataError :: forall url (m :: * -> *) a.
(Monad m, HasRqData m) =>
Errors String -> ClckT url m a
localRqEnv :: (RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a
$clocalRqEnv :: forall url (m :: * -> *) a.
(Monad m, HasRqData m) =>
(RqEnv -> RqEnv) -> ClckT url m a -> ClckT url m a
askRqEnv :: ClckT url m RqEnv
$caskRqEnv :: forall url (m :: * -> *).
(Monad m, HasRqData m) =>
ClckT url m RqEnv
HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)
#else
    deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadPlus, ServerMonad, HasRqData, FilterMonad r, WebMonad r, MonadState ClckState)
#endif

instance (Happstack m) => Happstack (ClckT url m)

instance MonadTrans (ClckT url) where
    lift :: m a -> ClckT url m a
lift = 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)
-> (m a -> RouteT url (StateT ClckState m) a)
-> m a
-> ClckT url m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT ClckState m a -> RouteT url (StateT ClckState m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ClckState m a -> RouteT url (StateT ClckState m) a)
-> (m a -> StateT ClckState m a)
-> m a
-> RouteT url (StateT ClckState m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT ClckState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | evaluate a 'ClckT' returning the inner monad
--
-- similar to 'evalStateT'.
evalClckT :: (Monad m) =>
             (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'
          -> ClckState                                            -- ^ initial 'ClckState'
          -> ClckT url m a                                        -- ^ 'ClckT' to evaluate
          -> m a
evalClckT :: (url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m a
evalClckT url -> [(Text, Maybe Text)] -> Text
showFn ClckState
clckState ClckT url m a
m = StateT ClckState m a -> ClckState -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RouteT url (StateT ClckState m) a
-> (url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (ClckT url m a -> RouteT url (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT url m a
m) url -> [(Text, Maybe Text)] -> Text
showFn) ClckState
clckState

-- | execute a 'ClckT' returning the final 'ClckState'
--
-- similar to 'execStateT'.
execClckT :: (Monad m) =>
             (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'
          -> ClckState                                            -- ^ initial 'ClckState'
          -> ClckT url m a                                        -- ^ 'ClckT' to evaluate
          -> m ClckState
execClckT :: (url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m ClckState
execClckT url -> [(Text, Maybe Text)] -> Text
showFn ClckState
clckState ClckT url m a
m =
    StateT ClckState m a -> ClckState -> m ClckState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (RouteT url (StateT ClckState m) a
-> (url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (ClckT url m a -> RouteT url (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT url m a
m) url -> [(Text, Maybe Text)] -> Text
showFn) ClckState
clckState

-- | run a 'ClckT'
--
-- similar to 'runStateT'.
runClckT :: (Monad m) =>
            (url -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -- ^ function to act as 'showURLParams'
         -> ClckState                                            -- ^ initial 'ClckState'
         -> ClckT url m a                                        -- ^ 'ClckT' to evaluate
         -> m (a, ClckState)
runClckT :: (url -> [(Text, Maybe Text)] -> Text)
-> ClckState -> ClckT url m a -> m (a, ClckState)
runClckT url -> [(Text, Maybe Text)] -> Text
showFn ClckState
clckState ClckT url m a
m =
    StateT ClckState m a -> ClckState -> m (a, ClckState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (RouteT url (StateT ClckState m) a
-> (url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (ClckT url m a -> RouteT url (StateT ClckState m) a
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT ClckT url m a
m) url -> [(Text, Maybe Text)] -> Text
showFn) ClckState
clckState

-- | map a transformation function over the inner monad
--
-- similar to 'mapStateT'
mapClckT :: (m (a, ClckState) -> n (b, ClckState)) -- ^ transformation function
         -> ClckT url m a                          -- ^ initial monad
         -> ClckT url n b
mapClckT :: (m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT m (a, ClckState) -> n (b, ClckState)
f (ClckT RouteT url (StateT ClckState m) a
r) = RouteT url (StateT ClckState n) b -> ClckT url n b
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT url (StateT ClckState n) b -> ClckT url n b)
-> RouteT url (StateT ClckState n) b -> ClckT url n b
forall a b. (a -> b) -> a -> b
$ (StateT ClckState m a -> StateT ClckState n b)
-> RouteT url (StateT ClckState m) a
-> RouteT url (StateT ClckState n) b
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((m (a, ClckState) -> n (b, ClckState))
-> StateT ClckState m a -> StateT ClckState n b
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT m (a, ClckState) -> n (b, ClckState)
f) RouteT url (StateT ClckState m) a
r

-- | error returned when a reform 'Form' fails to validate
data ClckFormError
    = ClckCFE (CommonFormError [Input])
    | EmptyUsername
    | InvalidDecimal T.Text
      deriving (Int -> ClckFormError -> ShowS
[ClckFormError] -> ShowS
ClckFormError -> String
(Int -> ClckFormError -> ShowS)
-> (ClckFormError -> String)
-> ([ClckFormError] -> ShowS)
-> Show ClckFormError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClckFormError] -> ShowS
$cshowList :: [ClckFormError] -> ShowS
show :: ClckFormError -> String
$cshow :: ClckFormError -> String
showsPrec :: Int -> ClckFormError -> ShowS
$cshowsPrec :: Int -> ClckFormError -> ShowS
Show)

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

-- | ClckForm - type for reform forms
type ClckFormT error m = Form m  [Input] error [XMLGenT m XML] ()
type ClckForm url    = Form (ClckT url (ServerPartT IO)) [Input] ClckFormError [XMLGenT (ClckT url (ServerPartT IO)) XML] ()



------------------------------------------------------------------------------
-- ClckPlugins / ClckPluginsSt
------------------------------------------------------------------------------

data ClckPluginsSt = ClckPluginsSt
    { ClckPluginsSt
-> forall (m :: * -> *).
   (Functor m, MonadIO m, Happstack m) =>
   [Text -> ClckT ClckURL m Text]
cpsPreProcessors :: forall m. (Functor m, MonadIO m, Happstack m) => [TL.Text -> ClckT ClckURL m TL.Text]
    , ClckPluginsSt -> [ClckT ClckURL IO (String, [NamedLink])]
cpsNavBarLinks   :: [ClckT ClckURL IO (String, [NamedLink])]
    , ClckPluginsSt -> Acid
cpsAcid          :: Acid  -- ^ this value is also in ClckState, but it is sometimes needed by plugins during initPlugin
    }

initialClckPluginsSt :: Acid -> ClckPluginsSt
initialClckPluginsSt :: Acid -> ClckPluginsSt
initialClckPluginsSt Acid
acid = ClckPluginsSt :: (forall (m :: * -> *).
 (Functor m, MonadIO m, Happstack m) =>
 [Text -> ClckT ClckURL m Text])
-> [ClckT ClckURL IO (String, [NamedLink])]
-> Acid
-> ClckPluginsSt
ClckPluginsSt
    { cpsPreProcessors :: forall (m :: * -> *).
(Functor m, MonadIO m, Happstack m) =>
[Text -> ClckT ClckURL m Text]
cpsPreProcessors = []
    , cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]
cpsNavBarLinks   = []
    , cpsAcid :: Acid
cpsAcid          = Acid
acid
    }

-- | ClckPlugins
--
--     newtype Plugins theme m hook config st
type ClckPlugins = Plugins Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt


setUnique :: (Functor m, MonadIO m) => Integer -> ClckT url m ()
setUnique :: Integer -> ClckT url m ()
setUnique Integer
i =
    do TVar Integer
u <- ClckState -> TVar Integer
uniqueId (ClckState -> TVar Integer)
-> ClckT url m ClckState -> ClckT url m (TVar Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       IO () -> ClckT url m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClckT url m ()) -> IO () -> ClckT url m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Integer -> Integer -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Integer
u Integer
i

-- | get a unique 'Integer'.
--
-- Only unique for the current request
getUnique :: (Functor m, MonadIO m) => ClckT url m Integer
getUnique :: ClckT url m Integer
getUnique =
    do TVar Integer
u <- ClckState -> TVar Integer
uniqueId (ClckState -> TVar Integer)
-> ClckT url m ClckState -> ClckT url m (TVar Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       IO Integer -> ClckT url m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Integer -> ClckT url m Integer)
-> IO Integer -> ClckT url m Integer
forall a b. (a -> b) -> a -> b
$ STM Integer -> IO Integer
forall a. STM a -> IO a
atomically (STM Integer -> IO Integer) -> STM Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ do Integer
i <- TVar Integer -> STM Integer
forall a. TVar a -> STM a
readTVar TVar Integer
u
                                TVar Integer -> Integer -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Integer
u (Integer -> Integer
forall a. Enum a => a -> a
succ Integer
i)
                                Integer -> STM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i

-- | get the 'Bool' value indicating if Google Analytics should be enabled or not
getEnableAnalytics :: (Functor m, MonadState ClckState m) => m Bool
getEnableAnalytics :: m Bool
getEnableAnalytics = ClckState -> Bool
enableAnalytics (ClckState -> Bool) -> m ClckState -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ClckState
forall s (m :: * -> *). MonadState s m => m s
get

-- | add an Admin menu
addAdminMenu :: (Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> ClckT url m ()
addAdminMenu :: (Text, [(Set Role, Text, Text)]) -> ClckT url m ()
addAdminMenu (Text
category, [(Set Role, Text, Text)]
entries) =
    (ClckState -> ClckState) -> ClckT url m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ClckState -> ClckState) -> ClckT url m ())
-> (ClckState -> ClckState) -> ClckT url m ()
forall a b. (a -> b) -> a -> b
$ \ClckState
cs ->
        let oldMenus :: [(Text, [(Set Role, Text, Text)])]
oldMenus = ClckState -> [(Text, [(Set Role, Text, Text)])]
adminMenus ClckState
cs
            newMenus :: [(Text, [(Set Role, Text, Text)])]
newMenus = Map Text [(Set Role, Text, Text)]
-> [(Text, [(Set Role, Text, Text)])]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Text [(Set Role, Text, Text)]
 -> [(Text, [(Set Role, Text, Text)])])
-> Map Text [(Set Role, Text, Text)]
-> [(Text, [(Set Role, Text, Text)])]
forall a b. (a -> b) -> a -> b
$ ([(Set Role, Text, Text)]
 -> [(Set Role, Text, Text)] -> [(Set Role, Text, Text)])
-> Text
-> [(Set Role, Text, Text)]
-> Map Text [(Set Role, Text, Text)]
-> Map Text [(Set Role, Text, Text)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(Set Role, Text, Text)]
-> [(Set Role, Text, Text)] -> [(Set Role, Text, Text)]
forall a. Eq a => [a] -> [a] -> [a]
List.union Text
category [(Set Role, Text, Text)]
entries (Map Text [(Set Role, Text, Text)]
 -> Map Text [(Set Role, Text, Text)])
-> Map Text [(Set Role, Text, Text)]
-> Map Text [(Set Role, Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(Text, [(Set Role, Text, Text)])]
-> Map Text [(Set Role, Text, Text)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [(Set Role, Text, Text)])]
oldMenus
        in ClckState
cs { adminMenus :: [(Text, [(Set Role, Text, Text)])]
adminMenus = [(Text, [(Set Role, Text, Text)])]
newMenus }

-- | append an action to the request init
appendRequestInit :: (Monad m) => ServerPart () -> ClckT url m ()
appendRequestInit :: ServerPart () -> ClckT url m ()
appendRequestInit ServerPart ()
action =
    (ClckState -> ClckState) -> ClckT url m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ClckState -> ClckState) -> ClckT url m ())
-> (ClckState -> ClckState) -> ClckT url m ()
forall a b. (a -> b) -> a -> b
$ \ClckState
cs -> ClckState
cs { requestInit :: ServerPart ()
requestInit = (ClckState -> ServerPart ()
requestInit ClckState
cs) ServerPart () -> ServerPart () -> ServerPart ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ServerPart ()
action }

-- | change the route url
withRouteClckT :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> url -> [(T.Text, Maybe T.Text)] -> T.Text)
               -> ClckT url  m a
               -> ClckT url' m a
withRouteClckT :: ((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> ClckT url m a -> ClckT url' m a
withRouteClckT (url' -> [(Text, Maybe Text)] -> Text)
-> url -> [(Text, Maybe Text)] -> Text
f (ClckT RouteT url (StateT ClckState m) a
routeT) = (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)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url (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)
-> url -> [(Text, Maybe Text)] -> Text
f RouteT url (StateT ClckState m) a
routeT)

type Clck url = ClckT url (ServerPartT IO)

instance (Functor m, MonadIO m) => IntegerSupply (ClckT url m) where
    nextInteger :: ClckT url m Integer
nextInteger = ClckT url m Integer
forall (m :: * -> *) url.
(Functor m, MonadIO m) =>
ClckT url m Integer
getUnique

nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a
nestURL :: (url1 -> url2) -> ClckT url1 m a -> ClckT url2 m a
nestURL url1 -> url2
f (ClckT RouteT url1 (StateT ClckState m) a
r) = 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
$ (url1 -> url2)
-> RouteT url1 (StateT ClckState m) a
-> RouteT url2 (StateT ClckState m) a
forall url1 url2 (m :: * -> *) a.
(url1 -> url2) -> RouteT url1 m a -> RouteT url2 m a
R.nestURL url1 -> url2
f RouteT url1 (StateT ClckState m) a
r

withAbs :: (Happstack m) => ClckT url m a -> ClckT url m a
withAbs :: ClckT url m a -> ClckT url m a
withAbs ClckT url m a
m =
    do Bool
secure <- Request -> Bool
rqSecure (Request -> Bool) -> ClckT url m Request -> ClckT url m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
       ClckState
clckState <- ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       ClckwrksConfig
cc <- ClckPlugins -> ClckT url m ClckwrksConfig
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m config
getConfig (ClckState -> ClckPlugins
plugins ClckState
clckState)
       let base :: Text
base = if Bool
secure then (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc) else ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc
       Text -> ClckT url m a -> ClckT url m a
forall url (m :: * -> *) a. Text -> ClckT url m a -> ClckT url m a
withAbs' Text
base ClckT url m a
m

withAbs' :: T.Text
      -> ClckT url m a
      -> ClckT url m a
withAbs' :: Text -> ClckT url m a -> ClckT url m a
withAbs' Text
prefix (ClckT (RouteT (url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a
r)) =
    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) -> StateT ClckState m a)
-> RouteT url (StateT ClckState m) a
forall url (m :: * -> *) a.
((url -> [(Text, Maybe Text)] -> Text) -> m a) -> RouteT url m a
RouteT (((url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a)
 -> RouteT url (StateT ClckState m) a)
-> ((url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a)
-> RouteT url (StateT ClckState m) a
forall a b. (a -> b) -> a -> b
$ \url -> [(Text, Maybe Text)] -> Text
showFn ->
        (url -> [(Text, Maybe Text)] -> Text) -> StateT ClckState m a
r (\url
url [(Text, Maybe Text)]
params -> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> url -> [(Text, Maybe Text)] -> Text
showFn url
url [(Text, Maybe Text)]
params)

instance (Monad m) => MonadRoute (ClckT url m) where
    type URL (ClckT url m) = url
    askRouteFn :: ClckT url m (URL (ClckT url m) -> [(Text, Maybe Text)] -> Text)
askRouteFn = RouteT
  url (StateT ClckState m) (url -> [(Text, Maybe Text)] -> Text)
-> ClckT url m (url -> [(Text, Maybe Text)] -> Text)
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT
   url (StateT ClckState m) (url -> [(Text, Maybe Text)] -> Text)
 -> ClckT url m (url -> [(Text, Maybe Text)] -> Text))
-> RouteT
     url (StateT ClckState m) (url -> [(Text, Maybe Text)] -> Text)
-> ClckT url m (url -> [(Text, Maybe Text)] -> Text)
forall a b. (a -> b) -> a -> b
$ RouteT
  url (StateT ClckState m) (url -> [(Text, Maybe Text)] -> Text)
forall (m :: * -> *).
MonadRoute m =>
m (URL m -> [(Text, Maybe Text)] -> Text)
askRouteFn

-- | similar to the normal acid-state 'query' except it automatically gets the correct 'AcidState' handle from the environment
query :: forall event m. (QueryEvent event, GetAcidState m (EventState event), Functor m, MonadIO m, MonadState ClckState m) => event -> m (EventResult event)
query :: event -> m (EventResult event)
query event
event =
    do AcidState (MethodState event)
as <- m (AcidState (MethodState event))
forall (m :: * -> *) st. GetAcidState m st => m (AcidState st)
getAcidState
       AcidState (MethodState event) -> event -> m (EventResult event)
forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' (AcidState (MethodState event)
as :: AcidState (EventState event)) event
event

-- | similar to the normal acid-state 'update' except it automatically gets the correct 'AcidState' handle from the environment
update :: forall event m. (UpdateEvent event, GetAcidState m (EventState event), Functor m, MonadIO m, MonadState ClckState m) => event -> m (EventResult event)
update :: event -> m (EventResult event)
update event
event =
    do AcidState (MethodState event)
as <- m (AcidState (MethodState event))
forall (m :: * -> *) st. GetAcidState m st => m (AcidState st)
getAcidState
       AcidState (MethodState event) -> event -> m (EventResult event)
forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' (AcidState (MethodState event)
as :: AcidState (EventState event)) event
event

instance (GetAcidState m st) => GetAcidState (XMLGenT m) st where
    getAcidState :: XMLGenT m (AcidState st)
getAcidState = m (AcidState st) -> XMLGenT m (AcidState st)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT m (AcidState st)
forall (m :: * -> *) st. GetAcidState m st => m (AcidState st)
getAcidState

instance (Functor m, Monad m) => GetAcidState (ClckT url m) CoreState where
    getAcidState :: ClckT url m (AcidState CoreState)
getAcidState = (Acid -> AcidState CoreState
acidCore (Acid -> AcidState CoreState)
-> (ClckState -> Acid) -> ClckState -> AcidState CoreState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClckState -> Acid
acidState) (ClckState -> AcidState CoreState)
-> ClckT url m ClckState -> ClckT url m (AcidState CoreState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get

instance (Functor m, Monad m) => GetAcidState (ClckT url m) NavBarState where
    getAcidState :: ClckT url m (AcidState NavBarState)
getAcidState = (Acid -> AcidState NavBarState
acidNavBar (Acid -> AcidState NavBarState)
-> (ClckState -> Acid) -> ClckState -> AcidState NavBarState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClckState -> Acid
acidState) (ClckState -> AcidState NavBarState)
-> ClckT url m ClckState -> ClckT url m (AcidState NavBarState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get

instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileDataState where
    getAcidState :: ClckT url m (AcidState ProfileDataState)
getAcidState = (Acid -> AcidState ProfileDataState
acidProfileData (Acid -> AcidState ProfileDataState)
-> (ClckState -> Acid) -> ClckState -> AcidState ProfileDataState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClckState -> Acid
acidState) (ClckState -> AcidState ProfileDataState)
-> ClckT url m ClckState
-> ClckT url m (AcidState ProfileDataState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get

-- * XMLGen / XMLGenerator instances for Clck

instance (Functor m, Monad m) => XMLGen (ClckT url m) where
    type XMLType          (ClckT url m) = XML
    type StringType       (ClckT url m) = TL.Text
    newtype ChildType     (ClckT url m) = ClckChild { ChildType (ClckT url m) -> XML
unClckChild :: XML }
    newtype AttributeType (ClckT url m) = ClckAttr { AttributeType (ClckT url m) -> Attribute
unClckAttr :: Attribute }
    genElement :: Name (StringType (ClckT url m))
-> [XMLGenT (ClckT url m) [AttributeType (ClckT url m)]]
-> [XMLGenT (ClckT url m) [ChildType (ClckT url m)]]
-> XMLGenT (ClckT url m) (XMLType (ClckT url m))
genElement Name (StringType (ClckT url m))
n [XMLGenT (ClckT url m) [AttributeType (ClckT url m)]]
attrs [XMLGenT (ClckT url m) [ChildType (ClckT url m)]]
children =
        do [Attribute]
attribs <- (AttributeType (ClckT url m) -> Attribute)
-> [AttributeType (ClckT url m)] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map AttributeType (ClckT url m) -> Attribute
forall url (m :: * -> *). AttributeType (ClckT url m) -> Attribute
unClckAttr ([AttributeType (ClckT url m)] -> [Attribute])
-> XMLGenT (ClckT url m) [AttributeType (ClckT url m)]
-> XMLGenT (ClckT url m) [Attribute]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XMLGenT (ClckT url m) [AttributeType (ClckT url m)]]
-> XMLGenT (ClckT url m) [AttributeType (ClckT url m)]
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr [XMLGenT (ClckT url m) [AttributeType (ClckT url m)]]
attrs
           [XML]
childer <- [XML] -> [XML]
flattenCDATA ([XML] -> [XML])
-> ([ChildType (ClckT url m)] -> [XML])
-> [ChildType (ClckT url m)]
-> [XML]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m) -> XML)
-> [ChildType (ClckT url m)] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map (ChildType (ClckT url m) -> XML
forall url (m :: * -> *). ChildType (ClckT url m) -> XML
unClckChild) ([ChildType (ClckT url m)] -> [XML])
-> XMLGenT (ClckT url m) [ChildType (ClckT url m)]
-> XMLGenT (ClckT url m) [XML]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [XMLGenT (ClckT url m) [ChildType (ClckT url m)]]
-> XMLGenT (ClckT url m) [ChildType (ClckT url m)]
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild [XMLGenT (ClckT url m) [ChildType (ClckT url m)]]
children
           ClckT url m XML -> XMLGenT (ClckT url m) XML
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m XML -> XMLGenT (ClckT url m) XML)
-> ClckT url m XML -> XMLGenT (ClckT url m) XML
forall a b. (a -> b) -> a -> b
$ XML -> ClckT url m XML
forall (m :: * -> *) a. Monad m => a -> m a
return (NSName -> [Attribute] -> [XML] -> XML
Element
                              (NSName -> NSName
forall n s. IsName n s => n -> Name s
toName NSName
Name (StringType (ClckT url m))
n)
                              [Attribute]
attribs
                              [XML]
childer
                             )
    xmlToChild :: XMLType (ClckT url m) -> ChildType (ClckT url m)
xmlToChild = XMLType (ClckT url m) -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild
    pcdataToChild :: StringType (ClckT url m) -> ChildType (ClckT url m)
pcdataToChild = XML -> ChildType (ClckT url m)
forall (m :: * -> *). XMLGen m => XMLType m -> ChildType m
xmlToChild (XML -> ChildType (ClckT url m))
-> (Text -> XML) -> Text -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata

flattenCDATA :: [XML] -> [XML]
flattenCDATA :: [XML] -> [XML]
flattenCDATA [XML]
cxml =
                case [XML] -> [XML] -> [XML]
flP [XML]
cxml [] of
                 [] -> []
                 [CDATA Bool
_ Text
""] -> []
                 [XML]
xs -> [XML]
xs
    where
        flP :: [XML] -> [XML] -> [XML]
        flP :: [XML] -> [XML] -> [XML]
flP [] [XML]
bs = [XML] -> [XML]
forall a. [a] -> [a]
reverse [XML]
bs
        flP [XML
x] [XML]
bs = [XML] -> [XML]
forall a. [a] -> [a]
reverse (XML
xXML -> [XML] -> [XML]
forall a. a -> [a] -> [a]
:[XML]
bs)
        flP (XML
x:XML
y:[XML]
xs) [XML]
bs = case (XML
x,XML
y) of
                           (CDATA Bool
e1 Text
s1, CDATA Bool
e2 Text
s2) | Bool
e1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
e2 -> [XML] -> [XML] -> [XML]
flP (Bool -> Text -> XML
CDATA Bool
e1 (Text
s1Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
s2) XML -> [XML] -> [XML]
forall a. a -> [a] -> [a]
: [XML]
xs) [XML]
bs
                           (XML, XML)
_ -> [XML] -> [XML] -> [XML]
flP (XML
yXML -> [XML] -> [XML]
forall a. a -> [a] -> [a]
:[XML]
xs) (XML
xXML -> [XML] -> [XML]
forall a. a -> [a] -> [a]
:[XML]
bs)
{-
instance (Functor m, Monad m) => IsAttrValue (ClckT url m) T.Text where
    toAttrValue = toAttrValue . T.unpack

instance (Functor m, Monad m) => IsAttrValue (ClckT url m) TL.Text where
    toAttrValue = toAttrValue . TL.unpack
-}
instance (Functor m, Monad m) => EmbedAsAttr (ClckT url m) Attribute where
    asAttr :: Attribute -> GenAttributeList (ClckT url m)
asAttr = [AttributeType (ClckT url m)] -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. Monad m => a -> m a
return ([AttributeType (ClckT url m)] -> GenAttributeList (ClckT url m))
-> (Attribute -> [AttributeType (ClckT url m)])
-> Attribute
-> GenAttributeList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AttributeType (ClckT url m)
-> [AttributeType (ClckT url m)] -> [AttributeType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (AttributeType (ClckT url m) -> [AttributeType (ClckT url m)])
-> (Attribute -> AttributeType (ClckT url m))
-> Attribute
-> [AttributeType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> AttributeType (ClckT url m)
forall url (m :: * -> *). Attribute -> AttributeType (ClckT url m)
ClckAttr

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n String) where
    asAttr :: Attr n String -> GenAttributeList (ClckT url m)
asAttr (n
n := String
str)  = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack String
str)

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Char) where
    asAttr :: Attr n Char -> GenAttributeList (ClckT url m)
asAttr (n
n := Char
c)  = Attr n Text -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (n
n n -> Text -> Attr n Text
forall n a. n -> a -> Attr n a
:= Char -> Text
TL.singleton Char
c)

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Bool) where
    asAttr :: Attr n Bool -> GenAttributeList (ClckT url m)
asAttr (n
n := Bool
True)  = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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
"true")
    asAttr (n
n := Bool
False) = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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
"false")

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Int) where
    asAttr :: Attr n Int -> GenAttributeList (ClckT url m)
asAttr (n
n := Int
i)  = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack (Int -> String
forall a. Show a => a -> String
show Int
i))

instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Integer) where
    asAttr :: Attr n Integer -> GenAttributeList (ClckT url m)
asAttr (n
n := Integer
i)  = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i))

instance (IsName n TL.Text) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where
    asAttr :: Attr n ClckURL -> GenAttributeList (ClckT ClckURL (ServerPartT IO))
asAttr (n
n := ClckURL
u) =
        do Text
url <- URL (XMLGenT (ClckT ClckURL (ServerPartT IO)))
-> XMLGenT (ClckT ClckURL (ServerPartT IO)) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (XMLGenT (ClckT ClckURL (ServerPartT IO)))
ClckURL
u
           Attribute -> GenAttributeList (ClckT ClckURL (ServerPartT IO))
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT ClckURL (ServerPartT IO)))
-> Attribute -> GenAttributeList (ClckT ClckURL (ServerPartT IO))
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
url)

instance (IsName n TL.Text) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where
    asAttr :: Attr n AdminURL -> GenAttributeList (Clck AdminURL)
asAttr (n
n := AdminURL
u) =
        do Text
url <- URL (XMLGenT (Clck AdminURL)) -> XMLGenT (Clck AdminURL) Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL (XMLGenT (Clck AdminURL))
AdminURL
u
           Attribute -> GenAttributeList (Clck AdminURL)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (Clck AdminURL))
-> Attribute -> GenAttributeList (Clck AdminURL)
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 (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where
    asAttr :: Attr n Text -> GenAttributeList (ClckT url m)
asAttr (n
n := Text
a) = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ Text
a)

instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where
    asAttr :: Attr n Text -> GenAttributeList (ClckT url m)
asAttr (n
n := Text
a) = Attribute -> GenAttributeList (ClckT url m)
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attribute -> GenAttributeList (ClckT url m))
-> Attribute -> GenAttributeList (ClckT url m)
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 -> AttrValue) -> Text -> AttrValue
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
a)

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Char where
    asChild :: Char -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Char -> ClckT url m [ChildType (ClckT url m)])
-> Char
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Char -> [ChildType (ClckT url m)])
-> Char
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Char -> ChildType (ClckT url m))
-> Char
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Char -> XML) -> Char -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (Char -> Text) -> Char -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
TL.singleton

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) String where
    asChild :: String -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (String -> ClckT url m [ChildType (ClckT url m)])
-> String
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (String -> [ChildType (ClckT url m)])
-> String
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (String -> ChildType (ClckT url m))
-> String
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (String -> XML) -> String -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (String -> Text) -> String -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Int where
    asChild :: Int -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Int -> ClckT url m [ChildType (ClckT url m)])
-> Int
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Int -> [ChildType (ClckT url m)])
-> Int
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Int -> ChildType (ClckT url m))
-> Int
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Int -> XML) -> Int -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (Int -> Text) -> Int -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Integer where
    asChild :: Integer -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Integer -> ClckT url m [ChildType (ClckT url m)])
-> Integer
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Integer -> [ChildType (ClckT url m)])
-> Integer
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Integer -> ChildType (ClckT url m))
-> Integer
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Integer -> XML) -> Integer -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (Integer -> Text) -> Integer -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Double where
    asChild :: Double -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Double -> ClckT url m [ChildType (ClckT url m)])
-> Double
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Double -> [ChildType (ClckT url m)])
-> Double
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Double -> ChildType (ClckT url m))
-> Double
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Double -> XML) -> Double -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (Double -> Text) -> Double -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Float where
    asChild :: Float -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Float -> ClckT url m [ChildType (ClckT url m)])
-> Float
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Float -> [ChildType (ClckT url m)])
-> Float
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Float -> ChildType (ClckT url m))
-> Float
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Float -> XML) -> Float -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
pcdata (Text -> XML) -> (Float -> Text) -> Float -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack (String -> Text) -> (Float -> String) -> Float -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) TL.Text where
    asChild :: Text -> GenChildList (ClckT url m)
asChild = String -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (String -> GenChildList (ClckT url m))
-> (Text -> String) -> Text -> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) T.Text where
    asChild :: Text -> GenChildList (ClckT url m)
asChild = String -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (String -> GenChildList (ClckT url m))
-> (Text -> String) -> Text -> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance (EmbedAsChild (ClckT url1 m) a, url1 ~ url2) => EmbedAsChild (ClckT url1 m) (ClckT url2 m a) where
    asChild :: ClckT url2 m a -> GenChildList (ClckT url1 m)
asChild ClckT url2 m a
c =
        do a
a <- ClckT url2 m a -> XMLGenT (ClckT url2 m) a
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT ClckT url2 m a
c
           a -> GenChildList (ClckT url1 m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild a
a

instance (Functor m, MonadIO m, EmbedAsChild (ClckT url m) a) => EmbedAsChild (ClckT url m) (IO a) where
    asChild :: IO a -> GenChildList (ClckT url m)
asChild IO a
c =
        do a
a <- ClckT url m a -> XMLGenT (ClckT url m) a
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (IO a -> ClckT url m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
c)
           a -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild a
a

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) XML where
    asChild :: XML -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (XML -> ClckT url m [ChildType (ClckT url m)])
-> XML
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (XML -> [ChildType (ClckT url m)])
-> XML
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (XML -> ChildType (ClckT url m))
-> XML
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Html where
    asChild :: Html -> GenChildList (ClckT url m)
asChild = ClckT url m [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (ClckT url m [ChildType (ClckT url m)]
 -> GenChildList (ClckT url m))
-> (Html -> ClckT url m [ChildType (ClckT url m)])
-> Html
-> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChildType (ClckT url m)] -> ClckT url m [ChildType (ClckT url m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ChildType (ClckT url m)]
 -> ClckT url m [ChildType (ClckT url m)])
-> (Html -> [ChildType (ClckT url m)])
-> Html
-> ClckT url m [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChildType (ClckT url m)
-> [ChildType (ClckT url m)] -> [ChildType (ClckT url m)]
forall a. a -> [a] -> [a]
:[]) (ChildType (ClckT url m) -> [ChildType (ClckT url m)])
-> (Html -> ChildType (ClckT url m))
-> Html
-> [ChildType (ClckT url m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> ChildType (ClckT url m)
forall url (m :: * -> *). XML -> ChildType (ClckT url m)
ClckChild (XML -> ChildType (ClckT url m))
-> (Html -> XML) -> Html -> ChildType (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> XML
cdata (Text -> XML) -> (Html -> Text) -> Html -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
renderHtml

instance (Functor m, MonadIO m, Happstack m) => EmbedAsChild (ClckT url m) ClckFormError where
    asChild :: ClckFormError -> GenChildList (ClckT url m)
asChild ClckFormError
formError = String -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (ClckFormError -> String
forall a. Show a => a -> String
show ClckFormError
formError)

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) () where
    asChild :: () -> GenChildList (ClckT url m)
asChild () = [ChildType (ClckT url m)] -> GenChildList (ClckT url m)
forall (m :: * -> *) a. Monad m => a -> m a
return []

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) UTCTime where
    asChild :: UTCTime -> GenChildList (ClckT url m)
asChild = String -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (String -> GenChildList (ClckT url m))
-> (UTCTime -> String) -> UTCTime -> GenChildList (ClckT url m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %F @ %r"

instance (Functor m, Monad m, EmbedAsChild (ClckT url m) a) => EmbedAsChild (ClckT url m) (Maybe a) where
    asChild :: Maybe a -> GenChildList (ClckT url m)
asChild Maybe a
Nothing = () -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild ()
    asChild (Just a
a) = a -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild a
a

instance (Functor m, Monad m) => AppendChild (ClckT url m) XML where
 appAll :: XML -> GenChildList (ClckT url m) -> GenXML (ClckT url m)
appAll XML
xml GenChildList (ClckT url m)
children = do
        [ChildType (ClckT url m)]
chs <- GenChildList (ClckT url m)
children
        case XML
xml of

         CDATA Bool
_ Text
_       -> XML -> XMLGenT (ClckT url m) XML
forall (m :: * -> *) a. Monad m => a -> m a
return XML
xml
         Element NSName
n [Attribute]
as [XML]
cs -> XML -> XMLGenT (ClckT url m) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML -> XMLGenT (ClckT url m) XML)
-> XML -> XMLGenT (ClckT url m) XML
forall a b. (a -> b) -> a -> b
$ NSName -> [Attribute] -> [XML] -> XML
Element NSName
n [Attribute]
as ([XML]
cs [XML] -> [XML] -> [XML]
forall a. [a] -> [a] -> [a]
++ ((ChildType (ClckT url m) -> XML)
-> [ChildType (ClckT url m)] -> [XML]
forall a b. (a -> b) -> [a] -> [b]
map ChildType (ClckT url m) -> XML
forall url (m :: * -> *). ChildType (ClckT url m) -> XML
unClckChild [ChildType (ClckT url m)]
chs))

instance (Functor m, Monad m) => SetAttr (ClckT url m) XML where
 setAll :: XML -> GenAttributeList (ClckT url m) -> GenXML (ClckT url m)
setAll XML
xml GenAttributeList (ClckT url m)
hats = do
        [AttributeType (ClckT url m)]
attrs <- GenAttributeList (ClckT url m)
hats
        case XML
xml of
         CDATA Bool
_ Text
_       -> XML -> XMLGenT (ClckT url m) XML
forall (m :: * -> *) a. Monad m => a -> m a
return XML
xml
         Element NSName
n [Attribute]
as [XML]
cs -> XML -> XMLGenT (ClckT url m) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML -> XMLGenT (ClckT url m) XML)
-> XML -> XMLGenT (ClckT url m) XML
forall a b. (a -> b) -> a -> b
$ NSName -> [Attribute] -> [XML] -> XML
Element NSName
n ((Attribute -> [Attribute] -> [Attribute])
-> [Attribute] -> [Attribute] -> [Attribute]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [Attribute]
as ((AttributeType (ClckT url m) -> Attribute)
-> [AttributeType (ClckT url m)] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map AttributeType (ClckT url m) -> Attribute
forall url (m :: * -> *). AttributeType (ClckT url m) -> Attribute
unClckAttr [AttributeType (ClckT url m)]
attrs)) [XML]
cs

instance (Functor m, Monad m) => XMLGenerator (ClckT url m)

-- | a wrapper which identifies how to treat different 'Text' values when attempting to embed them.
--
-- In general 'Content' values have already been
-- flatten/preprocessed/etc and are now basic formats like
-- @text/plain@, @text/html@, etc
data Content
    = TrustedHtml T.Text
    | PlainText   T.Text
      deriving (Content -> Content -> Bool
(Content -> Content -> Bool)
-> (Content -> Content -> Bool) -> Eq Content
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Content -> Content -> Bool
$c/= :: Content -> Content -> Bool
== :: Content -> Content -> Bool
$c== :: Content -> Content -> Bool
Eq, Eq Content
Eq Content
-> (Content -> Content -> Ordering)
-> (Content -> Content -> Bool)
-> (Content -> Content -> Bool)
-> (Content -> Content -> Bool)
-> (Content -> Content -> Bool)
-> (Content -> Content -> Content)
-> (Content -> Content -> Content)
-> Ord Content
Content -> Content -> Bool
Content -> Content -> Ordering
Content -> Content -> Content
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Content -> Content -> Content
$cmin :: Content -> Content -> Content
max :: Content -> Content -> Content
$cmax :: Content -> Content -> Content
>= :: Content -> Content -> Bool
$c>= :: Content -> Content -> Bool
> :: Content -> Content -> Bool
$c> :: Content -> Content -> Bool
<= :: Content -> Content -> Bool
$c<= :: Content -> Content -> Bool
< :: Content -> Content -> Bool
$c< :: Content -> Content -> Bool
compare :: Content -> Content -> Ordering
$ccompare :: Content -> Content -> Ordering
$cp1Ord :: Eq Content
Ord, ReadPrec [Content]
ReadPrec Content
Int -> ReadS Content
ReadS [Content]
(Int -> ReadS Content)
-> ReadS [Content]
-> ReadPrec Content
-> ReadPrec [Content]
-> Read Content
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Content]
$creadListPrec :: ReadPrec [Content]
readPrec :: ReadPrec Content
$creadPrec :: ReadPrec Content
readList :: ReadS [Content]
$creadList :: ReadS [Content]
readsPrec :: Int -> ReadS Content
$creadsPrec :: Int -> ReadS Content
Read, Int -> Content -> ShowS
[Content] -> ShowS
Content -> String
(Int -> Content -> ShowS)
-> (Content -> String) -> ([Content] -> ShowS) -> Show Content
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Content] -> ShowS
$cshowList :: [Content] -> ShowS
show :: Content -> String
$cshow :: Content -> String
showsPrec :: Int -> Content -> ShowS
$cshowsPrec :: Int -> Content -> ShowS
Show, Typeable Content
DataType
Constr
Typeable Content
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Content -> c Content)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Content)
-> (Content -> Constr)
-> (Content -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Content))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Content))
-> ((forall b. Data b => b -> b) -> Content -> Content)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Content -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Content -> r)
-> (forall u. (forall d. Data d => d -> u) -> Content -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Content -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Content -> m Content)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Content -> m Content)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Content -> m Content)
-> Data Content
Content -> DataType
Content -> Constr
(forall b. Data b => b -> b) -> Content -> Content
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Content -> c Content
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Content
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Content -> u
forall u. (forall d. Data d => d -> u) -> Content -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Content -> m Content
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Content -> m Content
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Content
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Content -> c Content
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Content)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Content)
$cPlainText :: Constr
$cTrustedHtml :: Constr
$tContent :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Content -> m Content
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Content -> m Content
gmapMp :: (forall d. Data d => d -> m d) -> Content -> m Content
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Content -> m Content
gmapM :: (forall d. Data d => d -> m d) -> Content -> m Content
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Content -> m Content
gmapQi :: Int -> (forall d. Data d => d -> u) -> Content -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Content -> u
gmapQ :: (forall d. Data d => d -> u) -> Content -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Content -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Content -> r
gmapT :: (forall b. Data b => b -> b) -> Content -> Content
$cgmapT :: (forall b. Data b => b -> b) -> Content -> Content
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Content)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Content)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Content)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Content)
dataTypeOf :: Content -> DataType
$cdataTypeOf :: Content -> DataType
toConstr :: Content -> Constr
$ctoConstr :: Content -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Content
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Content
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Content -> c Content
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Content -> c Content
$cp1Data :: Typeable Content
Data, Typeable)

instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Content where
    asChild :: Content -> GenChildList (ClckT url m)
asChild (TrustedHtml Text
html) = XML -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (XML -> GenChildList (ClckT url m))
-> XML -> GenChildList (ClckT url m)
forall a b. (a -> b) -> a -> b
$ Text -> XML
cdata (Text -> Text
TL.fromStrict Text
html)
    asChild (PlainText Text
txt)    = XML -> GenChildList (ClckT url m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (XML -> GenChildList (ClckT url m))
-> XML -> GenChildList (ClckT url m)
forall a b. (a -> b) -> a -> b
$ Text -> XML
pcdata (Text -> Text
TL.fromStrict Text
txt)

addPreProc :: (MonadIO m) =>
              Plugins theme n hook config ClckPluginsSt
           -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => TL.Text -> ClckT ClckURL mm TL.Text)
           -> m ()
addPreProc :: Plugins theme n hook config ClckPluginsSt
-> (forall (mm :: * -> *).
    (Functor mm, MonadIO mm, Happstack mm) =>
    Text -> ClckT ClckURL mm Text)
-> m ()
addPreProc Plugins theme n hook config ClckPluginsSt
plugins forall (mm :: * -> *).
(Functor mm, MonadIO mm, Happstack mm) =>
Text -> ClckT ClckURL mm Text
p =
    Plugins theme n hook config ClckPluginsSt
-> (ClckPluginsSt -> ClckPluginsSt) -> m ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> (st -> st) -> m ()
modifyPluginsSt Plugins theme n hook config ClckPluginsSt
plugins ((ClckPluginsSt -> ClckPluginsSt) -> m ())
-> (ClckPluginsSt -> ClckPluginsSt) -> m ()
forall a b. (a -> b) -> a -> b
$ \ClckPluginsSt
cps -> ClckPluginsSt
cps { cpsPreProcessors :: forall (m :: * -> *).
(Functor m, MonadIO m, Happstack m) =>
[Text -> ClckT ClckURL m Text]
cpsPreProcessors = Text -> ClckT ClckURL m Text
forall (mm :: * -> *).
(Functor mm, MonadIO mm, Happstack mm) =>
Text -> ClckT ClckURL mm Text
p (Text -> ClckT ClckURL m Text)
-> [Text -> ClckT ClckURL m Text] -> [Text -> ClckT ClckURL m Text]
forall a. a -> [a] -> [a]
: (ClckPluginsSt
-> forall (m :: * -> *).
   (Functor m, MonadIO m, Happstack m) =>
   [Text -> ClckT ClckURL m Text]
cpsPreProcessors ClckPluginsSt
cps) }

-- * Preprocess

data Segment cmd
    = TextBlock T.Text
    | Cmd cmd
      deriving Int -> Segment cmd -> ShowS
[Segment cmd] -> ShowS
Segment cmd -> String
(Int -> Segment cmd -> ShowS)
-> (Segment cmd -> String)
-> ([Segment cmd] -> ShowS)
-> Show (Segment cmd)
forall cmd. Show cmd => Int -> Segment cmd -> ShowS
forall cmd. Show cmd => [Segment cmd] -> ShowS
forall cmd. Show cmd => Segment cmd -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Segment cmd] -> ShowS
$cshowList :: forall cmd. Show cmd => [Segment cmd] -> ShowS
show :: Segment cmd -> String
$cshow :: forall cmd. Show cmd => Segment cmd -> String
showsPrec :: Int -> Segment cmd -> ShowS
$cshowsPrec :: forall cmd. Show cmd => Int -> Segment cmd -> ShowS
Show

instance Functor Segment where
    fmap :: (a -> b) -> Segment a -> Segment b
fmap a -> b
f (TextBlock Text
t) = Text -> Segment b
forall cmd. Text -> Segment cmd
TextBlock Text
t
    fmap a -> b
f (Cmd a
c)       = b -> Segment b
forall cmd. cmd -> Segment cmd
Cmd (a -> b
f a
c)

transform :: (Monad m) =>
             (cmd -> m Builder)
          -> [Segment cmd]
          -> m Builder
transform :: (cmd -> m Builder) -> [Segment cmd] -> m Builder
transform cmd -> m Builder
f [Segment cmd]
segments =
    do [Builder]
bs <- (Segment cmd -> m Builder) -> [Segment cmd] -> m [Builder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((cmd -> m Builder) -> Segment cmd -> m Builder
forall (m :: * -> *) cmd.
Monad m =>
(cmd -> m Builder) -> Segment cmd -> m Builder
transformSegment cmd -> m Builder
f) [Segment cmd]
segments
       Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
bs)

transformSegment :: (Monad m) =>
                    (cmd -> m Builder)
                 -> Segment cmd
                 -> m Builder
transformSegment :: (cmd -> m Builder) -> Segment cmd -> m Builder
transformSegment cmd -> m Builder
f (TextBlock Text
t) = Builder -> m Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
B.fromText Text
t)
transformSegment cmd -> m Builder
f (Cmd cmd
cmd) = cmd -> m Builder
f cmd
cmd

segments :: T.Text
         -> Parser a
         -> Parser [Segment a]
segments :: Text -> Parser a -> Parser [Segment a]
segments Text
name Parser a
p =
    Parser Text (Segment a) -> Parser [Segment a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Text -> Parser a -> Parser Text (Segment a)
forall cmd. Text -> Parser cmd -> Parser (Segment cmd)
cmd Text
name Parser a
p Parser Text (Segment a)
-> Parser Text (Segment a) -> Parser Text (Segment a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text (Segment a)
forall cmd. Parser (Segment cmd)
plainText)

cmd :: T.Text -> Parser cmd -> Parser (Segment cmd)
cmd :: Text -> Parser cmd -> Parser (Segment cmd)
cmd Text
n Parser cmd
p =
    do Char -> Parser Char
char Char
'{'
       ((Parser (Segment cmd) -> Parser (Segment cmd)
forall i a. Parser i a -> Parser i a
try (Parser (Segment cmd) -> Parser (Segment cmd))
-> Parser (Segment cmd) -> Parser (Segment cmd)
forall a b. (a -> b) -> a -> b
$ do Text -> Parser Text
asciiCI Text
n
                  Char -> Parser Char
char Char
'|'
                  cmd
r <- Parser cmd
p
                  Char -> Parser Char
char Char
'}'
                  Segment cmd -> Parser (Segment cmd)
forall (m :: * -> *) a. Monad m => a -> m a
return (cmd -> Segment cmd
forall cmd. cmd -> Segment cmd
Cmd cmd
r))
             Parser (Segment cmd)
-> Parser (Segment cmd) -> Parser (Segment cmd)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             (do Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')
                 Segment cmd -> Parser (Segment cmd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Segment cmd -> Parser (Segment cmd))
-> Segment cmd -> Parser (Segment cmd)
forall a b. (a -> b) -> a -> b
$ Text -> Segment cmd
forall cmd. Text -> Segment cmd
TextBlock (Char -> Text -> Text
T.cons Char
'{' Text
t)))

plainText :: Parser (Segment cmd)
plainText :: Parser (Segment cmd)
plainText =
    do Text
t <- (Char -> Bool) -> Parser Text
takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{')
       Segment cmd -> Parser (Segment cmd)
forall (m :: * -> *) a. Monad m => a -> m a
return (Segment cmd -> Parser (Segment cmd))
-> Segment cmd -> Parser (Segment cmd)
forall a b. (a -> b) -> a -> b
$ Text -> Segment cmd
forall cmd. Text -> Segment cmd
TextBlock Text
t

-- * Require Role

setRedirectCookie :: (Happstack m) =>
                     String -> m ()
setRedirectCookie :: String -> m ()
setRedirectCookie String
url =
    CookieLife -> Cookie -> m ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie CookieLife
Session (String -> String -> Cookie
mkCookie String
"clckwrks-authenticate-redirect" String
url)

getRedirectCookie :: (Happstack m) =>
                     m (Maybe String)
getRedirectCookie :: m (Maybe String)
getRedirectCookie =
    do String -> m ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
String -> m ()
expireCookie String
"clckwrks-authenticate-redirect"
       m String -> m (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (m String -> m (Maybe String)) -> m String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> m String
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m String
lookCookieValue String
"clckwrks-authenticate-redirect"

------------------------------------------------------------------------------
-- NavBar callback
------------------------------------------------------------------------------

addNavBarCallback :: (MonadIO m) =>
                   Plugins theme n hook config ClckPluginsSt
                -> ClckT ClckURL IO (String, [NamedLink])
                -> m ()
addNavBarCallback :: Plugins theme n hook config ClckPluginsSt
-> ClckT ClckURL IO (String, [NamedLink]) -> m ()
addNavBarCallback Plugins theme n hook config ClckPluginsSt
plugins ClckT ClckURL IO (String, [NamedLink])
ml =
    Plugins theme n hook config ClckPluginsSt
-> (ClckPluginsSt -> ClckPluginsSt) -> m ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> (st -> st) -> m ()
modifyPluginsSt Plugins theme n hook config ClckPluginsSt
plugins ((ClckPluginsSt -> ClckPluginsSt) -> m ())
-> (ClckPluginsSt -> ClckPluginsSt) -> m ()
forall a b. (a -> b) -> a -> b
$ \ClckPluginsSt
cps -> ClckPluginsSt
cps { cpsNavBarLinks :: [ClckT ClckURL IO (String, [NamedLink])]
cpsNavBarLinks = (ClckPluginsSt -> [ClckT ClckURL IO (String, [NamedLink])]
cpsNavBarLinks ClckPluginsSt
cps) [ClckT ClckURL IO (String, [NamedLink])]
-> [ClckT ClckURL IO (String, [NamedLink])]
-> [ClckT ClckURL IO (String, [NamedLink])]
forall a. [a] -> [a] -> [a]
++ [ClckT ClckURL IO (String, [NamedLink])
ml] }

getNavBarLinks :: (MonadIO m) =>
                Plugins theme n hook config ClckPluginsSt
             -> ClckT ClckURL m NavBarLinks
getNavBarLinks :: Plugins theme n hook config ClckPluginsSt
-> ClckT ClckURL m NavBarLinks
getNavBarLinks Plugins theme n hook config ClckPluginsSt
plugins =
    (IO (NavBarLinks, ClckState) -> m (NavBarLinks, ClckState))
-> ClckT ClckURL IO NavBarLinks -> ClckT ClckURL m NavBarLinks
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT IO (NavBarLinks, ClckState) -> m (NavBarLinks, ClckState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ClckT ClckURL IO NavBarLinks -> ClckT ClckURL m NavBarLinks)
-> ClckT ClckURL IO NavBarLinks -> ClckT ClckURL m NavBarLinks
forall a b. (a -> b) -> a -> b
$
      do [ClckT ClckURL IO (String, [NamedLink])]
genNavBarLinks <- (ClckPluginsSt -> [ClckT ClckURL IO (String, [NamedLink])]
cpsNavBarLinks (ClckPluginsSt -> [ClckT ClckURL IO (String, [NamedLink])])
-> ClckT ClckURL IO ClckPluginsSt
-> ClckT ClckURL IO [ClckT ClckURL IO (String, [NamedLink])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plugins theme n hook config ClckPluginsSt
-> ClckT ClckURL IO ClckPluginsSt
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m st
getPluginsSt Plugins theme n hook config ClckPluginsSt
plugins)
         [(String, [NamedLink])] -> NavBarLinks
NavBarLinks ([(String, [NamedLink])] -> NavBarLinks)
-> ClckT ClckURL IO [(String, [NamedLink])]
-> ClckT ClckURL IO NavBarLinks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ClckT ClckURL IO (String, [NamedLink])]
-> ClckT ClckURL IO [(String, [NamedLink])]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [ClckT ClckURL IO (String, [NamedLink])]
genNavBarLinks

getPreProcessors :: (MonadIO m) =>
                Plugins theme n hook config ClckPluginsSt
             -> (forall mm. (Functor mm, MonadIO mm, Happstack mm) => ClckT url m [TL.Text -> ClckT ClckURL mm TL.Text])
getPreProcessors :: Plugins theme n hook config ClckPluginsSt
-> forall (mm :: * -> *).
   (Functor mm, MonadIO mm, Happstack mm) =>
   ClckT url m [Text -> ClckT ClckURL mm Text]
getPreProcessors Plugins theme n hook config ClckPluginsSt
plugins =
    (IO ([Text -> ClckT ClckURL mm Text], ClckState)
 -> m ([Text -> ClckT ClckURL mm Text], ClckState))
-> ClckT url IO [Text -> ClckT ClckURL mm Text]
-> ClckT url m [Text -> ClckT ClckURL mm Text]
forall (m :: * -> *) a (n :: * -> *) b url.
(m (a, ClckState) -> n (b, ClckState))
-> ClckT url m a -> ClckT url n b
mapClckT IO ([Text -> ClckT ClckURL mm Text], ClckState)
-> m ([Text -> ClckT ClckURL mm Text], ClckState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ClckT url IO [Text -> ClckT ClckURL mm Text]
 -> ClckT url m [Text -> ClckT ClckURL mm Text])
-> ClckT url IO [Text -> ClckT ClckURL mm Text]
-> ClckT url m [Text -> ClckT ClckURL mm Text]
forall a b. (a -> b) -> a -> b
$
      (ClckPluginsSt -> [Text -> ClckT ClckURL mm Text]
ClckPluginsSt
-> forall (m :: * -> *).
   (Functor m, MonadIO m, Happstack m) =>
   [Text -> ClckT ClckURL m Text]
cpsPreProcessors (ClckPluginsSt -> [Text -> ClckT ClckURL mm Text])
-> ClckT url IO ClckPluginsSt
-> ClckT url IO [Text -> ClckT ClckURL mm Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Plugins theme n hook config ClckPluginsSt
-> ClckT url IO ClckPluginsSt
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m st
getPluginsSt Plugins theme n hook config ClckPluginsSt
plugins)

-- | create a google analytics tracking code block
--
-- This will under two different conditions:
--
--  * the 'enableAnalytics' field in 'ClckState' is 'False'
--
--  * the 'uacct' field in 'PageState' is 'Nothing'
googleAnalytics :: XMLGenT (Clck url) XML
googleAnalytics :: XMLGenT (Clck url) XML
googleAnalytics =
    do Bool
enabled <- XMLGenT (Clck url) Bool
forall (m :: * -> *). (Functor m, MonadState ClckState m) => m Bool
getEnableAnalytics
       case Bool
enabled of
         Bool
False -> XML -> XMLGenT (Clck url) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML -> XMLGenT (Clck url) XML) -> XML -> XMLGenT (Clck url) XML
forall a b. (a -> b) -> a -> b
$ Text -> XML
cdata Text
""
         Bool
True ->
             do Maybe UACCT
muacct <- GetUACCT -> XMLGenT (Clck url) (EventResult GetUACCT)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetUACCT
GetUACCT
                case Maybe UACCT
muacct of
                  Maybe UACCT
Nothing -> XML -> XMLGenT (Clck url) XML
forall (m :: * -> *) a. Monad m => a -> m a
return (XML -> XMLGenT (Clck url) XML) -> XML -> XMLGenT (Clck url) XML
forall a b. (a -> b) -> a -> b
$ Text -> XML
cdata Text
""
                  (Just UACCT
uacct) ->
                      UACCT -> GenXML (Clck url)
forall (m :: * -> *).
(XMLGenerator m, StringType m ~ Text) =>
UACCT -> GenXML m
universalAnalytics UACCT
uacct