Types.hs

-- | Internal types and functions
module Mig.Internal.Types
  ( -- * types
    Server (..)
  , Req (..)
  , Resp (..)
  , RespBody (..)
  , QueryMap
  , ToText (..)
  , Error (..)
  -- * constructors
  , toConst
  , toMethod
  , toWithBody
  , toWithCapture
  , toWithPath
  , toWithHeader
  , toWithFormData
  , toWithPathInfo
  , FormBody (..)
  -- * responses
  , text
  , json
  , html
  , raw
  , ok
  , badRequest
  , setContent
  -- * WAI
  , ServerConfig (..)
  , Kilobytes
  , toApplication
  -- * utils
  , setRespStatus
  , handleError
  , toResponse
  , fromRequest
  , pathHead
  ) where

import Data.Bifunctor
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as TL
import Data.Aeson (ToJSON)
import Data.Aeson qualified as Json
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Text.Blaze.Html (Html)
import Text.Blaze.Html (ToMarkup)
import Text.Blaze.Html qualified as Html
import Network.HTTP.Types.Method (Method)
import Network.HTTP.Types.Header (ResponseHeaders, RequestHeaders, HeaderName)
import Network.HTTP.Types.Status (Status, ok200, status500, status413)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text.Encoding qualified as Text
import Data.List qualified as List
import Network.Wai
import Text.Blaze.Renderer.Utf8 qualified as Html
import Data.Maybe
import Data.Sequence (Seq (..), (|>))
import Data.Sequence qualified as Seq
import Data.Foldable
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Typeable
import Network.Wai.Parse qualified as Parse

-- | Http response
data Resp = Resp
  { status :: Status
    -- ^ status
  , headers :: ResponseHeaders
    -- ^ headers
  , body :: RespBody
    -- ^ response body
  }

instance IsString Resp where
  fromString = text . TL.pack

-- | Http response body
data RespBody
  = TextResp Text
  | HtmlResp Html
  | JsonResp Json.Value
  | FileResp FilePath
  | StreamResp
  | RawResp BL.ByteString

-- | Http request
data Req = Req
  { path :: [Text]
    -- ^ URI path
  , query :: QueryMap
    -- ^ query parameters
  , headers :: RequestHeaders
    -- ^ request headers
  , method :: Method
    -- ^ request method
  , readBody :: IO (Either (Error Text) BL.ByteString)
    -- ^ lazy body reader. Error can happen if size is too big (configured on running the server)
  , readFormBody :: IO (Either (Error Text) FormBody)
  }

data FormBody = FormBody
  { params :: [(ByteString, ByteString)]
  , files :: [(ByteString, Parse.FileInfo BL.ByteString)]
  }

-- Errors

-- | Errors
data Error a = Error
  { status :: Status
    -- error status
  , body :: a
    -- message or error details
  }
  deriving (Show)

instance (Typeable a, Show a) => Exception (Error a) where

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

-- | Bad request response
badRequest :: Text -> Resp
badRequest message =
  Resp
    { status = status500
    , headers = setContent "text/plain"
    , body = TextResp message
    }

