From 69041cc39e2c8040561a7b2e33d603ebaf3798d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 15:11:32 +0800 Subject: [PATCH 1/7] S.Docs: added instance ToSample () --- src/Servant/Docs.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index beeec4ec..5998eef4 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -322,6 +322,9 @@ class HasDocs layout where class ToJSON a => ToSample a where toSample :: Proxy a -> Maybe ByteString +instance ToSample () where + toSample Proxy = Just $ encode () + -- | The class that helps us automatically get documentation -- for GET parameters. -- From 8d92d66e00c41aa1240ab5190a387fb638267842 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 15:19:14 +0800 Subject: [PATCH 2/7] refactored Servant.Docs.ToSample --- example/greet.hs | 4 +--- src/Servant/API/Get.hs | 2 +- src/Servant/API/Post.hs | 2 +- src/Servant/API/Put.hs | 2 +- src/Servant/API/ReqBody.hs | 2 +- src/Servant/Docs.hs | 13 ++++++++++--- test/Servant/ServerSpec.hs | 2 +- 7 files changed, 16 insertions(+), 11 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index c2c9976f..54226d9e 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -46,9 +46,7 @@ instance ToParam (QueryParam "capital" Bool) where Normal instance ToSample Greet where - toSample Proxy = Just (encode g) - - where g = Greet "Hello, haskeller!" + toSample = Just $ Greet "Hello, haskeller!" -- API specification type TestApi = diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index 4114b07e..c6d375b0 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -46,5 +46,5 @@ instance ToSample a => HasDocs (Get a) where single endpoint' action' where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ toSample p + action' = action & response.respBody .~ sampleByteString p p = Proxy :: Proxy a diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index d8909e5b..2a4a4feb 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -50,7 +50,7 @@ instance ToSample a => HasDocs (Post a) where where endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ toSample p + action' = action & response.respBody .~ sampleByteString p & response.respStatus .~ 201 p = Proxy :: Proxy a diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 012debe2..5c71097c 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -49,7 +49,7 @@ instance ToSample a => HasDocs (Put a) where where endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ toSample p + action' = action & response.respBody .~ sampleByteString p & response.respStatus .~ 200 p = Proxy :: Proxy a diff --git a/src/Servant/API/ReqBody.hs b/src/Servant/API/ReqBody.hs index b185b675..2479844a 100644 --- a/src/Servant/API/ReqBody.hs +++ b/src/Servant/API/ReqBody.hs @@ -48,5 +48,5 @@ instance (ToSample a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout - action' = action & rqbody .~ toSample p + action' = action & rqbody .~ sampleByteString p p = Proxy :: Proxy a diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 5998eef4..228a599e 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------- @@ -88,7 +89,10 @@ module Servant.Docs HasDocs(..), docs, markdown, printMarkdown , -- * Classes you need to implement for your types - ToSample(..), ToParam(..), ToCapture(..) + ToSample(..) + , sampleByteString + , ToParam(..) + , ToCapture(..) , -- * ADTs to represent an 'API' Method(..) @@ -320,10 +324,13 @@ class HasDocs layout where -- > -- > where g = Greet "Hello, haskeller!" class ToJSON a => ToSample a where - toSample :: Proxy a -> Maybe ByteString + toSample :: Maybe a instance ToSample () where - toSample Proxy = Just $ encode () + toSample = Just () + +sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString +sampleByteString Proxy = fmap encode (toSample :: Maybe a) -- | The class that helps us automatically get documentation -- for GET parameters. diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index d9f952b3..cba21e9c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -44,7 +44,7 @@ data Person = Person { instance ToJSON Person instance FromJSON Person instance ToSample Person where - toSample _proxy = Just $ encode alice + toSample = Just alice alice :: Person alice = Person "Alice" 42 From 9ee7373608b68f865a5c45e1460906118399f778 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 19:56:44 +0800 Subject: [PATCH 3/7] cabal: remove -Werror to allow deprecation warnings --- servant.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant.cabal b/servant.cabal index f5d50313..dec4f6e0 100644 --- a/servant.cabal +++ b/servant.cabal @@ -79,7 +79,7 @@ executable greet test-suite spec type: exitcode-stdio-1.0 ghc-options: - -Wall -Werror -fno-warn-name-shadowing -fno-warn-missing-signatures + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs From eff31f748514a122fe31c3be5b9a542f700d1b43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 19:57:53 +0800 Subject: [PATCH 4/7] implemented 'instance HasClient Raw' --- src/Servant/API/Delete.hs | 2 +- src/Servant/API/Get.hs | 2 +- src/Servant/API/Post.hs | 2 +- src/Servant/API/Put.hs | 2 +- src/Servant/API/Raw.hs | 19 +++++++++++++++++-- src/Servant/Common/Req.hs | 34 ++++++++++++++++++++++------------ test/Servant/ClientSpec.hs | 13 ++++++++++++- 7 files changed, 55 insertions(+), 19 deletions(-) diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index 80b78e44..7355615f 100644 --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -39,7 +39,7 @@ instance HasClient Delete where type Client Delete = BaseUrl -> EitherT String IO () clientWithRoute Proxy req host = - performRequest methodDelete req 204 host + performRequestJSON methodDelete req 204 host instance HasDocs Delete where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index c6d375b0..e1ac36ef 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -39,7 +39,7 @@ instance ToJSON result => HasServer (Get result) where instance FromJSON result => HasClient (Get result) where type Client (Get result) = BaseUrl -> EitherT String IO result clientWithRoute Proxy req host = - performRequest methodGet req 200 host + performRequestJSON methodGet req 200 host instance ToSample a => HasDocs (Get a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index 2a4a4feb..c646720c 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -42,7 +42,7 @@ instance FromJSON a => HasClient (Post a) where type Client (Post a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req uri = - performRequest methodPost req 201 uri + performRequestJSON methodPost req 201 uri instance ToSample a => HasDocs (Post a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 5c71097c..3ef2c17f 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -41,7 +41,7 @@ instance FromJSON a => HasClient (Put a) where type Client (Put a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req host = - performRequest methodPut req 200 host + performRequestJSON methodPut req 200 host instance ToSample a => HasDocs (Put a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index 27e43063..644ccb62 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -1,10 +1,17 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Servant.API.Raw where +import Control.Monad.Trans.Either +import Data.ByteString.Lazy import Data.Proxy +import Network.HTTP.Types import Network.Wai -import Servant.Docs +import Servant.Client +import Servant.Common.BaseUrl +import Servant.Common.Req +import Servant.Docs hiding (Method) import Servant.Server -- | Endpoint for plugging in your own Wai 'Application's. @@ -18,6 +25,14 @@ instance HasServer Raw where route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) +instance HasClient Raw where + type Client Raw = Method -> BaseUrl -> EitherT String IO ByteString + + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req method host = + performRequest method req (const True) host + + instance HasDocs Raw where docsFor _proxy (endpoint, action) = single endpoint action diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index bff9c393..363b92c9 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -77,9 +77,13 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do result <- action manager return (manager, result) -performRequest :: FromJSON result => - Method -> Req -> Int -> BaseUrl -> EitherT String IO result -performRequest method req wantedStatus host = do + +displayHttpRequest :: Method -> String +displayHttpRequest method = "HTTP " ++ cs method ++ " request" + + +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO ByteString +performRequest method req isWantedStatus host = do partialRequest <- liftIO $ reqToRequest req host let request = partialRequest { Client.method = method @@ -90,22 +94,28 @@ performRequest method req wantedStatus host = do Client.httpLbs request manager case eResponse of Left status -> - left (requestString ++ " failed with status: " ++ showStatus status) + left (displayHttpRequest method ++ " failed with status: " ++ showStatus status) Right response -> do let status = Client.responseStatus response - when (statusCode status /= wantedStatus) $ - left (requestString ++ " failed with status: " ++ showStatus status) - result <- either - (\ message -> left (requestString ++ " returned invalid json: " ++ message)) - return - (decodeLenient (Client.responseBody response)) - return result + unless (isWantedStatus (statusCode status)) $ + left (displayHttpRequest method ++ " failed with status: " ++ showStatus status) + return $ Client.responseBody response where - requestString = "HTTP " ++ cs method ++ " request" showStatus (Status code message) = show code ++ " - " ++ cs message + +performRequestJSON :: FromJSON result => + Method -> Req -> Int -> BaseUrl -> EitherT String IO result +performRequestJSON method req wantedStatus host = do + responseBody <- performRequest method req (== wantedStatus) host + either + (\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message)) + return + (decodeLenient responseBody) + + catchStatusCodeException :: IO a -> IO (Either Status a) catchStatusCodeException action = catch (Right <$> action) $ \ e -> case e of diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 2744b6ed..37765369 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Servant.ClientSpec where @@ -8,10 +9,12 @@ module Servant.ClientSpec where import Control.Concurrent import Control.Exception import Control.Monad.Trans.Either +import Data.ByteString.Lazy (ByteString) import Data.Char import Data.Foldable (forM_) import Data.Proxy import Data.Typeable +import Network.HTTP.Types import Network.Socket import Network.Wai import Network.Wai.Handler.Warp @@ -33,6 +36,8 @@ type Api = :<|> "param" :> QueryParam "name" String :> Get Person :<|> "params" :> QueryParams "names" String :> Get [Person] :<|> "flag" :> QueryFlag "flag" :> Get Bool + :<|> "rawSuccess" :> Raw + :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> @@ -53,6 +58,8 @@ server = serve api ( Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return + :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> \ a b c d -> return (a, b, c, d) ) @@ -65,6 +72,8 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool +getRawSuccess :: Method -> BaseUrl -> EitherT String IO ByteString +getRawFailure :: Method -> BaseUrl -> EitherT String IO ByteString getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> BaseUrl -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])]) @@ -74,6 +83,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure :<|> getMultiple) = client api From 286b1db836d4ec85017e3a5bdd49a937f4028dc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 20:36:36 +0800 Subject: [PATCH 5/7] Client Raw: returns `Right (status, body)` even for failure statuses --- src/Servant/API/Raw.hs | 2 +- src/Servant/Common/Req.hs | 7 ++++--- test/Servant/ClientSpec.hs | 10 ++++++++-- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index 644ccb62..340fe3e2 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -26,7 +26,7 @@ instance HasServer Raw where rawApplication request (respond . succeedWith) instance HasClient Raw where - type Client Raw = Method -> BaseUrl -> EitherT String IO ByteString + type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req method host = diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 363b92c9..ecf851a6 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -82,11 +82,12 @@ displayHttpRequest :: Method -> String displayHttpRequest method = "HTTP " ++ cs method ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO ByteString +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString) performRequest method req isWantedStatus host = do partialRequest <- liftIO $ reqToRequest req host let request = partialRequest { Client.method = method + , checkStatus = \ _status _headers _cookies -> Nothing } eResponse <- liftIO $ __withGlobalManager $ \ manager -> @@ -100,7 +101,7 @@ performRequest method req isWantedStatus host = do let status = Client.responseStatus response unless (isWantedStatus (statusCode status)) $ left (displayHttpRequest method ++ " failed with status: " ++ showStatus status) - return $ Client.responseBody response + return $ (statusCode status, Client.responseBody response) where showStatus (Status code message) = show code ++ " - " ++ cs message @@ -109,7 +110,7 @@ performRequest method req isWantedStatus host = do performRequestJSON :: FromJSON result => Method -> Req -> Int -> BaseUrl -> EitherT String IO result performRequestJSON method req wantedStatus host = do - responseBody <- performRequest method req (== wantedStatus) host + (_status, responseBody) <- performRequest method req (== wantedStatus) host either (\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message)) return diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 37765369..945e0379 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -72,8 +72,8 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool -getRawSuccess :: Method -> BaseUrl -> EitherT String IO ByteString -getRawFailure :: Method -> BaseUrl -> EitherT String IO ByteString +getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString) +getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString) getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> BaseUrl -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])]) @@ -115,6 +115,12 @@ spec = do it (show flag) $ withServer $ \ host -> do runEitherT (getQueryFlag flag host) `shouldReturn` Right flag + it "Servant.API.Raw on success" $ withServer $ \ host -> do + runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess") + + it "Servant.API.Raw on failure" $ withServer $ \ host -> do + runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure") + modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ property $ forAllShrink pathGen shrink $ \ a -> \ b c d -> From 49c301d26e12c05daa7e8a3ecf89545390c169aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 20:50:36 +0800 Subject: [PATCH 6/7] html's verbatim is called pre --- src/Servant/Utils/StaticFiles.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs index 8b1c772c..6399115b 100644 --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -26,8 +26,8 @@ toHtml :: String -> String toHtml markdown = "" ++ "" ++ - "" ++ + "
" ++
   markdown ++
