prodapi-userauth 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+75/−18 lines, 7 filesdep +prodapi-webdep −prodapidep ~base
Dependencies added: prodapi-web
Dependencies removed: prodapi
Dependency ranges changed: base
Files
- prodapi-userauth.cabal +4/−3
- src/Prod/UserAuth.hs +27/−1
- src/Prod/UserAuth/Api.hs +8/−0
- src/Prod/UserAuth/Counters.hs +2/−0
- src/Prod/UserAuth/HandlerCombinators.hs +22/−6
- src/Prod/UserAuth/JWT.hs +10/−6
- src/Prod/UserAuth/Runtime.hs +2/−2
prodapi-userauth.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: prodapi-userauth-version: 0.1.0.0+version: 0.2.0.0 synopsis: a base lib for performing user-authentication in prodapi services description: implements basic bricks for password, oauth2 authentification of user identities -- bug-reports:@@ -33,7 +33,7 @@ default-extensions: OverloadedStrings DataKinds TypeApplications TypeOperators build-depends: aeson >= 2.2.1 && < 2.3,- base >= 4.19.1 && < 4.20,+ base >= 4.19.1 && < 5, containers >= 0.6.8 && < 0.7, bytestring >= 0.12.1 && < 0.13, text >= 2.1.1 && < 2.2,@@ -43,7 +43,7 @@ jwt >= 0.11.0 && < 0.12, lucid >= 2.11.20230408 && < 2.12, postgresql-simple >= 0.7.0 && < 0.8,- prodapi >= 0.1.0 && < 0.2,+ prodapi-web >= 0.1.0 && < 0.2, prometheus-client >= 1.1.1 && < 1.2, servant >= 0.20.1 && < 0.21, servant-server >= 0.20 && < 0.21,@@ -53,3 +53,4 @@ default-language: Haskell2010 hs-source-dirs: src+
src/Prod/UserAuth.hs view
@@ -50,6 +50,7 @@ handleUserAuth runtime = handleEchoCookieClaims runtime :<|> handleWhoAmI runtime+ :<|> handleRenewCookie runtime :<|> handleCleanCookie :<|> handleRegister runtime :<|> handleLogin runtime@@ -59,8 +60,33 @@ handleEchoCookieClaims :: Runtime info -> Maybe LoggedInCookie -> Handler JWTClaimsSet handleEchoCookieClaims runtime cookie = do- inc echoes "requested" (counters runtime)+ inc echoes "echoed" (counters runtime) withLoginCookieVerified runtime cookie (pure . claims)++handleRenewCookie ::+ Runtime info ->+ Maybe LoggedInCookie ->+ Handler (Headers '[Header "Set-Cookie" LoggedInCookie] Text)+handleRenewCookie runtime cookie = do+ inc echoes "renewed" (counters runtime)+ withLoginCookieVerified runtime cookie $ \jwt -> do+ let muid = Map.lookup "user-id" (unClaimsMap . unregisteredClaims $ claims jwt)+ case muid of+ Just (Number nid) -> do+ inc renewals "valid" (counters runtime)+ let uid = truncate nid :: UserId+ cookie <- liftIO $ makeLoggedInCookie runtime uid+ liftIO $ traceAugmentCookie runtime cookie+ case cookie of+ Left _ -> do+ inc renewals "renew-failed" (counters runtime)+ throwError $ err500{errBody = "failed to renew cookie"}+ Right c -> do+ inc renewals "renew-ok" (counters runtime)+ pure $ addHeader c $ encodedJwt c+ _ -> do+ inc renewals "token-invalid" (counters runtime)+ throwError $ err400{errBody = "this cookie is wrong"} handleWhoAmI :: Runtime info -> Maybe LoggedInCookie -> Handler [WhoAmI info] handleWhoAmI runtime cookie = do
src/Prod/UserAuth/Api.hs view
@@ -20,6 +20,7 @@ type UserAuthApi a = EchoCookieClaimsApi :<|> WhoAmIApi a+ :<|> RenewCookieApi :<|> CleanCookieApi :<|> RegisterApi a :<|> LoginApi a@@ -33,6 +34,13 @@ :> "echo-cookie" :> Header "Cookie" LoggedInCookie :> Get '[JSON] JWTClaimsSet++type RenewCookieApi =+ Summary "renews a cookie"+ :> "user-auth"+ :> "renew"+ :> Header "Cookie" LoggedInCookie+ :> Post '[JSON] (Headers '[Header "Set-Cookie" LoggedInCookie] Text) type WhoAmIApi a = Summary "prints user identities for a cookie"
src/Prod/UserAuth/Counters.hs view
@@ -15,6 +15,7 @@ , logins :: Prometheus.Vector (Text) Prometheus.Counter , echoes :: Prometheus.Vector (Text) Prometheus.Counter , whoamis :: Prometheus.Vector (Text) Prometheus.Counter+ , renewals :: Prometheus.Vector (Text) Prometheus.Counter , recoveryRequests :: Prometheus.Vector (Text) Prometheus.Counter , recoveryApplied :: Prometheus.Vector (Text) Prometheus.Counter }@@ -26,6 +27,7 @@ <*> statuses "userauth_logins" "number of logins recorded" <*> statuses "userauth_echoes" "number of token-echo recorded" <*> statuses "userauth_whoamis" "number of whoamis received"+ <*> statuses "userauth_renewals" "number of renewals received" <*> statuses "userauth_recovery_requests" "number of recovery-requests received" <*> statuses "userauth_recovery_applied" "number of recovery-requests applied" where
src/Prod/UserAuth/HandlerCombinators.hs view
@@ -8,8 +8,10 @@ ) where +import Control.Monad.IO.Class (liftIO) import Data.Maybe (isJust) import Data.Text.Encoding (decodeLatin1)+import Data.Time.Clock.POSIX import Network.Wai (Request, requestHeaders) import Prod.UserAuth.Base import Prod.UserAuth.JWT@@ -21,16 +23,29 @@ mkAuthHandler, ) import Web.Cookie (parseCookies)+import qualified Web.JWT +verifyExpiryClaim :: Maybe (JWT a) -> IO (Maybe (JWT a))+verifyExpiryClaim jwt = case fmap claims jwt >>= Web.JWT.exp of+ Nothing -> pure Nothing -- no expiry+ (Just expdate) -> do+ now <- Web.JWT.numericDate <$> getPOSIXTime+ case now of+ Nothing -> pure Nothing -- could not get a current time+ (Just nowdate)+ | nowdate < expdate -> pure jwt -- there still is some time left+ | otherwise -> pure Nothing -- expired+ authHandler :: Runtime a -> AuthHandler Request UserAuthInfo authHandler runtime = mkAuthHandler go where go req = do let mCookies = fmap parseCookies $ lookup "cookie" $ requestHeaders req let jwtblob = fmap decodeLatin1 $ lookup "login-jwt" =<< mCookies- let mJwt = decodeAndVerifySignature (toVerify . hmacSecret $ secretstring runtime) =<< jwtblob- traceJWT runtime mJwt- pure $ UserAuthInfo mJwt+ let mJwt = decodeAndVerifySignature (toVerify . EncodeHMACSecret $ secretstring runtime) =<< jwtblob+ validJwt <- liftIO $ verifyExpiryClaim mJwt+ traceJWT runtime validJwt+ pure $ UserAuthInfo validJwt authServerContext :: Runtime a -> Context (AuthHandler Request UserAuthInfo ': '[]) authServerContext runtime =@@ -57,9 +72,10 @@ (Maybe (JWT VerifiedJWT) -> Handler a) -> Handler a withOptionalLoginCookieVerified runtime cookie act = do- let mJwt = decodeAndVerifySignature (toVerify . hmacSecret $ secretstring runtime) =<< fmap encodedJwt cookie- traceOptionalVerification runtime (isJust mJwt)- act mJwt+ let mJwt = decodeAndVerifySignature (toVerify . EncodeHMACSecret $ secretstring runtime) =<< fmap encodedJwt cookie+ validJwt <- liftIO $ verifyExpiryClaim mJwt+ traceOptionalVerification runtime (isJust validJwt)+ act validJwt authorized :: Runtime info -> UserAuthInfo -> (UserId -> Handler a) -> Handler a authorized rt auth act =
src/Prod/UserAuth/JWT.hs view
@@ -9,8 +9,10 @@ where import Data.Aeson (FromJSON, Result (..), Value (Number), fromJSON)+import Data.Fixed (E12, Fixed (..)) import qualified Data.Map.Strict as Map import Data.Text (Text)+import Data.Time.Clock (secondsToNominalDiffTime) import Data.Time.Clock.POSIX import Prod.UserAuth.Base import Prod.UserAuth.Runtime@@ -47,27 +49,29 @@ -} makeLoggedInCookie :: Runtime a -> UserId -> IO (Either ErrorMessage LoggedInCookie) makeLoggedInCookie runtime uid = do- now <- numericDate <$> getPOSIXTime- case now of+ tNow <- getPOSIXTime+ let times = (,) <$> (numericDate tNow) <*> (numericDate $ tNow + secondsToNominalDiffTime 3600)+ case times of Nothing -> pure $ Left "could not build a valid issued-at"- Just iat -> do+ Just (iat, exp) -> do extras <- augmentLoggedInCookieClaims runtime uid case extras of Left err -> pure $ Left err Right vals -> do traceJWTSigned runtime uid vals- pure $ Right $ adapt iat vals+ pure $ Right $ adapt iat exp vals where baseClaims = baseClaimsSet runtime- adapt iat extras = do+ adapt iat exp extras = do let claims = Map.fromList $ mconcat [[("user-id", (Number $ fromIntegral uid))], extras] LoggedInCookie $ encodeSigned- (hmacSecret $ secretstring runtime)+ (EncodeHMACSecret $ secretstring runtime) mempty ( baseClaims { iss = stringOrURI "jwt-app" , iat = Just iat+ , Web.JWT.exp = Just exp , unregisteredClaims = ClaimsMap claims } )
src/Prod/UserAuth/Runtime.hs view
@@ -48,7 +48,7 @@ data Runtime info = Runtime { counters :: !Counters- , secretstring :: !Text+ , secretstring :: !ByteString , baseClaimsSet :: !JWTClaimsSet , connstring :: !ByteString , augmentSession :: AugmentSession info@@ -67,7 +67,7 @@ trace rt v = liftIO $ runTracer (tracer rt) $ v initRuntime ::- Text ->+ ByteString -> JWTClaimsSet -> ByteString -> AugmentSession info ->