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

module Okapi.Mode.Client (
    ClientError (..),
    ClientSettings (..),
    Client (..),
    fetch,
    GClient,
    client,
) where

import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Kind (Type)
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics
    ( D1, C1, S1, K1 (..), M1 (..), Rec0
    , Generic (..), Rep
    , (:*:) (..)
    )
import Network.HTTP.Client qualified as HC
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 ClientError = ClientError deriving (ClientError -> ClientError -> Bool
(ClientError -> ClientError -> Bool)
-> (ClientError -> ClientError -> Bool) -> Eq ClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientError -> ClientError -> Bool
== :: ClientError -> ClientError -> Bool
$c/= :: ClientError -> ClientError -> Bool
/= :: ClientError -> ClientError -> Bool
Eq, Int -> ClientError -> ShowS
[ClientError] -> ShowS
ClientError -> String
(Int -> ClientError -> ShowS)
-> (ClientError -> String)
-> ([ClientError] -> ShowS)
-> Show ClientError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientError -> ShowS
showsPrec :: Int -> ClientError -> ShowS
$cshow :: ClientError -> String
show :: ClientError -> String
$cshowList :: [ClientError] -> ShowS
showList :: [ClientError] -> ShowS
Show)

data ClientSettings = ClientSettings
    { ClientSettings -> Manager
manager :: HC.Manager
    , ClientSettings -> String
baseUrl :: String
    }

data Client shape where
    Cb ::
        (Data.Request method path query headers body -> IO (Either ClientError result)) ->
        Client (Shape method path query headers body result)

fetch ::
    HC.Manager ->
    String ->
    Forest (Shape method path query headers body result) ->
    Data.Request method path query headers body ->
    IO (Either ClientError result)
fetch :: forall method path query headers body result.
Manager
-> String
-> Forest (Shape method path query headers body result)
-> Request method path query headers body
-> IO (Either ClientError result)
fetch Manager
mgr String
baseUrl Forest (Shape method path query headers body result)
endpoint Request method path query headers body
reqVal = case Forest (Shape method path query headers body result)
endpoint of
    (Request method path query headers body
req :-> Response status resHeaders resBody
singleRes) -> do
        waiReq <- Request method path query headers body
-> Request method path query headers body -> IO Request
forall method path query headers body.
Request method path query headers body
-> Request method path query headers body -> IO Request
Req.printRequest Request method path query headers body
req Request method path query headers body
Request method path query headers body
reqVal
        hcReq  <- toHCRequest baseUrl waiReq
        hcRes  <- HC.httpLbs hcReq mgr
        either (const (Left ClientError)) Right <$>
            Res.parseResponse singleRes (fromHCResponse hcRes)
    (Request method path query headers body
req :-< Responses Response responses
resContracts) -> do
        waiReq <- Request method path query headers body
-> Request method path query headers body -> IO Request
forall method path query headers body.
Request method path query headers body
-> Request method path query headers body -> IO Request
Req.printRequest Request method path query headers body
req Request method path query headers body
Request method path query headers body
reqVal
        hcReq  <- toHCRequest baseUrl waiReq
        hcRes  <- HC.httpLbs hcReq mgr
        either (const (Left ClientError)) Right <$>
            Resps.parseResponses resContracts (fromHCResponse hcRes)

toHCRequest :: String -> Wai.Request -> IO HC.Request
toHCRequest :: String -> Request -> IO Request
toHCRequest String
baseUrl Request
waiReq = do
    body <- Request -> IO ByteString
