servant-auth-server 0.2.3.0 → 0.2.4.0
raw patch · 5 files changed
+70/−9 lines, 5 filesdep ~http-types
Dependency ranges changed: http-types
Files
- package.yaml +2/−1
- servant-auth-server.cabal +4/−1
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +24/−4
- src/Servant/Auth/Server/Internal/ThrowAll.hs +12/−1
- test/Servant/Auth/ServerSpec.hs +28/−2
package.yaml view
@@ -1,5 +1,5 @@ name: servant-auth-server-version: 0.2.3.0+version: 0.2.4.0 synopsis: servant-server/servant-auth compatibility description: | This package provides the required instances for using the @Auth@ combinator@@ -47,6 +47,7 @@ - crypto-api >= 0.13 && < 0.14 - data-default-class >= 0.0 && < 0.2 - http-api-data >= 0.3 && < 0.4+ - http-types >= 0.9 && < 0.10 default-extensions:
servant-auth-server.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: servant-auth-server-version: 0.2.3.0+version: 0.2.4.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.@@ -58,6 +58,7 @@ , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2 , http-api-data >= 0.3 && < 0.4+ , http-types >= 0.9 && < 0.10 exposed-modules: Servant.Auth.Server Servant.Auth.Server.Internal@@ -102,6 +103,7 @@ , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2 , http-api-data >= 0.3 && < 0.4+ , http-types >= 0.9 && < 0.10 , servant-auth , servant-auth-server , servant-server >= 0.9.1 && < 0.10@@ -140,6 +142,7 @@ , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2 , http-api-data >= 0.3 && < 0.4+ , http-types >= 0.9 && < 0.10 , servant-auth-server , hspec > 2 && < 3 , QuickCheck >= 2.8 && < 2.9
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -1,14 +1,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Auth.Server.Internal.AddSetCookie where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as BS64+import Blaze.ByteString.Builder (toByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS64+import qualified Network.HTTP.Types as HTTP+import Network.Wai (mapResponseHeaders) import Servant -import System.Entropy (getEntropy)-import Web.Cookie+import System.Entropy (getEntropy)+import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response, -- but the headers come from the authentication check. In order to do that, we@@ -31,6 +35,7 @@ = Verb method stat ctyps (Headers ((Header "Set-Cookie" SetCookie) ': ls) a) AddSetCookieApi (Verb method stat ctyps a) = Verb method stat ctyps (Headers '[Header "Set-Cookie" SetCookie] a)+ AddSetCookieApi Raw = Raw data SetCookieList (n :: Nat) :: * where SetCookieNil :: SetCookieList 'Z@@ -60,6 +65,21 @@ (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++instance+ AddSetCookies ('S n) Application Application where+ addSetCookies cookies r request respond+ = r request (\response -> respond+ $ mapResponseHeaders (++ mkHeaders cookies) response)++mkHeaders :: SetCookieList x -> [HTTP.Header]+mkHeaders x = ("Set-Cookie",) <$> mkCookies x+ where+ mkCookies :: forall y. SetCookieList y -> [BS.ByteString]+ mkCookies SetCookieNil = []+ mkCookies (SetCookieCons Nothing rest) = mkCookies rest+ mkCookies (SetCookieCons (Just y) rest)+ = toByteString (renderSetCookie y) : mkCookies rest csrfCookie :: IO BS.ByteString csrfCookie = BS64.encode <$> getEntropy 32
src/Servant/Auth/Server/Internal/ThrowAll.hs view
@@ -2,8 +2,12 @@ module Servant.Auth.Server.Internal.ThrowAll where import Control.Monad.Error.Class-import Servant ((:<|>) (..), ServantErr)+import Servant ((:<|>) (..), ServantErr(..))+import Network.HTTP.Types+import Network.Wai +import qualified Data.ByteString.Char8 as BS+ class ThrowAll a where -- | 'throwAll' is a convenience function to throw errors across an entire -- sub-API@@ -23,3 +27,10 @@ instance {-# OVERLAPPABLE #-} (MonadError ServantErr m) => ThrowAll (m a) where throwAll = throwError++instance {-# OVERLAPS #-} ThrowAll Application where+ throwAll e _req respond+ = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))+ (errHeaders e)+ (errBody e)+
test/Servant/Auth/ServerSpec.hs view
@@ -24,6 +24,7 @@ cookie_http_only, cookie_name, cookie_value, destroyCookieJar) import Network.HTTP.Types (Status, status200, status401)+import Network.Wai (responseLBS) import Network.Wai.Handler.Warp (testWithApplication) import Network.Wreq (Options, auth, basicAuth, cookieExpiryTime, cookies, defaults,@@ -74,6 +75,23 @@ resp ^. responseHeader "Blah" `shouldBe` "1797" resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + context "Raw" $ do++ it "gets the response body" $ \port -> property $ \(user :: User) -> do+ jwt <- makeJWT user jwtCfg Nothing+ opts <- addJwtToHeader jwt+ resp <- getWith opts (url port ++ "/raw")+ resp ^. responseBody `shouldBe` "how are you?"++ it "doesn't clobber pre-existing reponse headers" $ \port -> property $+ \(user :: User) -> do+ jwt <- makeJWT user jwtCfg Nothing+ opts <- addJwtToHeader jwt+ resp <- getWith opts (url port ++ "/raw")+ resp ^. responseHeader "hi" `shouldBe` "there"+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")++ context "Setting cookies" $ do it "sets cookies that it itself accepts" $ \port -> property $ \user -> do@@ -267,6 +285,7 @@ ( Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)+ :<|> "raw" :> Raw ) jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])@@ -318,8 +337,11 @@ server :: Server (API auths) server authResult = case authResult of- Authenticated usr -> getInt usr :<|> postInt usr :<|> getHeaderInt- Indefinite -> throwAll err401+ Authenticated usr -> getInt usr+ :<|> postInt usr+ :<|> getHeaderInt+ :<|> raw+ Indefinite -> throwAll err401 _ -> throwAll err403 where getInt :: User -> Handler Int@@ -330,6 +352,10 @@ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int) getHeaderInt = return $ addHeader 1797 17++ raw :: Application+ raw _req respond+ = respond $ responseLBS status200 [("hi", "there")] "how are you?" -- }}} ------------------------------------------------------------------------------