-  "" ++
+  "
" ++ "" ++ "" From 102c752268ae301f6d81580f2984f5363f8b64d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Fri, 14 Nov 2014 19:54:38 +0800 Subject: [PATCH 7/7] removed Servant.Docs.printMarkdown --- example/greet.hs | 2 +- src/Servant/Docs.hs | 19 ++++++++----------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/example/greet.hs b/example/greet.hs index 54226d9e..569e4a44 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -102,4 +102,4 @@ main = do print =<< runEitherT (deleteGreet "blah" uri) killThread tid putStrLn "\n---------\n" - printMarkdown docsGreet + putStrLn $ markdown docsGreet diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 228a599e..215ed9a5 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -16,13 +16,13 @@ -- -- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@ -- --- You can then call 'printMarkdown' on it: +-- You can then call 'markdown' on it: -- --- @printMarkdown :: 'API' -> IO ()@ +-- @printMarkdown :: 'API' -> String@ -- -- or define a custom pretty printer: -- --- @yourPrettyDocs :: 'API' -> IO () -- or blaze-html's HTML, or ...@ +-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@ -- -- The only thing you'll need to do will be to implement some classes -- for your captures, get parameters and request or response bodies. @@ -70,7 +70,7 @@ -- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove" -- > -- > -- API specification --- > type TestApi = +-- > type TestApi = -- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet -- > :<|> "greet" :> RQBody Greet :> Post Greet -- > :<|> "delete" :> Capture "greetid" Text :> Delete @@ -83,10 +83,10 @@ -- > greetDocs = docs testApi -- > -- > main :: IO () --- > main = printMarkdown greetDocs +-- > main = putStrLn $ markdown greetDocs module Servant.Docs ( -- * 'HasDocs' class and key functions - HasDocs(..), docs, markdown, printMarkdown + HasDocs(..), docs, markdown , -- * Classes you need to implement for your types ToSample(..) @@ -355,11 +355,8 @@ class ToParam t where class ToCapture c where toCapture :: Proxy c -> DocCapture --- | Print documentation in Markdown format for --- the given 'API', on standard output. -printMarkdown :: API -> IO () -printMarkdown = print . markdown - +-- | Generate documentation in Markdown format for +-- the given 'API'. markdown :: API -> String markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList