eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #381 from haskell-servant/jkarni/default-config-for-serve

Browse source 
Add 'serveWithConfig'.
This commit is contained in:
Julian Arni 2016-02-19 15:29:54 +01:00
commit bfb64cda0b
24 changed files with 64 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
servant-client/test/Servant/ClientSpec.hs
View file

@ -115,7 +115,7 @@ api :: Proxy Api
api = Proxy
server :: Application
server = serve api EmptyConfig (
server = serve api (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
@ -142,7 +142,7 @@ failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi EmptyConfig (
failServer = serve failApi (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@ -232,7 +232,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
context "are correctly handled by the client" $
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =

2
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -82,7 +82,7 @@ main :: IO ()
main = do
dbConnection <- initDB
let config = dbConnection :. EmptyConfig
run 8080 (serve api config server)
run 8080 (serveWithConfig api config server)
{- Sample session:
$ curl http://localhost:8080/

2
servant-examples/socket-io-chat/socket-io-chat.hs
View file

@ -38,7 +38,7 @@ server sHandler = socketIOHandler
app :: WaiMonad () -> Application
app sHandler = serve api EmptyConfig $ server sHandler
app sHandler = serve api $ server sHandler
port :: Int
port = 3001

2
servant-examples/tutorial/T1.hs
View file

@ -42,4 +42,4 @@ server :: Server UserAPI
server = return users
app :: Application
app = serve userAPI EmptyConfig server
app = serve userAPI server

2
servant-examples/tutorial/T10.hs
View file

@ -68,4 +68,4 @@ server = T3.server :<|> serveDocs
plain = ("Content-Type", "text/plain")
app :: Application
app = serve api EmptyConfig server
app = serve api server

2
servant-examples/tutorial/T2.hs
View file

@ -49,4 +49,4 @@ server = return users
:<|> return isaac
app :: Application
app = serve userAPI EmptyConfig server
app = serve userAPI server

2
servant-examples/tutorial/T3.hs
View file

@ -81,4 +81,4 @@ server = position
marketing clientinfo = return (emailForClient clientinfo)
app :: Application
app = serve api EmptyConfig server
app = serve api server

2
servant-examples/tutorial/T4.hs
View file

@ -60,4 +60,4 @@ server :: Server PersonAPI
server = return persons
app :: Application
app = serve personAPI EmptyConfig server
app = serve personAPI server

2
servant-examples/tutorial/T5.hs
View file

@ -34,4 +34,4 @@ server = do
where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
app :: Application
app = serve ioAPI EmptyConfig server
app = serve ioAPI server

2
servant-examples/tutorial/T6.hs
View file

@ -15,4 +15,4 @@ server :: Server API
server = serveDirectory "tutorial"
app :: Application
app = serve api EmptyConfig server
app = serve api server

2
servant-examples/tutorial/T7.hs
View file

@ -30,4 +30,4 @@ readerServer = enter readerToEither readerServerT
readerToEither = Nat $ \r -> return (runReader r "hi")
app :: Application
app = serve readerAPI EmptyConfig readerServer
app = serve readerAPI readerServer

2
servant-examples/tutorial/T9.hs
View file

@ -102,4 +102,4 @@ writeJSFiles = do
TIO.writeFile "tutorial/t9/jq.js" jq
app :: Application
app = serve api' EmptyConfig server'
app = serve api' server'

2
servant-examples/wai-middleware/wai-middleware.hs
View file

@ -45,7 +45,7 @@ server = return products
-- so applying a middleware is really as simple as
-- applying a function to the result of 'serve'
app :: Application
app = logStdout (serve simpleAPI EmptyConfig server)
app = logStdout (serve simpleAPI server)
main :: IO ()
main = run 8080 app

2
servant-mock/example/main.hs
View file

@ -20,4 +20,4 @@ api :: Proxy API
api = Proxy
main :: IO ()
main = run 8080 (serve api EmptyConfig $ mock api Proxy)
main = run 8080 (serve api $ mock api Proxy)

17
servant-mock/src/Servant/Mock.hs
View file

@ -1,12 +1,12 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "overlapping-compat.h"
@ -67,7 +67,6 @@ import Network.HTTP.Types.Status
import Network.Wai
import Servant
import Servant.API.ContentTypes
import Servant.Server.Internal.Config
import Test.QuickCheck.Arbitrary (Arbitrary (..), vector)
import Test.QuickCheck.Gen (Gen, generate)

4
servant-mock/test/Servant/MockSpec.hs
View file

@ -52,7 +52,7 @@ spec = do
context "Get" $ do
let api :: Proxy (Get '[JSON] Body)
api = Proxy
app = serve api EmptyConfig (mock api Proxy)
app = serve api (mock api Proxy)
with (return app) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{
@ -65,7 +65,7 @@ spec = do
withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body))
withoutHeader = Proxy
toApp :: (HasMock api '[]) => Proxy api -> IO Application
toApp api = return $ serve api EmptyConfig (mock api (Proxy :: Proxy '[]))
toApp api = return $ serve api (mock api (Proxy :: Proxy '[]))
with (toApp withHeader) $ do
it "serves arbitrary response bodies" $ do
get "/" `shouldRespondWith` 200{

2
servant-server/example/greet.hs
View file

@ -59,7 +59,7 @@ server = helloH :<|> postGreetH :<|> deleteGreetH
-- Turn the server into a WAI app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module.
test :: Application
test = serve testApi EmptyConfig server
test = serve testApi server
-- Run the server.
--

14
servant-server/src/Servant/Server.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
@ -8,6 +9,7 @@
module Servant.Server
( -- * Run a wai application from an API
serve
, serveWithConfig
, -- * Construct a wai Application from an API
toApplication
@ -104,18 +106,18 @@ import Servant.Server.Internal.Enter
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
-- > config :: Config '[]
-- > config = EmptyConfig
-- >
-- > app :: Application
-- > app = serve myApi config server
-- > app = serve myApi server
-- >
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: (HasServer layout config)
serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application
serve p = serveWithConfig p EmptyConfig
serveWithConfig :: (HasServer layout config)
=> Proxy layout -> Config config -> Server layout -> Application
serve p config server = toApplication (runRouter (route p config d))
serveWithConfig p config server = toApplication (runRouter (route p config d))
where
d = Delayed r r r (\ _ _ -> Route server)
r = return (Route ())

8
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -11,14 +11,8 @@ module Servant.Server.Internal.RoutingApplication where
import Control.Applicative ((<$>))
#endif
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef,
writeIORef)
import Network.Wai (Application, Request,
Response, ResponseReceived,
requestBody,
strictRequestBody)
Response, ResponseReceived)
import Servant.Server.Internal.ServantErr
type RoutingApplication =

8
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -42,7 +42,7 @@ errorOrderServer = \_ _ -> throwE err402
errorOrderSpec :: Spec
errorOrderSpec = describe "HTTP error order"
$ with (return $ serve errorOrderApi EmptyConfig errorOrderServer) $ do
$ with (return $ serve errorOrderApi errorOrderServer) $ do
let badContentType = (hContentType, "text/plain")
badAccept = (hAccept, "text/plain")
badMethod = methodGet
@ -89,7 +89,7 @@ prioErrorsApi = Proxy
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
let server = return
with (return $ serve prioErrorsApi EmptyConfig server) $ do
with (return $ serve prioErrorsApi server) $ do
let check (mdescr, method) path (cdescr, ctype, body) resp =
it fulldescr $
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
@ -154,7 +154,7 @@ errorRetryServer
errorRetrySpec :: Spec
errorRetrySpec = describe "Handler search"
$ with (return $ serve errorRetryApi EmptyConfig errorRetryServer) $ do
$ with (return $ serve errorRetryApi errorRetryServer) $ do
let jsonCT = (hContentType, "application/json")
jsonAccept = (hAccept, "application/json")
@ -198,7 +198,7 @@ errorChoiceServer = return 0
errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors"
$ with (return $ serve errorChoiceApi EmptyConfig errorChoiceServer) $ do
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do
it "should respond with 404 if no path matches" $ do
request methodGet "" [] "" `shouldRespondWith` 404

4
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -48,12 +48,12 @@ combinedReaderServer = enter fReader combinedReaderServer'
enterSpec :: Spec
enterSpec = describe "Enter" $ do
with (return (serve readerAPI EmptyConfig readerServer)) $ do
with (return (serve readerAPI readerServer)) $ do
it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do
with (return (serve combinedAPI combinedReaderServer)) $ do
it "allows combnation of enters" $ do
get "bool" `shouldRespondWith` "true"

10
servant-server/test/Servant/Server/UsingConfigSpec.hs
View file

@ -30,7 +30,7 @@ testServer s = return s
oneEntryApp :: Application
oneEntryApp =
serve (Proxy :: Proxy OneEntryAPI) config testServer
serveWithConfig (Proxy :: Proxy OneEntryAPI) config testServer
where
config :: Config '[String]
config = "configEntry" :. EmptyConfig
@ -40,7 +40,7 @@ type OneEntryTwiceAPI =
"bar" :> ExtractFromConfig :> Get '[JSON] String
oneEntryTwiceApp :: Application
oneEntryTwiceApp = serve (Proxy :: Proxy OneEntryTwiceAPI) config $
oneEntryTwiceApp = serveWithConfig (Proxy :: Proxy OneEntryTwiceAPI) config $
testServer :<|>
testServer
where
@ -68,7 +68,7 @@ type InjectAPI =
Get '[JSON] String
injectApp :: Application
injectApp = serve (Proxy :: Proxy InjectAPI) config $
injectApp = serveWithConfig (Proxy :: Proxy InjectAPI) config $
(\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where
@ -90,7 +90,7 @@ type WithBirdfaceAPI =
"bar" :> ExtractFromConfig :> Get '[JSON] String
withBirdfaceApp :: Application
withBirdfaceApp = serve (Proxy :: Proxy WithBirdfaceAPI) config $
withBirdfaceApp = serveWithConfig (Proxy :: Proxy WithBirdfaceAPI) config $
testServer :<|>
testServer
where
@ -112,7 +112,7 @@ type NamedConfigAPI =
ExtractFromConfig :> Get '[JSON] String)
namedConfigApp :: Application
namedConfigApp = serve (Proxy :: Proxy NamedConfigAPI) config return
namedConfigApp = serveWithConfig (Proxy :: Proxy NamedConfigAPI) config return
where
config :: Config '[NamedConfig "sub" '[String]]
config = NamedConfig ("descend" :. EmptyConfig) :. EmptyConfig

31
servant-server/test/Servant/ServerSpec.hs
View file

@ -49,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
StdMethod (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (ServantErr (..), Server, err404,
serve, Config(EmptyConfig))
serve, serveWithConfig, Config(EmptyConfig))
import Test.Hspec (Spec, context, describe, it,
shouldBe, shouldContain)
import Test.Hspec.Wai (get, liftIO, matchHeaders,
@ -67,7 +67,7 @@ import Servant.Server.Internal.Config
-- * comprehensive api test
-- This declaration simply checks that all instances are in place.
_ = serve comprehensiveAPI comprehensiveApiConfig
_ = serveWithConfig comprehensiveAPI comprehensiveApiConfig
comprehensiveApiConfig :: Config '[NamedConfig "foo" '[]]
comprehensiveApiConfig = NamedConfig EmptyConfig :. EmptyConfig
@ -112,7 +112,7 @@ verbSpec = describe "Servant.API.Verb" $ do
wrongMethod m = if m == methodPatch then methodPost else methodPatch
test desc api method (status :: Int) = context desc $
with (return $ serve api EmptyConfig server) $ do
with (return $ serve api server) $ do
-- HEAD and 214/215 need not return bodies
unless (status `elem` [214, 215] || method == methodHead) $
@ -187,7 +187,7 @@ captureServer legs = case legs of
captureSpec :: Spec
captureSpec = do
describe "Servant.API.Capture" $ do
with (return (serve captureApi EmptyConfig captureServer)) $ do
with (return (serve captureApi captureServer)) $ do
it "can capture parts of the 'pathInfo'" $ do
response <- get "/2"
@ -198,7 +198,6 @@ captureSpec = do
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
EmptyConfig
(\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
it "strips the captured path snippet from pathInfo" $ do
@ -232,7 +231,7 @@ queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
it "allows retrieving simple GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
(flip runSession) (serve queryParamApi qpServer) $ do
let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params1,
@ -244,7 +243,7 @@ queryParamSpec = do
}
it "allows retrieving lists in GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
(flip runSession) (serve queryParamApi qpServer) $ do
let params2 = "?names[]=bob&names[]=john"
response2 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params2,
@ -258,7 +257,7 @@ queryParamSpec = do
it "allows retrieving value-less GET parameters" $
(flip runSession) (serve queryParamApi EmptyConfig qpServer) $ do
(flip runSession) (serve queryParamApi qpServer) $ do
let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3,
@ -310,7 +309,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
mkReq method x = Test.Hspec.Wai.request method x
[(hContentType, "application/json;charset=utf-8")]
with (return $ serve reqBodyApi EmptyConfig server) $ do
with (return $ serve reqBodyApi server) $ do
it "passes the argument to the handler" $ do
response <- mkReq methodPost "" (encode alice)
@ -343,13 +342,13 @@ headerSpec = describe "Servant.API.Header" $ do
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
with (return (serve headerApi EmptyConfig expectsInt)) $ do
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 200
with (return (serve headerApi EmptyConfig expectsString)) $ do
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
it "passes the header to the handler (String)" $
@ -373,7 +372,7 @@ rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
@ -381,7 +380,7 @@ rawSpec = do
simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
@ -415,7 +414,7 @@ alternativeServer =
alternativeSpec :: Spec
alternativeSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve alternativeApi EmptyConfig alternativeServer) $ do
with (return $ serve alternativeApi alternativeServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
@ -450,7 +449,7 @@ responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) EmptyConfig responseHeadersServer) $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
let methods = [methodGet, methodPost, methodPut, methodPatch]
@ -516,7 +515,7 @@ miscServ = versionHandler
hostHandler = return . show
miscCombinatorSpec :: Spec
miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""

4
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -16,7 +16,7 @@ import Test.Hspec (Spec, around_, describe, it)
import Test.Hspec.Wai (get, shouldRespondWith, with)
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
import Servant.Server (Server, serve, Config(EmptyConfig))
import Servant.Server (Server, serve)
import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory)
@ -29,7 +29,7 @@ api :: Proxy Api
api = Proxy
app :: Application
app = serve api EmptyConfig server
app = serve api server
server :: Server Api
server =