revamp a lot of the HasClient code to thread a Req object around instead of just the path. allows for a cleaner way to handle path, query string and request body modification. add support for GET params too

servant.cabal

@@ -21,6 +21,7 @@ library
     , either
     , aeson
     , bytestring
+    , exceptions
     , string-conversions
     , http-client
     , http-types

src/Servant.hs

@@ -18,6 +18,7 @@ import Data.Aeson
 import Data.ByteString.Lazy (ByteString)
 import Data.Monoid
 import Data.Proxy
+import Data.String.Conversions
 import Data.Text
 import GHC.Generics
 import GHC.TypeLits
@@ -29,23 +30,32 @@ import Soenke
 
 import qualified Network.HTTP.Client as Http.Client
 
--- * Captures
-data Capture sym a
-
 class FromText a where
-  capture :: Text -> Maybe a
+  fromText :: Text -> Maybe a
 
 class ToText a where
   toText :: a -> Text
 
 instance FromText Text where
-  capture = Just
+  fromText = Just
 
 instance ToText Text where
   toText = id
 
+instance FromText Bool where
+  fromText "true"  = Just True
+  fromText "false" = Just False
+  fromText _       = Nothing
+
+instance ToText Bool where
+  toText True  = "true"
+  toText False = "false"
+
+-- * Captures
+data Capture sym a
+
 captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
-captured _ = capture
+captured _ = fromText
 
 instance (KnownSymbol capture, FromText a, HasServer sublayout)
       => HasServer (Capture capture a :> sublayout) where
@@ -70,9 +80,11 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
   type Client (Capture capture a :> sublayout) =
     a -> Client sublayout
 
-  clientWithRoute Proxy path val =
+  clientWithRoute Proxy req val =
-      clientWithRoute (Proxy :: Proxy sublayout)
+    clientWithRoute (Proxy :: Proxy sublayout) $
-                      (path ++ "/" ++ unpack (toText val))
+      appendToPath p req
+
+    where p = unpack (toText val)
 
 -- * Request Body support
 data RQBody a
@@ -89,69 +101,102 @@ instance (FromJSON a, HasServer sublayout)
       Nothing -> return Nothing
       Just v  -> route (Proxy :: Proxy sublayout) (subserver v) request
 
-instance (ToJSON a, FromJSON b)
+instance (ToJSON a, HasClient sublayout)
-      => HasClient (RQBody a :> Post b) where
+      => HasClient (RQBody a :> sublayout) where
 
-  type Client (RQBody a :> Post b) =
+  type Client (RQBody a :> sublayout) =
-    a -> URI -> EitherT String IO b
+    a -> Client sublayout
 
-  clientWithRoute Proxy path body uri = do
+  clientWithRoute Proxy req body =
-    partialRequest <- liftIO . Http.Client.parseUrl $
+    clientWithRoute (Proxy :: Proxy sublayout) $
-      show ( nullURI { uriPath = path }
+      setRQBody (encode body) req
-             `relativeTo` uri
-           )
 
-    let request = partialRequest
+-- * GET params support (i.e query string arguments)
-          { Http.Client.method = methodPost
+data GetParam sym a
-          , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
-          }
 
-    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
+instance (KnownSymbol sym, FromText a, HasServer sublayout)
-      Http.Client.httpLbs request manager
+      => HasServer (GetParam sym a :> sublayout) where
 
-    when (Http.Client.responseStatus innerResponse /= status201) $
+  type Server (GetParam sym a :> sublayout) =
-      left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
+    Maybe a -> Server sublayout
 
-    maybe (left "HTTP POST request returned invalid json") return $
+  route Proxy subserver request = do
-      decode' (Http.Client.responseBody innerResponse)
+    let querytext = parseQueryText $ rawQueryString request
+        param =
+          case lookup paramName querytext of
+            Nothing       -> Nothing -- param absent from the query string
+            Just Nothing  -> Nothing -- param present with no value -> Nothing
+            Just (Just v) -> fromText v -- if present, we try to convert to
+                                        -- the right type
+
+    route (Proxy :: Proxy sublayout) (subserver param) request
+
+    where paramName = cs $ symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, ToText a, HasClient sublayout)
+      => HasClient (GetParam sym a :> sublayout) where
+
+  type Client (GetParam sym a :> sublayout) =
+    Maybe a -> Client sublayout
+
+  -- if mparam = Nothing, we don't add it to the query string
+  clientWithRoute Proxy req mparam =
+    clientWithRoute (Proxy :: Proxy sublayout) $
+      appendToQueryString pname mparamText req
+
+    where pname  = pack pname'
+          pname' = symbolVal (Proxy :: Proxy sym)
+          mparamText = fmap toText mparam
 
 -- * Example
 
-type TestApi = "hello" :> Capture "name" Text :> Get Greet
-          :<|> "greet" :> RQBody Greet :> Post Greet
-
-testApi :: Proxy TestApi
-testApi = Proxy
-
 data Greet = Greet { msg :: Text }
   deriving (Generic, Show)
 
 instance FromJSON Greet
 instance ToJSON Greet
 
+-- API specification
+type TestApi = 
+       "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
+  :<|> "greet" :> RQBody Greet :> Post Greet
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Server-side handlers
 server :: Server TestApi
 server = hello :<|> greet
 
-  where hello = return . Greet . ("Hello, " <>)
+  where hello name Nothing = hello name (Just False)
+        hello name (Just False) = return . Greet $ "Hello, " <> name
+        hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+
         greet = return
 
-getGreet :: Text -> URI -> EitherT String IO Greet
+-- Client-side query functions
+clientApi :: Client TestApi
+clientApi = client testApi
+
+getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
 postGreet :: Greet -> URI -> EitherT String IO Greet
