Begin writing actual client generation code

servant-freer-client/servant-freer-client.cabal

@@ -25,6 +25,7 @@ source-repository head
 
 library
   exposed-modules:
+    Servant.FreerReq
     Servant.FreerClient
   build-depends:
       base                  >= 4.7      && < 4.11

servant-freer-client/src/Servant/FreerClient.hs

@@ -1,69 +1,46 @@
-{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Servant.FreerClient where
 
-import Control.Exception (toException)
+import           Servant.API
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Exception
 import           Control.Monad.Freer.Http
 import           Control.Monad.Freer.Reader
 import           Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
-import Data.String.Conversions (cs)
+import           Data.Proxy
 import           Network.HTTP.Client (Response)
-import Network.HTTP.Types
 import           Network.HTTP.Media
-import Servant.Common.Req hiding (ClientM, runClientM')
+import qualified Network.HTTP.Types         as H
-
-import qualified Network.HTTP.Client as Client
 import qualified Network.HTTP.Types.Header  as HTTP
+import           Servant.Client hiding (ClientM, clientWithRoute)
+import           Servant.Common.Req hiding (ClientM, runClientM', performRequest)
+import           Servant.FreerReq
 
-newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r
+freeClient :: HasFreeClient r api => Proxy r -> Proxy api -> FreeClient r api
-                                               , Member (Exc ServantError) r
+freeClient r p = clientWithRoute r p defReq
-                                               , Member Http r) => (Eff r) a }
 
-instance Functor (ClientM r) where
+class HasFreeClient r api where
-  fmap f a = ClientM $ fmap f (runClientM' a)
+  type FreeClient (r :: [* -> *]) api :: *
+  clientWithRoute :: Proxy r -> Proxy api -> Req -> FreeClient r api
 
-instance Applicative (ClientM r) where
+instance ( Member Http r
-  pure a = ClientM $ pure a
-  f <*> a = ClientM $ (runClientM' f) <*> (runClientM' a)
-
-instance Monad (ClientM r) where
-  a >>= f = ClientM $ (runClientM' a) >>= (runClientM' . f)
-
-performRequest :: ( Member Http r
          , Member (Reader ClientEnv) r
-                  , Member (Exc ServantError) r)
+         , Member (Exc ServantError) r) => HasFreeClient r Raw where
-               => Method -> Req -> ClientM r ( Int, ByteString, MediaType
+  type FreeClient r Raw
-                                             , [HTTP.Header], Response ByteString)
+    = H.Method -> ClientM r ( Int
-performRequest reqMethod req = ClientM $ do
+                            , ByteString
-  m <- asks manager
+                            , MediaType
-  reqHost <- asks baseUrl
+                            , [HTTP.Header]
-  response <- case (reqToRequest req reqHost) of
+                            , Response ByteString)
-    Left some -> throwError . ConnectionError $ toException some
-    Right request -> doRequest request
-  let status = Client.responseStatus response
-      body = Client.responseBody response
-      hdrs = Client.responseHeaders response
-      status_code = statusCode status
-  ct <- case lookup "Content-Type" $ Client.responseHeaders response of
-    Nothing -> pure $ "application"//"octet-stream"
-    Just t -> case parseAccept t of
-      Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
-      Just t' -> pure t'
-  return (status_code, body, ct, hdrs, response)
 
-runClientM :: ClientM ('[ Reader ClientEnv
+  clientWithRoute :: Proxy r -> Proxy Raw -> Req -> FreeClient r Raw
-                        , Exc ServantError
+  clientWithRoute Proxy Proxy req httpMethod = do
-                        , Http
+    performRequest httpMethod req
-                        , IO]) a -> ClientEnv -> IO (Either ServantError a)
-runClientM cm ce@ClientEnv { manager = mgr } =
-  runM . (runHttp mgr) . runError . (flip runReader ce) $ runClientM' cm

servant-freer-client/src/Servant/FreerReq.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RankNTypes            #-}
+
+module Servant.FreerReq where
+
+import           Control.Exception (toException)
+import           Control.Monad.Freer
+import           Control.Monad.Freer.Exception
+import           Control.Monad.Freer.Http
+import           Control.Monad.Freer.Reader
+import           Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
+import           Data.String.Conversions (cs)
+import           Network.HTTP.Client (Response)
+import qualified Network.HTTP.Client as Client
+import           Network.HTTP.Media
+import           Network.HTTP.Types
+import qualified Network.HTTP.Types.Header   as HTTP
+import           Servant.Common.Req hiding (ClientM, runClientM')
+
+newtype ClientM r a = ClientM { runClientM' :: ( Member (Reader ClientEnv) r
+                                               , Member (Exc ServantError) r
+                                               , Member Http r) => (Eff r) a }
+
+instance Functor (ClientM r) where
+  fmap f a = ClientM $ fmap f (runClientM' a)
+
+instance Applicative (ClientM r) where
+  pure a = ClientM $ pure a
+  f <*> a = ClientM $ (runClientM' f) <*> (runClientM' a)
+
+instance Monad (ClientM r) where
+  a >>= f = ClientM $ (runClientM' a) >>= (runClientM' . f)
+
+performRequest :: ( Member Http r
+                  , Member (Reader ClientEnv) r
+                  , Member (Exc ServantError) r)
+               => Method -> Req -> ClientM r ( Int, ByteString, MediaType
+                                             , [HTTP.Header], Response ByteString)
+performRequest reqMethod req = ClientM $ do
+  m <- asks manager
+  reqHost <- asks baseUrl
+  response <- case (reqToRequest req reqHost) of
+    Left some -> throwError . ConnectionError $ toException some
+    Right request -> doRequest request
+  let status = Client.responseStatus response
+      body = Client.responseBody response
+      hdrs = Client.responseHeaders response
+      status_code = statusCode status
+  ct <- case lookup "Content-Type" $ Client.responseHeaders response of
+    Nothing -> pure $ "application"//"octet-stream"
+    Just t -> case parseAccept t of
+      Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
+      Just t' -> pure t'
+  return (status_code, body, ct, hdrs, response)
+
+runClientM :: ClientM ('[ Reader ClientEnv
+                        , Exc ServantError
+                        , Http
+                        , IO]) a -> ClientEnv -> IO (Either ServantError a)
+runClientM cm ce@ClientEnv { manager = mgr } =
+  runM . (runHttp mgr) . runError . (flip runReader ce) $ runClientM' cm