servant-auth-server 0.2.2.0 → 0.2.3.0
raw patch · 6 files changed
+37/−16 lines, 6 files
Files
- executables/README.lhs +3/−3
- package.yaml +1/−1
- servant-auth-server.cabal +1/−1
- src/Servant/Auth/Server.hs +1/−0
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +4/−4
- test/Servant/Auth/ServerSpec.hs +27/−7
executables/README.lhs view
@@ -71,13 +71,13 @@ protected _ = throwAll err401 type Unprotected =- Raw- :<|> "login"+ "login" :> ReqBody '[JSON] Login :> PostNoContent '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent)+ :<|> Raw unprotected :: CookieSettings -> JWTSettings -> Server Unprotected-unprotected cs jwts = serveDirectory "example/static" :<|> checkCreds cs jwts+unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static" type API auths = (Auth auths User :> Protected) :<|> Unprotected
package.yaml view
@@ -1,5 +1,5 @@ name: servant-auth-server-version: 0.2.2.0+version: 0.2.3.0 synopsis: servant-server/servant-auth compatibility description: | This package provides the required instances for using the @Auth@ combinator
servant-auth-server.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: servant-auth-server-version: 0.2.2.0+version: 0.2.3.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.
src/Servant/Auth/Server.hs view
@@ -114,6 +114,7 @@ import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.ThrowAll import Servant.Auth.Server.Internal.Types+import Servant.Auth.Server.SetCookieOrphan () import Crypto.JOSE as Jose import Servant (BasicAuthData (..))
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -39,8 +39,8 @@ class AddSetCookies (n :: Nat) orig new where addSetCookies :: SetCookieList n -> orig -> new -instance {-# OVERLAPS #-} AddSetCookies n oldb newb- => AddSetCookies n (a -> oldb) (a -> newb) where+instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb+ => AddSetCookies ('S n) (a -> oldb) (a -> newb) where addSetCookies cookies oldfn = \val -> addSetCookies cookies $ oldfn val instance AddSetCookies 'Z orig orig where@@ -57,8 +57,8 @@ Just cookie -> addHeader cookie <$> addSetCookies rest oldVal instance {-# OVERLAPS #-}- (AddSetCookies n a a', AddSetCookies n b b')- => AddSetCookies n (a :<|> b) (a' :<|> b') where+ (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')+ => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b csrfCookie :: IO BS.ByteString
test/Servant/Auth/ServerSpec.hs view
@@ -29,7 +29,7 @@ cookieExpiryTime, cookies, defaults, get, getWith, header, oauth2Bearer, responseBody, responseCookieJar,- responseStatus)+ responseStatus, responseHeader) import Servant hiding (BasicAuth, IsSecure (..)) import Servant.Auth.Server import Servant.Auth.Server.SetCookieOrphan ()@@ -66,6 +66,14 @@ it "fails (403) if one authentication fails" $ const $ pendingWith "Authentications don't yet fail, only are Indefinite" + it "doesn't clobber pre-existing response headers" $ \port -> property $+ \(user :: User) -> do+ jwt <- makeJWT user jwtCfg Nothing+ opts <- addJwtToHeader jwt+ resp <- getWith opts (url port ++ "/header")+ resp ^. responseHeader "Blah" `shouldBe` "1797"+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")+ context "Setting cookies" $ do it "sets cookies that it itself accepts" $ \port -> property $ \user -> do@@ -254,7 +262,12 @@ ------------------------------------------------------------------------------ -- * API and Server {{{ -type API auths = Auth auths User :> Get '[JSON] Int+type API auths+ = Auth auths User :>+ ( Get '[JSON] Int+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int+ :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)+ ) jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi = Proxy@@ -304,12 +317,19 @@ server :: Server (API auths)-server = getInt+server authResult = case authResult of+ Authenticated usr -> getInt usr :<|> postInt usr :<|> getHeaderInt+ Indefinite -> throwAll err401+ _ -> throwAll err403 where- getInt :: AuthResult User -> Handler Int- getInt (Authenticated usr) = return . length $ name usr- getInt Indefinite = throwError err401- getInt _ = throwError err403+ getInt :: User -> Handler Int+ getInt usr = return . length $ name usr++ postInt :: User -> Int -> Handler Int+ postInt _ = return++ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)+ getHeaderInt = return $ addHeader 1797 17 -- }}} ------------------------------------------------------------------------------