servant-auth-server 0.2.1.0 → 0.2.2.0
raw patch · 7 files changed
+168/−59 lines, 7 filesdep ~http-api-datadep ~servant-server
Dependency ranges changed: http-api-data, servant-server
Files
- package.yaml +103/−0
- servant-auth-server.cabal +12/−9
- src/Servant/Auth/Server.hs +4/−0
- src/Servant/Auth/Server/Internal.hs +17/−16
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +29/−34
- src/Servant/Auth/Server/Internal/JWT.hs +2/−0
- test/Servant/Auth/ServerSpec.hs +1/−0
+ package.yaml view
@@ -0,0 +1,103 @@+name: servant-auth-server+version: 0.2.2.0+synopsis: servant-server/servant-auth compatibility+description: |+ This package provides the required instances for using the @Auth@ combinator+ in your 'servant' server.++ Both cookie- and token- (REST API) based authentication is provided.++ For a quick overview of the usage, see the <http://github.com/plow-technologies/servant-auth#readme README>.+homepage: http://github.com/plow-technologies/servant-auth#readme+license: BSD3+license-file: LICENSE+author: Julian K. Arni+maintainer: jkarni@gmail.com+category: Web, Servant, Authentication+copyright: (c) Julian K. Arni+github: plow-technologies/servant-auth+tested-with: GHC == 7.10.2, GHC == 8.0.1++extra-source-files:+ - package.yaml++ghc-options: -Wall++dependencies:+ - base >= 4.7 && < 4.10+ - text >= 1 && < 2+ - servant-auth == 0.2.*+ # We have an orphan instance for SetCookie, so we need to be careful about upper bounds.+ - cookie >= 0.4 && < 0.4.2.2+ - wai >= 3.2 && < 3.3+ - mtl >= 2.2 && < 2.3+ - bytestring >= 0.10 && < 0.11+ - bytestring-conversion >= 0.3 && < 0.4+ - case-insensitive >= 1.2 && < 1.3+ - jose >= 0.5 && < 0.6+ - monad-time >= 0.2 && < 0.3+ - time >= 1.5 && < 1.7+ - servant-server >= 0.9.1 && < 0.10+ - base64-bytestring >= 1 && < 2+ - blaze-builder >= 0.4 && < 0.5+ - unordered-containers >= 0.2 && < 0.3+ - aeson >= 0.11 && < 2+ - lens >= 4 && < 5+ - entropy >= 0.3 && < 0.4+ - crypto-api >= 0.13 && < 0.14+ - data-default-class >= 0.0 && < 0.2+ - http-api-data >= 0.3 && < 0.4+++default-extensions:+ - AutoDeriveTypeable+ - ConstraintKinds+ - DataKinds+ - DefaultSignatures+ - DeriveFoldable+ - DeriveFunctor+ - DeriveGeneric+ - DeriveTraversable+ - FlexibleContexts+ - FlexibleInstances+ - FunctionalDependencies+ - GADTs+ - KindSignatures+ - MultiParamTypeClasses+ - OverloadedStrings+ - RankNTypes+ - ScopedTypeVariables+ - TypeFamilies+ - TypeOperators++library:+ source-dirs: src+ other-modules: []++tests:+ spec:+ main: Spec.hs+ source-dirs: test+ dependencies:+ - servant-auth-server+ - hspec > 2 && < 3+ - QuickCheck >= 2.8 && < 2.9+ - aeson+ - lens-aeson+ - warp+ - wreq+ - http-types+ - http-client++executables:+ readme:+ main: README.lhs+ source-dirs: executables+ ghc-options: -pgmL markdown-unlit+ dependencies:+ - servant-auth+ - servant-auth-server+ - servant-server >= 0.9.1 && < 0.10+ - warp+ - markdown-unlit+ - transformers
servant-auth-server.cabal view
@@ -1,9 +1,9 @@--- This file has been generated from package.yaml by hpack version 0.14.0.+-- This file has been generated from package.yaml by hpack version 0.15.0. -- -- see: https://github.com/sol/hpack name: servant-auth-server-version: 0.2.1.0+version: 0.2.2.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.@@ -23,6 +23,9 @@ build-type: Simple cabal-version: >= 1.10 +extra-source-files:+ package.yaml+ source-repository head type: git location: https://github.com/plow-technologies/servant-auth@@ -45,7 +48,7 @@ , jose >= 0.5 && < 0.6 , monad-time >= 0.2 && < 0.3 , time >= 1.5 && < 1.7- , servant-server >= 0.7 && < 0.10+ , servant-server >= 0.9.1 && < 0.10 , base64-bytestring >= 1 && < 2 , blaze-builder >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3@@ -54,7 +57,7 @@ , entropy >= 0.3 && < 0.4 , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2- , http-api-data >= 0.2 && < 0.4+ , http-api-data >= 0.3 && < 0.4 exposed-modules: Servant.Auth.Server Servant.Auth.Server.Internal@@ -89,7 +92,7 @@ , jose >= 0.5 && < 0.6 , monad-time >= 0.2 && < 0.3 , time >= 1.5 && < 1.7- , servant-server >= 0.7 && < 0.10+ , servant-server >= 0.9.1 && < 0.10 , base64-bytestring >= 1 && < 2 , blaze-builder >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3@@ -98,10 +101,10 @@ , entropy >= 0.3 && < 0.4 , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2- , http-api-data >= 0.2 && < 0.4+ , http-api-data >= 0.3 && < 0.4 , servant-auth , servant-auth-server- , servant-server >= 0.8 && < 0.10+ , servant-server >= 0.9.1 && < 0.10 , warp , markdown-unlit , transformers@@ -127,7 +130,7 @@ , jose >= 0.5 && < 0.6 , monad-time >= 0.2 && < 0.3 , time >= 1.5 && < 1.7- , servant-server >= 0.7 && < 0.10+ , servant-server >= 0.9.1 && < 0.10 , base64-bytestring >= 1 && < 2 , blaze-builder >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3@@ -136,7 +139,7 @@ , entropy >= 0.3 && < 0.4 , crypto-api >= 0.13 && < 0.14 , data-default-class >= 0.0 && < 0.2- , http-api-data >= 0.2 && < 0.4+ , http-api-data >= 0.3 && < 0.4 , servant-auth-server , hspec > 2 && < 3 , QuickCheck >= 2.8 && < 2.9
src/Servant/Auth/Server.hs view
@@ -20,6 +20,7 @@ -- | Basic types Auth , AuthResult(..)+ , AuthCheck(..) ---------------------------------------------------------------------------- -- * JWT@@ -50,6 +51,9 @@ -- ** Settings , JWTSettings(..) , defaultJWTSettings++ -- ** Create check+ , jwtAuthCheck ----------------------------------------------------------------------------
src/Servant/Auth/Server/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Servant.Auth.Server.Internal where import Control.Monad.Trans (liftIO)@@ -17,8 +18,9 @@ import Servant.Server.Internal.RoutingApplication -instance ( HasServer (AddSetCookieApi api) ctxs, AreAuths auths ctxs v- , AddSetCookie (ServerT api Handler) (ServerT (AddSetCookieApi api) Handler)+instance ( n ~ 'S ('S 'Z)+ , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v+ , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) , ToJWT v , HasContextEntry ctxs CookieSettings , HasContextEntry ctxs JWTSettings@@ -26,12 +28,12 @@ type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m route _ context subserver =- route (Proxy :: Proxy (AddSetCookieApi api))+ route (Proxy :: Proxy (AddSetCookiesApi n api)) context (fmap go subserver `addAuthCheck` authCheck) where- authCheck :: DelayedIO (AuthResult v, [Cookie.SetCookie])+ authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) authCheck = withRequest $ \req -> liftIO $ do authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req csrf' <- csrfCookie@@ -45,7 +47,7 @@ NotSecure -> False } cookies <- makeCookies authResult- return (authResult, csrf : cookies )+ return (authResult, Just csrf `SetCookieCons` cookies) jwtSettings :: JWTSettings jwtSettings = getContextEntry context@@ -53,18 +55,17 @@ cookieSettings :: CookieSettings cookieSettings = getContextEntry context - makeCookies :: AuthResult v -> IO [Cookie.SetCookie]+ makeCookies :: AuthResult v -> IO (SetCookieList ('S 'Z)) makeCookies (Authenticated v) = do ejwt <- makeCookie cookieSettings jwtSettings v case ejwt of- Nothing -> return []- Just jwt -> return [jwt]- makeCookies _ = return []-+ Nothing -> return $ Nothing `SetCookieCons` SetCookieNil+ Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil+ makeCookies _ = return $ Nothing `SetCookieCons` SetCookieNil - -- See note in AddSetCookie.hs about what this is doing.- go :: (old ~ ServerT api Handler- , new ~ ServerT (AddSetCookieApi api) Handler- ) => (AuthResult v -> ServerT api Handler)- -> (AuthResult v, [Cookie.SetCookie]) -> new- go fn (authResult, csrf) = addSetCookie csrf $ fn authResult+ go :: ( old ~ ServerT api Handler+ , new ~ ServerT (AddSetCookiesApi n api) Handler+ )+ => (AuthResult v -> ServerT api Handler)+ -> (AuthResult v, SetCookieList n) -> new+ go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -3,15 +3,10 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Auth.Server.Internal.AddSetCookie where -import Blaze.ByteString.Builder (toByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as BS64-import Data.ByteString.Conversion (ToByteString (..))-import Data.Monoid-import Data.String (IsString)-import qualified Data.Text.Encoding as T-import GHC.Generics (Generic) import Servant+ import System.Entropy (getEntropy) import Web.Cookie @@ -23,48 +18,48 @@ -- -- TODO: If the endpoints already have headers, this will not work as is. +data Nat = Z | S Nat +type family AddSetCookiesApi (n :: Nat) a where+ AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a+ AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)+ type family AddSetCookieApi a where AddSetCookieApi (a :> b) = a :> AddSetCookieApi b AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b AddSetCookieApi (Verb method stat ctyps (Headers ls a))- = Verb method stat ctyps (Headers ((Header "Set-Cookie" BSS) ': ls) a)+ = 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" BSS] a)+ = Verb method stat ctyps (Headers '[Header "Set-Cookie" SetCookie] a) +data SetCookieList (n :: Nat) :: * where+ SetCookieNil :: SetCookieList 'Z+ SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n) -class AddSetCookie orig new where- addSetCookie :: [SetCookie] -> orig -> new+class AddSetCookies (n :: Nat) orig new where+ addSetCookies :: SetCookieList n -> orig -> new -instance {-# OVERLAPS #-} AddSetCookie oldb newb- => AddSetCookie (a -> oldb) (a -> newb) where- addSetCookie cookie oldfn = \val -> addSetCookie cookie $ oldfn val+instance {-# OVERLAPS #-} AddSetCookies n oldb newb+ => AddSetCookies n (a -> oldb) (a -> newb) where+ addSetCookies cookies oldfn = \val -> addSetCookies cookies $ oldfn val +instance AddSetCookies 'Z orig orig where+ addSetCookies _ = id+ instance {-# OVERLAPPABLE #-} ( Functor m- , AddHeader "Set-Cookie" BSS old new- ) => AddSetCookie (m old) (m new) where- addSetCookie cookie val- -- What is happening here is sheer awfulness. Look the other way.- = addHeader (BSS $ foldr1 go $ toByteString . renderSetCookie <$> cookie) <$> val- where- go new old = old <> "\r\nSet-Cookie: " <> new+ , AddSetCookies n (m old) (m cookied)+ , AddHeader "Set-Cookie" SetCookie cookied new+ ) => AddSetCookies ('S n) (m old) (m new) where+ addSetCookies (mCookie `SetCookieCons` rest) oldVal =+ case mCookie of+ Nothing -> noHeader <$> addSetCookies rest oldVal+ Just cookie -> addHeader cookie <$> addSetCookies rest oldVal instance {-# OVERLAPS #-}- (AddSetCookie a a', AddSetCookie b b')- => AddSetCookie (a :<|> b) (a' :<|> b') where- addSetCookie cookie (a :<|> b) = addSetCookie cookie a :<|> addSetCookie cookie b---newtype BSS = BSS { getBSS :: BS.ByteString }- deriving (Eq, Show, Read, Generic, IsString, Monoid)--instance ToHttpApiData BSS where- toHeader = getBSS- toUrlPiece = T.decodeUtf8 . getBSS--instance ToByteString BSS where- builder (BSS x) = builder x+ (AddSetCookies n a a', AddSetCookies n b b')+ => AddSetCookies n (a :<|> b) (a' :<|> b') where+ addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b csrfCookie :: IO BS.ByteString csrfCookie = BS64.encode <$> getEntropy 32
src/Servant/Auth/Server/Internal/JWT.hs view
@@ -42,6 +42,8 @@ default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet +-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you+-- are protecting a @Raw@ endpoint. jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr jwtAuthCheck config = do req <- ask
test/Servant/Auth/ServerSpec.hs view
@@ -32,6 +32,7 @@ responseStatus) import Servant hiding (BasicAuth, IsSecure (..)) import Servant.Auth.Server+import Servant.Auth.Server.SetCookieOrphan () import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.QuickCheck