{-# LANGUAGE LambdaCase #-}

module Okapi.Handle
    ( Route (..)
    , Handle (..)
    , handle
    ) where

import Data.Kind (Type)
import Network.Wai qualified as Wai
import Okapi.Mode.Forest (Forest (..))
import Okapi.Mode.Function (Function (..), type (~>))
import Okapi.HTTP.Request qualified as Req
import Okapi.HTTP.Response qualified as Res
import Okapi.HTTP.Responses qualified as Resps

data Route (n :: Type -> Type) where
    (:=) :: Forest shape -> Function n shape -> Route n

infixl 0 :=

newtype Handle = Handle
    { Handle -> Request -> IO (Maybe Response)
runHandle :: Wai.Request -> IO (Maybe Wai.Response) }

handle :: (n ~> IO) -> Route n -> Handle
handle :: forall (n :: * -> *). (n ~> IO) -> Route n -> Handle
handle n ~> IO
nt (Forest shape
canopy := Fn (Request method path query headers body, Request) -> n result
f) = (Request -> IO (Maybe Response)) -> Handle
Handle ((Request -> IO (Maybe Response)) -> Handle)
-> (Request -> IO (Maybe Response)) -> Handle
forall a b. (a -> b) -> a -> b
$ \Request
waiReq -> case Forest shape
canopy of
    (Request method path query headers body
req :-> Response status resHeaders resBody
singleRes) ->
        Request method path query headers body
-> Request
-> IO
     (Either
        (Request method path query headers body)
        (Request method path query headers body))
forall method path query headers body.
Request method path query headers body
-> Request
-> IO
     (Either
        (Request method path query headers body)
        (Request method path query headers body))
Req.parseRequest Request method path query headers body
req Request
waiReq IO
  (Either
     (Request method path query headers body)
     (Request method path query headers body))
-> (Either
      (Request method path query headers body)
      (Request method path query headers body)
    -> IO (Maybe Response))
-> IO (Maybe Response)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Request method path query headers body
_       -> Maybe Response -> IO (Maybe Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
forall a. Maybe a
Nothing
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
nt ((Request method path query headers body, Request) -> n result
f (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Res.printResponse singleRes resVal
                pure (Just waiRes)
    (Request method path query headers body
req :-< Responses Response responses
resContracts) ->
        Request method path query headers body
-> Request
-> IO
     (Either
        (Request method path query headers body)
        (Request method path query headers body))
forall method path query headers body.
Request method path query headers body
-> Request
-> IO
     (Either
        (Request method path query headers body)
        (Request method path query headers body))
Req.parseRequest Request method path query headers body
req Request
waiReq IO
  (Either
     (Request method path query headers body)
     (Request method path query headers body))
-> (Either
      (Request method path query headers body)
      (Request method path query headers body)
    -> IO (Maybe Response))
-> IO (Maybe Response)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Request method path query headers body
_       -> Maybe Response -> IO (Maybe Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
forall a. Maybe a
Nothing
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
nt ((Request method path query headers body, Request) -> n result
f (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Resps.printResponses resContracts resVal
                pure (Just waiRes)