Client.hs

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

-- | Functions to create http-clients from the same code as server or API schema
module Mig.Client (
  ToClient (..),
  Client (..),
  ClientConfig (..),
  runClient,
  (:|) (..),
  FromClient (..),
  getRespOrValue,
  Client' (..),
  runClient',
  MonadIO (..),
  ClientOr,
) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Kind
import Data.Map.Strict qualified as Map
import Data.Proxy
import Data.String
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import GHC.TypeLits
import Network.HTTP.Client qualified as Http
import Network.HTTP.Media.RenderHeader (RenderHeader (..))
import Network.HTTP.Types.Header (HeaderName)
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Web.HttpApiData

import Mig.Core

{-| Infox synonym for pair. It can be useful to stack together
many client functions in the output of @toClient@ function.
-}
data (:|) a b = a :| b

instance (ToClient a, ToClient b) => ToClient (a :| b) where
  toClient api = a :| b
    where
      (a, b) = toClient api

  clientArity = clientArity @(a, b)

class MapRequest a where
  mapRequest :: (Http.Request -> Http.Request) -> (a -> a)
  mapCapture :: (CaptureMap -> CaptureMap) -> (a -> a)

instance MapRequest (Client a) where
  mapRequest f (Client a) = Client (\conf capt -> a conf capt . f)
  mapCapture f (Client a) = Client (\conf capt req -> a conf (f capt) req)

instance MapRequest (Send method Client a) where
  mapRequest f (Send client) = Send (mapRequest f client)
  mapCapture f (Send client) = Send (mapCapture f client)

instance (MapRequest b) => MapRequest (a -> b) where
  mapRequest f a = mapRequest f . a
  mapCapture f a = mapCapture f . a

instance (MapRequest a, MapRequest b) => MapRequest (a, b) where
  mapRequest f (a, b) = (mapRequest f a, mapRequest f b)
  mapCapture f (a, b) = (mapCapture f a, mapCapture f b)

instance (MapRequest a, MapRequest b) => MapRequest (a :| b) where
  mapRequest f (a :| b) = (mapRequest f a :| mapRequest f b)
  mapCapture f (a :| b) = (mapCapture f a :| mapCapture f b)

instance (MapRequest a, MapRequest b, MapRequest c) => MapRequest (a, b, c) where
  mapRequest f (a, b, c) = (mapRequest f a, mapRequest f b, mapRequest f c)
  mapCapture f (a, b, c) = (mapCapture f a, mapCapture f b, mapCapture f c)

instance (MapRequest a, MapRequest b, MapRequest c, MapRequest d) => MapRequest (a, b, c, d) where
  mapRequest f (a, b, c, d) = (mapRequest f a, mapRequest f b, mapRequest f c, mapRequest f d)
  mapCapture f (a, b, c, d) = (mapCapture f a, mapCapture f b, mapCapture f c, mapCapture f d)

{-| Creates http-client from server definition.

The result adapts to decalred types. It creates so many client functions as
the arity of the tuple in the result. The server can have more handlers than in the result
Routes from result definition and server definition are matched in the same order as they are declared.

The type of the client is derived from the type signature of the result. The information
on paths for handlers is derived from server definition.

To use the same code for both client and server it is convenient to declare
signatures for handlers as type synonyms parameterized by server monad.
And in the server implementation monad is going to be something IO-based but
in client handlers it will be `Client`-monad.

For example for a server:

> type Hello m = Capture "name" Text -> Get m (Resp Text)
> type Add m = Query "a" Int -> Query "b" Int -> Get m (Resp Int)
>
> server :: Server IO
> server = "api" /.
>   mconcat
>    [ "hello" /. helloHandler
>    , "add" /. addHandler
>    ]
>
> helloHandler :: Hello IO
> helloHandler (Capture name) = Send $ pure $ ok $ "Hello " <> name
>
> addHandler :: Add IO
> addHandler (Query a) (Query b) = Send $ pure $ ok (a + b)

We can define the client and reuse type signatures that we have defined in the server code:

> helloClient :: Hello Client
> addClient :: Add Client
>
> helloClient :| addClient = toClient server

If there is no definition for server. For example if we write implementation for
some external server or API provided by third party we can use recursive definition in the server.
For example if there is no haskell implementation for the server in the previous example. But we
know the API of the application we can define client with recursive definition:

> type Hello m = Capture "name" Text -> Get m (Resp Text)
> type Add m = Query "a" Int -> Query "b" Int -> Get m (Resp Int)
>
> helloClient :: Hello Client
> addClient :: Add Client
>
> helloClient :| addClient = toClient server
>
> server :: Server Client
> server = "api" /.
>   mconcat
>    [ "hello" /. helloClient
>    , "add" /. addClient
>    ]

The code does not get stuck into recursion loop because implementation of the route handlers
is not needed to create client functions. The function @toClient@ takes into account
only type-signatures of the handlers and paths.
-}
class (MapRequest a) => ToClient a where
  -- | converts to client function
  toClient :: Server m -> a

  -- | how many routes client has
  clientArity :: Int

