{-# LANGUAGE UndecidableInstances #-}

-- | Core types and functions for HTTP
module Mig.Core.Types.Http (
  -- * types
  Request (..),
  Response (..),
  ResponseBody (..),
  HeaderMap,
  QueryMap,
  ToText (..),

  -- * responses
  okResponse,
  badResponse,
  badRequest,
  setContent,
  noContentResponse,

  -- * utils
  setRespStatus,
  addRespHeaders,
  toFullPath,
) where

import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BL
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as TL
import Mig.Core.Class.MediaType (MediaType, ToMediaType (..), ToRespBody (..))
import Network.HTTP.Media.RenderHeader
import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)
import Network.HTTP.Types.Method (Method)
import Network.HTTP.Types.Status (Status, ok200, status500)

-- | Http response
data Response = Response
  { Response -> Status
status :: Status
  -- ^ status
  , Response -> ResponseHeaders
headers :: ResponseHeaders
  -- ^ headers
  , Response -> ResponseBody
body :: ResponseBody
  -- ^ response body
  }
  deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show, Response -> Response -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq)

-- | Response with no content
noContentResponse :: Status -> Response
noContentResponse :: Status -> Response
noContentResponse Status
status = Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status [] (MediaType -> ByteString -> ResponseBody
RawResp MediaType
"*/*" ByteString
"")

-- | Http response body
data ResponseBody
  = RawResp MediaType BL.ByteString
  | FileResp FilePath
  | StreamResp
  deriving (Int -> ResponseBody -> ShowS
[ResponseBody] -> ShowS
ResponseBody -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseBody] -> ShowS
$cshowList :: [ResponseBody] -> ShowS
show :: ResponseBody -> String
$cshow :: ResponseBody -> String
showsPrec :: Int -> ResponseBody -> ShowS
$cshowsPrec :: Int -> ResponseBody -> ShowS
Show, ResponseBody -> ResponseBody -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseBody -> ResponseBody -> Bool
$c/= :: ResponseBody -> ResponseBody -> Bool
== :: ResponseBody -> ResponseBody -> Bool
$c== :: ResponseBody -> ResponseBody -> Bool
Eq)

-- | Http request
data Request = Request
  { Request -> [Text]
path :: [Text]
  -- ^ URI path
  , Request -> Map ByteString (Maybe ByteString)
query :: QueryMap
  -- ^ query parameters
  , Request -> CaptureMap
capture :: CaptureMap
  -- ^ capture from path
  , Request -> HeaderMap
headers :: HeaderMap
  -- ^ request headers
  , Request -> ByteString
method :: Method
  -- ^ request method
  , Request -> IO (Either Text ByteString)
readBody :: IO (Either Text BL.ByteString)
  -- ^ lazy body reader. Error can happen if size is too big (configured on running the server)
  , Request -> Bool
isSecure :: Bool
  -- ^ was this request made over SSL connection
  }

-- | Headers as map
type HeaderMap = Map HeaderName ByteString

-- | Captures as map
type CaptureMap = Map Text Text

-- | Map of query parameters for fast-access
type QueryMap = Map ByteString (Maybe ByteString)

-- | Bad request response
badRequest :: forall media a. (ToRespBody media a) => a -> Response
badRequest :: forall {k} (media :: k) a. ToRespBody media a => a -> Response
badRequest a
message = forall {k} (mime :: k) a.
ToRespBody mime a =>
Status -> a -> Response
badResponse @media Status
status500 a
message

-- | Values convertible to lazy text
class ToText a where
  toText :: a -> Text

instance ToText TL.Text where
  toText :: Text -> Text
toText = Text -> Text
TL.toStrict

instance ToText Text where
  toText :: Text -> Text
toText = forall a. a -> a
id

instance ToText Int where
  toText :: Int -> Text
toText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToText Float where
  toText :: Float -> Text
toText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToText String where
  toText :: String -> Text
toText = forall a. IsString a => String -> a
fromString

{-# INLINE setContent #-}

-- | Headers to set content type
setContent :: MediaType -> ResponseHeaders
setContent :: MediaType -> ResponseHeaders
setContent MediaType
media =
  [(HeaderName
"Content-Type", forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
media)]

-- | Sets response status
setRespStatus :: Status -> Response -> Response
setRespStatus :: Status -> Response -> Response
setRespStatus Status
status (Response Status
_ ResponseHeaders
headers ResponseBody
body) = Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status ResponseHeaders
headers ResponseBody
body

addRespHeaders :: ResponseHeaders -> Response -> Response
addRespHeaders :: ResponseHeaders -> Response -> Response
addRespHeaders ResponseHeaders
headers (Response Status
status ResponseHeaders
hs ResponseBody
body) = Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status (ResponseHeaders
headers forall a. Semigroup a => a -> a -> a
<> ResponseHeaders
hs) ResponseBody
body

-- | Respond with ok 200-status
okResponse :: forall mime a. (ToRespBody mime a) => a -> Response
okResponse :: forall {k} (media :: k) a. ToRespBody media a => a -> Response
okResponse = Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
ok200 (MediaType -> ResponseHeaders
setContent MediaType
media) forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> ByteString -> ResponseBody
RawResp MediaType
media forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ty :: k) b. ToRespBody ty b => b -> ByteString
toRespBody @mime
  where
    media :: MediaType
media = forall {k} (a :: k). ToMediaType a => MediaType
toMediaType @mime

-- | Bad response qith given status
badResponse :: forall mime a. (ToRespBody mime a) => Status -> a -> Response
badResponse :: forall {k} (mime :: k) a.
ToRespBody mime a =>
Status -> a -> Response
badResponse Status
status = Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status (MediaType -> ResponseHeaders
setContent MediaType
media) forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> ByteString -> ResponseBody
RawResp MediaType
media forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (ty :: k) b. ToRespBody ty b => b -> ByteString
toRespBody @mime
  where
    media :: MediaType
media = forall {k} (a :: k). ToMediaType a => MediaType
toMediaType @mime

toFullPath :: Request -> Text
toFullPath :: Request -> Text
toFullPath Request
req = Text -> [Text] -> Text
Text.intercalate Text
"/" Request
req.path forall a. Semigroup a => a -> a -> a
<> Text
queries
  where
    queries :: Text
queries
      | forall k a. Map k a -> Bool
Map.null Request
req.query = forall a. Monoid a => a
mempty
      | Bool
otherwise = Text
"?" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"&" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Maybe ByteString) -> Text
fromQuery (forall k a. Map k a -> [(k, a)]
Map.toList Request
req.query))

    fromQuery :: (ByteString, Maybe ByteString) -> Text
fromQuery (ByteString
name, Maybe ByteString
mVal) = case Maybe ByteString
mVal of
      Just ByteString
val -> Text
nameText forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeUtf8 ByteString
val
      Maybe ByteString
Nothing -> Text
nameText
      where
        nameText :: Text
nameText = ByteString -> Text
Text.decodeUtf8 ByteString
name