f36e488 · typeable/servant

git.iko.soy/typeable/servant

Merge pull request #36 from alpmestan/some_refactorings

Client instance for Raw, API documentation serving, some refactoring.

commitf36e488f9e6af34e19e8c6eb52e1b845654e1012 authorAlp Mestanogullari <alpmestan@gmail.com> dateFri 14 Nov 2014, 13:17 (12 years ago) parente7b7256 102c752

13 files changed+92−44

compare with master

unifiedsplit

example/greet.hs+2−4 servant.cabal+1−1 src/Servant/API/Delete.hs+1−1 src/Servant/API/Get.hs+2−2 src/Servant/API/Post.hs+2−2 src/Servant/API/Put.hs+2−2 src/Servant/API/Raw.hs+17−2 src/Servant/API/ReqBody.hs+1−1 src/Servant/Common/Req.hs+23−12 src/Servant/Docs.hs+20−13 src/Servant/Utils/StaticFiles.hs+2−2 test/Servant/ClientSpec.hs+18−1 test/Servant/ServerSpec.hs+1−1

example/greet.hs+2−4

@@ -46,9 +46,7 @@ instance ToParam (QueryParam "capital" Bool) where

4646 Normal

4747

4848instance ToSample Greet where

49− toSample Proxy = Just (encode g)

50−

51− where g = Greet "Hello, haskeller!"

49+ toSample = Just $ Greet "Hello, haskeller!"

5250

5351-- API specification

5452type TestApi =

@@ -104,4 +102,4 @@ main = do

104102 print =<< runEitherT (deleteGreet "blah" uri)

105103 killThread tid

106104 putStrLn "\n---------\n"

107− printMarkdown docsGreet

105+ putStrLn $ markdown docsGreet

servant.cabal+1−1

@@ -80,7 +80,7 @@ executable greet

8080test-suite spec

8181 type: exitcode-stdio-1.0

8282 ghc-options:

83− -Wall -Werror -fno-warn-name-shadowing -fno-warn-missing-signatures

83+ -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures

8484 default-language: Haskell2010

8585 hs-source-dirs: test

8686 main-is: Spec.hs

src/Servant/API/Delete.hs+1−1

@@ -39,7 +39,7 @@ instance HasClient Delete where

3939 type Client Delete = BaseUrl -> EitherT String IO ()

4040

4141 clientWithRoute Proxy req host =

42− performRequest methodDelete req 204 host

42+ performRequestJSON methodDelete req 204 host

4343

4444instance HasDocs Delete where

4545 docsFor Proxy (endpoint, action) =

src/Servant/API/Get.hs+2−2

@@ -39,12 +39,12 @@ instance ToJSON result => HasServer (Get result) where

3939instance FromJSON result => HasClient (Get result) where

4040 type Client (Get result) = BaseUrl -> EitherT String IO result

4141 clientWithRoute Proxy req host =

42− performRequest methodGet req 200 host

42+ performRequestJSON methodGet req 200 host

4343

4444instance ToSample a => HasDocs (Get a) where

4545 docsFor Proxy (endpoint, action) =

4646 single endpoint' action'

4747

4848 where endpoint' = endpoint & method .~ DocGET

49− action' = action & response.respBody .~ toSample p

49+ action' = action & response.respBody .~ sampleByteString p

5050 p = Proxy :: Proxy a

src/Servant/API/Post.hs+2−2

@@ -42,7 +42,7 @@ instance FromJSON a => HasClient (Post a) where

4242 type Client (Post a) = BaseUrl -> EitherT String IO a

4343

4444 clientWithRoute Proxy req uri =

45− performRequest methodPost req 201 uri

45+ performRequestJSON methodPost req 201 uri

4646

4747instance ToSample a => HasDocs (Post a) where

4848 docsFor Proxy (endpoint, action) =

@@ -50,7 +50,7 @@ instance ToSample a => HasDocs (Post a) where

5050

5151 where endpoint' = endpoint & method .~ DocPOST

5252

53− action' = action & response.respBody .~ toSample p

53+ action' = action & response.respBody .~ sampleByteString p

5454 & response.respStatus .~ 201

5555

5656 p = Proxy :: Proxy a

src/Servant/API/Put.hs+2−2

@@ -41,7 +41,7 @@ instance FromJSON a => HasClient (Put a) where

4141 type Client (Put a) = BaseUrl -> EitherT String IO a

4242

4343 clientWithRoute Proxy req host =

44− performRequest methodPut req 200 host

44+ performRequestJSON methodPut req 200 host

4545

4646instance ToSample a => HasDocs (Put a) where

4747 docsFor Proxy (endpoint, action) =

@@ -49,7 +49,7 @@ instance ToSample a => HasDocs (Put a) where

4949

5050 where endpoint' = endpoint & method .~ DocPUT

5151

52− action' = action & response.respBody .~ toSample p

52+ action' = action & response.respBody .~ sampleByteString p

5353 & response.respStatus .~ 200

5454

5555 p = Proxy :: Proxy a

src/Servant/API/Raw.hs+17−2