-- | Config to run the clients
data ClientConfig = ClientConfig
  { port :: Int
  -- ^ port to connect to
  , manager :: Http.Manager
  -- ^ HTTP-manager
  }

-- | The client monad. All errors are unified to Lazy.ByteString.
newtype Client a = Client (ClientConfig -> CaptureMap -> Http.Request -> IO (RespOr AnyMedia BL.ByteString a))
  deriving (Functor)

instance Applicative Client where
  pure a = Client $ const $ const $ const $ pure $ pureResp a
  (<*>) = ap

pureResp :: a -> RespOr AnyMedia BL.ByteString a
pureResp a = RespOr $ Right $ Resp ok200 [] (Just a)

instance Monad Client where
  (Client ma) >>= mf = Client $ \config captureValues req -> do
    RespOr eResp <- ma config captureValues req
    case eResp of
      Right resp -> case resp.body of
        Just body -> case mf body of
          Client run -> run config captureValues req
        Nothing -> pure (RespOr $ Right $ Resp resp.status resp.headers Nothing)
      Left err -> pure (RespOr $ Left err)

instance MonadIO Client where
  liftIO act = Client $ \_ _ _ -> pureResp <$> act

-- | Runs client. It calls client handler and fetches the result.
runClient :: ClientConfig -> Client a -> IO (RespOr AnyMedia BL.ByteString a)
runClient config (Client act) = act config mempty Http.defaultRequest

instance (IsMethod method, FromReqBody (RespMedia a) (RespBody a), IsResp a) => ToClient (Send method Client a) where
  toClient api =
    mapRequest (setRequestMethod (toMethod @method)) $
      Send $
        fmap ok $
          httpSend @(RespMedia a) @(RespBody a) (getHeadPath $ Server $ fillCaptures $ unServer api)

  clientArity = 1

instance (ToClient a, ToClient b) => ToClient (a, b) where
  toClient (Server api) = (toClient (Server apiA), toClient (Server apiB))
    where
      (apiA, apiB) = bimap fromFlatApi fromFlatApi $ Prelude.splitAt (clientArity @a) (flatApi api)

  clientArity = clientArity @a + clientArity @b

instance (ToClient a, ToClient b, ToClient c) => ToClient (a, b, c) where
  toClient api = (a, b, c)
    where
      (a, (b, c)) = toClient api

  clientArity = clientArity @(a, (b, c))

instance (ToClient a, ToClient b, ToClient c, ToClient d) => ToClient (a, b, c, d) where
  toClient api = (a, b, c, d)
    where
      (a, (b, c, d)) = toClient api

  clientArity = clientArity @(a, (b, c, d))

getHeadPath :: Server m -> Path
getHeadPath (Server api) = case flatApi api of
  (pathHead, _) : _ -> pathHead
  _ -> error "Not enought methods. API is empty"

setRequestMethod :: Method -> Http.Request -> Http.Request
setRequestMethod m req = req{Http.method = m}

instance (KnownSymbol sym, ToHttpApiData a, ToClient b) => ToClient (Header sym a -> b) where
  toClient api = \header -> mapRequest (addHeader header) $ toClient @b api
  clientArity = clientArity @b

instance (KnownSymbol sym, ToHttpApiData a, ToClient b) => ToClient (OptionalHeader sym a -> b) where
  toClient api = \header -> mapRequest (addOptionalHeader header) $ toClient @b api
  clientArity = clientArity @b

instance (KnownSymbol sym, ToHttpApiData a, ToClient b) => ToClient (Query sym a -> b) where
  toClient api = \query -> mapRequest (addQuery query) $ toClient @b api
  clientArity = clientArity @b

instance (KnownSymbol sym, ToClient b) => ToClient (QueryFlag sym -> b) where
  toClient api = \(QueryFlag flag) -> mapRequest (addQuery @sym @Bool (Query flag)) $ toClient @b api
  clientArity = clientArity @b

instance (KnownSymbol sym, ToHttpApiData a, ToClient b) => ToClient (Optional sym a -> b) where
  toClient api = \query -> mapRequest (addOptional query) $ toClient @b api
  clientArity = clientArity @b

instance (KnownSymbol sym, ToHttpApiData a, ToClient b) => ToClient (Capture sym a -> b) where
  toClient api = \capture -> mapCapture (addCapture capture) $ toClient @b api
  clientArity = clientArity @b

