module Happstack.UrlDisp (
runUrlDisp,
path, meth, param, takePath, readPath, endPath, getInput, getInputMay,
h, (|/), (|//), (|?), (|\), (|\\), (|.),
UrlS(..), UrlDisp(..),
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
runUrlDisp :: ServerMonad m => UrlDisp m a -> m a
runUrlDisp d = evalStateT (unUrlDisp d) . UrlS . rqPaths =<< askRq
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
meth :: (ServerMonad m, MonadPlus m) => String -> m ()
meth m = case (maybeRead :: String -> Maybe Method) (map toUpper m) of
Nothing -> mzero
Just x -> methodOnly x
param :: (ServerMonad m, Alternative m) => (String, String) -> m ()
param (k,v) = getInput k >>= \x -> if x == v then return () else empty
getInput :: (ServerMonad f, Alternative f) => String -> f String
getInput x = maybe empty return . fmap (BS.unpack . inputValue) . lookup x . rqInputs =<< askRq
getInputMay :: (ServerMonad f, Alternative f) => String -> f (Maybe String)
getInputMay x = fmap (BS.unpack . inputValue) . lookup x . rqInputs <$> askRq
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
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
endPath :: (MonadState UrlS m, Alternative m) => m ()
endPath = pPath <$> get >>= \pss -> if null pss then return () else empty
infixl 4 |/, |//, |?, |\, |\\, |.
h :: (ServerMonad m) => m ()
h = return ()
(|/) :: (MonadState UrlS m, Alternative m) => m a -> String -> m ()
x |/ y = x >> path y
(|//) :: (ServerMonad m, MonadPlus m) => m a -> String -> m ()
x |// y = x >> meth y
(|?) :: (ServerMonad m, Alternative m) => m a -> (String, String) -> m ()
x |? y = x >> param y
(|\) :: (Read x, MonadState UrlS m, Alternative m) => m a -> (x -> m b) -> m b
x |\ f = x >> readPath >>= f
(|\\) :: (MonadState UrlS m, Alternative m) => m a -> (String -> m b) -> m b
x |\\ f = x >> takePath >>= f
(|.) :: (MonadState UrlS m, Alternative m) => m a -> m b -> m b
x |. f = x >> endPath >> f