happstack-foundation (empty) → 0.1.0
raw patch · 4 files changed
+244/−0 lines, 4 filesdep +acid-statedep +basedep +happstack-hspsetup-changed
Dependencies added: acid-state, base, happstack-hsp, happstack-server, hsp, lifted-base, monad-control, mtl, reform, reform-happstack, reform-hsp, safecopy, text, web-routes, web-routes-happstack, web-routes-hsp, web-routes-th
Files
- Happstack/Foundation.hs +168/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- happstack-foundation.cabal +44/−0
+ Happstack/Foundation.hs view
@@ -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)))
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-foundation.cabal view
@@ -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.*