-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Types and functions to route HTTP requests.
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


-- | The monad transformer stack for routing.
--
-- * The 'ExceptT' provides short-circuiting behaviour for
--   'rejectRoute' and 'failHandler'.
--
-- * In case of 'rejectRoute', a 'Nothing' value is returned and in
--   case of 'failHandler', a @Response ByteString@ is returned.
--
-- * The 'First' wrapper is provided to get instances of 'Alternative'
--   and 'MonadPlus' for 'RouterT'.
--
type RouterT m = ExceptT (Maybe (First (Response ByteString))) m

-- | HTTP request routing with short circuiting behavior.
class (Alternative m, MonadPlus m) => MonadRouter m where
  -- | Mark the current route as rejected, alternatives can be tried
  rejectRoute :: m a

  -- | Short-circuit the current handler and return a response
  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

-- | Convert a routable handler into a plain function.
--
-- This function is typically used to convert WebGear routes to a
-- 'Wai.Application'.
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)