Implement confidential OIDC authentication boundary
This commit is contained in:
parent
0f888986d7
commit
a4e615096c
1 changed files with 1896 additions and 329 deletions
|
|
@ -5,121 +5,147 @@ module Nuthatch.Session
|
|||
, constantTimeEq
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
( (&)
|
||||
, (?~)
|
||||
, (^.)
|
||||
, (.~)
|
||||
)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import Crypto.MAC.HMAC (HMAC, hmac)
|
||||
import Crypto.JOSE (runJOSE)
|
||||
import Crypto.JOSE.Compact (decodeCompact, encodeCompact)
|
||||
import Crypto.JOSE.JWA.JWS (Alg (HS256))
|
||||
import Crypto.JOSE.JWK (fromOctets)
|
||||
import Crypto.JOSE.JWS
|
||||
( algorithms
|
||||
, newJWSHeaderProtected
|
||||
)
|
||||
import Crypto.JWT
|
||||
( Audience (..)
|
||||
, ClaimsSet
|
||||
, HasClaimsSet (..)
|
||||
, JWTError
|
||||
, NumericDate (..)
|
||||
, SignedJWT
|
||||
, defaultJWTValidationSettings
|
||||
, emptyClaimsSet
|
||||
, issuerPredicate
|
||||
, signJWT
|
||||
, verifyJWT
|
||||
)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Key as Key
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import Data.ByteArray (convert)
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Set (singleton)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
||||
import Nuthatch.Config (Config (..))
|
||||
import Nuthatch.Paths (encodeUserId)
|
||||
import Nuthatch.Types
|
||||
import System.Entropy (getEntropy)
|
||||
|
||||
data SessionClaims = SessionClaims
|
||||
{ registeredClaims :: ClaimsSet
|
||||
, oidcIssuer :: Text
|
||||
, oidcSubject :: Text
|
||||
, displayName :: Maybe Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance HasClaimsSet SessionClaims where
|
||||
claimsSet update claims =
|
||||
fmap
|
||||
(\registered -> claims { registeredClaims = registered })
|
||||
(update (registeredClaims claims))
|
||||
|
||||
instance A.FromJSON SessionClaims where
|
||||
parseJSON value = A.withObject "SessionClaims" parse value
|
||||
where
|
||||
parse object =
|
||||
SessionClaims
|
||||
<$> A.parseJSON value
|
||||
<*> object A..: "oidc_issuer"
|
||||
<*> object A..: "oidc_subject"
|
||||
<*> object A..:? "display"
|
||||
|
||||
instance A.ToJSON SessionClaims where
|
||||
toJSON claims =
|
||||
case A.toJSON (registeredClaims claims) of
|
||||
A.Object object ->
|
||||
A.Object $
|
||||
KM.insert "oidc_issuer" (A.String (oidcIssuer claims)) $
|
||||
KM.insert "oidc_subject" (A.String (oidcSubject claims)) $
|
||||
maybe
|
||||
object
|
||||
(\display -> KM.insert "display" (A.String display) object)
|
||||
(displayName claims)
|
||||
value -> value
|
||||
|
||||
mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text SessionToken)
|
||||
mintSession cfg iss sub display = do
|
||||
now <- floor <$> getPOSIXTime
|
||||
let expAt = now + cfgSessionHours cfg * 3600
|
||||
uid = encodeUserId iss sub
|
||||
header = A.object
|
||||
[ "alg" A..= ("HS256" :: Text)
|
||||
, "typ" A..= ("JWT" :: Text)
|
||||
]
|
||||
payload = A.object $
|
||||
[ "iss" A..= ("nuthatch" :: Text)
|
||||
, "aud" A..= ("nuthatch" :: Text)
|
||||
, "iat" A..= now
|
||||
, "exp" A..= expAt
|
||||
, "sub" A..= unUserId uid
|
||||
, "oidc_issuer" A..= iss
|
||||
, "oidc_subject" A..= sub
|
||||
] <> maybe [] (\d -> ["display" A..= d]) display
|
||||
token = signJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) header payload
|
||||
pure (validateSessionToken token)
|
||||
mintSession cfg issuer subject display = do
|
||||
now <- getCurrentTime
|
||||
let expires = addUTCTime (fromInteger (cfgSessionHours cfg * 3600)) now
|
||||
userId = encodeUserId issuer subject
|
||||
applicationIssuer = "nuthatch"
|
||||
applicationAudience = "nuthatch"
|
||||
userSubject = fromString (T.unpack (unUserId userId))
|
||||
result <- runJOSE $ do
|
||||
let claims = SessionClaims
|
||||
{ registeredClaims =
|
||||
emptyClaimsSet
|
||||
& claimIss ?~ applicationIssuer
|
||||
& claimSub ?~ userSubject
|
||||
& claimAud ?~ Audience [applicationAudience]
|
||||
& claimIat ?~ NumericDate now
|
||||
& claimExp ?~ NumericDate expires
|
||||
, oidcIssuer = issuer
|
||||
, oidcSubject = subject
|
||||
, displayName = display
|
||||
}
|
||||
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
|
||||
header = newJWSHeaderProtected HS256
|
||||
encodeCompact <$> signJWT key header claims
|
||||
pure $ case result of
|
||||
Left (_ :: JWTError) -> Left "session token creation failed"
|
||||
Right compact ->
|
||||
validateSessionToken (TE.decodeUtf8 (BL.toStrict compact))
|
||||
|
||||
verifySession :: Config -> SessionToken -> IO (Either Text SessionUser)
|
||||
verifySession cfg (SessionToken token) = do
|
||||
now <- floor <$> getPOSIXTime
|
||||
pure $ do
|
||||
claims <- verifyJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) token
|
||||
expAt <- claimInt claims "exp"
|
||||
if expAt < now
|
||||
then Left "session expired"
|
||||
else do
|
||||
iss <- claimText claims "oidc_issuer"
|
||||
sub <- claimText claims "oidc_subject"
|
||||
let display = either (const Nothing) Just (claimText claims "display")
|
||||
uid = encodeUserId iss sub
|
||||
pure SessionUser
|
||||
{ suIssuer = iss
|
||||
, suSubject = sub
|
||||
, suUserId = uid
|
||||
, suDisplay = display
|
||||
let applicationIssuer = "nuthatch"
|
||||
applicationAudience = "nuthatch"
|
||||
result <- runJOSE $ do
|
||||
jwt <- decodeCompact (BL.fromStrict (TE.encodeUtf8 token))
|
||||
let settings =
|
||||
defaultJWTValidationSettings (== applicationAudience)
|
||||
& issuerPredicate .~ (== applicationIssuer)
|
||||
& algorithms .~ singleton HS256
|
||||
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
|
||||
verifyJWT settings key (jwt :: SignedJWT)
|
||||
pure $ case result of
|
||||
Left (_ :: JWTError) -> Left "session token validation failed"
|
||||
Right claims ->
|
||||
let userId = encodeUserId (oidcIssuer claims) (oidcSubject claims)
|
||||
expectedSubject = fromString (T.unpack (unUserId userId))
|
||||
registered = registeredClaims claims
|
||||
in if registered ^. claimSub /= Just expectedSubject
|
||||
|| registered ^. claimAud /= Just (Audience ["nuthatch"])
|
||||
|| registered ^. claimIat == Nothing
|
||||
|| registered ^. claimExp == Nothing
|
||||
then Left "session token claims are invalid"
|
||||
else Right SessionUser
|
||||
{ suIssuer = oidcIssuer claims
|
||||
, suSubject = oidcSubject claims
|
||||
, suUserId = userId
|
||||
, suDisplay = displayName claims
|
||||
}
|
||||
|
||||
signJwt :: BS.ByteString -> A.Value -> A.Value -> Text
|
||||
signJwt secret header payload =
|
||||
let h = b64Json header
|
||||
p = b64Json payload
|
||||
signingInput = h <> "." <> p
|
||||
sig = b64Raw (hmacSha256 secret signingInput)
|
||||
in TE.decodeUtf8 (signingInput <> "." <> sig)
|
||||
|
||||
verifyJwt :: BS.ByteString -> Text -> Either Text A.Object
|
||||
verifyJwt secret token =
|
||||
case T.splitOn "." token of
|
||||
[h, p, s] -> do
|
||||
let signingInput = TE.encodeUtf8 (h <> "." <> p)
|
||||
expected = b64Raw (hmacSha256 secret signingInput)
|
||||
if not (BA.constEq expected (TE.encodeUtf8 s))
|
||||
then Left "invalid session signature"
|
||||
else do
|
||||
payloadBytes <- b64Decode (TE.encodeUtf8 p)
|
||||
case A.eitherDecodeStrict payloadBytes of
|
||||
Left err -> Left (T.pack err)
|
||||
Right (A.Object obj) -> Right obj
|
||||
Right _ -> Left "jwt payload must be an object"
|
||||
_ -> Left "malformed session token"
|
||||
|
||||
hmacSha256 :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
hmacSha256 secret msg =
|
||||
convert (hmac secret msg :: HMAC SHA256)
|
||||
|
||||
b64Json :: A.Value -> BS.ByteString
|
||||
b64Json = B64.encodeUnpadded . BL.toStrict . A.encode
|
||||
|
||||
b64Raw :: BS.ByteString -> BS.ByteString
|
||||
b64Raw = B64.encodeUnpadded
|
||||
|
||||
b64Decode :: BS.ByteString -> Either Text BS.ByteString
|
||||
b64Decode bs =
|
||||
case B64.decode bs of
|
||||
Left err -> Left (T.pack err)
|
||||
Right x -> Right x
|
||||
|
||||
claimText :: A.Object -> Text -> Either Text Text
|
||||
claimText obj key =
|
||||
case KM.lookup (Key.fromText key) obj of
|
||||
Just (A.String t) -> Right t
|
||||
_ -> Left ("missing claim " <> key)
|
||||
|
||||
claimInt :: A.Object -> Text -> Either Text Integer
|
||||
claimInt obj key =
|
||||
case KM.lookup (Key.fromText key) obj of
|
||||
Just v ->
|
||||
case A.fromJSON v of
|
||||
A.Success (i :: Integer) -> Right i
|
||||
_ -> Left ("invalid integer claim " <> key)
|
||||
_ -> Left ("missing claim " <> key)
|
||||
|
||||
newCsrfToken :: IO CsrfToken
|
||||
newCsrfToken = do
|
||||
bytes <- getEntropy 32
|
||||
|
|
@ -127,9 +153,9 @@ newCsrfToken = do
|
|||
|
||||
constantTimeEq :: CsrfToken -> CsrfToken -> Bool
|
||||
constantTimeEq (CsrfToken a) (CsrfToken b) =
|
||||
let ba = TE.encodeUtf8 a
|
||||
bb = TE.encodeUtf8 b
|
||||
in BS.length ba == BS.length bb
|
||||
let left = TE.encodeUtf8 a
|
||||
right = TE.encodeUtf8 b
|
||||
in BS.length left == BS.length right
|
||||
&& BA.constEq
|
||||
(hash ba :: Digest SHA256)
|
||||
(hash bb :: Digest SHA256)
|
||||
(hash left :: Digest SHA256)
|
||||
(hash right :: Digest SHA256)
|
||||
|
|
|
|||
Loading…
Reference in a new issue