{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, RankNTypes #-}
module Happstack.Foundation
( AcidConfig(..)
, FoundationT
, FoundationT'
, FoundationForm
, whereami
, defaultTemplate
, query
, update
, 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
)
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 Data.String (IsString(..))
import Control.Monad.Reader
import Control.Monad.State
import HSP (XMLGenerator(..), XMLGen(..), EmbedAsChild(..), EmbedAsAttr(..), XML, XMLGenT(..), unXMLGenT, XMLType, Attr(..))
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)
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
-- | bracket the opening and close of the `AcidState` handle.
-- automatically creates a checkpoint on close
--
-- unfortunately, when nesting multiple calls if some migrations
-- succeed and some fail it leaves the system in an state where it is
-- hard to roll back to the old version of the app because some of the
-- checkpoints have been upgrade. We should replace this with a
-- version that only does the checkpoint if *all* the acid states
-- could be openned successfully.
withLocalState :: (MonadBaseControl IO m, MonadIO m, IsAcidic st, Typeable st) =>
Maybe FilePath -- ^ path to state directory
-> st -- ^ initial state value
-> (AcidState st -> m a) -- ^ function which uses the `AcidState` handle
-> 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 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
instance (Functor m, Monad m) => HasAcidState (FoundationT url 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
= AcidLocal
{ acidPath :: Maybe FilePath
, initialState :: st
}
defaultTemplate :: ( Functor m, Monad m
, EmbedAsChild (FoundationT' url acidState requestState m) body
, EmbedAsChild (FoundationT' url acidState requestState m) headers
, XMLType (FoundationT' url acidState requestState m) ~ XML
) =>
String
-> headers
-> body
-> FoundationT url acidState requestState m XML
defaultTemplate title headers body =
XMLGenT $ HTML.defaultTemplate title headers body
simpleApp :: (ToMessage a, IsAcidic acidState, Typeable acidState, PathInfo url, Monad m) =>
(forall r. m r -> IO r) -- ^ function to flatten inner monad
-> Conf -- ^ 'Conf' to pass onto 'simpleHTTP'
-> AcidConfig acidState -- ^ 'AcidState' configuration
-> requestState -- ^ initial @requestState@ value
-> url -- ^ default URL (ie, what does / map to)
-> (url -> FoundationT url acidState requestState m a) -- ^ handler
-> IO ()
simpleApp flattener conf acidConfig initialReqSt defRoute route =
withLocalState (acidPath acidConfig) (initialState acidConfig) $ \acid ->
do tid <- forkIO $ simpleHTTP conf $ do decodeBody (defaultBodyPolicy "/tmp" 0 10000 10000)
implSite Text.empty 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)))