diff --git a/Happstack/Foundation.hs b/Happstack/Foundation.hs new file mode 100644 --- /dev/null +++ b/Happstack/Foundation.hs @@ -0,0 +1,168 @@ +{-# 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))) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Jeremy Shaw + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jeremy Shaw nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/happstack-foundation.cabal b/happstack-foundation.cabal new file mode 100644 --- /dev/null +++ b/happstack-foundation.cabal @@ -0,0 +1,44 @@ +Name: happstack-foundation +Version: 0.1.0 +Synopsis: Glue code for using Happstack with acid-state, web-routes, reform, and HSP +Description: happstack-foundation is a libary which builds on top of existing components + to provide a powerful and type-safe environment for web development. It uses: + . + happstack-server for the underlying HTTP support + . + HSP for HTML templates + . + web-routes for type-safe URL routing + . + reform for type-safe form generation and validation + . + acid-state for persistent data storage +Homepage: http://www.happstack.com/ +License: BSD3 +License-file: LICENSE +Author: Jeremy Shaw +Maintainer: jeremy@n-heptane.com +Category: Happstack +Build-type: Simple +Cabal-version: >=1.6 + +Library + Exposed-modules: Happstack.Foundation + Build-Depends: + base < 5, + acid-state == 0.6.*, + happstack-hsp == 7.1.*, + happstack-server == 7.0.*, + hsp == 0.7.*, + lifted-base == 0.1.*, + monad-control == 0.3.*, + mtl == 2.1.*, + reform == 0.1.*, + reform-happstack == 0.1.*, + reform-hsp == 0.1.*, + safecopy == 0.6.*, + text == 0.11.*, + web-routes == 0.27.*, + web-routes-happstack == 0.23.*, + web-routes-hsp == 0.23.*, + web-routes-th == 0.22.*