+getGreet :<|> postGreet = clientApi
 
-getGreet :<|> postGreet
+-- Turn the server into a WAI app
-  = client testApi
-
 test :: Application
 test = serve testApi server
 
+-- Run the server
 runTestServer :: Port -> IO ()
 runTestServer port = run port test
 
+-- Run some queries against the server
 runTest :: IO ()
 runTest = do
   tid <- forkIO $ runTestServer 8001
-  let Just uri = parseURI "http://localhost:8001/"
+  let Just uri = parseURI "http://localhost:8001"
-  print =<< runEitherT (getGreet "alp" uri)
+  print =<< runEitherT (getGreet "alp" (Just True) uri)
+  print =<< runEitherT (getGreet "alp" (Just False) uri)
   let g = Greet "yo"
   print =<< runEitherT (postGreet g uri)
   killThread tid

src/Soenke.hs

@@ -4,12 +4,14 @@ module Soenke where
 
 import           Control.Concurrent
 import           Control.Monad
+import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Either
 import           Data.Aeson
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Proxy
 import           Data.String.Conversions
+import           Data.Text (Text)
 import           GHC.TypeLits
 import           Network.HTTP.Client        (Manager, defaultManagerSettings,
                                              newManager)
@@ -116,11 +118,45 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
 
 -- | 'client' allows you to produce operations to query an API from a client.
 client :: forall layout . HasClient layout => Proxy layout -> Client layout
-client Proxy = clientWithRoute (Proxy :: Proxy layout) ""
+client Proxy = clientWithRoute (Proxy :: Proxy layout) defReq
 
 class HasClient layout where
   type Client layout :: *
-  clientWithRoute :: Proxy layout -> String -> Client layout
+  clientWithRoute :: Proxy layout -> Req -> Client layout
+
+data Req = Req
+  { reqPath  :: String
+  , qs       :: QueryText
+  , reqBody  :: ByteString
+  }
+
+defReq :: Req
+defReq = Req "" [] ""
+
+appendToPath :: String -> Req -> Req
+appendToPath p req =
+  req { reqPath = reqPath req ++ "/" ++ p }
+
+appendToQueryString :: Text       -- ^ param name
+                    -> Maybe Text -- ^ param value
+                    -> Req
+                    -> Req
+appendToQueryString pname pvalue req
+  | pvalue == Nothing = req
+  | otherwise         = req { qs = qs req ++ [(pname, pvalue)]
+                            }
+
+setRQBody :: ByteString -> Req -> Req
+setRQBody b req = req { reqBody = b }
+
+reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Http.Client.Request
+reqToRequest req uri = fmap (setrqb . setQS ) $ Http.Client.parseUrl url
+
+  where url = show $ nullURI { uriPath = reqPath req }
+                       `relativeTo` uri
+
+        setrqb r = r { Http.Client.requestBody = Http.Client.RequestBodyLBS (reqBody req) }
+        setQS = Http.Client.setQueryString $ queryTextToQuery (qs req)
 
 {-# NOINLINE __manager #-}
 __manager :: MVar Manager
@@ -133,9 +169,9 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do
 
 instance FromJSON result => HasClient (Get result) where
   type Client (Get result) = URI -> EitherT String IO result
-  clientWithRoute Proxy path uri = do
+  clientWithRoute Proxy req uri = do
-    innerRequest <- liftIO $
+    innerRequest <- liftIO $ reqToRequest req uri
-      Http.Client.parseUrl (show (nullURI{uriPath = path} `relativeTo` uri))
+
     innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
       Http.Client.httpLbs innerRequest manager
     when (Http.Client.responseStatus innerResponse /= ok200) $
@@ -144,18 +180,13 @@ instance FromJSON result => HasClient (Get result) where
       decode' (Http.Client.responseBody innerResponse)
 
 instance FromJSON a => HasClient (Post a) where
-  type Client (Post a) = ByteString -> URI -> EitherT String IO a
+  type Client (Post a) = URI -> EitherT String IO a
 
-  clientWithRoute Proxy path rqbody uri = do
+  clientWithRoute Proxy req uri = do
-    partialRequest <- liftIO . Http.Client.parseUrl $
+    partialRequest <- liftIO $ reqToRequest req uri
-      show ( nullURI { uriPath = path }
-             `relativeTo` uri
-           )
 
-    let request = partialRequest 
+    let request = partialRequest { Http.Client.method = methodPost
-          { Http.Client.method = methodPost
+                                 }
-          , Http.Client.requestBody = Http.Client.RequestBodyLBS rqbody
-          }
 
     innerResponse <- liftIO . __withGlobalManager $ \ manager ->
       Http.Client.httpLbs request manager
@@ -168,12 +199,15 @@ instance FromJSON a => HasClient (Post a) where
 
 instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
   type Client (path :> sublayout) = Client sublayout
-  clientWithRoute Proxy path =
+
-     clientWithRoute (Proxy :: Proxy sublayout)
+  clientWithRoute Proxy req =
-       (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
+     clientWithRoute (Proxy :: Proxy sublayout) $
+       appendToPath p req
+
+    where p = symbolVal (Proxy :: Proxy path)
 
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
   type Client (a :<|> b) = Client a :<|> Client b
-  clientWithRoute Proxy path =
+  clientWithRoute Proxy req =
-    clientWithRoute (Proxy :: Proxy a) path :<|>
+    clientWithRoute (Proxy :: Proxy a) req :<|>
-    clientWithRoute (Proxy :: Proxy b) path
+    clientWithRoute (Proxy :: Proxy b) req