{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, UndecidableInstances, PackageImports #-}
module Web.Routes.Happstack where

import Control.Applicative ((<$>))
import Control.Monad (MonadPlus(mzero))
import qualified Data.ByteString.Char8 as C
import Data.List (intercalate)
import           Data.Text (Text)
import qualified Data.Text as Text
import Happstack.Server (Happstack, FilterMonad(..), ServerMonad(..), WebMonad(..), HasRqData(..), ServerPartT, Response, Request(rqPaths), ToMessage(..), dirs, seeOther)
import Web.Routes.RouteT (RouteT(RouteT), MonadRoute, URL, showURL, liftRouteT, mapRouteT)
import Web.Routes.Site (Site, runSite)

instance (ServerMonad m) => ServerMonad (RouteT url m) where
    askRq :: RouteT url m Request
askRq       = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: forall a. (Request -> Request) -> RouteT url m a -> RouteT url m a
localRq Request -> Request
f RouteT url m a
m = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT (forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f) RouteT url m a
m

instance (FilterMonad a m) => FilterMonad a (RouteT url m) where
    setFilter :: (a -> a) -> RouteT url m ()
setFilter     = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter
    composeFilter :: (a -> a) -> RouteT url m ()
composeFilter = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: forall b. RouteT url m b -> RouteT url m (b, a -> a)
getFilter     = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter

instance (WebMonad a m) => WebMonad a (RouteT url m) where
    finishWith :: forall b. a -> RouteT url m b
finishWith = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

instance (HasRqData m) => HasRqData (RouteT url m) where
    askRqEnv :: RouteT url m RqEnv
askRqEnv       = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall (m :: * -> *). HasRqData m => m RqEnv
askRqEnv
    localRqEnv :: forall a. (RqEnv -> RqEnv) -> RouteT url m a -> RouteT url m a
localRqEnv RqEnv -> RqEnv
f RouteT url m a
m = forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT (forall (m :: * -> *) a.
HasRqData m =>
(RqEnv -> RqEnv) -> m a -> m a
localRqEnv RqEnv -> RqEnv
f) RouteT url m a
m
    rqDataError :: forall a. Errors String -> RouteT url m a
rqDataError    = forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. HasRqData m => Errors String -> m a
rqDataError

instance (Happstack m) => Happstack (RouteT url m)

-- | convert a 'Site' to a normal Happstack route
--
-- calls 'mzero' if the route can be decoded.
--
-- see also: 'implSite_'
implSite :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
            Text           -- ^ "http://example.org"
         -> Text           -- ^ path to this handler, .e.g. "/route/" or ""
         -> Site url (m a) -- ^ the 'Site'
         -> m a
implSite :: forall (m :: * -> *) url a.
(Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -> Text -> Site url (m a) -> m a
implSite Text
domain Text
approot Site url (m a)
siteSpec =
  do Either String a
r <- forall (m :: * -> *) url a.
(Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -> Text -> Site url (m a) -> m (Either String a)
implSite_ Text
domain Text
approot Site url (m a)
siteSpec
     case Either String a
r of
       (Left String
_) -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
       (Right a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | convert a 'Site' to a normal Happstack route
--
-- If url decoding fails, it returns @Left "the parse error"@,
-- otherwise @Right a@.
--
-- see also: 'implSite'
implSite_ :: (Functor m, Monad m, MonadPlus m, ServerMonad m) =>
             Text          -- ^ "http://example.org" (or "http://example.org:80")
          -> Text        -- ^ path to this handler, .e.g. "/route/" or ""
          -> Site url (m a)  -- ^ the 'Site'
          -> m (Either String a)
implSite_ :: forall (m :: * -> *) url a.
(Functor m, Monad m, MonadPlus m, ServerMonad m) =>
Text -> Text -> Site url (m a) -> m (Either String a)
implSite_ Text
domain Text
approot Site url (m a)
siteSpec =
    forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dirs (Text -> String
Text.unpack Text
approot) forall a b. (a -> b) -> a -> b
$
         do Request
rq <- forall (m :: * -> *). ServerMonad m => m Request
askRq
            let f :: Either String (m a)
f        = forall url a. Text -> Site url a -> [Text] -> Either String a
runSite (Text
domain Text -> Text -> Text
`Text.append` Text
approot) Site url (m a)
siteSpec (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ Request -> [String]
rqPaths Request
rq)
            case Either String (m a)
f of
              (Left String
parseError) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left String
parseError)
              (Right m a
sp)   -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Request
rq { rqPaths :: [String]
rqPaths = [] }) m a
sp)
{-
implSite__ :: (Monad m) => String -> FilePath -> ([ErrorMsg] -> ServerPartT m a) -> Site url (ServerPartT m a) -> (ServerPartT m a)
implSite__ domain approot handleError siteSpec =
    dirs approot $ do rq <- askRq
                      let pathInfo = intercalate "/" (rqPaths rq)
                          f        = runSite (domain ++ approot) siteSpec pathInfo
                      case f of
                        (Failure errs) -> handleError errs
                        (Success sp)   -> localRq (const $ rq { rqPaths = [] }) sp
-}

-- | similar to 'seeOther' but takes a 'URL' 'm' as an argument
seeOtherURL :: (MonadRoute m, FilterMonad Response m) => URL m -> m Response
seeOtherURL :: forall (m :: * -> *).
(MonadRoute m, FilterMonad Response m) =>
URL m -> m Response
seeOtherURL URL m
url =
    do Text
otherURL <- forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL m
url
       forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (Text -> String
Text.unpack Text
otherURL) (forall a. ToMessage a => a -> Response
toResponse String
"")