@@ -1,10 +1,17 @@

1−{-# LANGUAGE TypeFamilies #-}

1+{-# LANGUAGE InstanceSigs #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

34module Servant.API.Raw where

6+import Control.Monad.Trans.Either

7+import Data.ByteString.Lazy

58import Data.Proxy

9+import Network.HTTP.Types

610import Network.Wai

7−import Servant.Docs

11+import Servant.Client

12+import Servant.Common.BaseUrl

13+import Servant.Common.Req

14+import Servant.Docs hiding (Method)

815import Servant.Server

916

1017-- | Endpoint for plugging in your own Wai 'Application's.

@@ -18,6 +25,14 @@ instance HasServer Raw where

1825 route Proxy rawApplication request respond =

1926 rawApplication request (respond . succeedWith)

2027

28+instance HasClient Raw where

29+ type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)

30+

31+ clientWithRoute :: Proxy Raw -> Req -> Client Raw

32+ clientWithRoute Proxy req method host =

33+ performRequest method req (const True) host

34+

35+

2136instance HasDocs Raw where

2237 docsFor _proxy (endpoint, action) =

2338 single endpoint action

src/Servant/API/ReqBody.hs+1−1

@@ -48,5 +48,5 @@ instance (ToSample a, HasDocs sublayout)

4848

4949 where sublayoutP = Proxy :: Proxy sublayout

5050

51− action' = action & rqbody .~ toSample p

51+ action' = action & rqbody .~ sampleByteString p

5252 p = Proxy :: Proxy a

src/Servant/Common/Req.hs+23−12

@@ -77,12 +77,17 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do

7777 result <- action manager

7878 return (manager, result)

7979

80−performRequest :: FromJSON result =>

81− Method -> Req -> Int -> BaseUrl -> EitherT String IO result

82−performRequest method req wantedStatus host = do

80+

81+displayHttpRequest :: Method -> String

82+displayHttpRequest method = "HTTP " ++ cs method ++ " request"

83+

84+

85+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)

86+performRequest method req isWantedStatus host = do

8387 partialRequest <- liftIO $ reqToRequest req host

8488

8589 let request = partialRequest { Client.method = method

90+ , checkStatus = \ _status _headers _cookies -> Nothing

8691 }

8792

8893 eResponse <- liftIO $ __withGlobalManager $ \ manager ->

@@ -90,22 +95,28 @@ performRequest method req wantedStatus host = do

9095 Client.httpLbs request manager

9196 case eResponse of

9297 Left status ->

93− left (requestString ++ " failed with status: " ++ showStatus status)

98+ left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)

9499

95100 Right response -> do

96101 let status = Client.responseStatus response

97− when (statusCode status /= wantedStatus) $

98− left (requestString ++ " failed with status: " ++ showStatus status)

99− result <- either

100− (\ message -> left (requestString ++ " returned invalid json: " ++ message))

101− return

102− (decodeLenient (Client.responseBody response))

103− return result

102+ unless (isWantedStatus (statusCode status)) $

103+ left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)

104+ return $ (statusCode status, Client.responseBody response)

104105 where

105− requestString = "HTTP " ++ cs method ++ " request"

106106 showStatus (Status code message) =

107107 show code ++ " - " ++ cs message

108108

109+

110+performRequestJSON :: FromJSON result =>

111+ Method -> Req -> Int -> BaseUrl -> EitherT String IO result

112+performRequestJSON method req wantedStatus host = do

113+ (_status, responseBody) <- performRequest method req (== wantedStatus) host

114+ either

115+ (\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message))

116+ return

117+ (decodeLenient responseBody)

118+

119+

109120catchStatusCodeException :: IO a -> IO (Either Status a)

110121catchStatusCodeException action = catch (Right <$> action) $

111122 \ e -> case e of

src/Servant/Docs.hs+20−13

@@ -1,5 +1,6 @@

