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

Add HasCfg typeclass.

Browse source 
This is largely Aaron Levin's work. But it was done in a merge commit,
        so couldn't be cherry-picked in a sensible way. Thanks Aaron!
This commit is contained in:
Julian K. Arni 2016-01-07 12:51:30 +01:00 committed by Sönke Hahn
parent da171780b8
commit 3cc3c5c986
15 changed files with 42 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -110,7 +110,7 @@ api :: Proxy Api
api = Proxy
server :: Application
server = serve api (
server = serve api EmptyConfig (
return alice
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
@ -137,7 +137,7 @@ failApi :: Proxy FailApi
failApi = Proxy
failServer :: Application
failServer = serve failApi (
failServer = serve failApi EmptyConfig (
(\ _request respond -> respond $ responseLBS ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
@ -227,7 +227,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
wrappedApiSpec :: Spec
wrappedApiSpec = describe "error status codes" $ do
let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []
let serveW api = serve api EmptyConfig $ throwE $ ServantErr 500 "error message" "" []
context "are correctly handled by the client" $
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
@ -283,8 +283,9 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a
, HasCfg api '[], HasClient api
, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi

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

@ -27,9 +27,10 @@ data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m
type HasCfg (AuthProtected :> rest) c = HasCfg rest c
route Proxy subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
route Proxy p subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) p $ addAcceptCheck subserver $ cookieCheck request
where
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
@ -66,7 +67,7 @@ server = return prvdata :<|> return pubdata
pubdata = [PublicData "this is a public piece of data"]
main :: IO ()
main = run 8080 (serve api server)
main = run 8080 (serve api EmptyConfig 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 $ server sHandler
app sHandler = serve api EmptyConfig $ 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 server
app = serve userAPI EmptyConfig 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 server
app = serve api EmptyConfig server

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

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

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

@ -60,4 +60,4 @@ server :: Server PersonAPI
server = return persons
app :: Application
app = serve personAPI server
app = serve personAPI EmptyConfig 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 server
app = serve ioAPI EmptyConfig server

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

@ -15,4 +15,4 @@ server :: Server API
server = serveDirectory "tutorial"
app :: Application
app = serve api server
app = serve api EmptyConfig 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 readerServer
app = serve readerAPI EmptyConfig 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' server'
app = serve api' EmptyConfig server'

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

@ -41,11 +41,11 @@ server = return products
-- logStdout :: Middleware
-- i.e, logStdout :: Application -> Application
-- serve :: Proxy api -> Server api -> Application
-- serve :: Proxy api -> Config a -> Server api -> Application
-- so applying a middleware is really as simple as
-- applying a function to the result of 'serve'
app :: Application
app = logStdout (serve simpleAPI server)
app = logStdout (serve simpleAPI EmptyConfig server)
main :: IO ()
main = run 8080 app

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

@ -110,7 +110,8 @@ import Servant.Server.Internal.Enter
-- > main :: IO ()
-- > main = Network.Wai.Handler.Warp.run 8080 app
--
serve :: HasServer layout => Proxy layout -> Config a -> Server layout -> Application
serve :: (HasCfg layout a, HasServer layout)
=> Proxy layout -> Config a -> Server layout -> Application
serve p cfg server = toApplication (runRouter (route p cfg d))
where
d = Delayed r r r (\ _ _ -> Route server)

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

@ -31,6 +31,7 @@ import Data.String (fromString)
import Data.String.Conversions (cs, (<>))
import Data.Text (Text)
import Data.Typeable
import GHC.Exts (Constraint)
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders)
@ -67,8 +68,9 @@ import Servant.Server.Internal.ServantErr
class HasServer layout where
type ServerT layout (m :: * -> *) :: *
type HasCfg layout (c :: [*]) :: Constraint
route :: Proxy layout -> Config a -> Delayed (Server layout) -> Router
route :: HasCfg layout a => Proxy layout -> Config a -> Delayed (Server layout) -> Router
type Server layout = ServerT layout (ExceptT ServantErr IO)
@ -88,6 +90,7 @@ type Server layout = ServerT layout (ExceptT ServantErr IO)
instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
type HasCfg (a :<|> b) c = (HasCfg a c, HasCfg b c)
route Proxy cfg server = choice (route pa cfg ((\ (a :<|> _) -> a) <$> server))
(route pb cfg ((\ (_ :<|> b) -> b) <$> server))
@ -119,6 +122,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m
type HasCfg (Capture capture a :> sublayout) c = (HasCfg sublayout c)
route Proxy cfg d =
DynamicRouter $ \ first ->
@ -195,6 +199,7 @@ instance OVERLAPPABLE_
) => HasServer (Verb method status ctypes a) where
type ServerT (Verb method status ctypes a) m = m a
type HasCfg (Verb method status ctypes a) c = ()
route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
@ -206,6 +211,7 @@ instance OVERLAPPING_
) => HasServer (Verb method status ctypes (Headers h a)) where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
type HasCfg (Verb method status ctypes (Headers h a)) c = ()
route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
@ -236,6 +242,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (Header sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasCfg (Header sym a :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
@ -268,6 +275,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParam sym a :> sublayout) m =
Maybe a -> ServerT sublayout m
type HasCfg (QueryParam sym a :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
@ -304,6 +312,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
type ServerT (QueryParams sym a :> sublayout) m =
[a] -> ServerT sublayout m
type HasCfg (QueryParams sym a :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
@ -335,6 +344,7 @@ instance (KnownSymbol sym, HasServer sublayout)
type ServerT (QueryFlag sym :> sublayout) m =
Bool -> ServerT sublayout m
type HasCfg (QueryFlag sym :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
let querytext = parseQueryText $ rawQueryString request
@ -358,6 +368,7 @@ instance (KnownSymbol sym, HasServer sublayout)
instance HasServer Raw where
type ServerT Raw m = Application
type HasCfg Raw c = ()
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
@ -392,6 +403,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
type ServerT (ReqBody list a :> sublayout) m =
a -> ServerT sublayout m
type HasCfg (ReqBody list a :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) cfg (addBodyCheck subserver (bodyCheck request))
@ -415,6 +427,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
type ServerT (path :> sublayout) m = ServerT sublayout m
type HasCfg (path :> sublayout) c = HasCfg sublayout c
route Proxy cfg subserver = StaticRouter $
M.singleton (cs (symbolVal proxyPath))
@ -423,12 +436,14 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
instance HasServer api => HasServer (RemoteHost :> api) where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
type HasCfg (RemoteHost :> api) c = HasCfg api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ remoteHost req)
instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
type HasCfg (IsSecure :> api) c = HasCfg api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ secure req)
@ -437,12 +452,14 @@ instance HasServer api => HasServer (IsSecure :> api) where
instance HasServer api => HasServer (Vault :> api) where
type ServerT (Vault :> api) m = Vault -> ServerT api m
type HasCfg (Vault :> api) c = HasCfg api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ vault req)
instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
type HasCfg (HttpVersion :> api) c = HasCfg api c
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)