diff --git a/example/greet.hs b/example/greet.hs index c2c9976f..569e4a44 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 = @@ -104,4 +102,4 @@ main = do print =<< runEitherT (deleteGreet "blah" uri) killThread tid putStrLn "\n---------\n" - printMarkdown docsGreet + putStrLn $ markdown docsGreet diff --git a/servant.cabal b/servant.cabal index 84a5ee76..6262c846 100644 --- a/servant.cabal +++ b/servant.cabal @@ -80,7 +80,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 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 4114b07e..e1ac36ef 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -39,12 +39,12 @@ 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) = 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..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) = @@ -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..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) = @@ -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/Raw.hs b/src/Servant/API/Raw.hs index 27e43063..340fe3e2 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 (Int, 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/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/Common/Req.hs b/src/Servant/Common/Req.hs index bff9c393..ecf851a6 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -77,12 +77,17 @@ __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 (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 -> @@ -90,22 +95,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 $ (statusCode status, 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 + (_status, 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/src/Servant/Docs.hs b/src/Servant/Docs.hs index beeec4ec..215ed9a5 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------- @@ -15,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. @@ -69,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 @@ -82,13 +83,16 @@ -- > 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(..), ToParam(..), ToCapture(..) + ToSample(..) + , sampleByteString + , ToParam(..) + , ToCapture(..) , -- * ADTs to represent an 'API' Method(..) @@ -320,7 +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 = 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. @@ -345,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 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 ++
-  "" ++
+  "
" ++ "" ++ "" diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 2744b6ed..945e0379 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 (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])]) @@ -74,6 +83,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure :<|> getMultiple) = client api @@ -104,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 -> 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