module Happstack.Foundation
(
AcidConfig(..)
, FoundationConf(..)
, defaultConf
, FoundationT
, FoundationT'
, FoundationForm
, whereami
, getRequestState
, setRequestState
, modifyRequestState
, defaultTemplate
, HasAcidState(..)
, query
, update
, getAcidSt
, simpleApp
, Data(..)
, Typeable(..)
, module Control.Applicative
, module Control.Monad.Reader
, module Control.Monad.State
, module Data.SafeCopy
, module Data.Acid
, module Happstack.Server
, module HSP
, module Web.Routes
, module Web.Routes.Happstack
, module Web.Routes.TH
, module Text.Reform
, module Text.Reform.Happstack
, module Text.Reform.HSP.Text
, AppError(..)
)
where
import Control.Applicative
import Control.Concurrent
import Control.Exception.Lifted (bracket)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Acid hiding (query, update)
import Data.Acid.Advanced
import Data.Acid.Local
import Data.Data
import Data.SafeCopy
import Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import Data.String (IsString(..))
import Control.Monad.Reader
import Control.Monad.State
import Happstack.Server.XMLGenT ()
import HSP (XMLGenerator(..), XMLGen(..), EmbedAsChild(..), EmbedAsAttr(..), XML, XMLGenT(..), unXMLGenT, XMLType, Attr(..), fromStringLit)
import Text.Reform
import Text.Reform.Happstack
import Text.Reform.HSP.Text
import Happstack.Server
import Happstack.Server.SimpleHTTP
import qualified Happstack.Server.HSP.HTML as HTML
import Web.Routes
import Web.Routes.TH
import Web.Routes.Happstack
import Web.Routes.XMLGenT
class HasAcidState m st where
getAcidState :: m (AcidState st)
instance (HasAcidState (FoundationT' url acid reqSt m) acidSt) => HasAcidState (XMLGenT (FoundationT' url acid reqSt m)) acidSt where
getAcidState = XMLGenT getAcidState
getAcidSt :: (Functor m, MonadState (AppState url acidState requestState) m) => m acidState
getAcidSt = acid <$> get
query :: forall event m.
( Functor m
, MonadIO m
, QueryEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
query event =
do as <- getAcidState
query' (as :: AcidState (EventState event)) event
update :: forall event m.
( Functor m
, MonadIO m
, UpdateEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
update event =
do as <- getAcidState
update' (as :: AcidState (EventState event)) event
withLocalState :: (MonadBaseControl IO m, MonadIO m, IsAcidic st, Typeable st) =>
Maybe FilePath
-> st
-> (AcidState st -> m a)
-> m a
withLocalState mPath initialState =
bracket (liftIO $ (maybe openLocalState openLocalStateFrom mPath) initialState)
(\acid -> liftIO $ (createArchive acid >> createCheckpointAndClose acid))
data AppState url acidState requestState = AppState
{ here :: url
, acid :: acidState
, reqSt :: requestState
}
type FoundationT' url acidState requestState m = RouteT url (StateT (AppState url acidState requestState) (ServerPartT m))
type FoundationT url acidState requestState m = XMLGenT (FoundationT' url acidState requestState m)
whereami :: (Functor m, Monad m) => FoundationT url acidState requestState m url
whereami = here <$> get
getRequestState :: (Functor m, MonadState (AppState url acidState requestState) m) => m requestState
getRequestState = reqSt <$> get
setRequestState :: (Functor m, MonadState (AppState url acidState requestState) m) =>
requestState
-> m ()
setRequestState st = modify $ \appState -> appState { reqSt = st }
modifyRequestState :: MonadState (AppState url acidState requestState) m =>
(requestState -> requestState)
-> m ()
modifyRequestState f = modify $ \appState -> appState { reqSt = f (reqSt appState) }
instance (Functor m, Monad m) => HasAcidState (FoundationT url (AcidState acidState) requestState m) acidState where
getAcidState = acid <$> get
data AppError
= AppCFE (CommonFormError [Input])
| TextError Text
instance IsString AppError where
fromString = TextError . fromString
instance FormError AppError where
type ErrorInputType AppError = [Input]
commonFormError = AppCFE
instance (Functor m, Monad m) => EmbedAsChild (FoundationT' url acidState requestState m) AppError where
asChild (AppCFE cfe) = asChild (commonFormErrorStr show cfe)
asChild (TextError txt) = asChild txt
type FoundationForm url acidState requestState m = Form (FoundationT url acidState requestState m) [Input] AppError [FoundationT url acidState requestState m XML] ()
data AcidConfig st where
AcidLocal :: (IsAcidic st, Typeable st) => Maybe FilePath -> st -> AcidConfig (AcidState st)
AcidUsing :: st -> AcidConfig st
withAcidConfig :: (MonadIO m, MonadBaseControl IO m) => AcidConfig st -> (st -> m a) -> m a
withAcidConfig (AcidLocal acidPath initialState) f =
withLocalState acidPath initialState f
withAcidConfig (AcidUsing st) f = f st
defaultTemplate :: ( Functor m, Monad m
, XMLGenerator (FoundationT' url acidState requestState m)
, EmbedAsChild (FoundationT' url acidState requestState m) body
, EmbedAsChild (FoundationT' url acidState requestState m) headers
, XMLType (FoundationT' url acidState requestState m) ~ XML
) =>
Lazy.Text
-> headers
-> body
-> FoundationT url acidState requestState m XML
defaultTemplate title headers body =
XMLGenT $ HTML.defaultTemplate title headers body
data FoundationConf = FoundationConf
{ httpConf :: Conf
, bodyPolicy :: BodyPolicy
}
defaultConf :: FoundationConf
defaultConf = FoundationConf
{ httpConf = nullConf
, bodyPolicy = defaultBodyPolicy "/tmp" 10000000 100000 100000
}
simpleApp :: (ToMessage a, PathInfo url, Monad m) =>
(forall r. m r -> IO r)
-> FoundationConf
-> AcidConfig acidState
-> requestState
-> url
-> Text
-> (url -> FoundationT url acidState requestState m a)
-> IO ()
simpleApp flattener FoundationConf{..} acidConfig initialReqSt defRoute baseURI route =
withAcidConfig acidConfig $ \acid ->
do tid <- forkIO $ simpleHTTP httpConf $ do decodeBody bodyPolicy
implSite baseURI Text.empty (site acid)
waitForTermination
killThread tid
where
site acid =
setDefault defRoute $ mkSitePI (\showFn url ->
mapServerPartT flattener (evalStateT (unRouteT (unXMLGenT (route url)) showFn) (AppState url acid initialReqSt)))