{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, RankNTypes, RecordWildCards, GADTs #-}
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 (FoundationT' url acid reqSt m) (AcidState acidSt)
getAcidState = FoundationT' url acid reqSt m (AcidState acidSt)
-> XMLGenT (FoundationT' url acid reqSt m) (AcidState acidSt)
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT FoundationT' url acid reqSt m (AcidState acidSt)
forall (m :: * -> *) st. HasAcidState m st => m (AcidState st)
getAcidState
getAcidSt :: (Functor m, MonadState (AppState url acidState requestState) m) => m acidState
getAcidSt :: m acidState
getAcidSt = AppState url acidState requestState -> acidState
forall url acidState requestState.
AppState url acidState requestState -> acidState
acid (AppState url acidState requestState -> acidState)
-> m (AppState url acidState requestState) -> m acidState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (AppState url acidState requestState)
forall s (m :: * -> *). MonadState s m => m s
get
query :: forall event m.
( Functor m
, MonadIO m
, QueryEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
query :: event -> m (EventResult event)
query event
event =
do AcidState (MethodState event)
as <- m (AcidState (MethodState event))
forall (m :: * -> *) st. HasAcidState 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
update :: forall event m.
( Functor m
, MonadIO m
, UpdateEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
update :: event -> m (EventResult event)
update event
event =
do AcidState (MethodState event)
as <- m (AcidState (MethodState event))
forall (m :: * -> *) st. HasAcidState 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
withLocalState :: (MonadBaseControl IO m, MonadIO m, SafeCopy st, IsAcidic st, Typeable st) =>
Maybe FilePath
-> st
-> (AcidState st -> m a)
-> m a
withLocalState :: Maybe FilePath -> st -> (AcidState st -> m a) -> m a
withLocalState Maybe FilePath
mPath st
initialState =
m (AcidState st)
-> (AcidState st -> m ()) -> (AcidState st -> m a) -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO (AcidState st) -> m (AcidState st)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AcidState st) -> m (AcidState st))
-> IO (AcidState st) -> m (AcidState st)
forall a b. (a -> b) -> a -> b
$ ((st -> IO (AcidState st))
-> (FilePath -> st -> IO (AcidState st))
-> Maybe FilePath
-> st
-> IO (AcidState st)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe st -> IO (AcidState st)
forall st.
(Typeable st, IsAcidic st, SafeCopy st) =>
st -> IO (AcidState st)
openLocalState FilePath -> st -> IO (AcidState st)
forall st.
(IsAcidic st, SafeCopy st) =>
FilePath -> st -> IO (AcidState st)
openLocalStateFrom Maybe FilePath
mPath) st
initialState)
(\AcidState st
acid -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (AcidState st -> IO ()
forall st. AcidState st -> IO ()
createArchive AcidState st
acid IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AcidState st -> IO ()
forall st. (IsAcidic st, Typeable st) => AcidState st -> IO ()
createCheckpointAndClose AcidState st
acid))
data AppState url acidState requestState = AppState
{ AppState url acidState requestState -> url
here :: url
, AppState url acidState requestState -> acidState
acid :: acidState
, AppState url acidState requestState -> requestState
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 :: FoundationT url acidState requestState m url
whereami = AppState url acidState requestState -> url
forall url acidState requestState.
AppState url acidState requestState -> url
here (AppState url acidState requestState -> url)
-> XMLGenT
(FoundationT' url acidState requestState m)
(AppState url acidState requestState)
-> FoundationT url acidState requestState m url
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLGenT
(FoundationT' url acidState requestState m)
(AppState url acidState requestState)
forall s (m :: * -> *). MonadState s m => m s
get
getRequestState :: (Functor m, MonadState (AppState url acidState requestState) m) => m requestState
getRequestState :: m requestState
getRequestState = AppState url acidState requestState -> requestState
forall url acidState requestState.
AppState url acidState requestState -> requestState
reqSt (AppState url acidState requestState -> requestState)
-> m (AppState url acidState requestState) -> m requestState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (AppState url acidState requestState)
forall s (m :: * -> *). MonadState s m => m s
get
setRequestState :: (Functor m, MonadState (AppState url acidState requestState) m) =>
requestState
-> m ()
setRequestState :: requestState -> m ()
setRequestState requestState
st = (AppState url acidState requestState
-> AppState url acidState requestState)
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AppState url acidState requestState
-> AppState url acidState requestState)
-> m ())
-> (AppState url acidState requestState
-> AppState url acidState requestState)
-> m ()
forall a b. (a -> b) -> a -> b
$ \AppState url acidState requestState
appState -> AppState url acidState requestState
appState { reqSt :: requestState
reqSt = requestState
st }
modifyRequestState :: MonadState (AppState url acidState requestState) m =>
(requestState -> requestState)
-> m ()
modifyRequestState :: (requestState -> requestState) -> m ()
modifyRequestState requestState -> requestState
f = (AppState url acidState requestState
-> AppState url acidState requestState)
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((AppState url acidState requestState
-> AppState url acidState requestState)
-> m ())
-> (AppState url acidState requestState
-> AppState url acidState requestState)
-> m ()
forall a b. (a -> b) -> a -> b
$ \AppState url acidState requestState
appState -> AppState url acidState requestState
appState { reqSt :: requestState
reqSt = requestState -> requestState
f (AppState url acidState requestState -> requestState
forall url acidState requestState.
AppState url acidState requestState -> requestState
reqSt AppState url acidState requestState
appState) }
instance (Functor m, Monad m) => HasAcidState (FoundationT url (AcidState acidState) requestState m) acidState where
getAcidState :: FoundationT
url (AcidState acidState) requestState m (AcidState acidState)
getAcidState = AppState url (AcidState acidState) requestState
-> AcidState acidState
forall url acidState requestState.
AppState url acidState requestState -> acidState
acid (AppState url (AcidState acidState) requestState
-> AcidState acidState)
-> XMLGenT
(FoundationT' url (AcidState acidState) requestState m)
(AppState url (AcidState acidState) requestState)
-> FoundationT
url (AcidState acidState) requestState m (AcidState acidState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLGenT
(FoundationT' url (AcidState acidState) requestState m)
(AppState url (AcidState acidState) requestState)
forall s (m :: * -> *). MonadState s m => m s
get
data AppError
= AppCFE (CommonFormError [Input])
| TextError Text
instance IsString AppError where
fromString :: FilePath -> AppError
fromString = Text -> AppError
TextError (Text -> AppError) -> (FilePath -> Text) -> FilePath -> AppError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. IsString a => FilePath -> a
fromString
instance FormError AppError where
type ErrorInputType AppError = [Input]
commonFormError :: CommonFormError (ErrorInputType AppError) -> AppError
commonFormError = CommonFormError [Input] -> AppError
CommonFormError (ErrorInputType AppError) -> AppError
AppCFE
instance (Functor m, Monad m) => EmbedAsChild (FoundationT' url acidState requestState m) AppError where
asChild :: AppError
-> GenChildList (FoundationT' url acidState requestState m)
asChild (AppCFE CommonFormError [Input]
cfe) = FilePath
-> GenChildList (FoundationT' url acidState requestState m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (([Input] -> FilePath) -> CommonFormError [Input] -> FilePath
forall input.
(input -> FilePath) -> CommonFormError input -> FilePath
commonFormErrorStr [Input] -> FilePath
forall a. Show a => a -> FilePath
show CommonFormError [Input]
cfe)
asChild (TextError Text
txt) = Text -> GenChildList (FoundationT' url acidState requestState m)
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild Text
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, SafeCopy 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 :: AcidConfig st -> (st -> m a) -> m a
withAcidConfig (AcidLocal Maybe FilePath
acidPath st
initialState) st -> m a
f =
Maybe FilePath -> st -> (AcidState st -> m a) -> m a
forall (m :: * -> *) st a.
(MonadBaseControl IO m, MonadIO m, SafeCopy st, IsAcidic st,
Typeable st) =>
Maybe FilePath -> st -> (AcidState st -> m a) -> m a
withLocalState Maybe FilePath
acidPath st
initialState st -> m a
AcidState st -> m a
f
withAcidConfig (AcidUsing st
st) st -> m a
f = st -> m a
f st
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 :: Text
-> headers -> body -> FoundationT url acidState requestState m XML
defaultTemplate Text
title headers
headers body
body =
FoundationT' url acidState requestState m XML
-> FoundationT url acidState requestState m XML
forall (m :: * -> *) a. m a -> XMLGenT m a
XMLGenT (FoundationT' url acidState requestState m XML
-> FoundationT url acidState requestState m XML)
-> FoundationT' url acidState requestState m XML
-> FoundationT url acidState requestState m XML
forall a b. (a -> b) -> a -> b
$ Text
-> headers
-> body
-> FoundationT'
url
acidState
requestState
m
(XMLType (FoundationT' url acidState requestState m))
forall (m :: * -> *) headers body.
(XMLGenerator m, EmbedAsChild m headers, EmbedAsChild m body,
StringType m ~ Text) =>
Text -> headers -> body -> m (XMLType m)
HTML.defaultTemplate Text
title headers
headers body
body
data FoundationConf = FoundationConf
{ FoundationConf -> Conf
httpConf :: Conf
, FoundationConf -> BodyPolicy
bodyPolicy :: BodyPolicy
}
defaultConf :: FoundationConf
defaultConf :: FoundationConf
defaultConf = FoundationConf :: Conf -> BodyPolicy -> FoundationConf
FoundationConf
{ httpConf :: Conf
httpConf = Conf
nullConf
, bodyPolicy :: BodyPolicy
bodyPolicy = FilePath -> Int64 -> Int64 -> Int64 -> BodyPolicy
defaultBodyPolicy FilePath
"/tmp" Int64
10000000 Int64
100000 Int64
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 :: (forall r. m r -> IO r)
-> FoundationConf
-> AcidConfig acidState
-> requestState
-> url
-> Text
-> (url -> FoundationT url acidState requestState m a)
-> IO ()
simpleApp forall r. m r -> IO r
flattener FoundationConf{BodyPolicy
Conf
bodyPolicy :: BodyPolicy
httpConf :: Conf
bodyPolicy :: FoundationConf -> BodyPolicy
httpConf :: FoundationConf -> Conf
..} AcidConfig acidState
acidConfig requestState
initialReqSt url
defRoute Text
baseURI url -> FoundationT url acidState requestState m a
route =
AcidConfig acidState -> (acidState -> IO ()) -> IO ()
forall (m :: * -> *) st a.
(MonadIO m, MonadBaseControl IO m) =>
AcidConfig st -> (st -> m a) -> m a
withAcidConfig AcidConfig acidState
acidConfig ((acidState -> IO ()) -> IO ()) -> (acidState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \acidState
acid ->
do ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Conf -> ServerPartT IO a -> IO ()
forall a. ToMessage a => Conf -> ServerPartT IO a -> IO ()
simpleHTTP Conf
httpConf (ServerPartT IO a -> IO ()) -> ServerPartT IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ do BodyPolicy -> ServerPartT IO ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m,
WebMonad Response m) =>
BodyPolicy -> m ()
decodeBody BodyPolicy
bodyPolicy
Text -> Text -> Site url (ServerPartT IO a) -> ServerPartT IO a
forall (m :: * -> *) url a.
(Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -> Text -> Site url (m a) -> m a
implSite Text
baseURI Text
Text.empty (acidState -> Site url (ServerPartT IO a)
site acidState
acid)
IO ()
waitForTermination
ThreadId -> IO ()
killThread ThreadId
tid
where
site :: acidState -> Site url (ServerPartT IO a)
site acidState
acid =
url -> Site url (ServerPartT IO a) -> Site url (ServerPartT IO a)
forall url a. url -> Site url a -> Site url a
setDefault url
defRoute (Site url (ServerPartT IO a) -> Site url (ServerPartT IO a))
-> Site url (ServerPartT IO a) -> Site url (ServerPartT IO a)
forall a b. (a -> b) -> a -> b
$ ((url -> [(Text, Maybe Text)] -> Text) -> url -> ServerPartT IO a)
-> Site url (ServerPartT IO a)
forall url a.
PathInfo url =>
((url -> [(Text, Maybe Text)] -> Text) -> url -> a) -> Site url a
mkSitePI (\url -> [(Text, Maybe Text)] -> Text
showFn url
url ->
(UnWebT m a -> UnWebT IO a) -> ServerPartT m a -> ServerPartT IO a
forall (m :: * -> *) a (n :: * -> *) b.
(UnWebT m a -> UnWebT n b) -> ServerPartT m a -> ServerPartT n b
mapServerPartT UnWebT m a -> UnWebT IO a
forall r. m r -> IO r
flattener (StateT (AppState url acidState requestState) (ServerPartT m) a
-> AppState url acidState requestState -> ServerPartT m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RouteT
url
(StateT (AppState url acidState requestState) (ServerPartT m))
a
-> (url -> [(Text, Maybe Text)] -> Text)
-> StateT (AppState url acidState requestState) (ServerPartT m) a
forall url (m :: * -> *) a.
RouteT url m a -> (url -> [(Text, Maybe Text)] -> Text) -> m a
unRouteT (FoundationT url acidState requestState m a
-> RouteT
url
(StateT (AppState url acidState requestState) (ServerPartT m))
a
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (url -> FoundationT url acidState requestState m a
route url
url)) url -> [(Text, Maybe Text)] -> Text
showFn) (url
-> acidState -> requestState -> AppState url acidState requestState
forall url acidState requestState.
url
-> acidState -> requestState -> AppState url acidState requestState
AppState url
url acidState
acid requestState
initialReqSt)))