{-# 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