Transform Main.hs into Tests

servant-client/servant-client.cabal

@@ -116,6 +116,7 @@ test-suite spec
     , kan-extensions
     , servant-client
     , servant-client-core
+    , sop-core
     , stm
     , text
     , transformers

servant-client/test/Servant/ClientTestUtils.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
@@ -26,10 +27,14 @@ import           Control.Concurrent
 import           Control.Monad.Error.Class
                  (throwError)
 import           Data.Aeson
+import qualified Data.ByteString.Lazy as LazyByteString
 import           Data.Char
                  (chr, isPrint)
 import           Data.Monoid ()
 import           Data.Proxy
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import           GHC.Generics
                  (Generic)
 import qualified Network.HTTP.Client                  as C
@@ -47,8 +52,11 @@ import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (..), Capture, CaptureAll,
                  DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
-                 Headers, JSON, NoContent (NoContent), Post, QueryFlag,
-                 QueryParam, QueryParams, Raw, ReqBody, addHeader)
+                 Headers, JSON, MimeRender(mimeRender),
+                 MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
+                 Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
+                 StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
+                 addHeader)
 import           Servant.Client
 import qualified Servant.Client.Core.Auth    as Auth
 import           Servant.Server
@@ -63,7 +71,7 @@ _ = client comprehensiveAPIWithoutStreaming
 data Person = Person
   { _name :: String
   , _age  :: Integer
-  } deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Read, Generic)
 
 instance ToJSON Person
 instance FromJSON Person
@@ -74,6 +82,22 @@ instance FromForm Person
 instance Arbitrary Person where
   arbitrary = Person <$> arbitrary <*> arbitrary
 
+instance MimeRender PlainText Person where
+  mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show
+
+instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where
+  mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
+
+instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
+  mimeUnrender contentTypeProxy input =
+    WithStatus <$> mimeUnrender contentTypeProxy input
+
+instance MimeUnrender PlainText Person where
+  mimeUnrender _ =
+    -- This does not handle any errors, but it should be fine for tests
+    Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict
+
+
 alice :: Person
 alice = Person "Alice" 42
 
@@ -105,6 +129,12 @@ type Api =
   :<|> "deleteContentType" :> DeleteNoContent
   :<|> "redirectWithCookie" :> Raw
   :<|> "empty" :> EmptyAPI
+  :<|> "uverb-success-or-redirect" :>
+            Capture "bool" Bool :>
+            UVerb 'GET '[PlainText] '[WithStatus 200 Person,
+                                      WithStatus 301 Text]
+  :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
+
 
 api :: Proxy Api
 api = Proxy
@@ -126,6 +156,10 @@ getMultiple     :: String -> Maybe Int -> Bool -> [(String, [Rational])]
 getRespHeaders  :: ClientM (Headers TestHeaders Bool)
 getDeleteContentType :: ClientM NoContent
 getRedirectWithCookie :: HTTP.Method -> ClientM Response
+uverbGetSuccessOrRedirect :: Bool
+                          -> ClientM (Union '[WithStatus 200 Person,
+                                              WithStatus 301 Text])
+uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
 
 getRoot
   :<|> getGet
@@ -143,7 +177,9 @@ getRoot
   :<|> getRespHeaders
   :<|> getDeleteContentType
   :<|> getRedirectWithCookie
-  :<|> EmptyClient = client api
+  :<|> EmptyClient
+  :<|> uverbGetSuccessOrRedirect
+  :<|> uverbGetCreated = client api
 
 server :: Application
 server = serve api (
@@ -166,7 +202,12 @@ server = serve api (
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> return NoContent
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
-  :<|> emptyServer)
+  :<|> emptyServer
+  :<|> (\shouldRedirect -> if shouldRedirect
+                              then respond (WithStatus @301 ("redirecting" :: Text))
+                              else respond (WithStatus @200 alice ))
+  :<|> respond (WithStatus @201 carol)
+  )
 
 type FailApi =
        "get" :> Raw

servant-client/test/Servant/SuccessSpec.hs

@@ -28,18 +28,24 @@ import           Control.Concurrent.STM.TVar
                  (newTVar, readTVar)
 import           Data.Foldable
                  (forM_, toList)
+import           Data.Functor.Identity
+                 (Identity(Identity))
 import           Data.Maybe
                  (listToMaybe)
 import           Data.Monoid ()
+import           Data.SOP.NS
+                 (NS(Z))
 import qualified Network.HTTP.Client                  as C
 import qualified Network.HTTP.Types                   as HTTP
+import           Network.HTTP.Types.Status
+                 (status301)
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
 import           Test.HUnit
 import           Test.QuickCheck
 
 import           Servant.API
-                 (NoContent (NoContent), getHeaders)
+                 (NoContent (NoContent), WithStatus(WithStatus), getHeaders)
 import           Servant.Client
 import qualified Servant.Client.Core.Request as Req
 import           Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
@@ -151,3 +157,44 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
             return $
               result === Right (cap, num, flag, body)
