{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE UndecidableInstances #-}

module Okapi.Mode.Function (
    Function (..),
    fn,
    type (~>),
    serve,
    tryServe,
    GFunction,
    app,
) where

import Data.Kind (Type)
import GHC.Generics
    ( D1, C1, S1, K1 (..), M1 (..), Rec0
    , Generic (..), Rep
    , (:*:) (..)
    )
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import Okapi.Mode.Forest (Forest (..), Shape)
import Okapi.Record.Data qualified as Data
import Okapi.HTTP.Request qualified as Req
import Okapi.HTTP.Response qualified as Res
import Okapi.HTTP.Responses qualified as Resps

data Function (n :: Type -> Type) shape where
    Fn ::
        ((Data.Request method path query headers body, Wai.Request) -> n result) ->
        Function n (Shape method path query headers body result)

fn ::
    ((Data.Request method path query headers body, Wai.Request) -> n result) ->
    Function n (Shape method path query headers body result)
fn :: forall method path query headers body (n :: * -> *) result.
((Request method path query headers body, Request) -> n result)
-> Function n (Shape method path query headers body result)
fn = ((Request method path query headers body, Request) -> n result)
-> Function n (Shape method path query headers body result)
forall method path query headers body (n :: * -> *) result.
((Request method path query headers body, Request) -> n result)
-> Function n (Shape method path query headers body result)
Fn

type (~>) :: (Type -> Type) -> (Type -> Type) -> Type
type f ~> g = forall a. f a -> g a

serve ::
    (n ~> IO) ->
    Forest (Shape method path query headers body result) ->
    Function n (Shape method path query headers body result) ->
    Wai.Application
serve :: forall (n :: * -> *) method path query headers body result.
(n ~> IO)
-> Forest (Shape method path query headers body result)
-> Function n (Shape method path query headers body result)
-> Application
serve n ~> IO
runner Forest (Shape method path query headers body result)
endpoint (Fn (Request method path query headers body, Request) -> n result
handler) Request
waiReq Response -> IO ResponseReceived
respond = case Forest (Shape method path query headers body result)
endpoint of
    (Request method path query headers body
req :-> Response status resHeaders resBody
singleRes) -> do
        parsed <- 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
        case parsed of
            Left Request method path query headers body
_       -> Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.status400 [] ByteString
forall a. Monoid a => a
mempty)
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
runner ((Request method path query headers body, Request) -> n result
handler (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Res.printResponse singleRes resVal
                respond waiRes
    (Request method path query headers body
req :-< Responses Response responses
resContracts) -> do
        parsed <- 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
        case parsed of
            Left Request method path query headers body
_       -> Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.status400 [] ByteString
forall a. Monoid a => a
mempty)
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
runner ((Request method path query headers body, Request) -> n result
handler (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Resps.printResponses resContracts resVal
                respond waiRes

tryServe ::
    (n ~> IO) ->
    Forest (Shape method path query headers body result) ->
    Function n (Shape method path query headers body result) ->
    Wai.Middleware
tryServe :: forall (n :: * -> *) method path query headers body result.
(n ~> IO)
-> Forest (Shape method path query headers body result)
-> Function n (Shape method path query headers body result)
-> Middleware
tryServe n ~> IO
runner Forest (Shape method path query headers body result)
endpoint (Fn (Request method path query headers body, Request) -> n result
handler) Application
next Request
waiReq Response -> IO ResponseReceived
respond = case Forest (Shape method path query headers body result)
endpoint of
    (Request method path query headers body
req :-> Response status resHeaders resBody
singleRes) -> do
        parsed <- 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
        case parsed of
            Left Request method path query headers body
_       -> Application
next Request
waiReq Response -> IO ResponseReceived
respond
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
runner ((Request method path query headers body, Request) -> n result
handler (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Res.printResponse singleRes resVal
                respond waiRes
    (Request method path query headers body
req :-< Responses Response responses
resContracts) -> do
        parsed <- 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
        case parsed of
            Left Request method path query headers body
_       -> Application
next Request
waiReq Response -> IO ResponseReceived
respond
            Right Request method path query headers body
reqVal -> do
                resVal <- n result -> IO result
n ~> IO
runner ((Request method path query headers body, Request) -> n result
handler (Request method path query headers body
Request method path query headers body
reqVal, Request
waiReq))
                waiRes <- Resps.printResponses resContracts resVal
                respond waiRes

class GFunction (n :: Type -> Type) (epF :: Type -> Type) (svF :: Type -> Type) where
    gServe :: (n ~> IO) -> epF () -> svF () -> Wai.Middleware

instance GFunction n epF svF => GFunction n (D1 dm epF) (D1 dm' svF) where
    gServe :: (n ~> IO) -> D1 dm epF () -> D1 dm' svF () -> Middleware
gServe n ~> IO
runner (M1 epF ()
ep) (M1 svF ()
sv) = forall (n :: * -> *) (epF :: * -> *) (svF :: * -> *).
GFunction n epF svF =>
(n ~> IO) -> epF () -> svF () -> Middleware
gServe @n @epF @svF n a -> IO a
n ~> IO
runner epF ()
ep svF ()
sv

instance GFunction n epF svF => GFunction n (C1 cm epF) (C1 cm' svF) where
    gServe :: (n ~> IO) -> C1 cm epF () -> C1 cm' svF () -> Middleware
gServe n ~> IO
runner (M1 epF ()
ep) (M1 svF ()
sv) = forall (n :: * -> *) (epF :: * -> *) (svF :: * -> *).
GFunction n epF svF =>
(n ~> IO) -> epF () -> svF () -> Middleware
gServe @n @epF @svF n a -> IO a
n ~> IO
runner epF ()
ep svF ()
sv

instance (GFunction n epL svL, GFunction n epR svR)
    => GFunction n (epL :*: epR) (svL :*: svR) where
    gServe :: (n ~> IO) -> (:*:) epL epR () -> (:*:) svL svR () -> Middleware
gServe n ~> IO
runner (epL ()
epL :*: epR ()
epR) (svL ()
svL :*: svR ()
svR) =
        forall (n :: * -> *) (epF :: * -> *) (svF :: * -> *).
GFunction n epF svF =>
(n ~> IO) -> epF () -> svF () -> Middleware
gServe @n @epL @svL n a -> IO a
n ~> IO
runner epL ()
epL svL ()
svL
        Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: * -> *) (epF :: * -> *) (svF :: * -> *).
GFunction n epF svF =>
(n ~> IO) -> epF () -> svF () -> Middleware
gServe @n @epR @svR n a -> IO a
n ~> IO
runner epR ()
epR svR ()
svR

instance GFunction n
    (S1 sm  (Rec0 (Forest (Shape method path query headers body result))))
    (S1 sm' (Rec0 (Function n (Shape method path query headers body result)))) where
    gServe :: (n ~> IO)
-> S1
     sm (Rec0 (Forest (Shape method path query headers body result))) ()
-> S1
     sm'
     (Rec0 (Function n (Shape method path query headers body result)))
     ()
-> Middleware
gServe n ~> IO
runner (M1 (K1 Forest (Shape method path query headers body result)
ep)) (M1 (K1 Function n (Shape method path query headers body result)
sv)) = (n ~> IO)
-> Forest (Shape method path query headers body result)
-> Function n (Shape method path query headers body result)
-> Middleware
forall (n :: * -> *) method path query headers body result.
(n ~> IO)
-> Forest (Shape method path query headers body result)
-> Function n (Shape method path query headers body result)
-> Middleware
tryServe n a -> IO a
n ~> IO
runner Forest (Shape method path query headers body result)
ep Function n (Shape method path query headers body result)
sv

app ::
    forall server n.
    ( Generic (server Forest)
    , Generic (server (Function n))
    , GFunction n (Rep (server Forest)) (Rep (server (Function n)))
    ) =>
    (n ~> IO) ->
    server Forest ->
    server (Function n) ->
    Wai.Application
app :: forall (server :: (* -> *) -> *) (n :: * -> *).
(Generic (server Forest), Generic (server (Function n)),
 GFunction n (Rep (server Forest)) (Rep (server (Function n)))) =>
(n ~> IO) -> server Forest -> server (Function n) -> Application
app n ~> IO
runner server Forest
endpoints server (Function n)
handlers =
    forall (n :: * -> *) (epF :: * -> *) (svF :: * -> *).
GFunction n epF svF =>
(n ~> IO) -> epF () -> svF () -> Middleware
gServe @n @(Rep (server Forest)) @(Rep (server (Function n)))
        n a -> IO a
n ~> IO
runner
        (server Forest -> Rep (server Forest) ()
forall x. server Forest -> Rep (server Forest) x
forall a x. Generic a => a -> Rep a x
from server Forest
endpoints)
        (server (Function n) -> Rep (server (Function n)) ()
forall x. server (Function n) -> Rep (server (Function n)) x
forall a x. Generic a => a -> Rep a x
from server (Function n)
handlers)
    Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ \Request
_ Response -> IO ResponseReceived
respond -> Response -> IO ResponseReceived
respond (Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
HTTP.status404 [] ByteString
forall a. Monoid a => a
mempty)