module WebGear.Route
( RouterT
, MonadRouter (..)
, runRoute
) where
import Control.Applicative (Alternative)
import Control.Arrow (Kleisli (..))
import Control.Monad (MonadPlus (..))
import Control.Monad.Except (ExceptT, MonadError (..), runExceptT)
import Data.ByteString.Lazy (ByteString)
import Data.HashMap.Strict (fromList)
import Data.Semigroup (First (..))
import Data.String (fromString)
import Data.Version (showVersion)
import Network.HTTP.Types (Header, hServer, notFound404)
import Paths_webgear_server (version)
import WebGear.Trait (linkzero, unlink)
import WebGear.Types (Handler, Response (..), waiResponse)
import qualified Network.Wai as Wai
type RouterT m = ExceptT (Maybe (First (Response ByteString))) m
class (Alternative m, MonadPlus m) => MonadRouter m where
rejectRoute :: m a
failHandler :: Response ByteString -> m a
instance Monad m => MonadRouter (RouterT m) where
rejectRoute :: RouterT m a
rejectRoute :: RouterT m a
rejectRoute = RouterT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
failHandler :: Response ByteString -> RouterT m a
failHandler :: Response ByteString -> RouterT m a
failHandler = Maybe (First (Response ByteString)) -> RouterT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Maybe (First (Response ByteString)) -> RouterT m a)
-> (Response ByteString -> Maybe (First (Response ByteString)))
-> Response ByteString
-> RouterT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First (Response ByteString) -> Maybe (First (Response ByteString))
forall a. a -> Maybe a
Just (First (Response ByteString)
-> Maybe (First (Response ByteString)))
-> (Response ByteString -> First (Response ByteString))
-> Response ByteString
-> Maybe (First (Response ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> First (Response ByteString)
forall a. a -> First a
First
runRoute :: Monad m
=> Handler (RouterT m) '[] res ByteString
-> (Wai.Request -> m Wai.Response)
runRoute :: Handler (RouterT m) '[] res ByteString -> Request -> m Response
runRoute route :: Handler (RouterT m) '[] res ByteString
route req :: Request
req = Response ByteString -> Response
waiResponse (Response ByteString -> Response)
-> (Either
(Maybe (First (Response ByteString))) (Response ByteString)
-> Response ByteString)
-> Either
(Maybe (First (Response ByteString))) (Response ByteString)
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Response ByteString
addServerHeader (Response ByteString -> Response ByteString)
-> (Either
(Maybe (First (Response ByteString))) (Response ByteString)
-> Response ByteString)
-> Either
(Maybe (First (Response ByteString))) (Response ByteString)
-> Response ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (First (Response ByteString)) -> Response ByteString)
-> (Response ByteString -> Response ByteString)
-> Either
(Maybe (First (Response ByteString))) (Response ByteString)
-> Response ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString
-> (First (Response ByteString) -> Response ByteString)
-> Maybe (First (Response ByteString))
-> Response ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Response ByteString
notFoundResponse First (Response ByteString) -> Response ByteString
forall a. First a -> a
getFirst) Response ByteString -> Response ByteString
forall a. a -> a
id (Either (Maybe (First (Response ByteString))) (Response ByteString)
-> Response)
-> m (Either
(Maybe (First (Response ByteString))) (Response ByteString))
-> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
(Maybe (First (Response ByteString))) m (Response ByteString)
-> m (Either
(Maybe (First (Response ByteString))) (Response ByteString))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
(Maybe (First (Response ByteString))) m (Response ByteString)
f
where
f :: ExceptT
(Maybe (First (Response ByteString))) m (Response ByteString)
f = Linked res (Response ByteString) -> Response ByteString
forall (ts :: [*]) a. Linked ts a -> a
unlink (Linked res (Response ByteString) -> Response ByteString)
-> RouterT m (Linked res (Response ByteString))
-> ExceptT
(Maybe (First (Response ByteString))) m (Response ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler (RouterT m) '[] res ByteString
-> Linked '[] Request
-> RouterT m (Linked res (Response ByteString))
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler (RouterT m) '[] res ByteString
route (Request -> Linked '[] Request
forall a. a -> Linked '[] a
linkzero Request
req)
notFoundResponse :: Response ByteString
notFoundResponse :: Response ByteString
notFoundResponse = Response :: forall a.
Status -> HashMap HeaderName ByteString -> Maybe a -> Response a
Response
{ respStatus :: Status
respStatus = Status
notFound404
, respHeaders :: HashMap HeaderName ByteString
respHeaders = [(HeaderName, ByteString)] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList []
, respBody :: Maybe ByteString
respBody = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "Not Found"
}
addServerHeader :: Response ByteString -> Response ByteString
addServerHeader :: Response ByteString -> Response ByteString
addServerHeader r :: Response ByteString
r = Response ByteString
r { respHeaders :: HashMap HeaderName ByteString
respHeaders = Response ByteString -> HashMap HeaderName ByteString
forall a. Response a -> HashMap HeaderName ByteString
respHeaders Response ByteString
r HashMap HeaderName ByteString
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall a. Semigroup a => a -> a -> a
<> [(HeaderName, ByteString)] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList [(HeaderName, ByteString)
serverHeader] }
serverHeader :: Header
serverHeader :: (HeaderName, ByteString)
serverHeader = (HeaderName
hServer, String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "WebGear/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version)