{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, RankNTypes, RecordWildCards, GADTs #-}
{-|
@happstack-foundation@ provides a type-safe environment for Haskell web development. It builds on top of:

 - happstack-server - an HTTP server

 - HSP - HTML Templating

 - web-routes - type-safe URL routing

 - reform - type-safe form composition and validation

 - acid-state - native Haskell persistent database

An example application can be found here:

<http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-foundation/examples/ControlV/Main.hs>

A screencast can be found here:

<http://www.youtube.com/watch?v=7Wmszk4wZxQ>

@happstack-foundation@ itself is not yet documented in the Happstack Crash Course. However, all of the components that it uses are:

<http://www.happstack.com/docs/crashcourse/index.html>

-}
module Happstack.Foundation
    ( -- * Configuration
      AcidConfig(..)
    , FoundationConf(..)
    , defaultConf
      -- * Type Aliases
    , FoundationT
    , FoundationT'
    , FoundationForm
    -- * FoundationT functions
    , whereami
    , getRequestState
    , setRequestState
    , modifyRequestState
      -- * HTML Template
    , defaultTemplate
      -- * acid-state
    , HasAcidState(..)
    , query
    , update
    , getAcidSt
      -- * running
    , simpleApp
    -- * re-exports
    , 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
    -- * Internals
    , 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 () -- instances for (Happstack (XMLGenT m))
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

-- | 'HasAcidState' provides a single method 'getAcidState' which can be used to retrieve an 'AcidState' handle from the current monad.
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

-- | wrapper around query from acid-state
--
-- This variant automatically gets the 'AcidState' handle from the monad
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

-- | wrapper around update from acid-state
--
-- This variant automatically gets the 'AcidState' handle from the monad
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

-- | 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, SafeCopy st, 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 :: 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))

-- | simple record that holds some state information that we want available in the 'FoundationT' monad
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
    }

-- | similar to the 'FoundationT'' type alias, but without the 'XMLGenT' wrapper. This variant is most often used in class constraints.
type FoundationT' url acidState requestState m = RouteT url (StateT (AppState url acidState requestState) (ServerPartT m))

-- | the 'FoundationT' monad
--
-- - @url@ - the type-safe URL route type
--
-- - @acidState@ - the type of the state value stored in acid-state
--
-- - @requestState@ - a per-request state value that the developer can get/set/modify
--
-- - @m@ - inner monad
--
-- see also: 'whereami', 'getRequestState', 'setRequestState', 'modifyRequestState', 'simpleApp'
type FoundationT  url acidState requestState m = XMLGenT (FoundationT' url acidState requestState m)

-- | returns the decoded 'url' from the 'Request'
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

-- | get the 'requestState' value
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

-- | set the 'requestState' value
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 }

-- | set the 'requestState' value
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

-- | an error type used with reform forms
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

-- | 'FoundationForm' is an alias for working with reform based Forms
type FoundationForm url acidState requestState m = Form (FoundationT url acidState requestState m) [Input] AppError [FoundationT url acidState requestState m XML] ()

-- | configuration information for our acid-state database
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

-- | default page template
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

-- | configuration for server
data FoundationConf = FoundationConf
    { FoundationConf -> Conf
httpConf   :: Conf
    , FoundationConf -> BodyPolicy
bodyPolicy ::  BodyPolicy
    }

-- | configuration
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
    }

-- | run the application
--
-- starts the database, listens for requests, etc.
simpleApp :: (ToMessage a, PathInfo url, Monad m) =>
             (forall r. m r -> IO r)             -- ^ function to flatten inner monad
          -> FoundationConf                      -- ^ 'Conf' to pass onto 'simpleHTTP'
          -> AcidConfig acidState                -- ^ 'AcidState' configuration
          -> requestState                        -- ^ initial @requestState@ value
          -> url                                 -- ^ default URL (ie, what does / map to)
          -> Text                                -- ^ the base URL for the site as seen by the outside world (or, at least, by your openid provider) (e.g. "http://example.org:8000", no trailing slash)
          -> (url -> FoundationT url acidState requestState m a) -- ^ handler
          -> 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)))