snaplet-customauth 0.2.1 → 0.3.0
raw patch · 13 files changed
+674/−120 lines, 13 filesdep +attoparsecdep +case-insensitivedep +cryptondep −bytestring-showdep −randomdep ~aesondep ~base64-bytestringdep ~bytestring
Dependencies added: attoparsec, case-insensitive, crypton, http-types, jose, memory, monad-time, network-uri
Dependencies removed: bytestring-show, random
Dependency ranges changed: aeson, base64-bytestring, bytestring, containers, hoauth2, http-client, lens, text, time, transformers
Files
- Snap/Snaplet/CustomAuth.hs +2/−0
- Snap/Snaplet/CustomAuth/AuthManager.hs +16/−7
- Snap/Snaplet/CustomAuth/Challenge.hs +37/−0
- Snap/Snaplet/CustomAuth/Handlers.hs +9/−7
- Snap/Snaplet/CustomAuth/OAuth2/Internal.hs +135/−77
- Snap/Snaplet/CustomAuth/OAuth2/Internal/DPoP.hs +200/−0
- Snap/Snaplet/CustomAuth/OAuth2/Internal/PAR.hs +113/−0
- Snap/Snaplet/CustomAuth/OAuth2/Internal/UserInfo.hs +60/−0
- Snap/Snaplet/CustomAuth/OAuth2/Splices.hs +0/−1
- Snap/Snaplet/CustomAuth/Types.hs +26/−6
- Snap/Snaplet/CustomAuth/User.hs +16/−6
- Snap/Snaplet/CustomAuth/Util.hs +36/−2
- snaplet-customauth.cabal +24/−14
Snap/Snaplet/CustomAuth.hs view
@@ -11,12 +11,14 @@ , defAuthSettings , authName , authCookieLifetime+ , authJWK , createAccount , loginUser , logoutUser , recoverSession , combinedLoginRecover , setUser+ , setUser' , currentUser , getAuthFailData , resetAuthFailData
Snap/Snaplet/CustomAuth/AuthManager.hs view
@@ -13,9 +13,10 @@ , OAuth2Settings(..) ) where +import Crypto.JOSE.JWK (JWK) import Data.Binary (Binary) import Data.ByteString (ByteString)-import Data.HashMap.Lazy (HashMap)+import Data.Map (Map) import Data.Text (Text) import Data.Time.Clock (NominalDiffTime) import Network.HTTP.Client (Manager)@@ -51,18 +52,26 @@ , stateStore' :: SnapletLens (Snaplet b) SessionManager , oauth2Provider :: Maybe Text , authFailData :: Maybe (AuthFailure e)- , providers :: HashMap Text Provider+ , providers :: Map Text Provider++ -- Parameters used by OAuth2+ , httpManager :: Manager+ -- | Used for RFC 7523 JWT Bearer tokens when required+ , jwk :: Maybe JWK } -data OAuth2Settings u i e b = IAuthBackend u i e b => OAuth2Settings {- oauth2Check :: Text -> Text -> Handler b (AuthManager u e b) (Either e (Maybe ByteString))- , oauth2Login :: Text -> Text -> Handler b (AuthManager u e b) (Either e (Maybe u))+data OAuth2Settings p u i e b = IAuthBackend u i e b => OAuth2Settings+ { oauth2Check :: p -> Text -> Handler b (AuthManager u e b) (Either e (Maybe ByteString))+ , oauth2Login :: p -> Text -> Handler b (AuthManager u e b) (Either e (Maybe u)) , oauth2Failure :: OAuth2Stage -> Handler b (AuthManager u e b) ()- , prepareOAuth2Create :: Text -> Text -> Handler b (AuthManager u e b) (Either e i)+ , prepareOAuth2Create :: p -> Text -> Handler b (AuthManager u e b) (Either e i) , oauth2AccountCreated :: u -> Handler b (AuthManager u e b) () , oauth2LoginDone :: Handler b (AuthManager u e b) () , resumeAction :: Text -> Text -> ByteString -> Handler b (AuthManager u e b) () , stateStore :: SnapletLens (Snaplet b) SessionManager- , httpManager :: Manager , bracket :: Handler b (AuthManager u e b) () -> Handler b (AuthManager u e b) ()+ -- | Enabled provider names along with user defined associated data.+ -- These are passed directly to routes and don't need to be+ -- represented in AuthManager data.+ , enabledProviders :: [(Text, p)] }
+ Snap/Snaplet/CustomAuth/Challenge.hs view
@@ -0,0 +1,37 @@+module Snap.Snaplet.CustomAuth.Challenge where++import Control.Applicative+import Data.Attoparsec.ByteString+import Data.Attoparsec.ByteString.Char8 (char)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, mk)+import Data.Char+import Data.Word+import Prelude hiding (takeWhile)++data WWWAuthenticateChallenge = WWWAuthenticateChallenge+ { challengeScheme :: CI ByteString+ , challengeParams :: [(CI ByteString, ByteString)]+ }+ deriving (Show, Eq)++parseWWWAuthenticateChallenge :: ByteString -> [WWWAuthenticateChallenge]+parseWWWAuthenticateChallenge x = either (const []) id $ flip parseOnly x $+ parseChallenge `sepBy` (char ',' *> spaces)+ where+ f :: (Enum a, Enum b) => a -> b+ f = toEnum . fromEnum+ spaces = skipWhile (isSpace . f)+ parseChallenge =+ WWWAuthenticateChallenge+ <$> (mk <$> takeWhile1 (/= (f ' ')) <* spaces)+ <*> authParam `sepBy1` (char ',' *> spaces)+ authParam =+ (,)+ <$> (mk <$> takeWhile1 (/= f '='))+ <* char '='+ <*> (((char '"' *> takeWhile (/= f '"') <* char '"') <|>+ (takeWhile (isAlphaNum . f))+ ) <|>+ (takeWhile (/= f ' ')))+ <* spaces
Snap/Snaplet/CustomAuth/Handlers.hs view
@@ -10,23 +10,23 @@ import Control.Error.Util hiding (err) import Control.Lens hiding (un)+import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.State import qualified Data.Configurator as C-import qualified Data.HashMap.Lazy as M+import qualified Data.Map as M import Data.Maybe-import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding-import Snap import Data.Map+import Snap import Snap.Snaplet.CustomAuth.Types hiding (name) import Snap.Snaplet.CustomAuth.AuthManager import Snap.Snaplet.CustomAuth.OAuth2.Internal-import Snap.Snaplet.CustomAuth.User (setUser, recoverSession, currentUser, isSessionDefined)+import Snap.Snaplet.CustomAuth.User (setUser, setUser', recoverSession, currentUser, isSessionDefined) import Snap.Snaplet.CustomAuth.Util (getParamText) setFailure'@@ -62,7 +62,7 @@ runMaybeT $ do ses <- MaybeT $ getCookie sesName lift $ expireCookie ses >> logout (decodeUtf8 $ cookieValue ses)- modify $ \mgr -> mgr { activeUser = Nothing }+ setUser' Nothing -- Recover if session token is present. Login if login+password are -- present.@@ -120,7 +120,7 @@ authInit :: IAuthBackend u i e b- => Maybe (OAuth2Settings u i e b)+ => Maybe (OAuth2Settings p u i e b) -> AuthSettings -> SnapletInit b (AuthManager u e b) authInit oa s = makeSnaplet (view authName s) "Custom auth" Nothing $ do@@ -128,7 +128,7 @@ un <- liftIO $ C.lookupDefault "_login" cfg "userField" pn <- liftIO $ C.lookupDefault "_password" cfg "passwordField" scn <- liftIO $ C.lookupDefault "_session" cfg "sessionCookieName"- ps <- maybe (return M.empty) oauth2Init oa+ ps <- maybe (return M.empty) (oauth2Init s) oa return $ AuthManager { activeUser = Nothing , cookieLifetime = s ^. authCookieLifetime@@ -139,6 +139,8 @@ , oauth2Provider = Nothing , authFailData = Nothing , providers = ps+ , httpManager = s ^. authHTTPManager+ , jwk = s ^. authJWK } isLoggedIn :: UserData u => Handler b (AuthManager u e b) Bool
Snap/Snaplet/CustomAuth/OAuth2/Internal.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} module Snap.Snaplet.CustomAuth.OAuth2.Internal ( oauth2Init@@ -12,55 +10,68 @@ import Control.Error.Util hiding (err) import Control.Lens-import Control.Monad.Except+import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.State+import qualified Crypto.Hash+import Crypto.Random (getRandomBytes) import Data.Aeson import qualified Data.Binary import Data.Binary (Binary)-import Data.Binary.Instances ()+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as B import qualified Data.ByteString.Base64+import qualified Data.ByteString.Base64.URL as URL import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)-import Data.Char (chr) import qualified Data.Configurator as C-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as M-import Data.Maybe (isJust, isNothing, catMaybes)-import Data.Monoid+import Data.List (find, lookup)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (isJust, isNothing, catMaybes, fromMaybe, fromJust, maybeToList) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8)-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)+import Data.Time.Clock (UTCTime(utctDayTime), getCurrentTime, diffUTCTime) import Network.HTTP.Client (Manager)-import Network.OAuth.OAuth2+import qualified Network.HTTP.Client as HTTP+import qualified Network.URI+import Network.OAuth.OAuth2 hiding (fetchAccessToken, error)+import Network.OAuth.OAuth2.AuthorizationRequest+import Network.OAuth.OAuth2.TokenRequest import Prelude hiding (lookup) import Snap hiding (path) import Snap.Snaplet.Session-import System.Random import URI.ByteString import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.OAuth2.Internal.DPoP+import Snap.Snaplet.CustomAuth.OAuth2.Internal.PAR+import Snap.Snaplet.CustomAuth.OAuth2.Internal.UserInfo import Snap.Snaplet.CustomAuth.Types hiding (name) import Snap.Snaplet.CustomAuth.User (setUser, currentUser, recoverSession)-import Snap.Snaplet.CustomAuth.Util (getStateName, getParamText, setFailure)+import Snap.Snaplet.CustomAuth.Util (getStateName, getParamText, setFailure, getTruncatedCurrentTime, fromURIByteString ) oauth2Init :: IAuthBackend u i e b- => OAuth2Settings u i e b- -> Initializer b (AuthManager u e b) (HashMap Text Provider)-oauth2Init s = do+ => AuthSettings+ -> OAuth2Settings p u i e b+ -> Initializer b (AuthManager u e b) (Map Text Provider)+oauth2Init auths s = do cfg <- getSnapletUserConfig root <- getSnapletRootURL hostname <- liftIO $ C.require cfg "hostname" scheme <- liftIO $ C.lookupDefault "https" cfg "protocol"- names <- liftIO $ C.lookupDefault [] cfg "oauth2.providers"+ let names = map fst $ enabledProviders s -- TODO: use discovery let makeProvider name = let name' = "oauth2." <> name lk = MaybeT . C.lookup cfg . (name' <>) lku n = lk n >>= MaybeT . return . hush . parseURI strictURIParserOptions . encodeUtf8+ lkMaybe n = lift $+ (hush . parseURI strictURIParserOptions . encodeUtf8 =<<) <$>+ C.lookup cfg (name' <> n) callback = URI (Scheme scheme) (Just $ Authority Nothing (Host hostname) Nothing) ("/" <> root <> "/oauth2callback/" <> (encodeUtf8 name))@@ -71,19 +82,26 @@ <*> lk ".scope" <*> lku ".endpoint.identity" <*> lk ".identityField"+ <*> lkMaybe ".endpoint.par"+ <*> lkMaybe ".issuer"+ <*> (lift $ C.lookupDefault False cfg $ name' <> ".dpop")+ <*> lkMaybe ".endpoint.jwks" <*> (OAuth2 <$> lk ".clientId"- <*> (lift $ runMaybeT $ lk ".clientSecret")+ <*> (lift . fmap (fromMaybe "") . runMaybeT $ lk ".clientSecret") <*> lku ".endpoint.auth" <*> lku ".endpoint.access"- <*> (pure $ Just callback))+ <*> (pure callback))+ providers <- liftIO $ catMaybes <$> mapM (runMaybeT . makeProvider) names addRoutes $ mapped._2 %~ (bracket s) $ [ ("oauth2createaccount", oauth2CreateAccount s) , ("oauth2callback/:provider", oauth2Callback s) , ("oauth2login/:provider", redirectLogin) ]- liftIO $ M.fromList . map (\x -> (providerName x, x)) . catMaybes <$>- (mapM (runMaybeT . makeProvider) names)+ maybe (pure ()) (\p -> error $ "JWK not provided while provider " <>+ T.unpack (providerName p) <> " uses PAR") $+ guard (isNothing (auths ^. authJWK)) *> find (isJust . parEndpoint) providers+ return . M.fromList $ map ((,) <$> providerName <*> id) providers redirectLogin :: Handler b (AuthManager u e b) ()@@ -94,62 +112,82 @@ where toProvider p = do success <- redirectToProvider $ providerName p- if success then return () else pass+ when (isNothing success) pass +userProvider+ :: OAuth2Settings p u i e b+ -> Provider+ -> p+userProvider s provider =+ fromJust $ lookup (providerName provider) $ enabledProviders s+ getRedirUrl :: Provider- -> Text+ -> B.ByteString+ -> B.ByteString -> URI-getRedirUrl p token =- appendQueryParams [("state", encodeUtf8 token)+getRedirUrl p token pkceChallenge =+ appendQueryParams [("state", token)+ ,("code_challenge", pkceChallenge) ,("scope", encodeUtf8 $ scope p)] $ authorizationUrl $ oauth p redirectToProvider :: Text- -> Handler b (AuthManager u e b) Bool+ -> Handler b (AuthManager u e b) (Maybe RedirectError) redirectToProvider pName = do- maybe (return False) redirectToProvider' =<< M.lookup pName <$> gets providers+ maybe (return $ Just UnknownProvider) redirectToProvider' =<< M.lookup pName <$> gets providers redirectToProvider' :: Provider- -> Handler b (AuthManager u e b) Bool-redirectToProvider' provider = do+ -> Handler b (AuthManager u e b) (Maybe RedirectError)+redirectToProvider' provider = fmap (either Just (const Nothing)) $ runExceptT $ do+ let oa = oauth provider -- Generate a state token and store it in SessionManager- store <- gets stateStore'- stamp <- liftIO $ (T.pack . show) <$> getCurrentTime- name <- getStateName- let randomChar i- | i < 10 = chr (i+48)- | i < 36 = chr (i+55)- | otherwise = chr (i+61)- randomText n = T.pack <$> replicateM n (randomChar <$> randomRIO (0,61))- token <- liftIO $ randomText 20- withTop' store $ do- setInSession name token- setInSession (name <> "_stamp") stamp- commitSession- let redirUrl = serializeURIRef' $ getRedirUrl provider token- redirect' redirUrl 303+ store <- lift $ gets stateStore'+ -- Some implementations may mind fractional iat/exp claims+ curr <- liftIO getTruncatedCurrentTime+ name <- (<> providerName provider) <$> lift getStateName+ -- PKCE verifier, used in access token fetch+ (token, pkceVerifier) <- liftIO genParams+ -- PKCE challenge, sent in the initial redirect/PAR request+ let pkceChallenge =+ decodeLatin1 . URL.encodeUnpadded . B.pack .+ ByteArray.unpack @(Crypto.Hash.Digest Crypto.Hash.SHA256) $+ Crypto.Hash.hash pkceVerifier+ baseParams =+ [ ("response_type", "code")+ , ("client_id", encodeUtf8 $ oauth2ClientId oa)+ , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)+ ]+ stateParams =+ [ ("state", token)+ , ("code_challenge", encodeUtf8 pkceChallenge)+ , ("code_challenge_method", "S256")+ , ("scope", encodeUtf8 $ scope provider)+ ] -getUserInfo- :: MonadIO m- => Manager- -> Provider- -> AccessToken- -> ExceptT (Maybe ByteString) m Text-getUserInfo mgr provider token = do- let endpoint = identityEndpoint provider- (withExceptT Just $ ExceptT $ liftIO $ authGetJSON mgr token endpoint) >>=- (maybe (throwE Nothing) pure . lookupProviderInfo)+ lift $ withTop' store $ do+ setInSession name $ decodeLatin1 token+ setInSession (name <> "_stamp") . T.pack $ show curr+ setInSession (name <> "_pkce_verifier") (decodeLatin1 $ pkceVerifier)+ commitSession+ lift . flip redirect' 303 =<< serializeURIRef' <$> maybe+ -- Known statically+ (lift . pure . appendQueryParams stateParams $ authorizationUrl oa)+ -- PAR. Need to fetch parameter with POST+ (parRequest provider curr (baseParams <> stateParams))+ (parEndpoint provider) where- lookup' a b = maybeText =<< M.lookup a b- maybeText (String x) = Just x- maybeText _ = Nothing- lookupProviderInfo = lookup' (identityField provider)+ genParams =+ (,)+ -- State token+ <$> (URL.encodeUnpadded <$> getRandomBytes 20)+ -- PKCE verifier+ <*> (URL.encodeUnpadded <$> getRandomBytes 32) oauth2Callback :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Handler b (AuthManager u e b) () oauth2Callback s = do provs <- gets providers@@ -158,13 +196,13 @@ oauth2Callback' :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Provider -> Handler b (AuthManager u e b) () oauth2Callback' s provider = do- name <- getStateName+ name <- (<> providerName provider) <$> getStateName+ mgr <- gets httpManager let ss = stateStore s- mgr = httpManager s res <- runExceptT $ do let param = oauth provider expiredStamp <- lift $ withTop' ss $@@ -173,6 +211,8 @@ when expiredStamp $ throwE ExpiredState hostState <- maybe (throwE StateNotStored) return =<< (lift $ withTop' ss $ getFromSession name)+ pkceVerifier <- maybe (throwE StateNotStored) (pure . encodeUtf8) =<<+ (lift $ withTop' ss $ getFromSession $ name <> "_pkce_verifier") providerState <- maybe (throwE StateNotReceived) return =<< (lift $ getParamText "state") when (hostState /= providerState) $ throwE BadState@@ -183,21 +223,39 @@ (maybe (throwE (IdExtractionFailed Nothing)) pure =<< (fmap ExchangeToken) <$> (lift $ getParamText "code")) >>= -- TODO: catch?- (liftIO . fetchAccessToken mgr param >=>- either (const $ throwE AccessTokenFetchError) pure >=>- -- TODO: get user id (sub) from idToken in token, if- -- available. Requires JWT handling.- withExceptT (IdExtractionFailed . ((hush . decodeUtf8' . toStrict) =<<)) .- getUserInfo (httpManager s) provider . accessToken)+ (fetchAccessToken mgr param pkceVerifier >=>+ withExceptT IdExtractionFailed .+ getUserInfo mgr provider . accessToken) either (setFailure ((oauth2Failure s) SCallback) (Just $ providerName provider) . Right . Create . OAuth2Failure) (oauth2Success s provider) res+ where+ -- Add PKCE challenge to access token+ fetchAccessToken :: Manager -> OAuth2 -> B.ByteString -> ExchangeToken -> ExceptT OAuth2Failure (Handler b (AuthManager u e b)) OAuth2Token+ fetchAccessToken mgr oa pkceVerifier code+ | dpopBoundAccessTokens provider = do+ let (uri, body) = accessTokenUrl oa code+ req <- liftIO (HTTP.requestFromURI $ fromURIByteString uri)+ curr <- liftIO getTruncatedCurrentTime+ clientAssertion <- withExceptT (DPoPRequestError . JOSEError) $ getClientAssertion provider curr+ resp <- withExceptT DPoPRequestError $ dpopReq provider id HTTP.httpLbs $ req+ & HTTP.urlEncodedBody+ ([("code_verifier", pkceVerifier)+ ,("client_assertion", clientAssertion)+ ,("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+ , ("client_id", encodeUtf8 $ oauth2ClientId oa)+ ] <> body)+ withExceptT AccessTokenFetchError $ except $ parseResponseFlexible $ HTTP.responseBody resp+ | otherwise = withExceptT AccessTokenFetchError $+ let (uri, body) = accessTokenUrl oa code+ in doSimplePostRequest mgr oa uri (("code_verifier", pkceVerifier):body) >>=+ except . parseResponseFlexible -- User has successfully completed OAuth2 login. Get the stored -- intended action and perform it. oauth2Success :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Provider -> Text -> Handler b (AuthManager u e b) ()@@ -219,7 +277,7 @@ doOauth2Login :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Provider -> Text -> Handler b (AuthManager u e b) ()@@ -233,7 +291,7 @@ where proceed = do res <- runExceptT $ do- usr <- ExceptT $ (oauth2Login s) (providerName provider) token+ usr <- ExceptT $ (oauth2Login s) (userProvider s provider) token maybe (return ()) (lift . setUser) usr return usr either (setFailure ((oauth2Failure s) SLogin)@@ -250,12 +308,12 @@ prepareOAuth2Create' :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Provider -> Text -> Handler b (AuthManager u e b) (Either (Either e CreateFailure) i) prepareOAuth2Create' s provider token =- (prepareOAuth2Create s) (providerName provider) token >>=+ ((prepareOAuth2Create s) (userProvider s provider) token) >>= either checkDuplicate (return . Right) where checkDuplicate e = do@@ -265,7 +323,7 @@ -- Check that stored action is not too old and that user matches doResume :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Provider -> Text -> Text@@ -280,7 +338,7 @@ (hush $ Data.ByteString.Base64.decode $ encodeUtf8 d) when (requireUser d' && isNothing user) $ throwE (Right AttachNotLoggedIn) u <- ExceptT $ return . either (Left . Left) Right =<<- (oauth2Check s) (providerName provider) token+ (oauth2Check s) (userProvider s provider) token -- Compare current user with action's stored user when (userId /= actionUser d') $ throwE (Right ActionUserMismatch)@@ -302,7 +360,7 @@ -- requesting account creation afterwards. oauth2CreateAccount :: IAuthBackend u i e b- => OAuth2Settings u i e b+ => OAuth2Settings p u i e b -> Handler b (AuthManager u e b) () oauth2CreateAccount s = do store <- gets stateStore'
+ Snap/Snaplet/CustomAuth/OAuth2/Internal/DPoP.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++module Snap.Snaplet.CustomAuth.OAuth2.Internal.DPoP where++import Control.Lens+import Control.Monad+import Control.Monad.Error.Class+import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Crypto.JOSE.Header+import Crypto.JOSE.JWK+import Crypto.JOSE.JWA.JWS (Alg(ES256))+import Crypto.JWT+import Data.Aeson+import qualified Data.Aeson.KeyMap as M+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import Data.List (find)+import Data.Maybe+import Data.Text (Text)+import Data.Text.Encoding (decodeLatin1, decodeUtf8, encodeUtf8)+import Data.Text.Strict.Lens+import Data.Time+import qualified Network.HTTP.Client as HTTP+import Network.HTTP.Types+import Network.HTTP.Types.Method+import Network.OAuth.OAuth2+import URI.ByteString+import Snap hiding (Method)+import Snap.Snaplet.Session++import Snap.Snaplet.CustomAuth.AuthManager hiding (jwk)+import Snap.Snaplet.CustomAuth.Challenge+import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.CustomAuth.Util++data DPoPJWT = DPoPJWT+ { jwtClaims :: ClaimsSet+ , claimHtm :: Text+ , claimHtu :: Text+ , claimNonce :: Maybe Text+ -- | PDS endpoints only+ , claimAth :: Maybe Text+ }++instance HasClaimsSet DPoPJWT where+ claimsSet f s = fmap (\a' -> s { jwtClaims = a'}) (f (jwtClaims s))++instance FromJSON DPoPJWT where+ parseJSON = withObject "DPoP" $ \o ->+ DPoPJWT+ <$> parseJSON (Object o)+ <*> o .: "htm"+ <*> o .: "htu"+ <*> o .:? "nonce"+ <*> o .:? "ath"++instance ToJSON DPoPJWT where+ toJSON s =+ Object $ M.union+ (M.fromList $ (maybe id (\x -> (("nonce",String x):)) $ claimNonce s)+ [ ("htm", String $ claimHtm s)+ , ("htu", String $ claimHtu s)+ ])+ ((\(Object o) -> o) $ toJSON $ jwtClaims s)++dpopKeys :: MonadRandom m => m JWK+dpopKeys = do+ jwk <- genJWK (ECGenParam P_256)+ let h = view thumbprint jwk :: Digest SHA256+ kid = view (re (base64url . digest) . utf8) h+ pure $ set jwkKid (Just kid) jwk++dpopClaims :: MonadRandom m => UTCTime -> Method -> URI -> Maybe Text -> m DPoPJWT+dpopClaims t method uri nonce = do+ jti <- decodeLatin1 . Base64.encode <$> getRandomBytes 12+ pure $ DPoPJWT+ { jwtClaims = emptyClaimsSet+ & claimJti ?~ jti+ & claimIat ?~ NumericDate t+ , claimHtm = decodeLatin1 method+ , claimHtu = decodeUtf8 $ normalizeURIRef' httpNormalization uri+ , claimNonce = nonce+ , claimAth = Nothing+ }++dpopJWTSign :: (MonadRandom m, MonadError e m, AsError e) => JWK -> DPoPJWT -> m SignedJWT+dpopJWTSign key dpop = do+ let hdr = newJWSHeader ((), ES256)+ & typ ?~ HeaderParam () "dpop+jwt"+ & jwk ?~ (HeaderParam () $ fromJust $ view asPublicKey key)+ signJWT key hdr dpop++-- | Generate DPoP JWK+newDPoP+ :: Provider+ -> Handler b (AuthManager u e b) ()+newDPoP provider = do+ ss <- gets stateStore'+ let oa = oauth provider+ --name <- (("_" <> providerName provider) <>) <$> getStateName+ name <- getStateName+ k <- liftIO dpopKeys+ withTop' ss $ setInSession (name <> "_dpop_jwk") $ decodeLatin1 $ BL.toStrict $ encode k++recoverDPoPKey+ :: Provider+ -> Handler b (AuthManager u e b) (Maybe JWK)+recoverDPoPKey provider = do+ ss <- gets stateStore'+ name <- getStateName+ raw <- withTop' ss (getFromSession (name <> "_dpop_jwk"))+ pure $ maybe Nothing (decode . BL.fromStrict . encodeUtf8) raw++newtype ResponseBodyError = ResponseBodyError { respError :: Text }+ deriving (Show, Eq)++instance FromJSON ResponseBodyError where+ parseJSON = withObject "Response" $ \v -> ResponseBodyError <$> v .: "error"++dpopReq+ :: Provider+ -> (a -> BL.ByteString)+ -> (HTTP.Request -> HTTP.Manager -> IO (HTTP.Response a))+ -> HTTP.Request+ -> ExceptT RedirectError (Handler b (AuthManager u e b)) (HTTP.Response a)+dpopReq provider toLBS reqf req = do+ (ss, mgr) <- lift $ gets ((,) <$> stateStore' <*> httpManager)+ name <- lift getStateName+ let nonceName = name <> "_dpop_nonce"+ t <- liftIO getTruncatedCurrentTime+ storedNonce <- lift $ withTop' ss $ getFromSession nonceName+ key <- maybe (throwE DPoPKeyMissing) pure =<< lift (recoverDPoPKey provider)+ let htu = URI+ (Scheme $ if HTTP.secure req then "https" else "http")+ (Just $ Authority Nothing (Host $ HTTP.host req) (Just $ Port $ HTTP.port req))+ (HTTP.path req)+ (Query []) Nothing+ dpopReq' maybeNonce = do+ -- dpopClaims t (HTTP.method req) htu maybeNonce+ let createClaims = runJOSE $+ dpopClaims t (HTTP.method req) htu maybeNonce+ claims <- liftIO createClaims >>= either+ (throwE . JOSEError) pure+ let createJWT = runJOSE $+ dpopJWTSign key claims+ jwt <- liftIO createJWT >>= either+ (throwE . JOSEError) pure+ let req' = req+ { HTTP.requestHeaders =+ ("dpop", BL.toStrict $ encodeCompact jwt):+ (filter ((/= "dpop") . fst) (HTTP.requestHeaders req))+ }+ liftIO (reqf req' mgr) >>=+ (\case+ r | Just dpopNonce <- getHeaderValue "dpop-nonce" r -> do+ let n = decodeUtf8 dpopNonce+ lift $ withTop' ss $ do+ setInSession nonceName n+ commitSession+ pure (r, Just n)+ r -> pure (r, Nothing)+ ) >>= \case+ (r, n@(Just _)) | nonceRequired r -> do+ dpopReq' n+ (r, x) -> do+ let maybeChallenge =+ find ((== "dpop") . challengeScheme) .+ parseWWWAuthenticateChallenge =<<+ getHeaderValue "www-authenticate" r+ pure r++ dpopReq' storedNonce+ where+ getHeaderValue n = lookup n . HTTP.responseHeaders++ nonceRequired r =+ let s = HTTP.responseStatus r+ in or+ [ isJust $ do+ challenge <-+ find ((== "dpop") . challengeScheme) . parseWWWAuthenticateChallenge =<<+ getHeaderValue "www-authenticate" r+ authError <- lookup "error" $ challengeParams challenge+ guard $+ statusCode s == 401 &&+ challengeScheme challenge == "DPoP" &&+ authError == "use_dpop_nonce"+ , isJust $ do+ contentType <- getHeaderValue "content-type" r+ (ResponseBodyError authError) <-+ guard (contentType == "application/json") *> (decode $ toLBS $ HTTP.responseBody r)+ guard $+ statusCode s == 400 &&+ authError == "use_dpop_nonce"+ ]
+ Snap/Snaplet/CustomAuth/OAuth2/Internal/PAR.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Support for making requests to resource servers, including+-- handling of DPoP.++module Snap.Snaplet.CustomAuth.OAuth2.Internal.PAR where++import Control.Lens+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Control.Monad.State+import Crypto.JWT hiding (jwk)+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as Base64+import Data.ByteString.Lazy (toStrict)+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8)+import Data.Time+import qualified Network.HTTP.Client as HTTP+import Network.OAuth.OAuth2+import qualified Network.URI+import Snap+import Unsafe.Coerce+import URI.ByteString++import Snap.Snaplet.CustomAuth.AuthManager+import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.CustomAuth.OAuth2.Internal.DPoP+import Snap.Snaplet.CustomAuth.Util++newtype RequestURI = RequestURI { reqURI :: Text }+ deriving (Show)++instance FromJSON RequestURI where+ parseJSON = withObject "RequestURI" $ \o -> RequestURI <$> o .: "request_uri"++getClientAssertion+ :: Provider+ -> UTCTime+ -> ExceptT JWTError (Handler b (AuthManager u e b)) ByteString+getClientAssertion provider curr = do+ maybeJWK <- lift $ gets jwk++ -- Tailored for bsky, may need generalisation for others+ let createClaims = do+ jti <- decodeLatin1 . Base64.encode <$> getRandomBytes 12+ let claims =+ emptyClaimsSet+ & claimAud ?~ Audience [aud]+ & claimIss ?~ sub+ & claimSub ?~ sub+ & claimJti ?~ jti+ & claimIat ?~ NumericDate curr+ & claimExp ?~ NumericDate (addUTCTime 90 curr)+ pure claims+ oa = oauth provider+ accessURI = oauth2AuthorizeEndpoint oa+ sub = fromJust $ preview stringOrUri $ oauth2ClientId oa+ aud = fromJust $ preview stringOrUri $ decodeLatin1 $+ schemeBS (uriScheme accessURI) <> "://" <>+ fromMaybe "" (hostBS . authorityHost <$> uriAuthority accessURI)++ claims <- liftIO createClaims++ let createAssertion = runJOSE $ do+ let j = fromJust maybeJWK+ hdr <- makeJWSHeader j+ encodeCompact <$> signClaims j hdr claims++ fmap toStrict $ ExceptT $ liftIO createAssertion++parRequest+ :: Provider+ -> UTCTime+ -> [(ByteString, ByteString)]+ -> URI+ -> ExceptT RedirectError (Handler b (AuthManager u e b)) (URIRef Absolute)+parRequest provider curr params parUrl = do+ let oa = oauth provider++ f <-+ if dpopBoundAccessTokens provider+ then do+ _ <- lift $ newDPoP provider+ pure $ dpopReq provider id+ else do+ mgr <- lift $ gets httpManager+ pure $ \f -> liftIO . flip f mgr++ clientAssertion <- withExceptT JOSEError $ getClientAssertion provider curr+ let parQuery =+ params <>+ [ ("client_assertion", clientAssertion)+ , ("client_assertion_type", "urn:ietf:params:oauth:client-assertion-type:jwt-bearer")+ ]++ req <- HTTP.urlEncodedBody parQuery <$> liftIO (HTTP.requestFromURI $ fromURIByteString parUrl)++ requestURI <-+ liftIO (HTTP.requestFromURI $ fromURIByteString parUrl) >>=+ f HTTP.httpLbs . HTTP.urlEncodedBody parQuery >>=+ maybe (throwE PARRequestURIParseError) (pure . reqURI) .+ decode . HTTP.responseBody++ let q = [ ("client_id", encodeUtf8 $ oauth2ClientId oa)+ , ("request_uri", encodeUtf8 requestURI)+ ]+ pure $ over (queryL . queryPairsL) (<> q) (oauth2AuthorizeEndpoint oa)
+ Snap/Snaplet/CustomAuth/OAuth2/Internal/UserInfo.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.CustomAuth.OAuth2.Internal.UserInfo where++import Control.Applicative+import Control.Lens+import Control.Monad.Time+import Control.Monad.Trans+import Control.Monad.Trans.Except+import Crypto.JOSE+import Crypto.JWT+import Data.Aeson (Value(..), eitherDecode)+import qualified Data.ByteString.Lazy as BL+import Data.Bifunctor+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)+import Network.HTTP.Client (Manager)+import qualified Network.HTTP.Client as HTTP+import Network.OAuth.OAuth2++import Snap.Snaplet.CustomAuth.Types+import Snap.Snaplet.CustomAuth.OAuth2.Internal.DPoP+import Snap.Snaplet.CustomAuth.Util++getUserInfo+ :: MonadIO m+ => Manager+ -> Provider+ -> AccessToken+ -> ExceptT (Maybe Text) m Text+getUserInfo mgr provider token+ | Just jwksURI <- jwksEndpoint provider = do+ jwks <- withExceptT (Just . T.pack) $ ExceptT $ do+ liftIO $ eitherDecode . HTTP.responseBody <$>+ (HTTP.requestFromURI (fromURIByteString jwksURI) >>=+ flip HTTP.httpLbs mgr)+ claims <- withExceptT (Just . T.pack . show @JWTError) $ mapExceptT liftIO $+ ExceptT $ runJOSE $ do+ jwt <- (decodeCompact . BL.fromStrict . encodeUtf8 . atoken) token+ verifyClaims (defaultJWTValidationSettings (const True))+ (jwks :: JWKSet)+ (jwt :: SignedJWT)+ sub <- maybe (throwE $ Just "sub not found") pure $ claims ^. claimSub+ pure $ fromJust $ sub ^? string <|> (T.pack . show <$> sub ^? uri)+ | otherwise = do+ -- TODO PAR if needed+ let endpoint = identityEndpoint provider+ mapExceptT (fmap (first (Just . decodeUtf8Lenient . BL.toStrict)) . liftIO)+ (authGetJSON mgr token endpoint) >>=+ (maybe (throwE Nothing) pure . lookupProviderInfo)+ where+ lookup' a b = maybeText =<< M.lookup a b+ maybeText (String x) = Just x+ maybeText _ = Nothing+ lookupProviderInfo = lookup' (identityField provider)+
Snap/Snaplet/CustomAuth/OAuth2/Splices.hs view
@@ -7,7 +7,6 @@ import Control.Monad.State import Data.Map.Syntax import Data.Maybe-import Data.Monoid import Heist import Heist.Compiled import Snap
Snap/Snaplet/CustomAuth/Types.hs view
@@ -5,13 +5,16 @@ module Snap.Snaplet.CustomAuth.Types where import Control.Lens.TH+import Crypto.JWT (JWTError)+import Crypto.JOSE.JWK (JWK) import Data.Binary import Data.Binary.Instances () import Data.ByteString import Data.Text (Text) import Data.Time.Clock (UTCTime, NominalDiffTime) import GHC.Generics (Generic)-import Network.OAuth.OAuth2 (OAuth2)+import Network.HTTP.Client (Manager)+import Network.OAuth.OAuth2 (OAuth2, TokenResponseError) import URI.ByteString (URI) import Snap.Core (Cookie(..))@@ -32,7 +35,7 @@ | DuplicateName | PasswordFailure PasswordFailure | OAuth2Failure OAuth2Failure- deriving (Eq, Show, Read)+ deriving (Eq, Show) data OAuth2Failure = StateNotStored | StateNotReceived | ExpiredState | BadState@@ -40,8 +43,9 @@ | AlreadyUser | AlreadyLoggedIn | IdentityInUse | ProviderError (Maybe Text)- | AccessTokenFetchError- deriving (Show, Read, Eq)+ | DPoPRequestError RedirectError+ | AccessTokenFetchError TokenResponseError+ deriving (Show, Eq) data OAuth2ActionFailure = ActionTimeout | ActionDecodeError | ActionUserMismatch@@ -60,6 +64,10 @@ , scope :: Text , identityEndpoint :: URI , identityField :: Text+ , parEndpoint :: Maybe URI+ , issuer :: Maybe URI+ , dpopBoundAccessTokens :: Bool+ , jwksEndpoint :: Maybe URI , oauth :: OAuth2 } deriving (Show)@@ -85,9 +93,21 @@ data AuthSettings = AuthSettings { _authName :: Text , _authCookieLifetime :: Maybe NominalDiffTime+ -- | Needed by OAuth2 if using PAR+ , _authJWK :: Maybe JWK+ -- | Needed by OAuth2 if using PAR+ , _authHTTPManager :: Manager } +data RedirectError+ = UnknownProvider+ | JWKMissing+ | DPoPKeyMissing+ | PARRequestURIParseError+ | JOSEError JWTError+ deriving (Show, Eq)+ makeLenses ''AuthSettings -defAuthSettings :: AuthSettings-defAuthSettings = AuthSettings "auth" Nothing+defAuthSettings :: Manager -> AuthSettings+defAuthSettings = AuthSettings "auth" Nothing Nothing
Snap/Snaplet/CustomAuth/User.hs view
@@ -1,23 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-} module Snap.Snaplet.CustomAuth.User where import Control.Error.Util+import Control.Monad import Control.Monad.State import Control.Monad.Trans.Maybe import Data.ByteString (ByteString)-import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Char8 (pack) import qualified Data.Configurator as C import Data.Maybe import Data.Text.Encoding import Data.Time.Clock (addUTCTime, getCurrentTime) import Snap-import qualified Text.Show.ByteString import Snap.Snaplet.CustomAuth.Types (AuthUser(..)) import Snap.Snaplet.CustomAuth.AuthManager +-- | Set user and set response headers to store it in a session+-- cookie. setUser :: UserData u => u@@ -29,12 +32,19 @@ (name, lifetime) <- gets ((,) <$> sessionCookieName <*> cookieLifetime) modifyResponse $ addHeader "Set-Cookie" $ name <> "=" <> session udata <>- (maybe "" (("; Max-Age=" <>) . toStrict . Text.Show.ByteString.show @Int . floor) lifetime) <>+ (maybe "" (("; Max-Age=" <>) . pack . show @Int . floor) lifetime) <> "; Path=/" <> (if secure then "; Secure; SameSite=None" else "") <> "; HttpOnly"- modify $ \mgr -> mgr { activeUser = Just usr }+ setUser' $ Just usr +-- | Only set user in AuthManager internal state.+setUser'+ :: Maybe u+ -> Handler b (AuthManager u e b) ()+setUser' usr =+ modify $ \mgr -> mgr { activeUser = usr }+ currentUser :: UserData u => Handler b (AuthManager u e b) (Maybe u) currentUser = do u <- get@@ -47,7 +57,7 @@ recoverSession :: IAuthBackend u i e b- => Handler b (AuthManager u e b) ()+ => Handler b (AuthManager u e b) () recoverSession = do sesName <- gets sessionCookieName let quit e = do@@ -57,7 +67,7 @@ usr <- runMaybeT $ do val <- MaybeT $ ((hush . decodeUtf8' . cookieValue =<<) <$> getCookie sesName) lift $ recover val- modify $ \mgr -> mgr { activeUser = join $ hush <$> usr }+ setUser' $ join $ hush <$> usr maybe (return ()) (either quit (const $ return ())) usr -- Just check if the session cookie is defined
Snap/Snaplet/CustomAuth/Util.hs view
@@ -7,10 +7,16 @@ import Control.Error.Util import Control.Monad.State import Data.ByteString (ByteString)-import Data.Monoid+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import Data.Char+import Data.Kind (Type) import Data.Text (Text) import Data.Text.Encoding+import Data.Time+import qualified Network.URI import Snap hiding (path)+import qualified URI.ByteString import Snap.Snaplet.CustomAuth.AuthManager @@ -22,7 +28,7 @@ return $ "__" <> name <> "_" <> path <> "_state" getParamText- :: forall (f :: * -> *).+ :: forall (f :: Type -> Type). MonadSnap f => ByteString -> f (Maybe Text)@@ -39,3 +45,31 @@ , authFailData = Just failure' } action++getTruncatedCurrentTime+ :: IO UTCTime+getTruncatedCurrentTime =+ (\t -> t { utctDayTime = fromInteger . floor . realToFrac $ utctDayTime t }) <$> getCurrentTime++fromURIByteString+ :: URI.ByteString.URI -> Network.URI.URI+fromURIByteString uri =+ Network.URI.URI+ { Network.URI.uriScheme = C8.unpack (URI.ByteString.schemeBS $ URI.ByteString.uriScheme uri)+ <> ":"+ , Network.URI.uriAuthority =+ (\a -> Network.URI.URIAuth+ { Network.URI.uriUserInfo = "" -- TODO?+ , Network.URI.uriRegName = C8.unpack $ URI.ByteString.hostBS $+ URI.ByteString.authorityHost a+ , Network.URI.uriPort = "" -- TODO?+ }+ )+ <$> URI.ByteString.uriAuthority uri+ , Network.URI.uriPath = C8.unpack $ URI.ByteString.uriPath uri+ , Network.URI.uriQuery = C8.unpack $ URI.ByteString.serializeQuery'+ URI.ByteString.httpNormalization $+ URI.ByteString.uriQuery uri+ , Network.URI.uriFragment = C8.unpack . URI.ByteString.serializeFragment' $+ URI.ByteString.uriFragment uri+ }
snaplet-customauth.cabal view
@@ -1,5 +1,5 @@ Name: snaplet-customauth-Version: 0.2.1+Version: 0.3.0 Synopsis: Alternate authentication snaplet Description: More customizable authentication snaplet with OAuth2 support License: BSD3@@ -23,38 +23,48 @@ other-modules: Snap.Snaplet.CustomAuth.AuthManager,+ Snap.Snaplet.CustomAuth.Challenge, Snap.Snaplet.CustomAuth.Handlers, Snap.Snaplet.CustomAuth.Heist, Snap.Snaplet.CustomAuth.Types, Snap.Snaplet.CustomAuth.User, Snap.Snaplet.CustomAuth.Util, Snap.Snaplet.CustomAuth.OAuth2.Internal,+ Snap.Snaplet.CustomAuth.OAuth2.Internal.DPoP,+ Snap.Snaplet.CustomAuth.OAuth2.Internal.PAR,+ Snap.Snaplet.CustomAuth.OAuth2.Internal.UserInfo, Snap.Snaplet.CustomAuth.OAuth2.Splices Build-depends: base >= 4.4 && < 5,- lens >= 3.7.6 && < 4.20,- bytestring >= 0.9.1 && < 0.11,- base64-bytestring >= 1.0.0.1 && < 1.1,- bytestring-show >= 0.3.5.6 && < 0.4,+ lens >= 3.7.6 && < 6,+ bytestring >= 0.9.1 && < 0.13,+ base64-bytestring >= 1.0.0.1 && < 1.3,+ crypton >= 1.0 && < 2,+ memory >= 0.18 && < 1,+ jose >= 0.11 && < 0.12,+ monad-time >= 0.4 && < 0.5, heist >= 1.0.1 && < 1.2, mtl >= 2 && < 3,- transformers >= 0.4 && < 0.6,+ transformers >= 0.4 && < 0.7, errors >= 2.3 && < 2.4, snap >= 1.1 && < 1.2, snap-core >= 1.0 && < 1.1, configurator >= 0.3 && < 0.4,- text >= 0.11 && < 1.3,- time >= 1.1 && < 1.12,+ text >= 0.11 && < 2.3,+ time >= 1.1 && < 1.13, xmlhtml >= 0.1 && < 0.3, binary >= 0.8.5 && < 0.9, binary-instances >= 1 && < 2,- hoauth2 >= 1.11.0 && < 1.17.0,- http-client >= 0.5.7 && < 0.7,+ hoauth2 >= 2.9 && < 3,+ attoparsec >= 0.13 && < 0.15,+ case-insensitive >= 1 && < 2,+ http-client >= 0.5.7 && < 0.8, http-client-tls >= 0.3.5 && < 0.4,- containers >= 0.5.6 && < 0.6,+ http-types >= 0.12 && < 0.13,+ containers >= 0.5.6 && < 0.7, unordered-containers >= 0.2.7.1 && < 0.3,- aeson >= 1.2 && < 1.6,+ aeson >= 2.0.1.0 && < 3, uri-bytestring >= 0.2.3 && < 0.4,- map-syntax >= 0.2 && < 0.4,- random >= 1.1 && < 1.2+ network-uri >= 2.6.1 && < 3,+ map-syntax >= 0.2 && < 0.4