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

Fix the auth combinator example.

Browse Source 
This change adapt the auth combinator example to the new router code.
In general, the server interpretation of user-written combinators will
be affected by the new routing code.

The change here also introduces a change in functionality: previously,
wrong authentication triggered a "hard failure", whereas we now trigger
a "soft failure", which is recoverable. For the simple example, this
does not make a lot of difference.

In general, I think having a soft failure is the right option to take
here, although we want a more general story about the relative
priorities of different error codes.
This commit is contained in:
Andres Loeh 2015-06-01 15:30:09 +02:00
parent 404bfdd89c
commit e83397a1db
1 changed files with 9 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
servant-examples/auth-combinator/auth-combinator.hs
View File

@ -28,14 +28,15 @@ data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy a request respond = route Proxy a = WithRequest $ \ request ->
case lookup "Cookie" (requestHeaders request) of route (Proxy :: Proxy rest) $ do
Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header." case lookup "Cookie" (requestHeaders request) of
Just v -> do Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")
authGranted <- isGoodCookie v Just v -> do
if authGranted authGranted <- isGoodCookie v
then route (Proxy :: Proxy rest) a request respond if authGranted
else respond . succeedWith $ responseLBS status403 [] "Invalid cookie." then a
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
type PrivateAPI = Get '[JSON] [PrivateData] type PrivateAPI = Get '[JSON] [PrivateData]