Wai.strictRequestBody Request
waiReq
    base <- HC.parseUrlThrow baseUrl
    let pathBS = ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"/" ((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 (Request -> [Text]
Wai.pathInfo Request
waiReq))
        qs     = Bool -> Query -> ByteString
HTTP.renderQuery Bool
True (Request -> Query
Wai.queryString Request
waiReq)
    pure base
        { HC.method         = Wai.requestMethod  waiReq
        , HC.path           = pathBS
        , HC.queryString    = qs
        , HC.requestHeaders = Wai.requestHeaders waiReq
        , HC.requestBody    = HC.RequestBodyLBS  body
        , HC.checkResponse  = \Request
_ Response BodyReader
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        }

fromHCResponse :: HC.Response LBS.ByteString -> Wai.Response
fromHCResponse :: Response ByteString -> Response
fromHCResponse Response ByteString
hcRes = Status -> RequestHeaders -> ByteString -> Response
Wai.responseLBS
    (Response ByteString -> Status
forall body. Response body -> Status
HC.responseStatus  Response ByteString
hcRes)
    (Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
HC.responseHeaders Response ByteString
hcRes)
    (Response ByteString -> ByteString
forall body. Response body -> body
HC.responseBody    Response ByteString
hcRes)

class GClient (epF :: Type -> Type) (clF :: Type -> Type) where
    gClient :: ClientSettings -> epF () -> clF ()

instance GClient epF clF => GClient (D1 dm epF) (D1 dm' clF) where
    gClient :: ClientSettings -> D1 dm epF () -> D1 dm' clF ()
gClient ClientSettings
s (M1 epF ()
ep) = clF () -> D1 dm' clF ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (epF :: * -> *) (clF :: * -> *).
GClient epF clF =>
ClientSettings -> epF () -> clF ()
gClient @epF @clF ClientSettings
s epF ()
ep)

instance GClient epF clF => GClient (C1 cm epF) (C1 cm' clF) where
    gClient :: ClientSettings -> C1 cm epF () -> C1 cm' clF ()
gClient ClientSettings
s (M1 epF ()
ep) = clF () -> C1 cm' clF ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (epF :: * -> *) (clF :: * -> *).
GClient epF clF =>
ClientSettings -> epF () -> clF ()
gClient @epF @clF ClientSettings
s epF ()
ep)

instance (GClient epL clL, GClient epR clR)
    => GClient (epL :*: epR) (clL :*: clR) where
    gClient :: ClientSettings -> (:*:) epL epR () -> (:*:) clL clR ()
gClient ClientSettings
s (epL ()
epL :*: epR ()
epR) =
        forall (epF :: * -> *) (clF :: * -> *).
GClient epF clF =>
ClientSettings -> epF () -> clF ()
gClient @epL @clL ClientSettings
s epL ()
epL clL () -> clR () -> (:*:) clL clR ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (epF :: * -> *) (clF :: * -> *).
GClient epF clF =>
ClientSettings -> epF () -> clF ()
gClient @epR @clR ClientSettings
s epR ()
epR

instance GClient
    (S1 sm  (Rec0 (Forest (Shape method path query headers body result))))
    (S1 sm' (Rec0 (Client (Shape method path query headers body result)))) where
    gClient :: ClientSettings
-> S1
     sm (Rec0 (Forest (Shape method path query headers body result))) ()
-> S1
     sm'
     (Rec0 (Client (Shape method path query headers body result)))
     ()
gClient (ClientSettings Manager
mgr String
url) (M1 (K1 Forest (Shape method path query headers body result)
ep)) =
        Rec0 (Client (Shape method path query headers body result)) ()
-> S1
     sm'
     (Rec0 (Client (Shape method path query headers body result)))
     ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Client (Shape method path query headers body result)
-> Rec0 (Client (Shape method path query headers body result)) ()
forall k i c (p :: k). c -> K1 i c p
K1 ((Request method path query headers body
 -> IO (Either ClientError result))
-> Client (Shape method path query headers body result)
forall method path query headers body result.
(Request method path query headers body
 -> IO (Either ClientError result))
-> Client (Shape method path query headers body result)
Cb \Request method path query headers body
reqVal -> Manager
-> String
-> Forest (Shape method path query headers body result)
-> Request method path query headers body
-> IO (Either ClientError result)
forall method path query headers body result.
Manager
-> String
-> Forest (Shape method path query headers body result)
-> Request method path query headers body
-> IO (Either ClientError result)
fetch Manager
mgr String
url Forest (Shape method path query headers body result)
ep Request method path query headers body
reqVal))

client ::
    forall server.
    ( Generic (server Forest)
    , Generic (server Client)
    , GClient (Rep (server Forest)) (Rep (server Client))
    ) =>
    server Forest ->
    ClientSettings ->
    server Client
client :: forall (server :: (* -> *) -> *).
(Generic (server Forest), Generic (server Client),
 GClient (Rep (server Forest)) (Rep (server Client))) =>
server Forest -> ClientSettings -> server Client
client server Forest
endpoints ClientSettings
settings =
    Rep (server Client) () -> server Client
forall a x. Generic a => Rep a x -> a
forall x. Rep (server Client) x -> server Client
to (forall (epF :: * -> *) (clF :: * -> *).
GClient epF clF =>
ClientSettings -> epF () -> clF ()
gClient @(Rep (server Forest)) @(Rep (server Client)) ClientSettings
settings (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))