f36e488 · typeable/servant

example/greet.hs+2−4

compare with master

unifiedsplit

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

46 Normal

47

48instance ToSample Greet where

49− toSample Proxy = Just (encode g)

50−

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

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

52

50

53-- API specification

51-- API specification

54type TestApi =

52type TestApi =

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

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

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

105 killThread tid

103 killThread tid

106 putStrLn "\n---------\n"

104 putStrLn "\n---------\n"

107− printMarkdown docsGreet

105+ putStrLn $ markdown docsGreet

servant.cabal+1−1

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

80test-suite spec

81 type: exitcode-stdio-1.0

82 ghc-options:

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

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

84 default-language: Haskell2010

85 hs-source-dirs: test

86 main-is: Spec.hs

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

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

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

40

41 clientWithRoute Proxy req host =

42− performRequest methodDelete req 204 host

42+ performRequestJSON methodDelete req 204 host

43

44instance HasDocs Delete where

45 docsFor Proxy (endpoint, action) =

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

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

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

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

41 clientWithRoute Proxy req host =

42− performRequest methodGet req 200 host

42+ performRequestJSON methodGet req 200 host

43

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

45 docsFor Proxy (endpoint, action) =

46 single endpoint' action'

47

48 where endpoint' = endpoint & method .~ DocGET

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

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

50 p = Proxy :: Proxy a

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

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

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

43

44 clientWithRoute Proxy req uri =

45− performRequest methodPost req 201 uri

45+ performRequestJSON methodPost req 201 uri

46

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

48 docsFor Proxy (endpoint, action) =

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

50

51 where endpoint' = endpoint & method .~ DocPOST

52

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

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

54 & response.respStatus .~ 201

55

56 p = Proxy :: Proxy a

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

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

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

42

43 clientWithRoute Proxy req host =

44− performRequest methodPut req 200 host

44+ performRequestJSON methodPut req 200 host

45

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

47 docsFor Proxy (endpoint, action) =

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

49

50 where endpoint' = endpoint & method .~ DocPUT

51

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

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

53 & response.respStatus .~ 200

54

55 p = Proxy :: Proxy a

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

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

