packages feed

prodapi-userauth (empty) → 0.1.0.0

raw patch · 14 files changed

+1277/−0 lines, 14 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, cookie, http-api-data, jwt, lucid, postgresql-simple, prodapi, prometheus-client, servant, servant-server, text, time, uuid, wai

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for prodapi-userauth++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Lucas DiCioccio (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ prodapi-userauth.cabal view
@@ -0,0 +1,55 @@+cabal-version:       >=1.10+-- Initial package description 'prodapi-userauth.cabal' generated by 'cabal+--  init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:                prodapi-userauth+version:             0.1.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:+license: BSD3+license-file:        LICENSE+author:              Lucas DiCioccio+maintainer:          lucas@dicioccio.fr+-- copyright:+category: Web+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:+      Prod.UserAuth+      Prod.UserAuth.Api+      Prod.UserAuth.Backend+      Prod.UserAuth.Base+      Prod.UserAuth.Counters+      Prod.UserAuth.HandlerCombinators+      Prod.UserAuth.JWT+      Prod.UserAuth.Runtime+      Prod.UserAuth.Trace+      Prod.UserAuth.OAuth2+      Paths_prodapi_userauth+  default-extensions: OverloadedStrings DataKinds TypeApplications TypeOperators+  build-depends:+    aeson >= 2.2.1 && < 2.3,+    base >= 4.19.1 && < 4.20,+    containers >= 0.6.8 && < 0.7,+    bytestring >= 0.12.1 && < 0.13,+    text >= 2.1.1 && < 2.2,+    time >= 1.12.2 && < 1.13,+    cookie >= 0.4.6 && < 0.5,+    http-api-data >= 0.6 && < 0.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,+    prometheus-client >= 1.1.1 && < 1.2,+    servant >= 0.20.1 && < 0.21,+    servant-server >= 0.20 && < 0.21,+    wai >= 3.2.4 && < 3.3,+    uuid >= 1.3.15 && < 1.4+  -- hs-source-dirs:+  default-language:    Haskell2010+  hs-source-dirs:+      src
+ src/Prod/UserAuth.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Prod.UserAuth (+    UserAuthApi,+    handleUserAuth,+    initRuntime,+    Runtime,+    --+    withLoginCookieVerified,+    withOptionalLoginCookieVerified,+    --+    CookieProtect,+    UserAuthInfo (..),+    authUserId,+    Request,+    authServerContext,+    --+    authorized,+    limited,+    --+    renderStatus,+    --+    Track (..),+    BehaviourTrack (..),+    BackendTrack (..),+    JwtTrack (..),+    CallbackTrack (..),+)+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (Value (Number))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Prod.Status (RenderStatus)+import Prod.UserAuth.Api (CookieProtect, UserAuthApi)+import Prod.UserAuth.Backend+import Prod.UserAuth.Base+import Prod.UserAuth.HandlerCombinators+import Prod.UserAuth.JWT+import Prod.UserAuth.Runtime (Counters (..), Runtime, counters, initRuntime, secretstring, tokenValidityDuration, traceAttempt, traceAugmentCookie, traceRecoveryApplication, traceRecoveryRequest, traceRegistration, withConn)+import Prod.UserAuth.Trace+import qualified Prometheus as Prometheus+import Servant+import Servant.Server++import Lucid++handleUserAuth :: Runtime info -> Server (UserAuthApi info)+handleUserAuth runtime =+    handleEchoCookieClaims runtime+        :<|> handleWhoAmI runtime+        :<|> handleCleanCookie+        :<|> handleRegister runtime+        :<|> handleLogin runtime+        :<|> handleRecoveryRequest runtime+        :<|> handleApplyRecovery runtime+        :<|> handleHello++handleEchoCookieClaims :: Runtime info -> Maybe LoggedInCookie -> Handler JWTClaimsSet+handleEchoCookieClaims runtime cookie = do+    inc echoes "requested" (counters runtime)+    withLoginCookieVerified runtime cookie (pure . claims)++handleWhoAmI :: Runtime info -> Maybe LoggedInCookie -> Handler [WhoAmI info]+handleWhoAmI runtime cookie = do+    inc whoamis "requested" (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 whoamis "success" (counters runtime)+                let uid = truncate nid :: UserId+                liftIO $ whoAmIQueryIO runtime uid+            _ -> do+                inc whoamis "token-corrupted" (counters runtime)+                throwError $ err400{errBody = "this cookie is wrong"}++handleHello :: UserAuthInfo -> Handler Text+handleHello (UserAuthInfo jwt) = do+    pure "hello world"++handleCleanCookie ::+    Handler (Headers '[Header "Set-Cookie" LoggedInCookie] ())+handleCleanCookie =+    pure $+        addHeader (LoggedInCookie "logged-off") ()++handleRegister ::+    Runtime info ->+    RegistrationRequest ->+    Handler (Headers '[Header "Set-Cookie" LoggedInCookie] (RegistrationResult info))+handleRegister runtime req = do+    inc registrations "requested" (counters runtime)+    res <- liftIO $ registerIO runtime req+    traceRegistration runtime req res+    withheaders <- liftIO $ wrapHeader res+    inc registrations "ok" (counters runtime)+    pure $ withheaders res+  where+    wrapHeader :: RegistrationResult info -> IO (a -> Headers '[Header "Set-Cookie" LoggedInCookie] a)+    wrapHeader res = case res of+        RegisterFailure -> pure noHeader+        RegisterSuccess dat -> do+            cookie <- makeLoggedInCookie runtime (userId dat)+            traceAugmentCookie runtime cookie+            case cookie of+                Left _ -> pure noHeader+                Right c -> pure $ addHeader c++handleLogin ::+    Runtime info ->+    LoginAttempt ->+    Handler (Headers '[Header "Set-Cookie" LoggedInCookie] (LoginResult info))+handleLogin runtime attempt = do+    inc logins "requested" (counters runtime)+    res <- liftIO $ loginIO runtime attempt+    traceAttempt runtime attempt res+    withheaders <- liftIO $ wrapHeader res+    pure $ withheaders res+  where+    wrapHeader :: LoginResult info -> IO (a -> Headers '[Header "Set-Cookie" LoggedInCookie] a)+    wrapHeader res = case res of+        LoginFailed -> do+            inc logins "ko" (counters runtime)+            pure noHeader+        LoginSuccess dat -> do+            inc logins "ok" (counters runtime)+            cookie <- makeLoggedInCookie runtime (userId dat)+            traceAugmentCookie runtime cookie+            case cookie of+                Left _ -> pure noHeader+                Right c -> pure $ addHeader c++handleRecoveryRequest :: Runtime info -> RecoveryRequest -> Handler RecoveryRequestNotification+handleRecoveryRequest runtime req = do+    inc recoveryRequests "requested" (counters runtime)+    xs <- liftIO $ recoveryRequestIO runtime req+    let token = case xs of [] -> ""; (x : _) -> tokenValue x :: Text+    inc recoveryRequests "ok" (counters runtime)+    let res = RecoveryRequestNotification (req.email) tokenValidityDuration token+    traceRecoveryRequest runtime req res+    pure res++handleApplyRecovery :: Runtime info -> ApplyRecoveryRequest -> Handler RecoveryResult+handleApplyRecovery runtime req = do+    inc recoveryApplied "requested" (counters runtime)+    res <- liftIO $ applyRecoveryIO runtime req+    traceRecoveryApplication runtime req res+    case res of+        RecoverySuccess -> pure res <* inc recoveryApplied "ok" (counters runtime)+        _ -> throwError err403++inc ::+    (MonadIO m) =>+    (a -> Prometheus.Vector (Text) Prometheus.Counter) ->+    Text ->+    a ->+    m ()+inc f s cnts =+    liftIO $ Prometheus.withLabel (f cnts) s Prometheus.incCounter++renderStatus :: RenderStatus a+renderStatus = const $ section_ $ do+    h1_ "user-auth"+    h4_ "login"+    p_ $ with form_ [id_ "login-form", action_ "/user-auth/login", method_ "post"] $ do+        p_ $ do+            label_ [for_ "login-email", type_ "text"] "email"+            input_ [type_ "text", id_ "login-email", name_ "email"]+        p_ $ do+            label_ [for_ "login-plain", type_ "text"] "password"+            input_ [type_ "password", id_ "login-plain", name_ "plain"]+        p_ $ do+            input_ [type_ "submit", value_ "login"]+    h4_ "register"+    p_ $ with form_ [id_ "register-form", action_ "/user-auth/registration", method_ "post"] $ do+        p_ $ do+            label_ [for_ "register-email", type_ "text"] "email"+            input_ [type_ "text", id_ "register-email", name_ "email"]+        p_ $ do+            label_ [for_ "register-plain", type_ "text"] "password"+            input_ [type_ "password", id_ "register-plain", name_ "plain"]+        p_ $ do+            input_ [type_ "submit", value_ "register"]+    h4_ "recovery-request"+    p_ $ with form_ [id_ "recovery-request-form", action_ "/user-auth/recovery/request", method_ "post"] $ do+        p_ $ do+            label_ [for_ "recovery-request-email", type_ "text"] "email"+            input_ [type_ "text", id_ "recovery-request-email", name_ "email"]+        p_ $ do+            input_ [type_ "submit", value_ "recover"]+    h4_ "recovery-apply"+    p_ $ with form_ [id_ "recovery-apply-form", action_ "/user-auth/recovery/apply", method_ "post"] $ do+        p_ $ do+            label_ [for_ "recovery-apply-email", type_ "text"] "email"+            input_ [type_ "text", id_ "recovery-apply-email", name_ "email"]+        p_ $ do+            label_ [for_ "recovery-apply-plain", type_ "text"] "new-password"+            input_ [type_ "password", id_ "recovery-apply-plain", name_ "plain"]+        p_ $ do+            label_ [for_ "recovery-apply-token", type_ "text"] "token"+            input_ [type_ "password", id_ "recovery-apply-token", name_ "token"]+        p_ $ do+            input_ [type_ "submit", value_ "recover"]+    h4_ "misc"+    p_ $ with a_ [href_ "/user-auth/whoami"] "whoami"+    p_ $ with a_ [href_ "/user-auth/echo-cookie"] "echo-cookie"+    p_ $+        with form_ [action_ "/user-auth/clean-cookie", method_ "post"] $+            input_ [type_ "submit", value_ "clear cookie"]
+ src/Prod/UserAuth/Api.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TypeFamilies #-}++module Prod.UserAuth.Api (+    UserAuthApi,+    CookieProtect,+)+where++import Data.Text (Text)+import Prod.UserAuth.Base+import Prod.UserAuth.JWT+import Servant+import Servant.Server.Experimental.Auth (AuthServerData)+import Web.JWT++type CookieProtect = AuthProtect "prod-user-auth"++type instance AuthServerData (AuthProtect "prod-user-auth") = UserAuthInfo++type UserAuthApi a =+    EchoCookieClaimsApi+        :<|> WhoAmIApi a+        :<|> CleanCookieApi+        :<|> RegisterApi a+        :<|> LoginApi a+        :<|> RequestRecoveryApi+        :<|> ApplyRecoveryApi+        :<|> HelloProtectedApi++type EchoCookieClaimsApi =+    Summary "echo cookie claims after validating it"+        :> "user-auth"+        :> "echo-cookie"+        :> Header "Cookie" LoggedInCookie+        :> Get '[JSON] JWTClaimsSet++type WhoAmIApi a =+    Summary "prints user identities for a cookie"+        :> "user-auth"+        :> "whoami"+        :> Header "Cookie" LoggedInCookie+        :> Get '[JSON] [WhoAmI a]++type CleanCookieApi =+    Summary "deletes the cookie"+        :> "user-auth"+        :> "clean-cookie"+        :> Post '[JSON] (Headers '[Header "Set-Cookie" LoggedInCookie] ())++type RegisterApi a =+    Summary "register a new user"+        :> "user-auth"+        :> "registration"+        :> ReqBody '[FormUrlEncoded, JSON] RegistrationRequest+        :> Post '[JSON] (Headers '[Header "Set-Cookie" LoggedInCookie] (RegistrationResult a))++type LoginApi a =+    Summary "login as a user"+        :> "user-auth"+        :> "login"+        :> ReqBody '[FormUrlEncoded, JSON] LoginAttempt+        :> Post '[JSON] (Headers '[Header "Set-Cookie" LoggedInCookie] (LoginResult a))++type RequestRecoveryApi =+    Summary "request an out-of-band password recovery"+        :> "user-auth"+        :> "recovery"+        :> "request"+        :> ReqBody '[FormUrlEncoded, JSON] RecoveryRequest+        :> Post '[JSON] RecoveryRequestNotification++type ApplyRecoveryApi =+    Summary "overwrites the password"+        :> "user-auth"+        :> "recovery"+        :> "apply"+        :> ReqBody '[FormUrlEncoded, JSON] ApplyRecoveryRequest+        :> Post '[JSON] RecoveryResult++type HelloProtectedApi =+    Summary "Hello World with Auth Protect"+        :> CookieProtect+        :> "user-auth"+        :> "hello"+        :> Get '[JSON] Text
+ src/Prod/UserAuth/Backend.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}++module Prod.UserAuth.Backend where++import Control.Monad ((<=<))+import Data.Int (Int64)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection, Only (..), execute, formatQuery, query, rollback)+import Database.PostgreSQL.Simple.SqlQQ (sql)+import Prod.UserAuth.Base+import Prod.UserAuth.Runtime (Runtime, augmentSession, augmentWhoAmI, tokenValidityDuration, trace, traceTransaction, withConn)+import Prod.UserAuth.Trace++registerIO :: Runtime a -> RegistrationRequest -> IO (RegistrationResult a)+registerIO rt req = do+    withConn rt $ \conn -> do+        traceTransaction rt conn $ do+            newU <- newuser rt conn+            case newU of+                [Only uid] -> do+                    nres <- newpass conn =<< mkNewPass uid+                    if nres /= 1+                        then rollback conn >> pure RegisterFailure+                        else do+                            info <- augmentSession rt conn (SessionData uid ())+                            case info of+                                Just extra -> pure $ RegisterSuccess (SessionData uid extra)+                                Nothing -> pure RegisterFailure+                _ -> pure RegisterFailure+  where+    emailV :: Text+    emailV = req.email+    plainV :: Text+    plainV = req.plain+    mkNewPass uid = pure $ SetPassword uid emailV plainV++type User = Only UserId++newuser :: Runtime a -> Connection -> IO [User]+newuser rt conn = do+    trace rt . Backend . SQLQuery =<< formatQuery conn q ()+    query conn q ()+  where+    q =+        [sql|+      INSERT INTO identities(id)+      VALUES (DEFAULT)+      RETURNING (id)+    |]++type Email = Text++finduser :: Runtime a -> Connection -> Email -> IO [User]+finduser rt conn email = do+    trace rt . Backend . SQLQuery =<< formatQuery conn q (Only email)+    query conn q (Only email)+  where+    q =+        [sql|+      SELECT identity_id+      FROM passwords+      WHERE email = ?+        AND enabled+    |]++finduidMail :: Runtime a -> Connection -> UserId -> IO [(UserId, Maybe Email)]+finduidMail rt conn uid = do+    trace rt . Backend . SQLQuery =<< formatQuery conn q (Only uid)+    query conn q (Only uid)+  where+    q =+        [sql|+      SELECT identities.id, passwords.email+      FROM identities+      LEFT JOIN passwords ON passwords.identity_id = identities.id+      WHERE identities.id = ?+        AND coalesce(true, passwords.enabled)+      LIMIT 1+    |]++data SetPassword+    = SetPassword+    { uid :: UserId+    , email :: Text+    , plain :: Text+    }++-- | Saves a new password.+newpass :: Connection -> SetPassword -> IO Int64+newpass conn pass = execute conn q (emailV, plainV, uidV)+  where+    emailV = pass.email+    plainV = pass.plain+    uidV = pass.uid+    q =+        [sql|+      INSERT INTO passwords(email,enabled,hashed,salt,identity_id)+      SELECT ?, true, encode(digest(? || x.xsalt, 'sha256'), 'hex'), x.xsalt, ?+        FROM (SELECT md5(random()::text) AS xsalt) x+    |]++-- | Resets a password.+resetpass :: Connection -> SetPassword -> IO Int64+resetpass conn pass = execute conn q (plainV, uidV, emailV)+  where+    emailV = pass.email+    plainV = pass.plain+    uidV = pass.uid+    q =+        [sql|+        UPDATE passwords+        SET hashed = encode(digest(? || x.xsalt, 'sha256'), 'hex')+          , salt = x.xsalt+        FROM (SELECT md5(random()::text) AS xsalt) x+        WHERE (identity_id = ?)+          AND (email = ?)+      |]++loginIO :: Runtime info -> LoginAttempt -> IO (LoginResult info)+loginIO rt attempt = withConn rt (\conn -> login rt conn attempt)++login :: forall info. Runtime info -> Connection -> LoginAttempt -> IO (LoginResult info)+login rt conn attempt = do+    trace rt . Backend . SQLQuery =<< formatQuery conn q (plainV, emailV)+    toResult conn =<< query conn q (plainV, emailV)+  where+    toResult :: Connection -> [(UserId, Bool)] -> IO (LoginResult info)+    toResult conn [(uid, True)] = do+        info <- augmentSession rt conn (SessionData uid ())+        case info of+            Just extra -> pure $ LoginSuccess (SessionData uid extra)+            Nothing -> pure LoginFailed+    toResult _ _ = pure LoginFailed+    plainV = attempt.plain+    emailV = attempt.email+    q =+        [sql|+      SELECT identity_id+           , encode(digest( ? || salt, 'sha256'), 'hex') = hashed+      FROM passwords+      WHERE email = ?+        AND enabled+    |]++data NewRecovery+    = NewRecovery+    { uid :: UserId+    }++type Token = Only TokenValue++tokenValue :: Token -> TokenValue+tokenValue (Only v) = v++newrecovery :: Connection -> NewRecovery -> IO [Token]+newrecovery conn recover = query conn q (Only uidV)+  where+    uidV = recover.uid+    q =+        [sql|+        INSERT INTO password_lost_request(timestamp,identity_id,token)+        SELECT CURRENT_TIMESTAMP, ?, md5(random()::text)+        RETURNING token+      |]++data CheckRecovery+    = CheckRecovery+    { uid :: UserId+    , token :: TokenValue+    }++checkrecovery :: Connection -> CheckRecovery -> IO RecoveryResult+checkrecovery conn check =+    toResult <$> query conn q (tokenValidityDuration :: Minutes, uidV, tokenV)+  where+    toResult :: [Only Bool] -> RecoveryResult+    toResult [Only True] = RecoverySuccess+    toResult _ = RecoveryFailed "invalid-checkrecovery-result"+    uidV = check.uid+    tokenV = check.token+    q =+        [sql|+        SELECT age(CURRENT_TIMESTAMP, timestamp) <= '? min'+        FROM password_lost_request+        WHERE (identity_id = ?)+          AND (token = ?)+          AND (used_at IS NULL)+        LIMIT 1+      |]++invalidaterecovery :: Connection -> CheckRecovery -> IO Int64+invalidaterecovery conn check = execute conn q (Only uidV)+  where+    uidV = check.uid+    q =+        [sql|+        UPDATE password_lost_request+        SET used_at = CURRENT_TIMESTAMP+        WHERE (identity_id = ?)+          AND (used_at IS NULL)+      |]++whoAmIQueryIO :: forall info. Runtime info -> UserId -> IO [WhoAmI info]+whoAmIQueryIO rt uid = do+    withConn rt $ \conn -> do+        emails <- finduidMail rt conn uid+        catMaybes <$> traverse (unwrapmail conn) emails+  where+    unwrapmail :: Connection -> (UserId, Maybe Email) -> IO (Maybe (WhoAmI info))+    unwrapmail conn (uid, eml) = do+        info <- augmentWhoAmI rt conn (WhoAmI eml uid)+        case info of+            Just extra -> pure $ Just $ WhoAmI eml extra+            Nothing -> pure Nothing++recoveryRequestIO :: Runtime a -> RecoveryRequest -> IO [Token]+recoveryRequestIO rt req = do+    withConn rt $ \conn -> do+        traceTransaction rt conn $ do+            newU <- finduser rt conn emailV+            case newU of+                [Only uid] -> newrecovery conn (NewRecovery uid)+                _ -> pure []+  where+    emailV :: Text+    emailV = req.email++applyRecoveryIO :: Runtime a -> ApplyRecoveryRequest -> IO RecoveryResult+applyRecoveryIO rt req = do+    withConn rt $ \conn -> do+        traceTransaction rt conn $ do+            newU <- finduser rt conn emailV+            case newU of+                [Only uid] -> do+                    recovery <- mkCheckRecovery uid+                    canRecover <- checkrecovery conn recovery+                    case canRecover of+                        RecoverySuccess -> do+                            nrec <- invalidaterecovery conn recovery+                            nres <- resetpass conn =<< mkSetPass uid+                            if (nrec < 1 && nres /= 1)+                                then rollback conn >> pure (RecoveryFailed "invariant failed")+                                else pure RecoverySuccess+                        r -> pure r+                _ -> pure $ RecoveryFailed "unfound user"+  where+    emailV :: Text+    emailV = req.email+    plainV :: Text+    plainV = req.plain+    tokenV :: Text+    tokenV = req.token+    mkCheckRecovery uid = pure $ CheckRecovery uid tokenV+    mkSetPass uid = pure $ SetPassword uid emailV plainV
+ src/Prod/UserAuth/Base.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE StrictData #-}++module Prod.UserAuth.Base where++import Control.Monad (guard)+import Data.Aeson (FromJSON, ToJSON, Value (Number))+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Servant+import Web.FormUrlEncoded++data RecoveryResult = RecoverySuccess | RecoveryFailed Text+    deriving (Show, Generic)++instance ToJSON RecoveryResult++type TokenValue = Text++data ApplyRecoveryRequest+    = ApplyRecoveryRequest+    { email :: Text+    , plain :: Text+    , token :: TokenValue+    }+    deriving (Generic)+instance Show ApplyRecoveryRequest where+    showsPrec _ x = (\x -> "ApplyRecoveryRequest<hidden>" <> x)++instance FromJSON ApplyRecoveryRequest+instance FromForm ApplyRecoveryRequest++data LoggedInCookie = LoggedInCookie {encodedJwt :: !Text}+    deriving (Generic)+instance Show LoggedInCookie where+    showsPrec _ x = (\x -> "LoggedInCookie<hidden>" <> x)++instance ToJSON LoggedInCookie++instance FromHttpApiData LoggedInCookie where+    parseUrlPiece = locateJWT+      where+        locateJWT :: Text -> Either Text LoggedInCookie+        locateJWT = safeHead . locateJWTlist+        safeHead :: [Text] -> Either Text LoggedInCookie+        safeHead (x : _) = Right (LoggedInCookie x)+        safeHead _ = Left "invalid login-jwt cookie key"+        locateJWTlist :: Text -> [Text]+        locateJWTlist dat = do+            w <- Text.splitOn ";" dat+            guard $ loginjwtCookiePrefix `Text.isPrefixOf` w+            pure $ Text.drop (Text.length loginjwtCookiePrefix) w++loginjwtCookiePrefix :: Text+loginjwtCookiePrefix = "login-jwt="++instance ToHttpApiData LoggedInCookie where+    toUrlPiece (LoggedInCookie txt) =+        mconcat [loginjwtCookiePrefix, txt, "; Path=/; SameSite=Strict; HttpOnly; Secure"]++data WhoAmI info+    = WhoAmI+    { email :: Maybe Text+    , info :: info+    }+    deriving (Generic)++instance (ToJSON info) => ToJSON (WhoAmI info)++data RegistrationRequest+    = RegistrationRequest+    { email :: Text+    , plain :: Text+    }+    deriving (Generic)++instance Show RegistrationRequest where+    showsPrec _ x = (\x -> "RegistrationRequest<hidden>" <> x)++instance FromJSON RegistrationRequest+instance FromForm RegistrationRequest++data RegistrationResult a = RegisterSuccess (SessionData a) | RegisterFailure+    deriving (Generic, Show)++instance (ToJSON a) => ToJSON (RegistrationResult a)++data SessionData a+    = SessionData+    { userId :: UserId+    , info :: a+    }+    deriving (Generic, Show)++instance (ToJSON a) => ToJSON (SessionData a)++type UserId = Int64++type Minutes = Int++data RecoveryRequest+    = RecoveryRequest+    { email :: Text+    }+    deriving (Generic)++instance Show RecoveryRequest where+    showsPrec _ x = (\x -> "RecoveryRequest<hidden>" <> x)++instance FromJSON RecoveryRequest+instance FromForm RecoveryRequest++data RecoveryRequestNotification+    = RecoveryRequestNotification+    { email :: Text+    , minutes :: Minutes+    , token :: TokenValue+    }+    deriving (Generic)++instance ToJSON RecoveryRequestNotification++instance Show RecoveryRequestNotification where+    showsPrec _ x = (\x -> "RecoveryRequestNotification<hidden>" <> x)++data LoginAttempt+    = LoginAttempt+    { email :: Text+    , plain :: Text+    }+    deriving (Generic)++instance Show LoginAttempt where+    showsPrec _ x = (\x -> "LoginAttempt<hidden>" <> x)++instance FromJSON LoginAttempt+instance FromForm LoginAttempt++data LoginResult a = LoginSuccess (SessionData a) | LoginFailed+    deriving (Generic, Show)++instance (ToJSON a) => ToJSON (LoginResult a)++type ErrorMessage = Text
+ src/Prod/UserAuth/Counters.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE StrictData #-}++module Prod.UserAuth.Counters (+    Counters (..),+    initCounters,+)+where++import Data.Text (Text)+import qualified Prometheus as Prometheus++data Counters+    = Counters+    { registrations :: Prometheus.Vector (Text) Prometheus.Counter+    , logins :: Prometheus.Vector (Text) Prometheus.Counter+    , echoes :: Prometheus.Vector (Text) Prometheus.Counter+    , whoamis :: Prometheus.Vector (Text) Prometheus.Counter+    , recoveryRequests :: Prometheus.Vector (Text) Prometheus.Counter+    , recoveryApplied :: Prometheus.Vector (Text) Prometheus.Counter+    }++initCounters :: IO Counters+initCounters =+    Counters+        <$> statuses "userauth_registrations" "number of registrations"+        <*> statuses "userauth_logins" "number of logins recorded"+        <*> statuses "userauth_echoes" "number of token-echo recorded"+        <*> statuses "userauth_whoamis" "number of whoamis received"+        <*> statuses "userauth_recovery_requests" "number of recovery-requests received"+        <*> statuses "userauth_recovery_applied" "number of recovery-requests applied"+  where+    statuses k h =+        Prometheus.register $+            Prometheus.vector "status" $+                Prometheus.counter (Prometheus.Info k h)
+ src/Prod/UserAuth/HandlerCombinators.hs view
@@ -0,0 +1,70 @@+module Prod.UserAuth.HandlerCombinators (+    authServerContext,+    authorized,+    limited,+    withLoginCookieVerified,+    withOptionalLoginCookieVerified,+    Request,+)+where++import Data.Maybe (isJust)+import Data.Text.Encoding (decodeLatin1)+import Network.Wai (Request, requestHeaders)+import Prod.UserAuth.Base+import Prod.UserAuth.JWT+import Prod.UserAuth.Runtime+import Servant+import Servant.Server+import Servant.Server.Experimental.Auth (+    AuthHandler,+    mkAuthHandler,+ )+import Web.Cookie (parseCookies)++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++authServerContext :: Runtime a -> Context (AuthHandler Request UserAuthInfo ': '[])+authServerContext runtime =+    authHandler runtime :. EmptyContext++withLoginCookieVerified ::+    Runtime info ->+    Maybe LoggedInCookie ->+    (JWT VerifiedJWT -> Handler a) ->+    Handler a+withLoginCookieVerified runtime Nothing _ = do+    traceVerification runtime False+    throwError $ err403{errBody = "Sorry, need some cookies."}+withLoginCookieVerified runtime cookie act = do+    withOptionalLoginCookieVerified runtime cookie $ \mJwt ->+        maybe+            (traceVerification runtime False >> throwError err403)+            (\x -> traceVerification runtime True >> act x)+            mJwt++withOptionalLoginCookieVerified ::+    Runtime info ->+    Maybe LoggedInCookie ->+    (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++authorized :: Runtime info -> UserAuthInfo -> (UserId -> Handler a) -> Handler a+authorized rt auth act =+    limited rt auth (traceDisallowed rt >> throwError err401) act++limited :: Runtime info -> UserAuthInfo -> (Handler a) -> (UserId -> Handler a) -> Handler a+limited rt auth fallback act =+    maybe (traceLimited rt >> fallback) (\uid -> traceAllowed rt >> act uid) (authUserId auth)
+ src/Prod/UserAuth/JWT.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE StrictData #-}++module Prod.UserAuth.JWT (+    UserAuthInfo (..),+    authUserId,+    makeLoggedInCookie,+    module Web.JWT,+)+where++import Data.Aeson (FromJSON, Result (..), Value (Number), fromJSON)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Data.Time.Clock.POSIX+import Prod.UserAuth.Base+import Prod.UserAuth.Runtime+import Web.JWT++data UserAuthInfo = UserAuthInfo (Maybe (JWT VerifiedJWT))++-- | Extract an decodes a JSON value from a UserAuthInfo containing a VerifiedJWT.+authClaim :: (FromJSON a) => UserAuthInfo -> Text -> Maybe a+authClaim (UserAuthInfo mjwt) key = do+    jwt <- mjwt+    obj <- Map.lookup key (unClaimsMap . unregisteredClaims $ claims jwt)+    case fromJSON obj of+        Error _ -> Nothing+        Success x -> Just x++-- | Extract a JSON value from a UserAuthInfo containing a VerifiedJWT.+authClaimValue :: UserAuthInfo -> Text -> Maybe Value+authClaimValue (UserAuthInfo mjwt) key = do+    jwt <- mjwt+    Map.lookup key (unClaimsMap . unregisteredClaims $ claims jwt)++-- | Extracts the UserId from a UserAuthInfo containing VerifiedJWT.+authUserId :: UserAuthInfo -> Maybe UserId+authUserId uai = do+    val <- authClaim uai "user-id"+    case val of+        (Number nid) -> pure (truncate nid :: UserId)+        _ -> Nothing++{- | Encodes a JWT cookie for a given UserId.++The runtime allows augmenting the JWT with extra claims.+-}+makeLoggedInCookie :: Runtime a -> UserId -> IO (Either ErrorMessage LoggedInCookie)+makeLoggedInCookie runtime uid = do+    now <- numericDate <$> getPOSIXTime+    case now of+        Nothing -> pure $ Left "could not build a valid issued-at"+        Just iat -> 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+  where+    baseClaims = baseClaimsSet runtime+    adapt iat extras = do+        let claims = Map.fromList $ mconcat [[("user-id", (Number $ fromIntegral uid))], extras]+        LoggedInCookie $+            encodeSigned+                (hmacSecret $ secretstring runtime)+                mempty+                ( baseClaims+                    { iss = stringOrURI "jwt-app"+                    , iat = Just iat+                    , unregisteredClaims = ClaimsMap claims+                    }+                )
+ src/Prod/UserAuth/OAuth2.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- | Helpers to build OAuth2 callbacks to implement "log-in with Google, GitHub etc".++Unlike other Runtimes, this Runtime is more of a template than a full.+A library user must pas a number of+We consider two different states:+- the transientState (a unique state to recognize a callback, and passed as query-params)+- the finalState (after the user has been redirected to your application)+you may exchange the CallbackCode for a token, store it, associate it with a+user, perform lookups on the third-party before returning (usually with yet another redirect).+-}+module Prod.UserAuth.OAuth2 where++import Control.Monad.IO.Class (liftIO)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Prod.Tracer as Tracer+import Servant++newtype CallbackCode = CallbackCode Text+    deriving (FromHttpApiData)++data Track transientState finalState+    = OAuth2Initialization transientState+    | OAuth2Calback transientState (CallbackResult finalState)+    deriving (Show)++{- | Proves that an authorization has been initiated, carrying OAuth2 redirect+to the IDP and some state to encode and link the whole flow.+-}+data AuthorizeStateProof transientState = AuthorizeStateProof+    { transientState :: transientState+    , initialRedirect :: Text+    }+    deriving (Show)++-- | Proves that the OAuth2 IDP redirected the user to your application.+data ProofOfProcessedToken finalState = ProofOfProcessedToken+    { finalState :: finalState+    }+    deriving (Show)++data CallbackResult finalState+    = UnrecognizedState+    | OtherError Text+    | Success (ProofOfProcessedToken finalState)+    deriving (Show)++data Runtime transientState finalState = Runtime+    { tracer :: Tracer IO (Track transientState finalState)+    , initiateState :: IO (AuthorizeStateProof transientState)+    , requestToken :: transientState -> CallbackCode -> IO (CallbackResult finalState)+    }++type Oauth2InitiateRedirectApi transientState =+    "oauth2"+        :> "login"+        :> Get '[JSON] ()++type Oauth2CallbackApi transientState =+    "oauth2"+        :> "callback"+        :> QueryParam' '[Required] "state" transientState+        :> QueryParam' '[Required] "code" CallbackCode+        :> Get '[JSON] ()++handleOAuth2InitiateRedirect ::+    Runtime transientState finalState ->+    Handler ()+handleOAuth2InitiateRedirect rt = do+    p <- liftIO go+    throwError err302{errHeaders = [("Location", Text.encodeUtf8 p.initialRedirect)]}+  where+    go = do+        p <- rt.initiateState+        Tracer.runTracer rt.tracer (OAuth2Initialization p.transientState)+        pure p++handleOAuth2Callback ::+    Runtime transientState finalState ->+    (finalState -> Handler ()) ->+    transientState ->+    CallbackCode ->+    Handler ()+handleOAuth2Callback rt finalize transientState code = do+    res <- liftIO go+    case res of+        UnrecognizedState ->+            throwError err400{errBody = "invalid oauth2 callback transientState"}+        OtherError _ ->+            throwError err500+        Success p ->+            finalize p.finalState+  where+    go = do+        p <- rt.requestToken transientState code+        Tracer.runTracer rt.tracer (OAuth2Calback transientState p)+        pure p++type OAuth2MinimalApi transientState =+    Oauth2InitiateRedirectApi transientState+        :<|> Oauth2CallbackApi transientState++serveMinimalApi ::+    Runtime transientState finalState ->+    (finalState -> Handler ()) ->+    Server (OAuth2MinimalApi transientState)+serveMinimalApi rt finalize =+    handleOAuth2InitiateRedirect rt+        :<|> handleOAuth2Callback rt finalize
+ src/Prod/UserAuth/Runtime.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StrictData #-}++module Prod.UserAuth.Runtime (+    Counters (..),+    initRuntime,+    Runtime,+    AugmentSession,+    augmentSession,+    AugmentWhoAmI,+    augmentWhoAmI,+    augmentLoggedInCookieClaims,+    AugmentCookieClaims,+    counters,+    secretstring,+    baseClaimsSet,+    withConn,+    Connection,+    tokenValidityDuration,+    trace,+    traceTransaction,+    traceAttempt,+    traceVerification,+    traceOptionalVerification,+    traceRegistration,+    traceRecoveryRequest,+    traceRecoveryApplication,+    traceAllowed,+    traceDisallowed,+    traceLimited,+    traceJWT,+    traceJWTSigned,+    traceAugmentCookie,+)+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (Value)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection, Only (..), close, connectPostgreSQL, execute, query, rollback, withTransaction)+import Prod.Tracer (Tracer (..))+import Prod.UserAuth.Base (ApplyRecoveryRequest, ErrorMessage, LoggedInCookie, LoginAttempt, LoginResult, Minutes, RecoveryRequest, RecoveryRequestNotification, RecoveryResult, RegistrationRequest, RegistrationResult, SessionData, UserId, WhoAmI)+import Prod.UserAuth.Counters (Counters (..), initCounters)+import Prod.UserAuth.Trace (BackendTrack (..), BehaviourTrack (..), CallbackTrack (..), JwtTrack (..), Track (..))+import Web.JWT++data Runtime info+    = Runtime+    { counters :: !Counters+    , secretstring :: !Text+    , baseClaimsSet :: !JWTClaimsSet+    , connstring :: !ByteString+    , augmentSession :: AugmentSession info+    , augmentWhoAmI :: AugmentWhoAmI info+    , augmentLoggedInCookieClaims :: AugmentCookieClaims+    , tracer :: Tracer IO (Track info)+    }++type AugmentSession info = Connection -> SessionData () -> IO (Maybe info)++type AugmentWhoAmI info = Connection -> WhoAmI UserId -> IO (Maybe info)++type AugmentCookieClaims = UserId -> IO (Either ErrorMessage [(Text, Value)])++trace :: (MonadIO m) => Runtime a -> Track a -> m ()+trace rt v = liftIO $ runTracer (tracer rt) $ v++initRuntime ::+    Text ->+    JWTClaimsSet ->+    ByteString ->+    AugmentSession info ->+    AugmentWhoAmI info ->+    AugmentCookieClaims ->+    Tracer IO (Track info) ->+    IO (Runtime info)+initRuntime skret claims cstring augSession augWhoAmI augCookie tracer =+    Runtime+        <$> initCounters+        <*> pure skret+        <*> pure claims+        <*> pure cstring+        <*> pure augSession+        <*> pure augWhoAmI+        <*> pure augCookie+        <*> pure tracer++withConn :: Runtime b -> (Connection -> IO a) -> IO a+withConn runtime act = do+    conn <- connectPostgreSQL (connstring runtime)+    trace runtime (Backend SQLConnect)+    !ret <- act conn+    close conn+    pure ret++traceTransaction :: Runtime a -> Connection -> IO b -> IO b+traceTransaction runtime conn act =+    withTransaction conn $ do+        trace runtime (Backend SQLTransaction)+        act++traceAttempt :: (MonadIO m) => Runtime a -> LoginAttempt -> LoginResult a -> m ()+traceAttempt runtime l r =+    liftIO $ trace runtime $ Behaviour $ Attempt l r++traceVerification :: (MonadIO m) => Runtime a -> Bool -> m ()+traceVerification runtime bool =+    liftIO $ trace runtime $ Behaviour $ Verification bool++traceOptionalVerification :: (MonadIO m) => Runtime a -> Bool -> m ()+traceOptionalVerification runtime bool =+    liftIO $ trace runtime $ Behaviour $ OptionalVerification bool++traceRegistration :: (MonadIO m) => Runtime a -> RegistrationRequest -> RegistrationResult a -> m ()+traceRegistration runtime req res =+    liftIO $ trace runtime $ Behaviour $ Registration req res++traceRecoveryRequest :: (MonadIO m) => Runtime a -> RecoveryRequest -> RecoveryRequestNotification -> m ()+traceRecoveryRequest runtime req res =+    liftIO $ trace runtime $ Behaviour $ Recovery req res++traceRecoveryApplication :: (MonadIO m) => Runtime a -> ApplyRecoveryRequest -> RecoveryResult -> m ()+traceRecoveryApplication runtime req res =+    liftIO $ trace runtime $ Behaviour $ ApplyRecovery req res++traceAllowed, traceDisallowed, traceLimited :: (MonadIO m) => Runtime a -> m ()+traceAllowed runtime =+    liftIO $ trace runtime $ Bearer $ Allowed (Just True)+traceDisallowed runtime =+    liftIO $ trace runtime $ Bearer $ Allowed (Just False)+traceLimited runtime =+    liftIO $ trace runtime $ Bearer $ Allowed Nothing++traceJWT :: (MonadIO m) => (Runtime a) -> Maybe (JWT (VerifiedJWT)) -> m ()+traceJWT runtime jwt =+    liftIO $ trace runtime $ Bearer $ Extracted jwt++traceJWTSigned :: (MonadIO m) => (Runtime a) -> UserId -> [(Text, Value)] -> m ()+traceJWTSigned runtime uid claims =+    liftIO $ trace runtime $ Bearer $ Signed uid claims++traceAugmentCookie :: (MonadIO m) => (Runtime a) -> Either ErrorMessage LoggedInCookie -> m ()+traceAugmentCookie runtime c =+    liftIO $ trace runtime $ Callbacks $ AugmentCookie c++tokenValidityDuration :: Minutes+tokenValidityDuration = 30
+ src/Prod/UserAuth/Trace.hs view
@@ -0,0 +1,44 @@+module Prod.UserAuth.Trace where++import Data.Aeson (Value)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Prod.UserAuth.Base+import Web.JWT++data Track info+    = Behaviour (BehaviourTrack info)+    | Bearer JwtTrack+    | Backend BackendTrack+    | Callbacks CallbackTrack+    deriving (Show)++-- | Track enough information to study potentially-malicious activities.+data BehaviourTrack info+    = Attempt LoginAttempt (LoginResult info)+    | Verification Bool+    | OptionalVerification Bool+    | Registration RegistrationRequest (RegistrationResult info)+    | Recovery RecoveryRequest RecoveryRequestNotification+    | ApplyRecovery ApplyRecoveryRequest RecoveryResult+    deriving (Show)++-- | Bearer tokens with JWT.+data JwtTrack+    = Extracted (Maybe (JWT VerifiedJWT))+    | Allowed (Maybe Bool)+    | Signed UserId [(Text, Value)]+    deriving (Show)++-- | Track backend sql information.+data BackendTrack+    = SQLConnect+    | SQLTransaction+    | SQLRollback+    | SQLQuery !ByteString+    deriving (Show)++-- | Track callback information.+data CallbackTrack+    = AugmentCookie (Either ErrorMessage LoggedInCookie)+    deriving (Show)