11{-# LANGUAGE TypeFamilies #-}

22{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE TemplateHaskell #-}

56-------------------------------------------------------------------------------

@@ -15,13 +16,13 @@

1516--

1617-- @docs :: 'HasDocs' api => 'Proxy' api -> 'API'@

1718--

18−-- You can then call 'printMarkdown' on it:

19+-- You can then call 'markdown' on it:

1920--

20−-- @printMarkdown :: 'API' -> IO ()@

21+-- @printMarkdown :: 'API' -> String@

2122--

2223-- or define a custom pretty printer:

2324--

24−-- @yourPrettyDocs :: 'API' -> IO () -- or blaze-html's HTML, or ...@

25+-- @yourPrettyDocs :: 'API' -> String -- or blaze-html's HTML, or ...@

2526--

2627-- The only thing you'll need to do will be to implement some classes

2728-- for your captures, get parameters and request or response bodies.

@@ -69,7 +70,7 @@

6970-- > toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"

7071-- >

7172-- > -- API specification

72−-- > type TestApi =

73+-- > type TestApi =

7374-- > "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet

7475-- > :<|> "greet" :> RQBody Greet :> Post Greet

7576-- > :<|> "delete" :> Capture "greetid" Text :> Delete

@@ -82,13 +83,16 @@

8283-- > greetDocs = docs testApi

8384-- >

8485-- > main :: IO ()

85−-- > main = printMarkdown greetDocs

86+-- > main = putStrLn $ markdown greetDocs

8687module Servant.Docs

8788 ( -- * 'HasDocs' class and key functions

88− HasDocs(..), docs, markdown, printMarkdown

89+ HasDocs(..), docs, markdown

8990

9091 , -- * Classes you need to implement for your types

91− ToSample(..), ToParam(..), ToCapture(..)

92+ ToSample(..)

93+ , sampleByteString

94+ , ToParam(..)

95+ , ToCapture(..)

9296

9397 , -- * ADTs to represent an 'API'

9498 Method(..)

@@ -320,7 +324,13 @@ class HasDocs layout where

320324-- >

321325-- > where g = Greet "Hello, haskeller!"

322326class ToJSON a => ToSample a where

323− toSample :: Proxy a -> Maybe ByteString

327+ toSample :: Maybe a

328+

329+instance ToSample () where

330+ toSample = Just ()

331+

332+sampleByteString :: forall a . ToSample a => Proxy a -> Maybe ByteString

333+sampleByteString Proxy = fmap encode (toSample :: Maybe a)

324334

325335-- | The class that helps us automatically get documentation

326336-- for GET parameters.

@@ -345,11 +355,8 @@ class ToParam t where

345355class ToCapture c where

346356 toCapture :: Proxy c -> DocCapture

347357

348−-- | Print documentation in Markdown format for

349−-- the given 'API', on standard output.

350−printMarkdown :: API -> IO ()

351−printMarkdown = print . markdown

352−

358+-- | Generate documentation in Markdown format for

359+-- the given 'API'.

353360markdown :: API -> String

354361markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList

355362

src/Servant/Utils/StaticFiles.hs+2−2

@@ -26,8 +26,8 @@ toHtml :: String -> String

2626toHtml markdown =

2727 "<html>" ++

2828 "<body>" ++

29− "<verbatim>" ++

29+ "<pre>" ++

3030 markdown ++

31− "</verbatim>" ++

31+ "</pre>" ++

3232 "</body>" ++

3333 "</html>"

test/Servant/ClientSpec.hs+18−1

@@ -1,6 +1,7 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

32{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

45{-# LANGUAGE ViewPatterns #-}

67module Servant.ClientSpec where

@@ -8,10 +9,12 @@ module Servant.ClientSpec where

89import Control.Concurrent

910import Control.Exception

1011import Control.Monad.Trans.Either

12+import Data.ByteString.Lazy (ByteString)

1113import Data.Char

1214import Data.Foldable (forM_)

1315import Data.Proxy

1416import Data.Typeable

17+import Network.HTTP.Types

1518import Network.Socket

1619import Network.Wai

1720import Network.Wai.Handler.Warp

@@ -33,6 +36,8 @@ type Api =

3336 :<|> "param" :> QueryParam "name" String :> Get Person

3437 :<|> "params" :> QueryParams "names" String :> Get [Person]

3538 :<|> "flag" :> QueryFlag "flag" :> Get Bool

39+ :<|> "rawSuccess" :> Raw

40+ :<|> "rawFailure" :> Raw

3641 :<|> "multiple" :>

3742 Capture "first" String :>

3843 QueryParam "second" Int :>

@@ -53,6 +58,8 @@ server = serve api (

5358 Nothing -> left (400, "missing parameter"))

5459 :<|> (\ names -> return (zipWith Person names [0..]))

5560 :<|> return

61+ :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")

62+ :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")

5663 :<|> \ a b c d -> return (a, b, c, d)

5764 )

5865

@@ -65,6 +72,8 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person

6572getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person

6673getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]

6774getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool

75+getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)

76+getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString)

6877getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

6978 -> BaseUrl

7079 -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])

@@ -74,6 +83,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

7483 :<|> getQueryParam

7584 :<|> getQueryParams

7685 :<|> getQueryFlag

86+ :<|> getRawSuccess

87+ :<|> getRawFailure

7788 :<|> getMultiple)

7889 = client api

7990

@@ -104,6 +115,12 @@ spec = do

104115 it (show flag) $ withServer $ \ host -> do

105116 runEitherT (getQueryFlag flag host) `shouldReturn` Right flag

106117

118+ it "Servant.API.Raw on success" $ withServer $ \ host -> do

119+ runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess")

120+

121+ it "Servant.API.Raw on failure" $ withServer $ \ host -> do

122+ runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure")

123+

107124 modifyMaxSuccess (const 20) $ do

108125 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $

109126 property $ forAllShrink pathGen shrink $ \ a -> \ b c d ->

test/Servant/ServerSpec.hs+1−1

@@ -44,7 +44,7 @@ data Person = Person {

4444instance ToJSON Person

4545instance FromJSON Person

4646instance ToSample Person where

47− toSample _proxy = Just $ encode alice

47+ toSample = Just alice

4848

4949alice :: Person

5050alice = Person "Alice" 42