servant-auth-server 0.2.0.0 → 0.2.1.0
raw patch · 9 files changed
+151/−82 lines, 9 filesdep +bytestring-conversiondep ~cookiedep ~servant-server
Dependencies added: bytestring-conversion
Dependency ranges changed: cookie, servant-server
Files
- executables/README.lhs +32/−19
- servant-auth-server.cabal +11/−7
- src/Servant/Auth/Server.hs +8/−2
- src/Servant/Auth/Server/Internal.hs +4/−13
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +30/−18
- src/Servant/Auth/Server/Internal/ConfigTypes.hs +15/−12
- src/Servant/Auth/Server/Internal/Cookie.hs +32/−10
- src/Servant/Auth/Server/SetCookieOrphan.hs +19/−0
- test/Servant/Auth/ServerSpec.hs +0/−1
executables/README.lhs view
@@ -34,12 +34,14 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} import Control.Concurrent (forkIO) import Control.Monad (forever)+import Control.Monad.Trans (liftIO) import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) import Network.Wai.Handler.Warp (run) import System.Environment (getArgs) import Servant import Servant.Auth.Server+import Servant.Auth.Server.SetCookieOrphan () data User = User { name :: String, email :: String } deriving (Eq, Show, Read, Generic)@@ -55,30 +57,32 @@ instance ToJSON Login instance FromJSON Login -type Protected = "name" :> Get '[JSON] String- :<|> "email" :> Get '[JSON] String- :<|> "login" :> ReqBody '[JSON] Login :> PostNoContent '[JSON] NoContent+type Protected+ = "name" :> Get '[JSON] String+ :<|> "email" :> Get '[JSON] String -- | 'Protected' will be protected by 'auths', which we still have to specify. protected :: AuthResult User -> Server Protected -- If we get an "Authenticated v", we can trust the information in v, since -- it was signed by a key we trust.-protected (Authenticated user) =- return (name user) :<|> return (email user) :<|> const (return NoContent)--- Otherwise, if the user is logging in, we check the credentials. If not,--- we reject the requests as unauthenticated.-protected _ = throwError err401 :<|> throwError err401 :<|> checkCreds+protected (Authenticated user) = return (name user) :<|> return (email user)+-- Otherwise, we return a 401.+protected _ = throwAll err401 -type Unprotected = Get '[JSON] ()+type Unprotected =+ Raw+ :<|> "login"+ :> ReqBody '[JSON] Login+ :> PostNoContent '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) -unprotected :: Server Unprotected-unprotected = return ()+unprotected :: CookieSettings -> JWTSettings -> Server Unprotected+unprotected cs jwts = serveDirectory "example/static" :<|> checkCreds cs jwts type API auths = (Auth auths User :> Protected) :<|> Unprotected -server :: Server (API auths)-server = protected :<|> unprotected+server :: CookieSettings -> JWTSettings -> Server (API auths)+server cs jwts = protected :<|> unprotected cs jwts ~~~ @@ -105,7 +109,7 @@ cfg = defaultCookieSettings :. jwtCfg :. EmptyContext --- Here we actually make concrete api = Proxy :: Proxy (API '[JWT])- _ <- forkIO $ run 7249 $ serveWithContext api cfg server+ _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) putStrLn "Started server on localhost:7249" putStrLn "Enter name and email separated by a space for a new token"@@ -193,14 +197,23 @@ let jwtCfg = defaultJWTSettings myKey cfg = defaultCookieSettings :. jwtCfg :. EmptyContext --- Here is the actual change- api = Proxy :: Proxy (API '[JWT])- run 7249 $ serveWithContext api cfg server+ api = Proxy :: Proxy (API '[Cookie])+ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) -- Here is the login handler-checkCreds :: Login -> Handler NoContent-checkCreds (Login "Ali Baba" "Open Sesame") = return NoContent-checkCreds _ = throwError err401+checkCreds :: CookieSettings -> JWTSettings -> Login+ -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent)+checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do+ -- Usually you would ask a database for the user info. This is just a+ -- regular servant handler, so you can follow your normal database access+ -- patterns (including using 'enter').+ let usr = User "Ali Baba" "ali@email.com"+ mcookie <- liftIO $ makeCookie cookieSettings jwtSettings usr+ case mcookie of+ Nothing -> throwError err401+ Just cookie -> return $ addHeader cookie NoContent+checkCreds _ _ _ = throwError err401 ~~~ ### CSRF and the frontend
servant-auth-server.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: servant-auth-server-version: 0.2.0.0+version: 0.2.1.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.@@ -13,7 +13,7 @@ For a quick overview of the usage, see the <http://github.com/plow-technologies/servant-auth#readme README>. category: Web, Servant, Authentication homepage: http://github.com/plow-technologies/servant-auth#readme-bug-reports: https://github.com/plow-techologies/servant-auth/issues+bug-reports: https://github.com/plow-technologies/servant-auth/issues author: Julian K. Arni maintainer: jkarni@gmail.com copyright: (c) Julian K. Arni@@ -25,7 +25,7 @@ source-repository head type: git- location: https://github.com/plow-techologies/servant-auth+ location: https://github.com/plow-technologies/servant-auth library hs-source-dirs:@@ -36,10 +36,11 @@ base >= 4.7 && < 4.10 , text >= 1 && < 2 , servant-auth == 0.2.*- , cookie >= 0.4 && < 0.5+ , 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@@ -66,6 +67,7 @@ Servant.Auth.Server.Internal.JWT Servant.Auth.Server.Internal.ThrowAll Servant.Auth.Server.Internal.Types+ Servant.Auth.Server.SetCookieOrphan default-language: Haskell2010 executable readme@@ -78,10 +80,11 @@ base >= 4.7 && < 4.10 , text >= 1 && < 2 , servant-auth == 0.2.*- , cookie >= 0.4 && < 0.5+ , 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@@ -98,7 +101,7 @@ , http-api-data >= 0.2 && < 0.4 , servant-auth , servant-auth-server- , servant-server+ , servant-server >= 0.8 && < 0.10 , warp , markdown-unlit , transformers@@ -115,10 +118,11 @@ base >= 4.7 && < 4.10 , text >= 1 && < 2 , servant-auth == 0.2.*- , cookie >= 0.4 && < 0.5+ , 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
src/Servant/Auth/Server.hs view
@@ -64,7 +64,10 @@ -- ** Settings , CookieSettings(..) , defaultCookieSettings+ , makeCookie+ , makeCookieBS + -- ** Related types , IsSecure(..) @@ -94,6 +97,7 @@ -- ** Re-exports , Default(def)+ , SetCookie ) where import Data.Default.Class (Default (def))@@ -102,12 +106,14 @@ import Servant.Auth.Server.Internal.BasicAuth import Servant.Auth.Server.Internal.Class import Servant.Auth.Server.Internal.ConfigTypes+import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.ThrowAll import Servant.Auth.Server.Internal.Types -import Servant (BasicAuthData(..))-import Crypto.JOSE as Jose+import Crypto.JOSE as Jose+import Servant (BasicAuthData (..))+import Web.Cookie (SetCookie) -- | Generate a key suitable for use with 'defaultConfig'. generateKey :: IO Jose.JWK
src/Servant/Auth/Server/Internal.hs view
@@ -3,7 +3,6 @@ module Servant.Auth.Server.Internal where import Control.Monad.Trans (liftIO)-import qualified Data.ByteString.Lazy as BSL import Servant ((:>), Handler, HasServer (..), Proxy (..), HasContextEntry(getContextEntry)) import Servant.Auth@@ -11,6 +10,7 @@ import Servant.Auth.Server.Internal.AddSetCookie import Servant.Auth.Server.Internal.Class+import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.JWT import Servant.Auth.Server.Internal.Types@@ -55,19 +55,10 @@ makeCookies :: AuthResult v -> IO [Cookie.SetCookie] makeCookies (Authenticated v) = do- ejwt <- makeJWT v jwtSettings Nothing+ ejwt <- makeCookie cookieSettings jwtSettings v case ejwt of- Left _ -> return []- Right jwt -> return [Cookie.def- { Cookie.setCookieName = "JWT-Cookie"- , Cookie.setCookieValue = BSL.toStrict jwt- , Cookie.setCookieHttpOnly = True- , Cookie.setCookieMaxAge = cookieMaxAge cookieSettings- , Cookie.setCookieExpires = cookieExpires cookieSettings- , Cookie.setCookieSecure = case cookieIsSecure cookieSettings of- Secure -> True- NotSecure -> False- }]+ Nothing -> return []+ Just jwt -> return [jwt] makeCookies _ = return []
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -1,13 +1,18 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# 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 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 System.Entropy (getEntropy) import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response,@@ -22,9 +27,10 @@ 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) AddSetCookieApi (Verb method stat ctyps a)- = Verb method stat ctyps (Headers '[Header "Set-Cookie" BS.ByteString] a)- AddSetCookieApi (Headers ls a) = Headers ((Header "Set-Cookie" BS.ByteString) ': ls) a+ = Verb method stat ctyps (Headers '[Header "Set-Cookie" BSS] a) class AddSetCookie orig new where@@ -36,23 +42,29 @@ instance {-# OVERLAPPABLE #-} ( Functor m- ) => AddSetCookie (m a) (m (Headers '[Header "Set-Cookie" BS.ByteString] a)) where- addSetCookie cookie v = addSetCookie cookie <$> v+ , 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 instance {-# OVERLAPS #-} (AddSetCookie a a', AddSetCookie b b') => AddSetCookie (a :<|> b) (a' :<|> b') where addSetCookie cookie (a :<|> b) = addSetCookie cookie a :<|> addSetCookie cookie b -instance {-# OVERLAPPABLE #-}- (AddHeader "Set-Cookie" BS.ByteString old new)- => AddSetCookie old new where- addSetCookie cookie val- -- What is happening here is sheer awfulness. Look the other way.- = addHeader (foldr1 go $ toByteString . renderSetCookie <$> cookie) val- where- go new old = old <> "\r\nSet-Cookie: " <> new +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 csrfCookie :: IO BS.ByteString csrfCookie = BS64.encode <$> getEntropy 32
src/Servant/Auth/Server/Internal/ConfigTypes.hs view
@@ -49,17 +49,19 @@ { -- | 'Secure' means browsers will only send cookies over HTTPS. Default: -- @Secure@.- cookieIsSecure :: IsSecure+ cookieIsSecure :: IsSecure -- | How long from now until the cookie expires. Default: @Nothing@- , cookieMaxAge :: Maybe DiffTime+ , cookieMaxAge :: Maybe DiffTime -- | At what time the cookie expires. Default: @Nothing@- , cookieExpires :: Maybe UTCTime+ , cookieExpires :: Maybe UTCTime -- | 'SameSite' settings. Default: @SameSiteLax@.- , cookieSameSite :: SameSite+ , cookieSameSite :: SameSite+ -- | What name to use for the cookie used for the session.+ , sessionCookieName :: BS.ByteString -- | What name to use for the cookie used for CSRF protection.- , xsrfCookieName :: BS.ByteString+ , xsrfCookieName :: BS.ByteString -- | What name to use for the header used for CSRF protection.- , xsrfHeaderName :: BS.ByteString+ , xsrfHeaderName :: BS.ByteString } deriving (Eq, Show, Generic) instance Default CookieSettings where@@ -67,12 +69,13 @@ defaultCookieSettings :: CookieSettings defaultCookieSettings = CookieSettings- { cookieIsSecure = Secure- , cookieMaxAge = Nothing- , cookieExpires = Nothing- , cookieSameSite = SameSiteLax- , xsrfCookieName = "XSRF-TOKEN"- , xsrfHeaderName = "X-XSRF-TOKEN"+ { cookieIsSecure = Secure+ , cookieMaxAge = Nothing+ , cookieExpires = Nothing+ , cookieSameSite = SameSiteLax+ , sessionCookieName = "JWT-Cookie"+ , xsrfCookieName = "XSRF-TOKEN"+ , xsrfHeaderName = "X-XSRF-TOKEN" }
src/Servant/Auth/Server/Internal/Cookie.hs view
@@ -1,18 +1,21 @@ module Servant.Auth.Server.Internal.Cookie where +import Blaze.ByteString.Builder (toByteString) import Control.Monad.Except import Control.Monad.Reader-import qualified Crypto.JOSE as Jose-import qualified Crypto.JWT as Jose-import Crypto.Util (constTimeEq)-import qualified Data.ByteString.Lazy as BSL-import Data.CaseInsensitive (mk)-import Network.Wai (requestHeaders)+import qualified Crypto.JOSE as Jose+import qualified Crypto.JWT as Jose+import Crypto.Util (constTimeEq)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.CaseInsensitive (mk)+import Network.Wai (requestHeaders) import Web.Cookie -import Servant.Auth.Server.Internal.JWT (FromJWT (decodeJWT))-import Servant.Auth.Server.Internal.Types import Servant.Auth.Server.Internal.ConfigTypes+import Servant.Auth.Server.Internal.JWT (FromJWT (decodeJWT), ToJWT,+ makeJWT)+import Servant.Auth.Server.Internal.Types cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr@@ -24,8 +27,8 @@ xsrfCookie <- lookup (xsrfCookieName ccfg) cookies xsrfHeader <- lookup (mk $ xsrfHeaderName ccfg) $ requestHeaders req guard $ xsrfCookie `constTimeEq` xsrfHeader- -- JWT-Cookie *must* be HttpOnly and Secure- lookup "JWT-Cookie" cookies+ -- session cookie *must* be HttpOnly and Secure+ lookup (sessionCookieName ccfg) cookies verifiedJWT <- liftIO $ runExceptT $ do unverifiedJWT <- Jose.decodeCompact $ BSL.fromStrict jwtCookie Jose.validateJWSJWT (jwtSettingsToJwtValidationSettings jwtCfg)@@ -37,3 +40,22 @@ Right v -> case decodeJWT v of Left _ -> mzero Right v' -> return v'++makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)+makeCookie cookieSettings jwtSettings v = do+ ejwt <- makeJWT v jwtSettings Nothing+ case ejwt of+ Left _ -> return Nothing+ Right jwt -> return $ Just $ def+ { setCookieName = sessionCookieName cookieSettings+ , setCookieValue = BSL.toStrict jwt+ , setCookieHttpOnly = True+ , setCookieMaxAge = cookieMaxAge cookieSettings+ , setCookieExpires = cookieExpires cookieSettings+ , setCookieSecure = case cookieIsSecure cookieSettings of+ Secure -> True+ NotSecure -> False+ }++makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)+makeCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeCookie a b c
+ src/Servant/Auth/Server/SetCookieOrphan.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.Auth.Server.SetCookieOrphan () where++import Blaze.ByteString.Builder (toByteString)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Web.Cookie (SetCookie, parseSetCookie, renderSetCookie)+import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))+import Data.ByteString.Conversion (ToByteString(..))++instance FromHttpApiData SetCookie where+ parseUrlPiece = parseHeader . encodeUtf8+ parseHeader = Right . parseSetCookie++instance ToHttpApiData SetCookie where+ toUrlPiece = decodeUtf8 . toHeader+ toHeader = toByteString . renderSetCookie++instance ToByteString SetCookie where+ builder = renderSetCookie
test/Servant/Auth/ServerSpec.hs view
@@ -24,7 +24,6 @@ cookie_http_only, cookie_name, cookie_value, destroyCookieJar) import Network.HTTP.Types (Status, status200, status401)-import Network.Wai (Application) import Network.Wai.Handler.Warp (testWithApplication) import Network.Wreq (Options, auth, basicAuth, cookieExpiryTime, cookies, defaults,