-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Common types and functions used throughout WebGear.
module WebGear.Types
  ( -- * WebGear Request
    -- | WebGear requests are WAI requests. This module reexports a number
    -- of useful functions that operate on requests from "Network.Wai"
    -- module.
    Request
  , remoteHost
  , httpVersion
  , isSecure
  , requestMethod
  , pathInfo
  , setPathInfo
  , queryString
  , requestHeaders
  , requestHeader
  , requestBodyLength
  , getRequestBodyChunk

    -- * WebGear Response
  , Response (..)
  , waiResponse
  , addResponseHeader

  , Handler
  , Middleware
  , RequestMiddleware
  , ResponseMiddleware
  ) where

import Control.Arrow (Kleisli)
import Data.ByteString (ByteString)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Network.HTTP.Types (Header, HeaderName, Status)
import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString,
                    remoteHost, requestBodyLength, requestHeaders, requestMethod)

import WebGear.Trait (Linked)

import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HM
import qualified Network.Wai as Wai


-- | Get the value of a request header
requestHeader :: HeaderName -> Request -> Maybe ByteString
requestHeader :: HeaderName -> Request -> Maybe ByteString
requestHeader h :: HeaderName
h r :: Request
r = (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString) -> ByteString)
-> Maybe (HeaderName, ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
h) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> [(HeaderName, ByteString)]
requestHeaders Request
r)

-- | Get request with an updated URL path info.
setPathInfo :: [Text] -> Request -> Request
setPathInfo :: [Text] -> Request -> Request
setPathInfo p :: [Text]
p r :: Request
r = Request
r { pathInfo :: [Text]
pathInfo = [Text]
p }

-- | A response sent from the server to the client.
--
-- The response contains a status, optional headers and an optional
-- body of type @a@.
data Response a = Response
    { Response a -> Status
respStatus  :: Status                            -- ^ Response status code
    , Response a -> HashMap HeaderName ByteString
respHeaders :: HM.HashMap HeaderName ByteString  -- ^ Response headers
    , Response a -> Maybe a
respBody    :: Maybe a                           -- ^ Optional response body
    }

-- | Convert a WebGear response to a WAI Response.
waiResponse :: Response LBS.ByteString -> Wai.Response
waiResponse :: Response ByteString -> Response
waiResponse Response{..} = Status -> [(HeaderName, ByteString)] -> ByteString -> Response
Wai.responseLBS Status
respStatus (HashMap HeaderName ByteString -> [(HeaderName, ByteString)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap HeaderName ByteString
respHeaders) (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "" Maybe ByteString
respBody)

-- | Create or update a response header.
addResponseHeader :: Header -> Response a -> Response a
addResponseHeader :: (HeaderName, ByteString) -> Response a -> Response a
addResponseHeader (name :: HeaderName
name, val :: ByteString
val) resp :: Response a
resp = Response a
resp { respHeaders :: HashMap HeaderName ByteString
respHeaders = (ByteString -> ByteString -> ByteString)
-> HeaderName
-> ByteString
-> HashMap HeaderName ByteString
-> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith ByteString -> ByteString -> ByteString
forall b c. b -> c -> c
f HeaderName
name ByteString
val (Response a -> HashMap HeaderName ByteString
forall a. Response a -> HashMap HeaderName ByteString
respHeaders Response a
resp) }
  where
    f :: b -> c -> c
f = (c -> b -> c) -> b -> c -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip c -> b -> c
forall a b. a -> b -> a
const

-- | A handler is a function from a request to response in a monadic
-- context. Both the request and the response can have linked traits.
--
-- The type level list @req@ contains all the traits expected to be
-- present in the request. The handler will produce a response that
-- satisfies all the traits in the type level list @res@.
type Handler m req res a = Kleisli m (Linked req Request) (Linked res (Response a))

-- | A middleware takes a handler as input and produces another
-- handler that usually adds some functionality.
--
-- A middleware can do a number of things with the request
-- handling such as:
--
--   * Change the request traits before invoking the handler.
--   * Change the response traits before passing it back to its caller.
--   * Use the linked value of any of the request or response traits.
--   * Change the response body.
--
type Middleware m req req' res' res a' a = Handler m req' res' a' -> Handler m req res a

-- | A middleware that manipulates only the request traits and leaves
-- the response unchanged.
type RequestMiddleware m req req' res a = Middleware m req req' res res a a

-- | A middleware that manipulates only the response traits and leaves
-- the request unchanged.
type ResponseMiddleware m req res' res a = Middleware m req req res' res a a