{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}{-| This module defines the Monad stack used by Happstack. You mostly don't want to be looking in here. Look in "Happstack.Server.Monads" instead.
-}moduleHappstack.Server.Internal.MonadswhereimportControl.Applicative(Applicative,pure,(<*>),Alternative(empty,(<|>)))importControl.Monad(MonadPlus(mzero,mplus),ap,liftM,msum)importControl.Monad.Trans(MonadTrans,lift,MonadIO,liftIO)importControl.Monad.Reader(ReaderT(ReaderT),runReaderT,MonadReader,ask,local)importControl.Monad.Writer(WriterT(WriterT),runWriterT,MonadWriter,tell,pass,listens)importqualifiedControl.Monad.WriterasWriter(listen)-- So that we can disambiguate 'Listen.listen'importControl.Monad.State(MonadState,get,put)importControl.Monad.Error(ErrorT(ErrorT),runErrorT,Error,MonadError,throwError,catchError,mapErrorT)importControl.Monad.Maybe(MaybeT(MaybeT),runMaybeT)importqualifiedData.ByteString.Lazy.UTF8asLU(fromString)importData.Char(ord)importData.List(inits,isPrefixOf,stripPrefix,tails)importData.Monoid(Monoid(mempty,mappend),Dual(..),Endo(..))importqualifiedPaths_happstack_serverasCabalimportqualifiedData.VersionasDVimportDebug.Trace(trace)importHappstack.Server.Types(Request,Response,resultBS,setHeader)-- | An alias for 'WebT' when using 'IO'.typeWeba=WebTIOa-- | An alias for @'ServerPartT' 'IO'@typeServerParta=ServerPartTIOa---------------------------------------- HERE BEGINS ServerPartT definitions-- | 'ServerPartT' is a rich, featureful monad for web development. ---- see also: 'simpleHTTP', 'ServerMonad', 'FilterMonad', 'WebMonad', and 'HasRqData'newtypeServerPartTma=ServerPartT{unServerPartT::ReaderTRequest(WebTm)a}deriving(Monad,MonadPlus,Functor)instance(MonadIOm)=>MonadIO(ServerPartTm)whereliftIO=ServerPartT.liftIO{-# INLINE liftIO #-}-- | Particularly useful when combined with 'runWebT' to produce-- a @m ('Maybe' 'Response')@ from a 'Request'.runServerPartT::ServerPartTma->Request->WebTmarunServerPartT=runReaderT.unServerPartT-- | function for lifting WebT to ServerPartT---- NOTE: This is mostly for internal use. If you want to access the-- 'Request' in user-code see 'askRq' from 'ServerMonad'.---- > do request <- askRq-- > ...withRequest::(Request->WebTma)->ServerPartTmawithRequest=ServerPartT.ReaderT-- | A constructor for a 'ServerPartT' when you don't care about the request.---- NOTE: This is mostly for internal use. If you think you need to use-- it in your own code, you might consider asking on the mailing list-- or IRC to find out if there is an alternative solution.anyRequest::Monadm=>WebTma->ServerPartTmaanyRequestx=withRequest$\_->x-- | Apply a function to transform the inner monad of-- @'ServerPartT' m@. -- -- Often used when transforming a monad with 'ServerPartT', since-- 'simpleHTTP' requires a @'ServerPartT' 'IO' a@. Refer to 'UnWebT'-- for an explanation of the structure of the monad.---- Here is an example. Suppose you want to embed an 'ErrorT' into your-- 'ServerPartT' to enable 'throwError' and 'catchError' in your 'Monad'.---- > type MyServerPartT e m a = ServerPartT (ErrorT e m) a---- Now suppose you want to pass @MyServerPartT@ into a function that-- demands a @'ServerPartT' 'IO' a@ (e.g. 'simpleHTTP'). You can-- provide the function:---- > unpackErrorT :: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a-- > unpackErrorT et = do-- > eitherV <- runErrorT et-- > return $ case eitherV of-- > Left err -> Just (Left $ toResponse $ -- > "Catastrophic failure " ++ show err-- > , filterFun $ \r -> r{rsCode = 500})-- > Right x -> x---- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your-- 'ServerPartT' list.---- > simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart `catchError` myHandler)---- Or alternatively:---- > simpleHTTP' unpackErrorT nullConf (myPart `catchError` myHandler)---- Also see 'Happstack.Server.Error.spUnwrapErrorT' for a more sophisticated version of this-- function.--mapServerPartT::(UnWebTma->UnWebTnb)->(ServerPartTma->ServerPartTnb)mapServerPartTfma=withRequest$\rq->mapWebTf(runServerPartTmarq)-- | A variant of 'mapServerPartT' where the first argument also takes-- a 'Request'. Useful if you want to 'runServerPartT' on a different-- 'ServerPartT' inside your monad (see 'spUnwrapErrorT').mapServerPartT'::(Request->UnWebTma->UnWebTnb)->(ServerPartTma->ServerPartTnb)mapServerPartT'fma=withRequest$\rq->mapWebT(frq)(runServerPartTmarq)instanceMonadTrans(ServerPartT)whereliftm=withRequest(\_->liftm)instance(Monadm)=>Monoid(ServerPartTma)wheremempty=mzeromappend=mplusinstance(Monadm,Functorm)=>Applicative(ServerPartTm)wherepure=return(<*>)=apinstance(Functorm,MonadPlusm)=>Alternative(ServerPartTm)whereempty=mzero(<|>)=mplusinstance(Monadm,MonadWriterwm)=>MonadWriterw(ServerPartTm)wheretell=lift.telllistenm=withRequest$\rq->Writer.listen(runServerPartTmrq)>>=returnpassm=withRequest$\rq->pass(runServerPartTmrq)>>=returninstance(Monadm,MonadErrorem)=>MonadErrore(ServerPartTm)wherethrowErrore=lift$throwErrorecatchErroractionhandler=withRequest$\rq->(runServerPartTactionrq)`catchError`((fliprunServerPartT$rq).handler)instance(Monadm,MonadReaderrm)=>MonadReaderr(ServerPartTm)whereask=liftasklocalfnm=withRequest$\rq->localfn(runServerPartTmrq)instance(Monadm,MonadStatesm)=>MonadStates(ServerPartTm)whereget=liftgetput=lift.putinstanceMonadm=>FilterMonadResponse(ServerPartTm)wheresetFilter=anyRequest.setFiltercomposeFilter=anyRequest.composeFiltergetFilterm=withRequest$\rq->getFilter(runServerPartTmrq)instanceMonadm=>WebMonadResponse(ServerPartTm)wherefinishWithr=anyRequest$finishWithr-- | The 'ServerMonad' class provides methods for reading or locally-- modifying the 'Request'. It is essentially a specialized version of-- the 'MonadReader' class. Providing the unique names, 'askRq' and-- 'localRq' makes it easier to use 'ServerPartT' and 'ReaderT'-- together.classMonadm=>ServerMonadmwhereaskRq::mRequestlocalRq::(Request->Request)->ma->mainstance(Monadm)=>ServerMonad(ServerPartTm)whereaskRq=ServerPartT$asklocalRqfm=ServerPartT$localf(unServerPartTm)instance(Errore,ServerMonadm)=>ServerMonad(ErrorTem)whereaskRq=liftaskRqlocalRqf=mapErrorT$localRqf--------------------------------- HERE BEGINS WebT definitions-- | A monoid operation container. If @a@ is a monoid, then-- 'SetAppend' is a monoid with the following behaviors:---- > Set x `mappend` Append y = Set (x `mappend` y)-- > Append x `mappend` Append y = Append (x `mappend` y)-- > _ `mappend` Set y = Set y---- A simple way of summarizing this is, if the right side is 'Append',-- then the right is appended to the left. If the right side is-- 'Set', then the left side is ignored.dataSetAppenda=Seta|Appendaderiving(Eq,Show)instanceMonoida=>Monoid(SetAppenda)wheremempty=AppendmemptySetx`mappend`Appendy=Set(x`mappend`y)Appendx`mappend`Appendy=Append(x`mappend`y)_`mappend`Sety=Sety-- | Extract the value from a 'SetAppend'.-- Note that a 'SetAppend' is actually a @CoPointed@ from:-- <http://hackage.haskell.org/packages/archive/category-extras/latest/doc/html/Control-Functor-Pointed.html>-- But lets not drag in that dependency. yet...extract::SetAppendt->textract(Setx)=xextract(Appendx)=xinstanceFunctor(SetAppend)wherefmapf(Setx)=Set$fxfmapf(Appendx)=Append$fx-- | 'FilterFun' is a lot more fun to type than @'SetAppend' ('Dual'-- ('Endo' a))@.typeFilterFuna=SetAppend(Dual(Endoa))unFilterFun::FilterFuna->(a->a)unFilterFun=appEndo.getDual.extract-- | turn a function into a 'FilterFun'. Primarily used with 'mapServerPartT'filterFun::(a->a)->FilterFunafilterFun=Set.Dual.EndonewtypeFilterTamb=FilterT{unFilterT::WriterT(FilterFuna)mb}deriving(Monad,MonadTrans,Functor)instance(MonadIOm)=>MonadIO(FilterTam)whereliftIO=FilterT.liftIO{-# INLINE liftIO #-}-- | A set of functions for manipulating filters. ---- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods-- are the fundamental ways of manipulating 'Response' values.classMonadm=>FilterMonadam|m->awhere-- | Ignores all previous alterations to your filter---- As an example:---- > do-- > composeFilter f-- > setFilter g-- > return "Hello World"---- The @'setFilter' g@ will cause the first @'composeFilter' f@ to-- be ignored.setFilter::(a->a)->m()-- | Composes your filter function with the existing filter-- function.composeFilter::(a->a)->m()-- | Retrieves the filter from the environment.getFilter::mb->m(b,a->a)-- | Resets all your filters. An alias for @'setFilter' 'id'@.ignoreFilters::(FilterMonadam)=>m()ignoreFilters=setFilteridinstance(Monadm)=>FilterMonada(FilterTam)wheresetFilter=FilterT.tell.Set.Dual.EndocomposeFilter=FilterT.tell.Append.Dual.EndogetFilter=FilterT.listensunFilterFun.unFilterT-- | The basic 'Response' building object.newtypeWebTma=WebT{unWebT::ErrorTResponse(FilterT(Response)(MaybeTm))a}deriving(Functor)instance(MonadIOm)=>MonadIO(WebTm)whereliftIO=WebT.liftIO{-# INLINE liftIO #-}-- | 'UnWebT' is almost exclusively used with 'mapServerPartT'. If you-- are not using 'mapServerPartT' then you do not need to wrap your-- head around this type. If you are -- the type is not as complex as-- it first appears.-- -- It is worth discussing the unpacked structure of 'WebT' a bit as-- it's exposed in 'mapServerPartT' and 'mapWebT'.---- A fully unpacked 'WebT' has a structure that looks like:---- > ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))---- So, ignoring @m@, as it is just the containing 'Monad', the-- outermost layer is a 'Maybe'. This is 'Nothing' if 'mzero' was-- called or @'Just' ('Either' 'Response' a, 'SetAppend' ('Endo'-- 'Response'))@ if 'mzero' wasn't called. Inside the 'Maybe', there-- is a pair. The second element of the pair is our filter function-- @'FilterFun' 'Response'@. @'FilterFun' 'Response'@ is a type-- alias for @'SetAppend' ('Dual' ('Endo' 'Response'))@. This is-- just a wrapper for a @'Response' -> 'Response'@ function with a-- particular 'Monoid' behavior. The value---- > Append (Dual (Endo f))---- Causes @f@ to be composed with the previous filter.---- > Set (Dual (Endo f))---- Causes @f@ to not be composed with the previous filter.---- Finally, the first element of the pair is either @'Left'-- 'Response'@ or @'Right' a@.---- Another way of looking at all these pieces is from the behaviors-- they control. The 'Maybe' controls the 'mzero' behavior. @'Set'-- ('Endo' f)@ comes from the 'setFilter' behavior. Likewise,-- @'Append' ('Endo' f)@ is from 'composeFilter'. @'Left'-- 'Response'@ is what you get when you call 'finishWith' and-- @'Right' a@ is the normal exit.---- An example case statement looks like:---- > ex1 webt = do-- > val <- ununWebT webt-- > case val of-- > Nothing -> Nothing -- this is the interior value when mzero was used-- > Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"-- > -- f is our filter function-- > Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value-- > -- f is still our filter function--typeUnWebTma=m(Maybe(EitherResponsea,FilterFunResponse))instanceMonadm=>Monad(WebTm)wherem>>=f=WebT$unWebTm>>=unWebT.f{-# INLINE (>>=) #-}returna=WebT$returna{-# INLINE return #-}fails=outputTraceMessages(mkFailMessages)-- | 'WebMonad' provides a means to end the current computation-- and return a 'Response' immediately. This provides an-- alternate escape route. In particular it has a monadic value-- of any type. And unless you call @'setFilter' 'id'@ first your-- response filters will be applied normally.---- Extremely useful when you're deep inside a monad and decide-- that you want to return a completely different content type,-- since it doesn't force you to convert all your return types to-- 'Response' early just to accommodate this.---- see also: 'escape' and 'escape''classMonadm=>WebMonadam|m->awhere-- abort the current computation and return a valuefinishWith::a-- ^ value to return (For 'ServerPart', 'a' will always be the type 'Response')->mb-- | Used to ignore all your filters and immediately end the-- computation. A combination of 'ignoreFilters' and 'finishWith'.escape::(WebMonadam,FilterMonadam)=>ma->mbescapegen=ignoreFilters>>gen>>=finishWith-- | An alternate form of 'escape' that can be easily used within a do-- block.escape'::(WebMonadam,FilterMonadam)=>a->mbescape'a=ignoreFilters>>finishWithainstance(Monadm)=>WebMonadResponse(WebTm)wherefinishWithr=WebT$throwErrorrinstanceMonadTransWebTwherelift=WebT.lift.lift.liftinstance(Monadm)=>MonadPlus(WebTm)where-- | Aborts a computation.---- This is primarily useful because 'msum' will take an array of-- 'MonadPlus' and return the first one that isn't 'mzero', which-- is exactly the semantics expected from objects that take lists-- of 'ServerPartT'.mzero=WebT$lift$lift$mzeromplusxy=WebT$ErrorT$FilterT$(lowerx)`mplus`(lowery)wherelower=(unFilterT.runErrorT.unWebT)instance(Monadm)=>FilterMonadResponse(WebTm)wheresetFilterf=WebT$lift$setFilter$fcomposeFilterf=WebT.lift.composeFilter$fgetFilterm=WebT$ErrorT$liftMlft$getFilter(runErrorT$unWebTm)wherelft(Leftr,_)=Leftrlft(Righta,f)=Right(a,f)instance(Monadm)=>Monoid(WebTma)wheremempty=mzeromappend=mplus-- | For when you really need to unpack a 'WebT' entirely (and not-- just unwrap the first layer with 'unWebT').ununWebT::WebTma->UnWebTmaununWebT=runMaybeT.runWriterT.unFilterT.runErrorT.unWebT-- | For wrapping a 'WebT' back up. @'mkWebT' . 'ununWebT' = 'id'@mkWebT::UnWebTma->WebTmamkWebT=WebT.ErrorT.FilterT.WriterT.MaybeT-- | See 'mapServerPartT' for a discussion of this function.mapWebT::(UnWebTma->UnWebTnb)->(WebTma->WebTnb)mapWebTfma=mkWebT$f(ununWebTma)-- | This is kinda like a very oddly shaped 'mapServerPartT' or 'mapWebT'.-- You probably want one or the other of those.localContext::Monadm=>(WebTma->WebTm'a)->ServerPartTma->ServerPartTm'alocalContextfnhs=withRequest$\rq->fn(runServerPartThsrq)instance(Monadm,Functorm)=>Applicative(WebTm)wherepure=return(<*>)=apinstance(Functorm,MonadPlusm)=>Alternative(WebTm)whereempty=mzero(<|>)=mplusinstanceMonadReaderrm=>MonadReaderr(WebTm)whereask=liftasklocalfnm=mkWebT$localfn(ununWebTm)instanceMonadStatestm=>MonadStatest(WebTm)whereget=liftgetput=lift.putinstanceMonadErrorem=>MonadErrore(WebTm)wherethrowErrorerr=lift$throwErrorerrcatchErroractionhandler=mkWebT$catchError(ununWebTaction)(ununWebT.handler)instanceMonadWriterwm=>MonadWriterw(WebTm)wheretell=lift.telllistenm=mkWebT$Writer.listen(ununWebTm)>>=(return.liftWebT)whereliftWebT(Nothing,_)=NothingliftWebT(Just(Leftx,f),_)=Just(Leftx,f)liftWebT(Just(Rightx,f),w)=Just(Right(x,w),f)passm=mkWebT$ununWebTm>>=liftWebTwhereliftWebTNothing=returnNothingliftWebT(Just(Leftx,f))=return$Just(Leftx,f)liftWebT(Just(Rightx,f))=pass(returnx)>>=(\a->return$Just(Righta,f))-- | Deprecated: use 'msum'.multi::Monadm=>[ServerPartTma]->ServerPartTmamulti=msum{-# DEPRECATED multi "Use msum instead" #-}-- | What is this for, exactly? I don't understand why @Show a@ is-- even in the context Deprecated: This function appears to do nothing-- at all. If it use it, let us know why.debugFilter::(MonadIOm,Showa)=>ServerPartTma->ServerPartTmadebugFilterhandle=withRequest$\rq->dor<-runServerPartThandlerqreturnr{-# DEPRECATED debugFilter "This function appears to do nothing." #-}-- "Pattern match failure in do expression at src\AppControl.hs:43:24"-- is converted to:-- "src\AppControl.hs:43:24: Pattern match failure in do expression"-- Then we output this to stderr. Help debugging under Emacs console when using GHCi.-- This is GHC specific, but you may add your favourite compiler here also.outputTraceMessage::String->a->aoutputTraceMessagesc|"Pattern match failure "`isPrefixOf`s=letw=[(k,p)|(i,p)<-zip(tailss)(initss),Justk<-[stripPrefix" at "i]]v=concatMap(\(k,p)->k++": "++p)wintracevcoutputTraceMessagesc=tracescmkFailMessage::(FilterMonadResponsem,WebMonadResponsem)=>String->mbmkFailMessages=doignoreFiltersletres=setHeader"Content-Type""text/html; charset=UTF-8"$resultBS500(LU.fromString(failHtmls))finishWith$resfailHtml::String->StringfailHtmlerrString="<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"++"<html><head><title>Happstack "++ver++" Internal Server Error</title></head>"++"<body><h1>Happstack "++ver++"</h1>"++"<p>Something went wrong here<br>"++"Internal server error<br>"++"Everything has stopped</p>"++"<p>The error was \""++(escapeStringerrString)++"\"</p></body></html>"wherever=DV.showVersionCabal.versionescapeString::String->StringescapeStringstr=concatMapencodeEntitystrwhereencodeEntity::Char->StringencodeEntity'<'="&lt;"encodeEntity'>'="&gt;"encodeEntity'&'="&amp;"encodeEntity'"'="&quot;"encodeEntityc|ordc>127="&#"++show(ordc)++";"|otherwise=[c]