-- | Server type. It is a function fron request to response.
-- Some servers does not return valid value. We use it to find right path.
--
-- Example:
--
-- > server :: Server IO
-- > server =
-- >   "api" /. "v1" /.
-- >      mconcat
-- >        [ "foo" /. (\(Query @"name" arg) -> Get  @Json (handleFoo arg)
-- >        , "bar" /. Post @Json handleBar
-- >        ]
-- >
-- > handleFoo :: Int -> IO Text
-- > handleBar :: IO Text
--
-- Note that server is monoid and it can be constructed with Monoid functions and
-- path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers:
--
-- * @Query@ - for required query parameters
-- * @Optional@ - for optional query parameters
-- * @Capture@ - for parsing elements of URI
-- * @Body@ - fot JSON-body input
-- * @RawBody@ - for raw ByteString input
-- * @Header@ - for headers
--
-- To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc.
-- Let's discuss the structure of the constructor. Let's take Get for example:
--
-- > newtype Get ty m a = Get (m a)
--
--  Let's look at the arguments of he type
--
-- * @ty@ - type of the response. it can be: Text, Html, Json, ByteString
-- * @m@ - underlying server monad
-- * @a@ - result type. It should be convertible to the type of the response.
--
-- also result can be wrapped to special data types to modify Http-response.
-- we have wrappers:
--
-- * @SetStatus@ - to set status
-- * @AddHeaders@ - to append headers
-- * @Either (Error err)@ - to response with errors
newtype Server m = Server { unServer :: Req -> m (Maybe Resp) }

toConst :: Functor m => m Resp -> Server m
toConst act = Server $ const $ Just <$> act

toMethod :: Monad m => Method -> m Resp -> Server m
toMethod method act = Server $ checkMethod method act

checkMethod :: Monad m => Method -> m Resp -> Req -> m (Maybe Resp)
checkMethod method act req
  | null req.path && req.method == method = Just <$> act
  | otherwise = pure Nothing

toWithBody :: MonadIO m => (BL.ByteString -> Server m) -> Server m
toWithBody act = Server $ \req -> do
  eBody <- liftIO req.readBody
  case eBody of
    Right body -> unServer (act body) req
    Left err -> pure $ Just $ setRespStatus err.status (text err.body)

-- TODO: make it size limited by HTTP-body size
toWithFormData :: MonadIO m => (FormBody -> Server m) -> Server m
toWithFormData act = Server $ \req -> do
  eFormBody <- liftIO req.readFormBody
  case eFormBody of
    Right formBody -> unServer (act formBody) req
    Left err -> pure $ Just $ setRespStatus err.status (text err.body)


-- | Size of the input body
type Kilobytes = Int

-- | Read request body in chunks
readRequestBody :: IO B.ByteString -> Maybe Kilobytes -> IO (Either (Error Text) [B.ByteString])
readRequestBody readChunk maxSize = loop 0 Seq.empty
  where
    loop :: Kilobytes -> Seq B.ByteString -> IO (Either (Error Text) [B.ByteString])
    loop !currentSize !result
      | isBigger currentSize = pure outOfSize
      | otherwise = do
          chunk <- readChunk
          if B.null chunk
            then pure $ Right (toList result)
            else loop (currentSize + B.length chunk) (result |> chunk)

    outOfSize :: Either (Error Text) a
    outOfSize = Left (Error status413 (Text.pack $ "Request is too big Jim!"))

    isBigger = case maxSize of
      Just size -> \current -> current > size
      Nothing -> const False

toWithPath :: Monad m => Text -> Server m -> Server m
toWithPath route act = Server $ \req ->
  case hasPath route req.path of
    Just restPath -> unServer act (req { path = restPath })
    _ -> pure Nothing

type Path = [Text]

hasPath :: Text -> Path -> Maybe Path
hasPath route (path:restPath)
  | route == path = Just restPath
  | otherwise = Nothing
hasPath _ _ = Nothing

toWithCapture :: Monad m => (Text -> Server m) -> Server m
toWithCapture act = Server $ \req ->
  case pathHead req of
    Just (arg, nextReq) -> unServer (act arg) nextReq
    Nothing -> pure Nothing

pathHead :: Req -> Maybe (Text, Req)
pathHead req =
  case req.path of
    hd : tl -> Just (hd, req { path = tl })
    _ -> Nothing

toWithHeader :: HeaderName -> (Maybe ByteString -> Server m) -> Server m
toWithHeader name act = Server $ \req ->
  unServer (act (fmap snd $ List.find ((== name) . fst) req.headers)) req

toWithPathInfo :: ([Text] -> Server m) -> Server m
toWithPathInfo act = Server $ \req ->
  unServer (act req.path) req

instance Monad m => Semigroup (Server m) where
  (<>) (Server serverA) (Server serverB) = Server $ \req -> do
    mRespA <- serverA req
    maybe (serverB req) (pure . Just) mRespA

instance Monad m => Monoid (Server m) where
  mempty = Server (const $ pure Nothing)

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

instance ToText TL.Text where
  toText = TL.toStrict

instance ToText Text where
  toText = id

instance ToText Int where
  toText = Text.pack . show

instance ToText Float where
  toText = Text.pack . show

instance ToText String where
  toText = fromString

{-# INLINE setContent #-}
-- | Headers to set content type
setContent :: ByteString -> ResponseHeaders
setContent contentType =
  [("Content-Type", contentType <>"; charset=utf-8")]

setRespStatus :: Status -> Resp -> Resp
setRespStatus status (Resp _ headers body) = Resp status headers body

-- | Json response constructor
json :: (ToJSON resp) => resp -> Resp
json = (ok (setContent "text/json") . JsonResp . Json.toJSON)

-- | Text response constructor
text :: ToText a => a -> Resp
text = ok (setContent "text/plain") . TextResp . toText

-- | Html response constructor
html :: (ToMarkup a) => a -> Resp
html = ok (setContent "text/html") . HtmlResp . Html.toHtml

-- | Raw bytestring response constructor
raw :: BL.ByteString -> Resp
raw = ok (setContent "text/plain") . RawResp

-- | Respond with ok 200-status
ok :: ResponseHeaders -> RespBody -> Resp
ok headers body = Resp ok200 headers body

-- | Handle errors
handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m
handleError handler (Server act) = Server $ \req ->
  (act req) `catch` (\err -> unServer (handler err) req)

-------------------------------------------------------------------------------------
-- render to WAI

-- | Server config
data ServerConfig = ServerConfig
  { maxBodySize :: Maybe Kilobytes
  }

-- | Convert server to WAI-application
toApplication :: ServerConfig -> Server IO -> Application
toApplication config server req processResponse = do
  mResp <- unServer (handleError onErr server) =<< fromRequest config.maxBodySize req
  processResponse $ toResponse $ fromMaybe noResult mResp
  where
    noResult = badRequest "Server produces nothing"

    onErr :: SomeException -> Server IO
    onErr err = toConst $ pure $ badRequest $ "Error: Exception has happened: " <> toText (show err)

-- | Convert response to low-level WAI-response
toResponse :: Resp -> Response
toResponse resp =
  case resp.body of
    TextResp textResp -> lbs $ BL.fromStrict (Text.encodeUtf8 textResp)
    HtmlResp htmlResp -> lbs (Html.renderMarkup htmlResp)
    JsonResp jsonResp -> lbs (Json.encode jsonResp)
    FileResp file -> responseFile resp.status resp.headers file Nothing
    RawResp str -> lbs str
    StreamResp -> undefined
  where
    lbs = responseLBS resp.status resp.headers

-- | Read request from low-level WAI-request
-- First argument limits the size of input body. The body is read in chunks.
fromRequest :: Maybe Kilobytes -> Request -> IO Req
fromRequest maxSize req =
  pure $ Req
    { path = pathInfo req
    , query = Map.fromList $ mapMaybe (\(key, mVal) -> (key, ) <$> mVal) (queryString req)
    , headers = requestHeaders req
    , method = requestMethod req
    , readBody = fmap (fmap BL.fromChunks) $ readRequestBody (getRequestBodyChunk req) maxSize
    , readFormBody = getReadFormBody req
    }

getReadFormBody :: Request -> IO (Either (Error Text) FormBody)
getReadFormBody req = do
  case Parse.getRequestBodyType req of
    Nothing -> pure $ Right (FormBody [] [])
    Just reqBodyType -> do
      eResult <- try @IO @SomeException (Parse.sinkRequestBody Parse.lbsBackEnd reqBodyType (getRequestBodyChunk req))
      pure $ bimap (const toError) (uncurry FormBody) eResult
  where
    toError = Error status413 (Text.pack $ "Request is too big!")