instance (ToRespBody media a, ToClient b) => ToClient (Body media a -> b) where
  toClient api = \(Body body) -> mapRequest (addBody @media body) $ toClient @b api
  clientArity = clientArity @b

instance (ToClient b) => ToClient (PathInfo -> b) where
  toClient api = \(PathInfo _path) -> toClient @b api
  clientArity = clientArity @b

instance (ToClient b) => ToClient (IsSecure -> b) where
  toClient api = \(IsSecure _val) -> toClient @b api
  clientArity = clientArity @b

instance (ToClient b) => ToClient (RawRequest -> b) where
  toClient api = \(RawRequest _val) -> toClient @b api
  clientArity = clientArity @b

instance (ToClient b) => ToClient (RawResponse -> b) where
  toClient api = \(RawResponse _val) -> toClient @b api
  clientArity = clientArity @b

addQuery :: forall sym a. (KnownSymbol sym, ToHttpApiData a) => Query sym a -> Http.Request -> Http.Request
addQuery (Query a) req = req{Http.queryString = str}
  where
    str =
      if B.null (Http.queryString req)
        then param
        else Http.queryString req <> "&" <> param

    param = fromString (symbolVal (Proxy @sym)) <> "=" <> Text.encodeUtf8 (toUrlPiece a)

addOptional :: forall sym a. (KnownSymbol sym, ToHttpApiData a) => Optional sym a -> Http.Request -> Http.Request
addOptional (Optional mVal) = case mVal of
  Nothing -> id
  Just val -> addQuery @sym (Query val)

addHeader :: forall sym a. (KnownSymbol sym, ToHttpApiData a) => Header sym a -> Http.Request -> Http.Request
addHeader (Header a) = addRequestHeader (fromString $ symbolVal (Proxy @sym), toHeader a)

addOptionalHeader :: forall sym a. (KnownSymbol sym, ToHttpApiData a) => OptionalHeader sym a -> Http.Request -> Http.Request
addOptionalHeader (OptionalHeader ma) = case ma of
  Nothing -> id
  Just a -> addHeader @sym (Header a)

addCapture :: forall sym a. (KnownSymbol sym, ToHttpApiData a) => Capture sym a -> CaptureMap -> CaptureMap
addCapture (Capture a) =
  Map.insert (fromString (symbolVal (Proxy @sym))) (toUrlPiece a)

addBody :: forall media a. (ToRespBody media a) => a -> Http.Request -> Http.Request
addBody body req =
  addRequestHeader ("Content-Type", renderHeader (toMediaType @media)) $
    req{Http.requestBody = Http.RequestBodyLBS (toRespBody @media body)}

addRequestHeader :: (HeaderName, ByteString) -> Http.Request -> Http.Request
addRequestHeader header req = req{Http.requestHeaders = header : Http.requestHeaders req}

pathToString :: CaptureMap -> Path -> ByteString
pathToString captureValues (Path path) = case path of
  [] -> mempty
  item : rest -> flip rec (Path rest) $ case item of
    StaticPath p -> p
    CapturePath p ->
      case Map.lookup p captureValues of
        Just val -> val
        Nothing -> error $ "No value for capture: " <> Text.unpack p
  where
    rec a rest = Text.encodeUtf8 a <> "/" <> pathToString captureValues rest

httpSend :: forall media a. (FromReqBody media a) => Path -> Client a
httpSend path =
  mapRequest (addRequestHeader ("Accept", renderHeader $ toMediaType @media)) $
    Client $ \config captureValues req ->
      toSend <$> Http.httpLbs (setRoute captureValues path $ setPort config.port req) config.manager
  where
    toSend :: Http.Response BL.ByteString -> RespOr AnyMedia BL.ByteString a
    toSend resp =
      RespOr $ case fromReqBody @media $ Http.responseBody resp of
        Right body -> Right $ toResp body
        Left _ -> Left $ toResp $ Http.responseBody resp
      where
        toResp :: val -> Resp AnyMedia val
        toResp = Resp (Http.responseStatus resp) (Http.responseHeaders resp) . Just

setPort :: Int -> Http.Request -> Http.Request
setPort port req = req{Http.port = port}

setRoute :: CaptureMap -> Path -> Http.Request -> Http.Request
setRoute captureValues path req = req{Http.path = pathToString captureValues path}

----------------------------------------------------------
-- from response

-- | Helper type-synonym for convenience
type ClientOr a = Client' (Either BL.ByteString a)

{-| ClientConfig in @ReaderT IO@ monad. It encapsulates typical execution
of client functions
-}
newtype Client' a = Client' (ReaderT ClientConfig IO a)
  deriving (Functor, Applicative, Monad, MonadReader ClientConfig, MonadIO)

