97d4133 · typeable/servant

example/greet.hs+11−2

compare with master

unifiedsplit

@@ -34,6 +34,9 @@ instance ToJSON Greet

34instance ToCapture (Capture "name" Text) where

35 toCapture _ = DocCapture "name" "name of the person to greet"

36

37+instance ToCapture (Capture "greetid" Text) where

38+ toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"

39+

37instance ToParam (GetParam "capital" Bool) where

40instance ToParam (GetParam "capital" Bool) where

38 toParam _ =

41 toParam _ =

39 DocGetParam "capital"

42 DocGetParam "capital"

@@ -49,13 +52,14 @@ instance ToSample Greet where

49type TestApi =

52type TestApi =

50 "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet

53 "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet

51 :<|> "greet" :> RQBody Greet :> Post Greet

54 :<|> "greet" :> RQBody Greet :> Post Greet

55+ :<|> "delete" :> Capture "greetid" Text :> Delete

52

56

53testApi :: Proxy TestApi

57testApi :: Proxy TestApi

54testApi = Proxy

58testApi = Proxy

55

59

56-- Server-side handlers

60-- Server-side handlers

57server :: Server TestApi

61server :: Server TestApi

58−server = hello :<|> greet

62+server = hello :<|> greet :<|> delete

59

63

60 where hello name Nothing = hello name (Just False)

64 where hello name Nothing = hello name (Just False)

61 hello name (Just False) = return . Greet $ "Hello, " <> name

65 hello name (Just False) = return . Greet $ "Hello, " <> name

@@ -63,18 +67,22 @@ server = hello :<|> greet

63

67

64 greet = return

68 greet = return

65

69

70+ delete _ = return ()

71+

66-- Client-side query functions

72-- Client-side query functions

67clientApi :: Client TestApi

73clientApi :: Client TestApi

68clientApi = client testApi

74clientApi = client testApi

69

75

70getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet

76getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet

71postGreet :: Greet -> URI -> EitherT String IO Greet

77postGreet :: Greet -> URI -> EitherT String IO Greet

78+deleteGreet :: Text -> URI -> EitherT String IO ()

72−getGreet :<|> postGreet = clientApi

79+getGreet :<|> postGreet :<|> deleteGreet = clientApi

73

80

74-- Turn the server into a WAI app

81-- Turn the server into a WAI app

75test :: Application

82test :: Application

76test = serve testApi server

83test = serve testApi server

77

84

85+-- Documentation

78docsGreet :: API

86docsGreet :: API

79docsGreet = docs testApi

87docsGreet = docs testApi

80

88

@@ -91,6 +99,7 @@ main = do

91 print =<< runEitherT (getGreet "alp" (Just False) uri)

99 print =<< runEitherT (getGreet "alp" (Just False) uri)

92 let g = Greet "yo"

100 let g = Greet "yo"

93 print =<< runEitherT (postGreet g uri)

101 print =<< runEitherT (postGreet g uri)

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

94 killThread tid

103 killThread tid

95 putStrLn "\n---------\n"

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

96 printMarkdown docsGreet

105 printMarkdown docsGreet

servant.cabal+1

@@ -21,6 +21,7 @@ library

21 Servant.Text

22 Servant.API

23 Servant.API.Capture

24+ Servant.API.Delete

24 Servant.API.Get

25 Servant.API.Get

25 Servant.API.GetParam

26 Servant.API.GetParam

26 Servant.API.Post

27 Servant.API.Post

src/Servant.hs+2

@@ -1,11 +1,13 @@

1module Servant

2 ( module Servant.API

3 , module Servant.Client

4+ , module Servant.Docs

4 , module Servant.Server

5 , module Servant.Server

5 , module Servant.Text

6 , module Servant.Text

6 ) where

7 ) where

7

8

8import Servant.API

9import Servant.API

9import Servant.Client

10import Servant.Client

11+import Servant.Docs

10import Servant.Server

12import Servant.Server

11import Servant.Text

13import Servant.Text

src/Servant/API.hs+2

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

1module Servant.API

2 ( module Servant.API.Capture

3+ , module Servant.API.Delete

3 , module Servant.API.Get

4 , module Servant.API.Get

4 , module Servant.API.GetParam

5 , module Servant.API.GetParam

5 , module Servant.API.Post

6 , module Servant.API.Post

@@ -9,6 +10,7 @@ module Servant.API

9 ) where

10 ) where

10

11

11import Servant.API.Capture

12import Servant.API.Capture

13+import Servant.API.Delete

12import Servant.API.Get

14import Servant.API.Get

13import Servant.API.GetParam

15import Servant.API.GetParam

14import Servant.API.Post

16import Servant.API.Post

src/Servant/API/Delete.hsnew file+58

@@ -0,0 +1,58 @@

1+{-# LANGUAGE TypeFamilies #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+module Servant.API.Delete where

5+

6+import Control.Monad

7+import Control.Monad.IO.Class

8+import Control.Monad.Trans.Either

9+import Data.Proxy

10+import Data.String.Conversions

11+import Network.HTTP.Types

12+import Network.URI

13+import Network.Wai

14+import Servant.Client

15+import Servant.Docs

16+import Servant.Server

17+

18+import qualified Network.HTTP.Client as Client

19+

20+-- | Endpoint for DELETE requests.

21+data Delete

22+

23+instance HasServer Delete where

24+ type Server Delete = EitherT (Int, String) IO ()

25+

26+ route Proxy action _globalPathInfo request respond

27+ | null (pathInfo request) && requestMethod request == methodDelete = do

28+ e <- runEitherT action

29+ respond $ Just $ case e of

30+ Right () ->

31+ responseLBS status204 [] ""

32+ Left (status, message) ->

33+ responseLBS (mkStatus status (cs message)) [] (cs message)

34+ | otherwise = respond Nothing

35+

36+instance HasClient Delete where

37+ type Client Delete = URI -> EitherT String IO ()

38+

39+ clientWithRoute Proxy req uri = do

40+ partialRequest <- liftIO $ reqToRequest req uri

41+

42+ let request = partialRequest { Client.method = methodDelete

43+ }

44+

45+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->

46+ Client.httpLbs request manager

47+

48+ when (Client.responseStatus innerResponse /= status204) $

49+ left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))

50+

51+instance HasDocs Delete where

52+ docsFor Proxy (endpoint, action) =

53+ single endpoint' action'

54+

55+ where endpoint' = endpoint & method .~ DocDELETE

56+

57+ action' = action & response.respBody .~ Nothing

58+ & response.respStatus .~ 204

src/Servant/Docs.hs+1−1

@@ -398,6 +398,6 @@ printMarkdown = imapM_ printEndpoint

398 putStrLn $ ""

399 putStrLn $ " - Status code " ++ show (resp ^. respStatus)

400 resp ^. respBody &

401− maybe (putStrLn " - No response body")

401+ maybe (putStrLn " - No response body\n")

402 (\b -> putStrLn " - Response body as below." >> jsonStr b)

403