From 50f5c367271180529294029e749382202c8df1f3 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Fri, 24 Oct 2014 19:39:03 +0200 Subject: [PATCH] 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 | 1 + src/Servant.hs | 127 +++++++++++++++++++++++++++++++++---------------- src/Soenke.hs | 76 +++++++++++++++++++++-------- 3 files changed, 142 insertions(+), 62 deletions(-) diff --git a/servant.cabal b/servant.cabal index 2c361b32..4365333c 100644 --- a/servant.cabal +++ b/servant.cabal @@ -21,6 +21,7 @@ library , either , aeson , bytestring + , exceptions , string-conversions , http-client , http-types diff --git a/src/Servant.hs b/src/Servant.hs index 5c5dea76..2159813b 100644 --- a/src/Servant.hs +++ b/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 :: Proxy sublayout) - (path ++ "/" ++ unpack (toText val)) + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy sublayout) $ + 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) - => HasClient (RQBody a :> Post b) where +instance (ToJSON a, HasClient sublayout) + => HasClient (RQBody a :> sublayout) where - type Client (RQBody a :> Post b) = - a -> URI -> EitherT String IO b + type Client (RQBody a :> sublayout) = + a -> Client sublayout - clientWithRoute Proxy path body uri = do - partialRequest <- liftIO . Http.Client.parseUrl $ - show ( nullURI { uriPath = path } - `relativeTo` uri - ) + clientWithRoute Proxy req body = + clientWithRoute (Proxy :: Proxy sublayout) $ + setRQBody (encode body) req - let request = partialRequest - { Http.Client.method = methodPost - , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body) - } +-- * GET params support (i.e query string arguments) +data GetParam sym a - innerResponse <- liftIO . __withGlobalManager $ \ manager -> - Http.Client.httpLbs request manager +instance (KnownSymbol sym, FromText a, HasServer sublayout) + => HasServer (GetParam sym a :> sublayout) where - when (Http.Client.responseStatus innerResponse /= status201) $ - left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse)) + type Server (GetParam sym a :> sublayout) = + Maybe a -> Server sublayout - maybe (left "HTTP POST request returned invalid json") return $ - decode' (Http.Client.responseBody innerResponse) + route Proxy subserver request = do + 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 - = client testApi - +-- Turn the server into a WAI app 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/" - print =<< runEitherT (getGreet "alp" uri) + let Just uri = parseURI "http://localhost:8001" + 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 diff --git a/src/Soenke.hs b/src/Soenke.hs index 000e0e22..4be66dfc 100644 --- a/src/Soenke.hs +++ b/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 - innerRequest <- liftIO $ - Http.Client.parseUrl (show (nullURI{uriPath = path} `relativeTo` uri)) + clientWithRoute Proxy req uri = do + innerRequest <- liftIO $ reqToRequest req 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 - partialRequest <- liftIO . Http.Client.parseUrl $ - show ( nullURI { uriPath = path } - `relativeTo` uri - ) + clientWithRoute Proxy req uri = do + partialRequest <- liftIO $ reqToRequest req uri - let request = partialRequest - { Http.Client.method = methodPost - , Http.Client.requestBody = Http.Client.RequestBodyLBS rqbody - } + let request = partialRequest { Http.Client.method = methodPost + } 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) - (path ++ "/" ++ (symbolVal (Proxy :: Proxy path))) + + clientWithRoute Proxy req = + 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 :: Proxy a) path :<|> - clientWithRoute (Proxy :: Proxy b) path + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req