urldisp-happstack (empty) → 0.1

raw patch · 4 files changed

+232/−0 lines, 4 filesdep +basedep +bytestringdep +happstack-serversetup-changed

Dependencies added: base, bytestring, happstack-server, mtl

Files

• Happstack/UrlDisp.hs +180/−0
• LICENSE +27/−0
• Setup.hs +2/−0
• urldisp-happstack.cabal +23/−0

@@ -0,0 +1,180 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, MultiParamTypeClasses #-}+module Happstack.UrlDisp (+    -- * Run the monad+    runUrlDisp,+    -- * Verbose API+    path, meth, param, takePath, readPath, endPath, getInput, getInputMay,+    -- * Infix API+    h, (|/), (|//), (|?), (|\), (|\\), (|.),+    UrlS(..), UrlDisp(..),+    -- * Lifted catch+    spCatch+  ) where++import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)+import qualified Happstack.Server as HS+import Happstack.Server hiding (path)+import Control.Applicative+import qualified Control.Exception as C+import Control.Monad.State.Strict+import Data.Char+import qualified Data.ByteString.Lazy.Char8 as BS++spCatch :: (C.Exception e) =>+           ServerPartT IO a -> (e -> ServerPartT IO a) -> ServerPartT IO a+spCatch sp exhandler = mapServerPartT' go sp+    where go req act = (act >>= forceIt) `C.catch` \e -> ununWebT $ runServerPartT (exhandler e) req+          forceIt Nothing = return Nothing+          forceIt x@(Just (eitherResp,_)) = do+            either (\y -> C.evaluate y >>= const (return ()))+                   (\y -> C.evaluate y >>= const (return ()))+                    eitherResp+            return x+++data UrlS = UrlS { pPath :: [String] }++newtype UrlDisp m a = UrlDisp {unUrlDisp :: (StateT UrlS m a)}+    deriving (Functor, Monad, MonadState UrlS, ServerMonad, MonadIO, Applicative, MonadPlus)+++instance (Monad m) => WebMonad Response (UrlDisp (ServerPartT m)) where+    finishWith r = lift $ anyRequest $ finishWith r++instance (FilterMonad Response m,  Monad m) => FilterMonad Response (StateT UrlS m) where+    setFilter f = lift (setFilter f)+    composeFilter f = lift (composeFilter f)+    getFilter f = StateT $ \st -> getFilter (runStateT f st) >>=+                                 \((b,s),fun) -> return ((b,fun),s)++instance (FilterMonad Response m, Monad m) => FilterMonad Response (UrlDisp m) where+    setFilter f = lift (setFilter f)+    composeFilter f = lift (composeFilter f)+    getFilter f = UrlDisp .  getFilter . unUrlDisp $ f++instance MonadTrans UrlDisp where+    lift m = UrlDisp $ lift m++instance ServerMonad m => ServerMonad (StateT UrlS m) where+    askRq = lift askRq+    localRq f m = StateT $ localRq f . runStateT m++instance Monad m => Applicative (StateT UrlS m) where+    pure = return+    (<*>) = ap++instance (Monad m, MonadPlus m, Functor m) => Alternative (UrlDisp m) where+    empty = mzero+    (<|>) = mplus+++instance Alternative (ServerPartT IO) where+    empty = mzero+    (<|>) = mplus++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+    [(x,"")] -> Just x+    _ -> Nothing++-- | Unpacks a UrlDisp into a plain old ServerMonad. Used as a top-level wrapper.+runUrlDisp :: ServerMonad m => UrlDisp m a -> m a+runUrlDisp d = evalStateT (unUrlDisp d) . UrlS . rqPaths =<< askRq++-- | Filters on and consumes the next element of the url path.+-- @ path \"str\" @ will match requests whose next path element is \"str\"+-- Consumption of the path element backtracks on failure.+path :: (MonadState UrlS m, Alternative m) => String -> m ()+path x = pPath <$> get >>= f where+    f (p:ps) = if p == x then modify (\par -> par {pPath = ps}) else empty+    f _ = empty++-- | Filters on the request method.+-- @ meth \"GET\" @ will match requests made using get.+meth :: (ServerMonad m, MonadPlus m) => String -> m ()+meth m = case (maybeRead :: String -> Maybe Method) (map toUpper m) of+           Nothing -> mzero+           Just x  -> methodOnly x++-- | Filters on any parameter (via put or get).+-- @ param (\"cmd\", \"foo\") @ will match on ?cmd=foo+param :: (ServerMonad m, Alternative m) => (String, String) -> m ()+param (k,v) = getInput k >>= \x -> if x == v then return () else empty++-- | Returns a string representation of a parameter, if available. Otherwise fails.+getInput :: (ServerMonad f, Alternative f) => String -> f String+getInput x  = maybe empty return . fmap (BS.unpack . inputValue) . lookup x . rqInputs =<< askRq++-- | Returns Just a string representation of a parameter, or Nothing.+getInputMay :: (ServerMonad f, Alternative f) => String -> f (Maybe String)+getInputMay x  = fmap (BS.unpack . inputValue) . lookup x . rqInputs <$> askRq++-- | Matches and consumes the next element of the path if+-- that element can be successfully read as the proper type. The parsed+-- element is returned.+readPath :: (Read a, MonadState UrlS m, Alternative m) => m a+readPath = pPath <$> get >>= f where+    f (p:ps) = maybe empty ((modify (\par -> par {pPath = ps}) >>) . return) (maybeRead p)+    f _ = empty++-- | Combinator that consumes the next element of the path and passes it+-- as an unparsed string into the following lambda expression.+-- @ h `takePath` \\x -> output (x++\"99\") @ will match on \"\/12\" and+-- output \"1299\"+-- Consumption of the path element backtracks on failure.+takePath :: (MonadState UrlS m, Alternative m) => m String+takePath = pPath <$> get >>= f where+    f (p:ps) = modify (\par -> par {pPath = ps}) >> return p+    f _ = empty++-- | Only matches if the remaining path is empty.+endPath :: (MonadState UrlS m, Alternative m) => m ()+endPath = pPath <$> get >>= \pss -> if null pss then return () else empty+++-- another variant of the API++infixl 4 |/, |//, |?, |\, |\\, |.+++-- | A null CGI action, used to begin a string of path combinators+h :: (ServerMonad m) => m ()+h = return ()++-- | Combinator that filters on and consumes the next element of the url+-- path.+-- @ h |\/ \"dir\" |\/ \"subdir\" @ will match \"\/dir\/subdir\".+-- Consumtion of the path element backtracks on failure.+(|/) :: (MonadState UrlS m, Alternative m) => m a -> String -> m ()+x |/ y = x >> path y++-- | Combinator that filters on the request method.+-- @ h |\/\/ \"GET\" @ will match requests made using get.+(|//) :: (ServerMonad m, MonadPlus m) => m a -> String -> m ()+x |// y = x >> meth y++-- | Combinator that filters on any parameter (via put or get).+-- @ h |? (\"cmd\",\"foo\") @ will match on ?cmd=foo+(|?) :: (ServerMonad m, Alternative m) => m a -> (String, String) -> m ()+x |? y = x >> param y++-- | Combinator that matches and consumes the next element of the path+-- if path element can be successfully read as the proper type and passed+-- to the following lambda expression.+-- @ h |\\ \\x -> output (x + (1.5::Float)) @ will match on \"\/12\"+-- and output \"13.5\". Consumption of the path element backtracks+-- on failure.+(|\) :: (Read x, MonadState UrlS m, Alternative m) => m a -> (x -> m b) -> m b+x |\ f = x >> readPath >>= f++-- | Combinator that consumes the next element of the path and passes it+-- as an unparsed string into the following lambda expression.+-- @ h |\\\\ \\x -> output (x++\"99\") @ will match on \"\/12\"+-- and output \"1299\"+-- Consumtion of the path element backtracks on failure.+(|\\) :: (MonadState UrlS m, Alternative m) => m a -> (String -> m b) -> m b+x |\\ f = x >> takePath >>= f++-- | Combinator that only matches if the remaining path is empty.+(|.) :: (MonadState UrlS m, Alternative m) => m a -> m  b -> m b+x |. f = x >> endPath >> f

@@ -0,0 +1,27 @@+Copyright (c) Sterling Clover 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,23 @@+name:                urldisp-happstack+version:             0.1+synopsis:            Simple, declarative, expressive URL routing -- on happstack.+description:         UrlDisp combinators ported over happstack, as well as a lifted catch.+category:            Language+license:             BSD3+license-file:        LICENSE+author:              Sterling Clover+maintainer:          s.clover@gmail.com+Tested-With:         GHC == 6.10.3+Build-Type:          Simple+Cabal-Version:       >= 1.6++library+  build-depends:     base >= 4, base < 5, mtl, bytestring, happstack-server+  exposed-modules:   Happstack.UrlDisp+  ghc-options:       -Wall+  if impl(ghc >= 6.8)+    ghc-options:     -fwarn-tabs++source-repository head+  type:     darcs+  location: http://code.haskell.org/~sclv/urldisp-happstack