1−{-# LANGUAGE TypeFamilies #-}

1+{-# LANGUAGE InstanceSigs #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeFamilies #-}

3module Servant.API.Raw where

4module Servant.API.Raw where

4

5

6+import Control.Monad.Trans.Either

7+import Data.ByteString.Lazy

5import Data.Proxy

8import Data.Proxy

9+import Network.HTTP.Types

6import Network.Wai

10import 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)

8import Servant.Server

15import Servant.Server

9

16

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

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

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

18 route Proxy rawApplication request respond =

25 route Proxy rawApplication request respond =

19 rawApplication request (respond . succeedWith)

26 rawApplication request (respond . succeedWith)

20

27

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+

21instance HasDocs Raw where

36instance HasDocs Raw where

22 docsFor _proxy (endpoint, action) =

37 docsFor _proxy (endpoint, action) =

23 single endpoint action

38 single endpoint action

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

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

48

49 where sublayoutP = Proxy :: Proxy sublayout

50

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

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

52 p = Proxy :: Proxy a

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

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

77 result <- action manager

78 return (manager, result)

79

80−performRequest :: FromJSON result =>

80+

81+displayHttpRequest :: Method -> String

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

83+

84+

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

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

82−performRequest method req wantedStatus host = do

86+performRequest method req isWantedStatus host = do

83 partialRequest <- liftIO $ reqToRequest req host

87 partialRequest <- liftIO $ reqToRequest req host

84

88

85 let request = partialRequest { Client.method = method

89 let request = partialRequest { Client.method = method

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

86 }

91 }

87

92

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

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

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

90 Client.httpLbs request manager

95 Client.httpLbs request manager

91 case eResponse of

96 case eResponse of

92 Left status ->

97 Left status ->

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

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

94

99

95 Right response -> do

100 Right response -> do

96 let status = Client.responseStatus response

101 let status = Client.responseStatus response

97− when (statusCode status /= wantedStatus) $

102+ unless (isWantedStatus (statusCode status)) $

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

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

99− result <- either

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

101− return

102− (decodeLenient (Client.responseBody response))

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

103− return result

104 where

105 where

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

106 showStatus (Status code message) =

107 show code ++ " - " ++ cs message

108

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+

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

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

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

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

111 \ e -> case e of

122 \ e -> case e of

src/Servant/Docs.hs+20−13

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

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE TemplateHaskell #-}

4

5

5-------------------------------------------------------------------------------

6-------------------------------------------------------------------------------

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

15--

16--

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

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

17--

18--

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

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

19--

20--

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

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

21--

22--

22-- or define a custom pretty printer:

23-- or define a custom pretty printer:

23--

24--

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

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

25--

26--

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

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

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

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

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

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

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

70-- >

71-- >

71-- > -- API specification

72-- > -- API specification

72−-- > type TestApi =

73+-- > type TestApi =

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

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

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

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

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

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

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

82-- > greetDocs = docs testApi

83-- > greetDocs = docs testApi

83-- >

84-- >

84-- > main :: IO ()

85-- > main :: IO ()

85−-- > main = printMarkdown greetDocs

86+-- > main = putStrLn $ markdown greetDocs

86module Servant.Docs

87module Servant.Docs

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

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

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

89+ HasDocs(..), docs, markdown

89

90

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

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

92+ ToSample(..)

93+ , sampleByteString

94+ , ToParam(..)

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

95+ , ToCapture(..)

92

96

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

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

94 Method(..)

98 Method(..)

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

320-- >

324-- >

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

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

322class ToJSON a => ToSample a where

326class ToJSON a => ToSample a where

327+ toSample :: Maybe a

328+

329+instance ToSample () where

330+ toSample = Just ()

331+

323− toSample :: Proxy a -> Maybe ByteString

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

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

324

334

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

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

326-- for GET parameters.

336-- for GET parameters.

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

345class ToCapture c where

355class ToCapture c where

346 toCapture :: Proxy c -> DocCapture

356 toCapture :: Proxy c -> DocCapture

347

357

348−-- | Print documentation in Markdown format for

358+-- | Generate documentation in Markdown format for

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

359+-- the given 'API'.

350−printMarkdown :: API -> IO ()

351−printMarkdown = print . markdown

352−

353markdown :: API -> String

360markdown :: API -> String

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

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

355

362

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

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

26toHtml markdown =

27 "<html>" ++

28 "<body>" ++

29− "<verbatim>" ++

29+ "<pre>" ++

30 markdown ++

31− "</verbatim>" ++

31+ "</pre>" ++

32 "</body>" ++

33 "</html>"

test/Servant/ClientSpec.hs+18−1

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE ViewPatterns #-}

5{-# LANGUAGE ViewPatterns #-}

5

6

6module Servant.ClientSpec where

7module Servant.ClientSpec where

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

8import Control.Concurrent

9import Control.Concurrent

9import Control.Exception

10import Control.Exception

10import Control.Monad.Trans.Either

11import Control.Monad.Trans.Either

12+import Data.ByteString.Lazy (ByteString)

11import Data.Char

13import Data.Char

12import Data.Foldable (forM_)

14import Data.Foldable (forM_)

13import Data.Proxy

15import Data.Proxy

14import Data.Typeable

16import Data.Typeable

17+import Network.HTTP.Types

15import Network.Socket

18import Network.Socket

16import Network.Wai

19import Network.Wai

17import Network.Wai.Handler.Warp

20import Network.Wai.Handler.Warp

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

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

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

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

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

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

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

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

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

36 :<|> "multiple" :>

41 :<|> "multiple" :>

37 Capture "first" String :>

42 Capture "first" String :>

38 QueryParam "second" Int :>

43 QueryParam "second" Int :>

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

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

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

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

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

55 :<|> return

60 :<|> return

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

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

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

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

57 )

64 )

58

65

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

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

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

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

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

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

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

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

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

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

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

69 -> BaseUrl

78 -> BaseUrl

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

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

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

74 :<|> getQueryParam

83 :<|> getQueryParam

75 :<|> getQueryParams

84 :<|> getQueryParams

76 :<|> getQueryFlag

85 :<|> getQueryFlag

86+ :<|> getRawSuccess

87+ :<|> getRawFailure

77 :<|> getMultiple)

88 :<|> getMultiple)

78 = client api

89 = client api

79

90

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

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

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

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

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

106

117

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+

107 modifyMaxSuccess (const 20) $ do

124 modifyMaxSuccess (const 20) $ do

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

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

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

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

test/Servant/ServerSpec.hs+1−1

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

44instance ToJSON Person

45instance FromJSON Person

46instance ToSample Person where

47− toSample _proxy = Just $ encode alice

47+ toSample = Just alice

48

49alice :: Person

50alice = Person "Alice" 42