+
+    context "With a route that can either return success or redirect" $ do
+      it "Redirects when appropriate" $ \(_, baseUrl) -> do
+        eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
+
+        -- This is what we would actually want, since the 301 is part of the
+        -- declared api:
+        --   case eitherResponse of
+        --     Left clientError -> fail $ show clientError
+        --     Right response ->
+        --       case response of
+        --         Z (Identity (WithStatus person :: WithStatus 200 Person)) ->
+        --           fail "Expected to be redirected"
+        --         S (last) ->
+        --           let Identity (WithStatus message :: WithStatus 301 Text)
+        --                 = unZ last
+        --           in message `shouldBe` "redirecting"
+        --
+        -- But since servant-client interprets the 301 as an error, this is the
+        -- behaviour we actually have
+        case eitherResponse of
+          Left clientError ->
+            case clientError of
+              FailureResponse _request response -> do
+                responseStatusCode response `shouldBe` status301
+                responseBody response `shouldBe` "redirecting"
+              r ->
+                fail $ "Expected FailureResponse, got: " <> show r
+          Right r ->
+            fail $ "Expected a ClientError, got: " <> show r
+
+      it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
+        Right response <- runClient (uverbGetSuccessOrRedirect False) baseUrl
+        let Z (Identity (WithStatus person :: WithStatus 200 Person)) = response
+        person `shouldBe` alice
+
+    context "with a route that uses uverb but only has a single response" $
+      it "returns the expected response" $ \(_, baseUrl) -> do
+        Right response <- runClient (uverbGetCreated) baseUrl
+        let Z (Identity (WithStatus person :: WithStatus 201 Person)) = response
+        person `shouldBe` carol

servant-server/test/Servant/ServerSpec.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 
 module Servant.ServerSpec where
@@ -49,14 +48,16 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
-                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
-                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
-                 QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
-                 SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)
+                 Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
+                 HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
+                 NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
+                 Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
+                 ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
+                 UVerb, Verb, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err401, err403, err404, serve, serveWithContext)
+                 emptyServer, err401, err403, err404, respond, serve,
+                 serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
@@ -87,6 +88,7 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
 spec :: Spec
 spec = do
   verbSpec
+  uverbSpec
   captureSpec
   captureAllSpec
   queryParamSpec
@@ -253,8 +255,8 @@ captureSpec = do
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
-        (\ "captured" -> Tagged $ \request_ respond ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+        (\ "captured" -> Tagged $ \request_ sendResponse ->
+            sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "strips the captured path snippet from pathInfo" $ do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
@@ -305,8 +307,8 @@ captureAllSpec = do
 
     with (return (serve
         (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
-        (\ _captured -> Tagged $ \request_ respond ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+        (\ _captured -> Tagged $ \request_ sendResponse ->
+            sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "consumes everything from pathInfo" $ do
         get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
 
@@ -544,8 +546,8 @@ rawApi :: Proxy RawApi
 rawApi = Proxy
 
 rawApplication :: Show a => (Request -> a) -> Tagged m Application
-rawApplication f = Tagged $ \request_ respond ->
-    respond $ responseLBS ok200 []
+rawApplication f = Tagged $ \request_ sendResponse ->
+    sendResponse $ responseLBS ok200 []
         (cs $ show $ f request_)
 
 rawSpec :: Spec
@@ -706,7 +708,7 @@ basicAuthApi = Proxy
 basicAuthServer :: Server BasicAuthAPI
 basicAuthServer =
   const (return jerry) :<|>
-  (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+  (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
 
 basicAuthContext :: Context '[ BasicAuthCheck () ]
 basicAuthContext =
@@ -751,7 +753,7 @@ genAuthApi = Proxy
 
 genAuthServer :: Server GenAuthAPI
 genAuthServer = const (return tweety)
-           :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+           :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
 
 type instance AuthServerData (AuthProtect "auth") = ()
 
@@ -781,6 +783,73 @@ genAuthSpec = do
         it "plays nice with subsequent Raw endpoints" $ do
           get "/foo" `shouldRespondWith` 418
 
+-- }}}
+------------------------------------------------------------------------------
+-- * UVerb {{{
+------------------------------------------------------------------------------
+
+newtype PersonResponse = PersonResponse Person
+  deriving Generic
+instance ToJSON PersonResponse
+instance HasStatus PersonResponse where
+  type StatusOf PersonResponse = 200
+
+newtype RedirectResponse = RedirectResponse String
+  deriving Generic
+instance ToJSON RedirectResponse
+instance HasStatus RedirectResponse where
+  type StatusOf RedirectResponse = 301
+
+newtype AnimalResponse = AnimalResponse Animal
+  deriving Generic
+instance ToJSON AnimalResponse
+instance HasStatus AnimalResponse where
+  type StatusOf AnimalResponse = 203
+
+
+type UVerbApi
+  = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]
+  :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]
+
+uverbSpec :: Spec
+uverbSpec = describe "Servant.API.UVerb " $ do
+  let
+      joe = Person "joe" 42
+      mouse = Animal "Mouse" 7
+
+      personHandler
+        :: Bool
+        -> Handler (Union '[PersonResponse
+                           ,RedirectResponse])
+      personHandler True = respond $ RedirectResponse "over there!"
+      personHandler False = respond $ PersonResponse joe
+
+      animalHandler = respond $ AnimalResponse mouse
+
+      server :: Server UVerbApi
+      server = personHandler :<|> animalHandler
+
+  with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do
+    context "A route returning either 301/String or 200/Person" $ do
+      context "when requesting the person" $ do
+        let theRequest = THW.get "/person/false"
+        it "returns status 200" $
+            theRequest `shouldRespondWith` 200
+        it "returns a person" $ do
+            response <- theRequest
+            liftIO $ decode' (simpleBody response) `shouldBe` Just joe
+      context "requesting the redirect" $
+        it "returns a message and status 301" $
+          THW.get "/person/true"
+            `shouldRespondWith` "\"over there!\"" {matchStatus = 301}
+    context "a route with a single response type" $ do
+      let theRequest = THW.get "/animal"
+      it "should return the defined status code" $
+         theRequest `shouldRespondWith` 203
+      it "should return the expected response" $ do
+        response <- theRequest
+        liftIO $ decode' (simpleBody response) `shouldBe` Just mouse
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * Test data types {{{