{-# 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       = m Request -> RouteT url m Request
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> RouteT url m a -> RouteT url m a
localRq Request -> Request
f RouteT url m a
m = (m a -> m a) -> RouteT url m a -> RouteT url m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((Request -> Request) -> m a -> m a
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     = m () -> RouteT url m ()
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m () -> RouteT url m ())
-> ((a -> a) -> m ()) -> (a -> a) -> RouteT url m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter
    composeFilter :: (a -> a) -> RouteT url m ()
composeFilter = m () -> RouteT url m ()
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m () -> RouteT url m ())
-> ((a -> a) -> m ()) -> (a -> a) -> RouteT url m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: RouteT url m b -> RouteT url m (b, a -> a)
getFilter     = (m b -> m (b, a -> a))
-> RouteT url m b -> RouteT url m (b, a -> a)
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT m b -> m (b, a -> a)
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 :: a -> RouteT url m b
finishWith = m b -> RouteT url m b
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m b -> RouteT url m b) -> (a -> m b) -> a -> RouteT url m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
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       = m RqEnv -> RouteT url m RqEnv
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT m RqEnv
forall (m :: * -> *). HasRqData m => m RqEnv
askRqEnv
    localRqEnv :: (RqEnv -> RqEnv) -> RouteT url m a -> RouteT url m a
localRqEnv RqEnv -> RqEnv
f RouteT url m a
m = (m a -> m a) -> RouteT url m a -> RouteT url m a
forall (m :: * -> *) a (n :: * -> *) b url.
(m a -> n b) -> RouteT url m a -> RouteT url n b
mapRouteT ((RqEnv -> RqEnv) -> m a -> m a
forall (m :: * -> *) a.
HasRqData m =>
(RqEnv -> RqEnv) -> m a -> m a
localRqEnv RqEnv -> RqEnv
f) RouteT url m a
m
    rqDataError :: Errors String -> RouteT url m a
rqDataError    = m a -> RouteT url m a
forall (m :: * -> *) a url. m a -> RouteT url m a
liftRouteT (m a -> RouteT url m a)
-> (Errors String -> m a) -> Errors String -> RouteT url m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors String -> m a
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 :: Text -> Text -> Site url (m a) -> m a
implSite Text
domain Text
approot Site url (m a)
siteSpec =
  do Either String a
r <- Text -> Text -> Site url (m a) -> m (Either String a)
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
_) -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       (Right a
a) -> a -> m 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_ :: Text -> Text -> Site url (m a) -> m (Either String a)
implSite_ Text
domain Text
approot Site url (m a)
siteSpec =
    String -> m (Either String a) -> m (Either String a)
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dirs (Text -> String
Text.unpack Text
approot) (m (Either String a) -> m (Either String a))
-> m (Either String a) -> m (Either String a)
forall a b. (a -> b) -> a -> b
$
         do Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
            let f :: Either String (m a)
f        = Text -> Site url (m a) -> [Text] -> Either String (m a)
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 ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ Request -> [String]
rqPaths Request
rq)
            case Either String (m a)
f of
              (Left String
parseError) -> Either String a -> m (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
parseError)
              (Right m a
sp)   -> a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> m a -> m (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (Request -> Request -> Request
forall a b. a -> b -> a
const (Request -> Request -> Request) -> Request -> Request -> Request
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 :: URL m -> m Response
seeOtherURL URL m
url =
    do Text
otherURL <- URL m -> m Text
forall (m :: * -> *). MonadRoute m => URL m -> m Text
showURL URL m
url
       String -> Response -> m Response
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (Text -> String
Text.unpack Text
otherURL) (String -> Response
forall a. ToMessage a => a -> Response
toResponse String
"")