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
parent e9db7f651c
commit f8ea9ba8fe
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 ()
:<|> (\ 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)