-- | Runs the client call
runClient' :: ClientConfig -> Client' a -> IO a
runClient' config (Client' act) = runReaderT act config

{-| Class to strip away all newtype wrappers that serve for API-definition.
For example it converts the types signature for client function:

> Capture "foo" Text -> Header "bar" Int -> Get Client (Resp a)

to the version without HTTP-newtype wrappers:

> Text -> Int -> Client' (Resp a)

The instances are defined for all HTTP-newtype wrappers.
Also we can use function @getRespOrValue@ if we do not need
the http information of response.
-}
class FromClient a where
  type ClientResult a :: Type
  fromClient :: a -> ClientResult a

instance (ToRespBody (RespMedia a) (RespError a), IsResp a) => FromClient (Send method Client a) where
  type ClientResult (Send method Client a) = Client' (RespOr (RespMedia a) BL.ByteString (RespBody a))
  fromClient f = Client' $ ReaderT $ flip fromSendClient f

instance (FromClient b) => FromClient (Body media a -> b) where
  type ClientResult (Body media a -> b) = a -> ClientResult b
  fromClient f arg = fromClient (f (Body arg))

instance (FromClient b) => FromClient (Capture sym a -> b) where
  type ClientResult (Capture sym a -> b) = a -> ClientResult b
  fromClient f arg = fromClient (f (Capture arg))

instance (FromClient b) => FromClient (Query sym a -> b) where
  type ClientResult (Query sym a -> b) = a -> ClientResult b
  fromClient f arg = fromClient (f (Query arg))

instance (FromClient b) => FromClient (QueryFlag a -> b) where
  type ClientResult (QueryFlag a -> b) = Bool -> ClientResult b
  fromClient f arg = fromClient (f (QueryFlag arg))

instance (FromClient b) => FromClient (Optional sym a -> b) where
  type ClientResult (Optional sym a -> b) = Maybe a -> ClientResult b
  fromClient f arg = fromClient (f (Optional arg))

instance (FromClient b) => FromClient (Header sym a -> b) where
  type ClientResult (Header sym a -> b) = a -> ClientResult b
  fromClient f arg = fromClient (f (Header arg))

instance (FromClient b) => FromClient (OptionalHeader sym a -> b) where
  type ClientResult (OptionalHeader sym a -> b) = Maybe a -> ClientResult b
  fromClient f arg = fromClient (f (OptionalHeader arg))

instance (FromClient b) => FromClient (PathInfo -> b) where
  type ClientResult (PathInfo -> b) = ClientResult b
  fromClient f = fromClient @b (f $ PathInfo [])

instance (FromClient b) => FromClient (IsSecure -> b) where
  type ClientResult (IsSecure -> b) = ClientResult b
  fromClient f = fromClient @b (f (IsSecure True))

instance (FromClient b) => FromClient (RawRequest -> b) where
  type ClientResult (RawRequest -> b) = ClientResult b
  fromClient f = fromClient @b (f $ error "no request")

instance (FromClient b) => FromClient (RawResponse -> b) where
  type ClientResult (RawResponse -> b) = ClientResult b
  fromClient f = fromClient @b (f $ error "no response")

fromSendClient ::
  forall a method.
  (ToRespBody (RespMedia a) (RespError a), IsResp a) =>
  ClientConfig ->
  Send method Client a ->
  IO (RespOr (RespMedia a) BL.ByteString (RespBody a))
fromSendClient config (Send client) =
  joinRespOr @a <$> runClient config client

joinRespOr :: forall a. (ToRespBody (RespMedia a) (RespError a), IsResp a) => RespOr AnyMedia BL.ByteString a -> RespOr (RespMedia a) BL.ByteString (RespBody a)
joinRespOr (RespOr eResp) = RespOr $ case eResp of
  Right resp -> case resp.body of
    Just result ->
      if getStatus result == ok200
        then Right $ Resp (getStatus result) (getHeaders result) (getRespBody result)
        else Left $ Resp (getStatus result) (getHeaders result) (toRespBody @(RespMedia a) <$> getRespError result)
    Nothing -> Right $ Resp resp.status resp.headers Nothing
  Left resp -> Left $ Resp resp.status resp.headers resp.body

{-| If we need only value from the server and not HTTP-info (status, or headers)
we can omit that data with this function
-}
getRespOrValue :: RespOr media BL.ByteString a -> Either BL.ByteString a
getRespOrValue (RespOr eResp) = case eResp of
  Right resp -> maybe noContentValue Right resp.body
  Left resp -> maybe noContentValue Left resp.body
  where
    noContentValue = Left "No content in the response"