Implement confidential OIDC authentication boundary
This commit is contained in:
parent
0f888986d7
commit
a4e615096c
6 changed files with 1896 additions and 329 deletions
|
|
@ -2,9 +2,10 @@ module Nuthatch.Api
|
|||
( Api
|
||||
, HealthEndpoint
|
||||
, ReadyEndpoint
|
||||
, LoginPageEndpoint
|
||||
, BrowserScriptEndpoint
|
||||
, LoginEndpoint
|
||||
, LoginStart
|
||||
, OidcCallbackEndpoint
|
||||
, LoginSuccess
|
||||
, LogoutEndpoint
|
||||
, LogoutSuccess
|
||||
|
|
@ -25,10 +26,6 @@ module Nuthatch.Api
|
|||
, PaginationToken (..)
|
||||
, SearchQuery (..)
|
||||
, DeclaredSize (..)
|
||||
, DevUsername (..)
|
||||
, LoginRequest (..)
|
||||
, LoginResponse (..)
|
||||
, LoginView (..)
|
||||
, HealthResponse (..)
|
||||
, ReadyResponse (..)
|
||||
, BrowseResponse (..)
|
||||
|
|
@ -73,7 +70,6 @@ import Nuthatch.Types
|
|||
import Servant.API
|
||||
import Servant.Server (HasServer (..))
|
||||
import Servant.Server.Experimental.Auth (AuthServerData)
|
||||
import Web.FormUrlEncoded (FromForm (..), lookupUnique)
|
||||
|
||||
data HTML
|
||||
data JavaScript
|
||||
|
|
@ -121,44 +117,6 @@ newtype DeclaredSize = DeclaredSize { unDeclaredSize :: Integer }
|
|||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
|
||||
newtype DevUsername = DevUsername { unDevUsername :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data LoginRequest = LoginRequest
|
||||
{ loginUsername :: DevUsername
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON LoginRequest where
|
||||
parseJSON = withObject "LoginRequest" $ \o -> do
|
||||
raw <- o .: "username"
|
||||
LoginRequest <$> either (fail . T.unpack) pure (validateDevUsername raw)
|
||||
|
||||
instance FromForm LoginRequest where
|
||||
fromForm form = do
|
||||
raw <- lookupUnique "username" form
|
||||
LoginRequest <$> validateDevUsername raw
|
||||
|
||||
data LoginResponse = LoginResponse
|
||||
{ loginUserId :: UserId
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON LoginResponse where
|
||||
toJSON response = object ["user_id" .= loginUserId response]
|
||||
|
||||
data LoginView = LoginView
|
||||
{ loginViewHtml :: HtmlPage
|
||||
, loginViewJson :: LoginResponse
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance MimeRender HTML LoginView where
|
||||
mimeRender proxy = mimeRender proxy . loginViewHtml
|
||||
|
||||
instance ToJSON LoginView where
|
||||
toJSON = toJSON . loginViewJson
|
||||
|
||||
newtype HealthResponse = HealthResponse { healthOk :: Bool }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
|
|
@ -302,13 +260,16 @@ instance ToJSON ReadyError where
|
|||
errorValue "dependency_unavailable" "PostgreSQL is unavailable" Nothing
|
||||
|
||||
data LoginError
|
||||
= InvalidUsername
|
||||
= OidcAuthorizationFailed
|
||||
| OidcCallbackRejected
|
||||
| SessionCreationFailed Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON LoginError where
|
||||
toJSON InvalidUsername =
|
||||
errorValue "invalid_username" "username must be one token" Nothing
|
||||
toJSON OidcAuthorizationFailed =
|
||||
errorValue "oidc_authorization_failed" "OIDC authorization could not start" Nothing
|
||||
toJSON OidcCallbackRejected =
|
||||
errorValue "oidc_callback_rejected" "OIDC callback validation failed" Nothing
|
||||
toJSON (SessionCreationFailed message) =
|
||||
errorValue "session_error" message Nothing
|
||||
|
||||
|
|
@ -407,29 +368,43 @@ type HealthEndpoint =
|
|||
type ReadyEndpoint =
|
||||
"readyz" :> Throws ReadyError :> Get '[JSON] ReadyResponse
|
||||
|
||||
type LoginPageEndpoint =
|
||||
"login" :> Get '[HTML] HtmlPage
|
||||
|
||||
type BrowserScriptEndpoint =
|
||||
"nuthatch.js" :> Get '[JavaScript] BrowserScript
|
||||
|
||||
type LoginStart =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
, Header "Location" Text
|
||||
]
|
||||
NoContent
|
||||
|
||||
type LoginEndpoint =
|
||||
"login"
|
||||
:> Throws LoginError
|
||||
:> Verb 'GET 303 '[JSON] LoginStart
|
||||
|
||||
type LoginSuccess =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
, Header "Set-Cookie" Text
|
||||
, Header "X-CSRF-Token" CsrfToken
|
||||
, Header "Set-Cookie" Text
|
||||
, Header "Location" Text
|
||||
]
|
||||
LoginView
|
||||
NoContent
|
||||
|
||||
type LoginEndpoint =
|
||||
"login"
|
||||
type OidcCallbackEndpoint =
|
||||
"oidc"
|
||||
:> "callback"
|
||||
:> Throws LoginError
|
||||
:> ReqBody '[JSON, FormUrlEncoded] LoginRequest
|
||||
:> Post '[HTML, JSON] LoginSuccess
|
||||
:> QueryParam' '[Required, Strict] "code" Text
|
||||
:> QueryParam' '[Required, Strict] "state" Text
|
||||
:> Header' '[Required, Strict] "Cookie" Text
|
||||
:> Verb 'GET 303 '[JSON] LoginSuccess
|
||||
|
||||
type LogoutSuccess =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
, Header "Set-Cookie" Text
|
||||
, Header "Set-Cookie" Text
|
||||
]
|
||||
NoContent
|
||||
|
|
@ -501,9 +476,9 @@ type DeletePrefixEndpoint =
|
|||
type Api =
|
||||
HealthEndpoint
|
||||
:<|> ReadyEndpoint
|
||||
:<|> LoginPageEndpoint
|
||||
:<|> BrowserScriptEndpoint
|
||||
:<|> LoginEndpoint
|
||||
:<|> OidcCallbackEndpoint
|
||||
:<|> LogoutEndpoint
|
||||
:<|> BrowseEndpoint
|
||||
:<|> DownloadEndpoint
|
||||
|
|
@ -554,16 +529,6 @@ validatePaginationToken raw
|
|||
| T.any isControl raw = Left "pagination token contains a control character"
|
||||
| otherwise = Right (PaginationToken raw)
|
||||
|
||||
validateDevUsername :: Text -> Either Text DevUsername
|
||||
validateDevUsername raw
|
||||
| T.null raw = Left "username must not be empty"
|
||||
| T.length raw > 128 = Left "username is too long"
|
||||
| T.any invalidCharacter raw = Left "username must be one printable token"
|
||||
| otherwise = Right (DevUsername raw)
|
||||
where
|
||||
invalidCharacter character =
|
||||
isControl character || character `elem` (" \t\r\n" :: String)
|
||||
|
||||
mutationResultText :: MutationResult -> Text
|
||||
mutationResultText MutationPending = "pending"
|
||||
mutationResultText MutationSucceeded = "succeeded"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ import qualified Data.Aeson as A
|
|||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (isRight)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
|
|
@ -30,17 +29,18 @@ import Data.UUID.V4 (nextRandom)
|
|||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import Network.HTTP.Types
|
||||
( hContentType
|
||||
, hCookie
|
||||
, hLocation
|
||||
, status400
|
||||
, urlDecode
|
||||
)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (Request (..), responseLBS)
|
||||
import Nuthatch.Api
|
||||
import Nuthatch.Audit (audit)
|
||||
import Nuthatch.Config (Config (..))
|
||||
import Nuthatch.Db (Db, ensurePersonalPool, withTransaction)
|
||||
import qualified Nuthatch.Db as Db
|
||||
import Nuthatch.Oidc
|
||||
import Nuthatch.Paths
|
||||
import Nuthatch.Protocol
|
||||
import Nuthatch.Redis (Redis, cacheGet, cacheInvalidatePrefixes, cacheSet, throttleTake)
|
||||
|
|
@ -57,13 +57,26 @@ import Nuthatch.S3
|
|||
)
|
||||
import Nuthatch.Session
|
||||
import Nuthatch.Types
|
||||
import Nuthatch.Ui (browsePage, browserScript, loginPage)
|
||||
import Nuthatch.Ui (browsePage, browserScript)
|
||||
import Servant
|
||||
import Servant.Server.Experimental.Auth
|
||||
( AuthHandler
|
||||
, mkAuthHandler
|
||||
)
|
||||
import Servant.Types.SourceT (runSourceT, source)
|
||||
import Web.Cookie
|
||||
( defaultSetCookie
|
||||
, parseCookies
|
||||
, renderSetCookieBS
|
||||
, sameSiteLax
|
||||
, setCookieHttpOnly
|
||||
, setCookieMaxAge
|
||||
, setCookieName
|
||||
, setCookiePath
|
||||
, setCookieSameSite
|
||||
, setCookieSecure
|
||||
, setCookieValue
|
||||
)
|
||||
|
||||
data Env = Env
|
||||
{ envConfig :: Config
|
||||
|
|
@ -105,9 +118,9 @@ server :: Env -> Server Api
|
|||
server env =
|
||||
pure (HealthResponse True)
|
||||
:<|> handleReady env
|
||||
:<|> pure (HtmlPage (loginPage ""))
|
||||
:<|> pure (BrowserScript browserScript)
|
||||
:<|> handleLoginRequest env
|
||||
:<|> handleOidcCallback env
|
||||
:<|> handleLogoutRequest env
|
||||
:<|> handleBrowseRequest env
|
||||
:<|> handleDownloadRequest env
|
||||
|
|
@ -117,7 +130,7 @@ server env =
|
|||
|
||||
authenticationHandler :: Config -> AuthHandler Request SessionContext
|
||||
authenticationHandler cfg = mkAuthHandler $ \request -> do
|
||||
let cookies = parseCookies (requestHeaders request)
|
||||
let cookies = requestCookies request
|
||||
sessionName = TE.encodeUtf8 (cfgCookieName cfg)
|
||||
csrfName = TE.encodeUtf8 (cfgCsrfCookieName cfg)
|
||||
token <- maybe (throwError loginRequired) pure (lookup sessionName cookies)
|
||||
|
|
@ -155,36 +168,68 @@ handleReady env = do
|
|||
|
||||
handleLoginRequest
|
||||
:: Env
|
||||
-> LoginRequest
|
||||
-> Handler LoginStart
|
||||
handleLoginRequest env = do
|
||||
let cfg = envConfig env
|
||||
authorizationResult <- liftIO (beginAuthorization cfg)
|
||||
authorization <- either
|
||||
(const (throwOperationError err502 OidcAuthorizationFailed))
|
||||
pure
|
||||
authorizationResult
|
||||
pure $
|
||||
addHeader
|
||||
(cookieValue
|
||||
(cfgOidcTransactionCookieName cfg)
|
||||
(authorizationTransaction authorization)
|
||||
"/oidc/callback"
|
||||
True) $
|
||||
addHeader (authorizationLocation authorization) NoContent
|
||||
|
||||
handleOidcCallback
|
||||
:: Env
|
||||
-> Text
|
||||
-> Text
|
||||
-> Text
|
||||
-> Handler LoginSuccess
|
||||
handleLoginRequest env request = do
|
||||
let username = unDevUsername (loginUsername request)
|
||||
let uid = encodeUserId "nuthatch-dev" username
|
||||
cfg = envConfig env
|
||||
handleOidcCallback env code state cookieHeader = do
|
||||
let cfg = envConfig env
|
||||
cookies = parseCookies (TE.encodeUtf8 cookieHeader)
|
||||
transactionName = TE.encodeUtf8 (cfgOidcTransactionCookieName cfg)
|
||||
transaction <- maybe
|
||||
(throwOperationError err400 OidcCallbackRejected)
|
||||
(parseCookieValueText OidcCallbackRejected)
|
||||
(lookup transactionName cookies)
|
||||
identityResult <- liftIO (redeemAuthorizationCode cfg transaction state code)
|
||||
identity <- case identityResult of
|
||||
Left reason -> do
|
||||
liftIO $ audit "login" "rejected" Nothing [("reason", A.String reason)]
|
||||
throwOperationError err400 OidcCallbackRejected
|
||||
Right accepted -> pure accepted
|
||||
let uid = encodeUserId (identityIssuer identity) (identitySubject identity)
|
||||
liftIO (ensurePersonalPool (envDb env) cfg uid)
|
||||
tokenResult <- liftIO (mintSession cfg "nuthatch-dev" username (Just username))
|
||||
tokenResult <- liftIO $
|
||||
mintSession
|
||||
cfg
|
||||
(identityIssuer identity)
|
||||
(identitySubject identity)
|
||||
(identityDisplay identity)
|
||||
token <- either
|
||||
(throwOperationError err500 . SessionCreationFailed)
|
||||
(const (throwOperationError err500 (SessionCreationFailed "session creation failed")))
|
||||
pure
|
||||
tokenResult
|
||||
csrf <- liftIO newCsrfToken
|
||||
liftIO $ audit "login" "ok" (Just (unUserId uid)) []
|
||||
pure (loginResponse cfg uid token csrf)
|
||||
pure (loginResponse cfg token csrf)
|
||||
|
||||
loginResponse
|
||||
:: Config
|
||||
-> UserId
|
||||
-> SessionToken
|
||||
-> CsrfToken
|
||||
-> LoginSuccess
|
||||
loginResponse cfg uid token csrf =
|
||||
addHeader (cookieValue cfg (cfgCookieName cfg) (unSessionToken token) True) $
|
||||
addHeader (cookieValue cfg (cfgCsrfCookieName cfg) (unCsrfToken csrf) False) $
|
||||
addHeader csrf (LoginView
|
||||
{ loginViewHtml = HtmlPage
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><meta http-equiv=\"refresh\" content=\"0;url=/\"></head><body><a href=\"/\">Continue to Nuthatch</a></body></html>"
|
||||
, loginViewJson = LoginResponse uid
|
||||
})
|
||||
loginResponse :: Config -> SessionToken -> CsrfToken -> LoginSuccess
|
||||
loginResponse cfg token csrf =
|
||||
addHeader (cookieValue (cfgCookieName cfg) (unSessionToken token) "/" True) $
|
||||
addHeader (cookieValue (cfgCsrfCookieName cfg) (unCsrfToken csrf) "/" False) $
|
||||
addHeader
|
||||
(expiredCookieValue
|
||||
(cfgOidcTransactionCookieName cfg)
|
||||
"/oidc/callback") $
|
||||
addHeader "/" NoContent
|
||||
|
||||
handleLogoutRequest
|
||||
:: Env
|
||||
|
|
@ -195,8 +240,13 @@ handleLogoutRequest env session providedCsrf = do
|
|||
requireCsrf LogoutCsrfRejected session providedCsrf
|
||||
let cfg = envConfig env
|
||||
pure $
|
||||
addHeader (expiredCookieValue (cfgCookieName cfg)) $
|
||||
addHeader (expiredCookieValue (cfgCsrfCookieName cfg)) NoContent
|
||||
addHeader (expiredCookieValue (cfgCookieName cfg) "/") $
|
||||
addHeader (expiredCookieValue (cfgCsrfCookieName cfg) "/") $
|
||||
addHeader
|
||||
(expiredCookieValue
|
||||
(cfgOidcTransactionCookieName cfg)
|
||||
"/oidc/callback")
|
||||
NoContent
|
||||
|
||||
handleBrowseRequest
|
||||
:: Env
|
||||
|
|
@ -396,15 +446,32 @@ browsePrefixText :: BrowsePrefix -> Text
|
|||
browsePrefixText (BrowsePrefix Nothing) = ""
|
||||
browsePrefixText (BrowsePrefix (Just path)) = unRelativePath path
|
||||
|
||||
cookieValue :: Config -> Text -> Text -> Bool -> Text
|
||||
cookieValue _cfg name value httpOnly =
|
||||
name <> "=" <> value
|
||||
<> "; Path=/; SameSite=Lax"
|
||||
<> if httpOnly then "; HttpOnly" else ""
|
||||
cookieValue :: Text -> Text -> BS.ByteString -> Bool -> Text
|
||||
cookieValue name value path httpOnly =
|
||||
TE.decodeUtf8 $
|
||||
renderSetCookieBS $
|
||||
defaultSetCookie
|
||||
{ setCookieName = TE.encodeUtf8 name
|
||||
, setCookieValue = TE.encodeUtf8 value
|
||||
, setCookiePath = Just path
|
||||
, setCookieHttpOnly = httpOnly
|
||||
, setCookieSecure = True
|
||||
, setCookieSameSite = Just sameSiteLax
|
||||
}
|
||||
|
||||
expiredCookieValue :: Text -> Text
|
||||
expiredCookieValue name =
|
||||
name <> "=; Path=/; Max-Age=0; SameSite=Lax"
|
||||
expiredCookieValue :: Text -> BS.ByteString -> Text
|
||||
expiredCookieValue name path =
|
||||
TE.decodeUtf8 $
|
||||
renderSetCookieBS $
|
||||
defaultSetCookie
|
||||
{ setCookieName = TE.encodeUtf8 name
|
||||
, setCookieValue = ""
|
||||
, setCookiePath = Just path
|
||||
, setCookieMaxAge = Just 0
|
||||
, setCookieHttpOnly = True
|
||||
, setCookieSecure = True
|
||||
, setCookieSameSite = Just sameSiteLax
|
||||
}
|
||||
|
||||
mutationAuditResult :: MutationResult -> Text
|
||||
mutationAuditResult MutationSucceeded = "ok"
|
||||
|
|
@ -725,18 +792,16 @@ lastSeg t =
|
|||
(x : _) -> x
|
||||
[] -> t
|
||||
|
||||
parseCookies :: [HTTP.Header] -> [(BS.ByteString, BS.ByteString)]
|
||||
parseCookies headers =
|
||||
case lookup "Cookie" headers of
|
||||
Nothing -> []
|
||||
Just raw ->
|
||||
[ (trimBS k, trimBS (BS8.drop 1 v))
|
||||
| part <- BS8.split ';' raw
|
||||
, let (k, v) = BS8.break (== '=') part
|
||||
, not (BS.null v)
|
||||
]
|
||||
requestCookies :: Request -> [(BS.ByteString, BS.ByteString)]
|
||||
requestCookies request =
|
||||
maybe [] parseCookies (lookup hCookie (requestHeaders request))
|
||||
|
||||
trimBS :: BS.ByteString -> BS.ByteString
|
||||
trimBS = BS8.dropWhile isSpace . BS8.dropWhileEnd isSpace
|
||||
where
|
||||
isSpace c = c == ' ' || c == '\t'
|
||||
parseCookieValueText
|
||||
:: A.ToJSON error
|
||||
=> error
|
||||
-> BS.ByteString
|
||||
-> Handler Text
|
||||
parseCookieValueText operationError bytes =
|
||||
case TE.decodeUtf8' bytes of
|
||||
Right value | not (T.null value) && T.length value <= 8192 -> pure value
|
||||
_ -> throwOperationError err400 operationError
|
||||
|
|
|
|||
|
|
@ -1,27 +1,36 @@
|
|||
module Nuthatch.Config
|
||||
( Config (..)
|
||||
, AuthMode (..)
|
||||
, loadConfig
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.List (nub)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
data AuthMode = AuthDev
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Config = Config
|
||||
{ cfgListenHost :: String
|
||||
, cfgListenPort :: Int
|
||||
, cfgTlsCertPath :: FilePath
|
||||
, cfgTlsKeyPath :: FilePath
|
||||
, cfgPublicBaseUrl :: Text
|
||||
, cfgJwtSecret :: Text
|
||||
, cfgSessionHours :: Integer
|
||||
, cfgCookieName :: Text
|
||||
, cfgCsrfCookieName :: Text
|
||||
, cfgOidcTransactionCookieName :: Text
|
||||
, cfgOidcIssuer :: Text
|
||||
, cfgOidcClientId :: Text
|
||||
, cfgOidcAdditionalAudiences :: [Text]
|
||||
, cfgOidcClientSecret :: Text
|
||||
, cfgOidcRedirectUri :: Text
|
||||
, cfgOidcTransactionMinutes :: Integer
|
||||
, cfgOidcMaxIdTokenSeconds :: Integer
|
||||
, cfgPgConn :: String
|
||||
, cfgRedisHost :: String
|
||||
, cfgRedisPort :: Int
|
||||
|
|
@ -40,22 +49,45 @@ data Config = Config
|
|||
, cfgListCacheTtlSec :: Integer
|
||||
, cfgSearchMaxKeys :: Int
|
||||
, cfgRecoveryGraceSec :: Integer
|
||||
, cfgAuthMode :: AuthMode
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
loadConfig :: IO Config
|
||||
loadConfig = do
|
||||
listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
|
||||
let (host, portText) = splitHostPort listen
|
||||
port <- requireRead "NUTHATCH_LISTEN port" portText
|
||||
publicBase <- T.pack . fromMaybe ("http://" <> listen) <$> lookupEnv "NUTHATCH_PUBLIC_BASE_URL"
|
||||
tlsCertPath <- fromMaybe "/tls/tls.crt" <$> lookupEnv "NUTHATCH_TLS_CERT_PATH"
|
||||
tlsKeyPath <- fromMaybe "/tls/tls.key" <$> lookupEnv "NUTHATCH_TLS_KEY_PATH"
|
||||
publicBase <- T.pack <$> requireEnv "NUTHATCH_PUBLIC_BASE_URL"
|
||||
when (not ("https://" `T.isPrefixOf` publicBase)) $
|
||||
fail "NUTHATCH_PUBLIC_BASE_URL must use https"
|
||||
jwtSecret <- T.pack <$> requireEnv "NUTHATCH_JWT_SECRET"
|
||||
when (T.length jwtSecret < 16) $
|
||||
fail "NUTHATCH_JWT_SECRET must be at least 16 characters"
|
||||
when (BS.length (TE.encodeUtf8 jwtSecret) < 32) $
|
||||
fail "NUTHATCH_JWT_SECRET must be at least 32 bytes"
|
||||
sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
|
||||
cookieName <- T.pack . fromMaybe "nuthatch_session" <$> lookupEnv "NUTHATCH_COOKIE_NAME"
|
||||
csrfCookie <- T.pack . fromMaybe "nuthatch_csrf" <$> lookupEnv "NUTHATCH_CSRF_COOKIE_NAME"
|
||||
transactionCookie <- T.pack . fromMaybe "nuthatch_oidc" <$> lookupEnv "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME"
|
||||
oidcIssuer <- T.dropWhileEnd (== '/') . T.pack <$> requireEnv "NUTHATCH_OIDC_ISSUER"
|
||||
oidcClientId <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_ID"
|
||||
additionalAudienceValue <- lookupEnv "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES"
|
||||
let oidcAdditionalAudiences =
|
||||
case T.strip . T.pack <$> additionalAudienceValue of
|
||||
Nothing -> []
|
||||
Just "" -> []
|
||||
Just value -> map T.strip (T.splitOn "," value)
|
||||
when
|
||||
( any T.null oidcAdditionalAudiences
|
||||
|| oidcClientId `elem` oidcAdditionalAudiences
|
||||
|| length oidcAdditionalAudiences /= length (nub oidcAdditionalAudiences)
|
||||
) $
|
||||
fail "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES must contain unique non-client values"
|
||||
oidcClientSecret <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_SECRET"
|
||||
oidcRedirectUri <- T.pack <$> requireEnv "NUTHATCH_OIDC_REDIRECT_URI"
|
||||
when (oidcRedirectUri /= publicBase <> "/oidc/callback") $
|
||||
fail "NUTHATCH_OIDC_REDIRECT_URI must equal the public callback URL"
|
||||
oidcTransactionMinutes <- envInteger "NUTHATCH_OIDC_TRANSACTION_MINUTES" 5
|
||||
oidcMaxIdTokenSeconds <- envInteger "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS" 3600
|
||||
pgConn <- requireEnv "NUTHATCH_PG_CONN"
|
||||
redisUrl <- requireEnv "NUTHATCH_REDIS_URL"
|
||||
(redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
|
||||
|
|
@ -73,18 +105,24 @@ loadConfig = do
|
|||
listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
|
||||
searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
|
||||
recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
|
||||
authModeText <- fromMaybe "dev" <$> lookupEnv "NUTHATCH_AUTH_MODE"
|
||||
authMode <- case authModeText of
|
||||
"dev" -> pure AuthDev
|
||||
other -> fail $ "unsupported NUTHATCH_AUTH_MODE: " <> other
|
||||
pure Config
|
||||
{ cfgListenHost = host
|
||||
, cfgListenPort = port
|
||||
, cfgTlsCertPath = tlsCertPath
|
||||
, cfgTlsKeyPath = tlsKeyPath
|
||||
, cfgPublicBaseUrl = publicBase
|
||||
, cfgJwtSecret = jwtSecret
|
||||
, cfgSessionHours = sessionHours
|
||||
, cfgCookieName = cookieName
|
||||
, cfgCsrfCookieName = csrfCookie
|
||||
, cfgOidcTransactionCookieName = transactionCookie
|
||||
, cfgOidcIssuer = oidcIssuer
|
||||
, cfgOidcClientId = oidcClientId
|
||||
, cfgOidcAdditionalAudiences = oidcAdditionalAudiences
|
||||
, cfgOidcClientSecret = oidcClientSecret
|
||||
, cfgOidcRedirectUri = oidcRedirectUri
|
||||
, cfgOidcTransactionMinutes = oidcTransactionMinutes
|
||||
, cfgOidcMaxIdTokenSeconds = oidcMaxIdTokenSeconds
|
||||
, cfgPgConn = pgConn
|
||||
, cfgRedisHost = redisHost
|
||||
, cfgRedisPort = redisPort
|
||||
|
|
@ -103,7 +141,6 @@ loadConfig = do
|
|||
, cfgListCacheTtlSec = listTtl
|
||||
, cfgSearchMaxKeys = searchMax
|
||||
, cfgRecoveryGraceSec = recoveryGrace
|
||||
, cfgAuthMode = authMode
|
||||
}
|
||||
|
||||
splitHostPort :: String -> (String, String)
|
||||
|
|
|
|||
469
src/Nuthatch/Oidc.hs
Normal file
469
src/Nuthatch/Oidc.hs
Normal file
|
|
@ -0,0 +1,469 @@
|
|||
module Nuthatch.Oidc
|
||||
( AuthorizationRequest (..)
|
||||
, OidcIdentity (..)
|
||||
, beginAuthorization
|
||||
, redeemAuthorizationCode
|
||||
, verifyIdToken
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Exception (catch)
|
||||
import Control.Lens
|
||||
( (&)
|
||||
, (?~)
|
||||
, (^.)
|
||||
, (.~)
|
||||
)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import Crypto.JOSE (runJOSE)
|
||||
import Crypto.JOSE.Compact (decodeCompact, encodeCompact)
|
||||
import Crypto.JOSE.JWA.JWS (Alg (HS256, RS256))
|
||||
import Crypto.JOSE.JWK (JWKSet, fromOctets)
|
||||
import Crypto.JOSE.JWS
|
||||
( algorithms
|
||||
, newJWSHeaderProtected
|
||||
)
|
||||
import Crypto.JWT
|
||||
( Audience (..)
|
||||
, ClaimsSet
|
||||
, HasClaimsSet (..)
|
||||
, JWTError
|
||||
, NumericDate (..)
|
||||
, SignedJWT
|
||||
, StringOrURI
|
||||
, defaultJWTValidationSettings
|
||||
, emptyClaimsSet
|
||||
, issuerPredicate
|
||||
, signJWT
|
||||
, verifyJWT
|
||||
)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson.Key (Key)
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
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 qualified Data.Set as Set
|
||||
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
|
||||
( UTCTime
|
||||
, addUTCTime
|
||||
, diffUTCTime
|
||||
, getCurrentTime
|
||||
)
|
||||
import Network.HTTP.Client (HttpException, applyBasicAuth)
|
||||
import Network.HTTP.Simple
|
||||
( getResponseBody
|
||||
, getResponseStatusCode
|
||||
, httpLBS
|
||||
, parseRequest
|
||||
, setRequestBodyURLEncoded
|
||||
, setRequestMethod
|
||||
)
|
||||
import Network.HTTP.Types.URI (renderQuery)
|
||||
import Nuthatch.Config (Config (..))
|
||||
import System.Entropy (getEntropy)
|
||||
|
||||
data AuthorizationRequest = AuthorizationRequest
|
||||
{ authorizationLocation :: Text
|
||||
, authorizationTransaction :: Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data OidcIdentity = OidcIdentity
|
||||
{ identityIssuer :: Text
|
||||
, identitySubject :: Text
|
||||
, identityDisplay :: Maybe Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data Discovery = Discovery
|
||||
{ discoveryIssuer :: Text
|
||||
, discoveryAuthorizationEndpoint :: Text
|
||||
, discoveryTokenEndpoint :: Text
|
||||
, discoveryJwksUri :: Text
|
||||
}
|
||||
|
||||
instance A.FromJSON Discovery where
|
||||
parseJSON = A.withObject "OIDC discovery" $ \object ->
|
||||
Discovery
|
||||
<$> object A..: "issuer"
|
||||
<*> object A..: "authorization_endpoint"
|
||||
<*> object A..: "token_endpoint"
|
||||
<*> object A..: "jwks_uri"
|
||||
|
||||
data TokenResponse = TokenResponse
|
||||
{ tokenResponseIdToken :: Text
|
||||
}
|
||||
|
||||
instance A.FromJSON TokenResponse where
|
||||
parseJSON = A.withObject "OIDC token response" $ \object ->
|
||||
TokenResponse <$> object A..: "id_token"
|
||||
|
||||
data TransactionClaims = TransactionClaims
|
||||
{ transactionRegistered :: ClaimsSet
|
||||
, transactionState :: Text
|
||||
, transactionNonce :: Text
|
||||
, transactionVerifier :: Text
|
||||
, transactionIssuer :: Text
|
||||
, transactionClientId :: Text
|
||||
, transactionRedirectUri :: Text
|
||||
, transactionReturnTarget :: Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance HasClaimsSet TransactionClaims where
|
||||
claimsSet update claims =
|
||||
fmap
|
||||
(\registered -> claims { transactionRegistered = registered })
|
||||
(update (transactionRegistered claims))
|
||||
|
||||
instance A.FromJSON TransactionClaims where
|
||||
parseJSON value = A.withObject "OIDC transaction" parse value
|
||||
where
|
||||
parse object =
|
||||
TransactionClaims
|
||||
<$> A.parseJSON value
|
||||
<*> object A..: "state"
|
||||
<*> object A..: "nonce"
|
||||
<*> object A..: "verifier"
|
||||
<*> object A..: "oidc_issuer"
|
||||
<*> object A..: "client_id"
|
||||
<*> object A..: "redirect_uri"
|
||||
<*> object A..: "return_target"
|
||||
|
||||
instance A.ToJSON TransactionClaims where
|
||||
toJSON claims =
|
||||
extendClaims
|
||||
(transactionRegistered claims)
|
||||
[ ("state", A.String (transactionState claims))
|
||||
, ("nonce", A.String (transactionNonce claims))
|
||||
, ("verifier", A.String (transactionVerifier claims))
|
||||
, ("oidc_issuer", A.String (transactionIssuer claims))
|
||||
, ("client_id", A.String (transactionClientId claims))
|
||||
, ("redirect_uri", A.String (transactionRedirectUri claims))
|
||||
, ("return_target", A.String (transactionReturnTarget claims))
|
||||
]
|
||||
|
||||
data IdTokenClaims = IdTokenClaims
|
||||
{ idTokenRegistered :: ClaimsSet
|
||||
, idTokenNonce :: Text
|
||||
, idTokenAuthorizedParty :: Maybe Text
|
||||
, idTokenName :: Maybe Text
|
||||
, idTokenPreferred :: Maybe Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance HasClaimsSet IdTokenClaims where
|
||||
claimsSet update claims =
|
||||
fmap
|
||||
(\registered -> claims { idTokenRegistered = registered })
|
||||
(update (idTokenRegistered claims))
|
||||
|
||||
instance A.FromJSON IdTokenClaims where
|
||||
parseJSON value = A.withObject "OIDC ID token" parse value
|
||||
where
|
||||
parse object =
|
||||
IdTokenClaims
|
||||
<$> A.parseJSON value
|
||||
<*> object A..: "nonce"
|
||||
<*> object A..:? "azp"
|
||||
<*> object A..:? "name"
|
||||
<*> object A..:? "preferred_username"
|
||||
|
||||
instance A.ToJSON IdTokenClaims where
|
||||
toJSON claims =
|
||||
extendClaims
|
||||
(idTokenRegistered claims)
|
||||
[ ("nonce", A.String (idTokenNonce claims))
|
||||
, ("azp", maybe A.Null A.String (idTokenAuthorizedParty claims))
|
||||
, ("name", maybe A.Null A.String (idTokenName claims))
|
||||
, ("preferred_username", maybe A.Null A.String (idTokenPreferred claims))
|
||||
]
|
||||
|
||||
beginAuthorization :: Config -> IO (Either Text AuthorizationRequest)
|
||||
beginAuthorization cfg = do
|
||||
discoveryResult <- fetchDiscovery cfg
|
||||
case discoveryResult of
|
||||
Left message -> pure (Left message)
|
||||
Right discovery -> do
|
||||
state <- randomBase64Url 32
|
||||
nonce <- randomBase64Url 32
|
||||
verifier <- randomBase64Url 32
|
||||
transactionResult <- mintTransaction cfg state nonce verifier
|
||||
pure $ do
|
||||
transaction <- transactionResult
|
||||
let challenge =
|
||||
TE.decodeUtf8 $
|
||||
B64.encodeUnpadded $
|
||||
BA.convert (hash (TE.encodeUtf8 verifier) :: Digest SHA256)
|
||||
query = renderQuery True
|
||||
[ ("response_type", Just "code")
|
||||
, ("client_id", Just (TE.encodeUtf8 (cfgOidcClientId cfg)))
|
||||
, ("redirect_uri", Just (TE.encodeUtf8 (cfgOidcRedirectUri cfg)))
|
||||
, ("scope", Just "openid profile")
|
||||
, ("state", Just (TE.encodeUtf8 state))
|
||||
, ("nonce", Just (TE.encodeUtf8 nonce))
|
||||
, ("code_challenge", Just (TE.encodeUtf8 challenge))
|
||||
, ("code_challenge_method", Just "S256")
|
||||
]
|
||||
Right AuthorizationRequest
|
||||
{ authorizationLocation =
|
||||
discoveryAuthorizationEndpoint discovery
|
||||
<> TE.decodeUtf8 query
|
||||
, authorizationTransaction = transaction
|
||||
}
|
||||
|
||||
redeemAuthorizationCode
|
||||
:: Config
|
||||
-> Text
|
||||
-> Text
|
||||
-> Text
|
||||
-> IO (Either Text OidcIdentity)
|
||||
redeemAuthorizationCode cfg transactionToken returnedState code = do
|
||||
transactionResult <- verifyTransaction cfg transactionToken
|
||||
case transactionResult of
|
||||
Left message -> pure (Left message)
|
||||
Right transaction
|
||||
| not (constantTimeTextEq returnedState (transactionState transaction)) ->
|
||||
pure (Left "OIDC state mismatch")
|
||||
| transactionIssuer transaction /= cfgOidcIssuer cfg ->
|
||||
pure (Left "OIDC transaction issuer mismatch")
|
||||
| transactionClientId transaction /= cfgOidcClientId cfg ->
|
||||
pure (Left "OIDC transaction client mismatch")
|
||||
| transactionRedirectUri transaction /= cfgOidcRedirectUri cfg ->
|
||||
pure (Left "OIDC transaction redirect URI mismatch")
|
||||
| transactionReturnTarget transaction /= "/" ->
|
||||
pure (Left "OIDC transaction return target mismatch")
|
||||
| otherwise -> do
|
||||
discoveryResult <- fetchDiscovery cfg
|
||||
case discoveryResult of
|
||||
Left message -> pure (Left message)
|
||||
Right discovery -> do
|
||||
tokenResult <- exchangeCode cfg discovery transaction code
|
||||
case tokenResult of
|
||||
Left message -> pure (Left message)
|
||||
Right idToken ->
|
||||
fetchAndVerifyIdToken
|
||||
cfg
|
||||
discovery
|
||||
(transactionNonce transaction)
|
||||
idToken
|
||||
|
||||
fetchDiscovery :: Config -> IO (Either Text Discovery)
|
||||
fetchDiscovery cfg = catchOidcHttp "OIDC discovery request failed" $ do
|
||||
request <- parseRequest $
|
||||
T.unpack (cfgOidcIssuer cfg <> "/.well-known/openid-configuration")
|
||||
response <- httpLBS request
|
||||
pure $
|
||||
if getResponseStatusCode response /= 200
|
||||
then Left "OIDC discovery request failed"
|
||||
else case A.eitherDecode (getResponseBody response) of
|
||||
Left _ -> Left "OIDC discovery document is malformed"
|
||||
Right discovery
|
||||
| discoveryIssuer discovery == cfgOidcIssuer cfg -> Right discovery
|
||||
| otherwise -> Left "OIDC discovery issuer mismatch"
|
||||
|
||||
exchangeCode
|
||||
:: Config
|
||||
-> Discovery
|
||||
-> TransactionClaims
|
||||
-> Text
|
||||
-> IO (Either Text Text)
|
||||
exchangeCode cfg discovery transaction code = do
|
||||
catchOidcHttp "OIDC token exchange failed" $ do
|
||||
initial <- parseRequest (T.unpack (discoveryTokenEndpoint discovery))
|
||||
let request =
|
||||
applyBasicAuth
|
||||
(TE.encodeUtf8 (cfgOidcClientId cfg))
|
||||
(TE.encodeUtf8 (cfgOidcClientSecret cfg)) $
|
||||
setRequestMethod "POST" $
|
||||
setRequestBodyURLEncoded
|
||||
[ ("grant_type", "authorization_code")
|
||||
, ("code", TE.encodeUtf8 code)
|
||||
, ("redirect_uri", TE.encodeUtf8 (cfgOidcRedirectUri cfg))
|
||||
, ("code_verifier", TE.encodeUtf8 (transactionVerifier transaction))
|
||||
]
|
||||
initial
|
||||
response <- httpLBS request
|
||||
pure $
|
||||
if getResponseStatusCode response /= 200
|
||||
then Left "OIDC token exchange failed"
|
||||
else case A.eitherDecode (getResponseBody response) of
|
||||
Left _ -> Left "OIDC token response is malformed"
|
||||
Right tokenResponse -> Right (tokenResponseIdToken tokenResponse)
|
||||
|
||||
fetchAndVerifyIdToken
|
||||
:: Config
|
||||
-> Discovery
|
||||
-> Text
|
||||
-> Text
|
||||
-> IO (Either Text OidcIdentity)
|
||||
fetchAndVerifyIdToken cfg discovery expectedNonce compact = do
|
||||
catchOidcHttp "OIDC JWKS request failed" $ do
|
||||
jwksRequest <- parseRequest (T.unpack (discoveryJwksUri discovery))
|
||||
jwksResponse <- httpLBS jwksRequest
|
||||
if getResponseStatusCode jwksResponse /= 200
|
||||
then pure (Left "OIDC JWKS request failed")
|
||||
else case A.eitherDecode (getResponseBody jwksResponse) of
|
||||
Left _ -> pure (Left "OIDC JWKS document is malformed")
|
||||
Right jwks -> do
|
||||
now <- getCurrentTime
|
||||
verifyIdToken cfg jwks now expectedNonce compact
|
||||
|
||||
verifyIdToken
|
||||
:: Config
|
||||
-> JWKSet
|
||||
-> UTCTime
|
||||
-> Text
|
||||
-> Text
|
||||
-> IO (Either Text OidcIdentity)
|
||||
verifyIdToken cfg jwks now expectedNonce compact = do
|
||||
let expectedIssuer = fromString (T.unpack (cfgOidcIssuer cfg))
|
||||
expectedAudience = fromString (T.unpack (cfgOidcClientId cfg))
|
||||
expectedAudiences =
|
||||
expectedAudience :
|
||||
map (fromString . T.unpack) (cfgOidcAdditionalAudiences cfg)
|
||||
settings =
|
||||
defaultJWTValidationSettings (`elem` expectedAudiences)
|
||||
& issuerPredicate .~ (== expectedIssuer)
|
||||
& algorithms .~ singleton RS256
|
||||
result <- runJOSE $ do
|
||||
jwt <- decodeCompact (BL.fromStrict (TE.encodeUtf8 compact))
|
||||
verifyJWT settings jwks (jwt :: SignedJWT)
|
||||
pure $ case result of
|
||||
Left (_ :: JWTError) -> Left "OIDC ID token validation failed"
|
||||
Right claims ->
|
||||
validateIdentity
|
||||
(cfgOidcClientId cfg)
|
||||
expectedAudiences
|
||||
claims
|
||||
where
|
||||
validateIdentity expectedClientId expectedAudiences claims
|
||||
| not (constantTimeTextEq expectedNonce (idTokenNonce claims)) =
|
||||
Left "OIDC nonce mismatch"
|
||||
| length expectedAudiences > 1
|
||||
, idTokenAuthorizedParty claims /= Just expectedClientId =
|
||||
Left "OIDC ID token authorized party is invalid"
|
||||
| Just authorizedParty <- idTokenAuthorizedParty claims
|
||||
, authorizedParty /= expectedClientId =
|
||||
Left "OIDC ID token authorized party is invalid"
|
||||
| Just (Audience audiences) <- idTokenRegistered claims ^. claimAud
|
||||
, Set.fromList audiences == Set.fromList expectedAudiences
|
||||
, length audiences == length expectedAudiences =
|
||||
validateRegisteredClaims claims
|
||||
| Just (Audience audiences) <- idTokenRegistered claims ^. claimAud
|
||||
, all (`elem` audiences) expectedAudiences =
|
||||
Left "OIDC ID token audience is not exclusive"
|
||||
| otherwise =
|
||||
Left "OIDC ID token audience is invalid"
|
||||
validateRegisteredClaims claims = do
|
||||
issuer <- requiredStringOrUri "issuer" (idTokenRegistered claims ^. claimIss)
|
||||
subject <- requiredStringOrUri "subject" (idTokenRegistered claims ^. claimSub)
|
||||
issuedAt <- requiredDate "issued-at" (idTokenRegistered claims ^. claimIat)
|
||||
expiresAt <- requiredDate "expiration" (idTokenRegistered claims ^. claimExp)
|
||||
if T.null issuer || T.null subject
|
||||
then Left "OIDC ID token identity is empty"
|
||||
else if issuedAt > addUTCTime 30 now
|
||||
then Left "OIDC ID token issued-at is in the future"
|
||||
else if expiresAt <= issuedAt
|
||||
|| diffUTCTime expiresAt issuedAt >
|
||||
fromInteger (cfgOidcMaxIdTokenSeconds cfg)
|
||||
then Left "OIDC ID token lifetime exceeds policy"
|
||||
else Right OidcIdentity
|
||||
{ identityIssuer = issuer
|
||||
, identitySubject = subject
|
||||
, identityDisplay =
|
||||
idTokenName claims
|
||||
<|> idTokenPreferred claims
|
||||
}
|
||||
|
||||
mintTransaction
|
||||
:: Config
|
||||
-> Text
|
||||
-> Text
|
||||
-> Text
|
||||
-> IO (Either Text Text)
|
||||
mintTransaction cfg state nonce verifier = do
|
||||
now <- getCurrentTime
|
||||
let expires =
|
||||
addUTCTime
|
||||
(fromInteger (cfgOidcTransactionMinutes cfg * 60))
|
||||
now
|
||||
claims = TransactionClaims
|
||||
{ transactionRegistered =
|
||||
emptyClaimsSet
|
||||
& claimIss ?~ "nuthatch"
|
||||
& claimAud ?~ Audience ["nuthatch-oidc-callback"]
|
||||
& claimIat ?~ NumericDate now
|
||||
& claimExp ?~ NumericDate expires
|
||||
, transactionState = state
|
||||
, transactionNonce = nonce
|
||||
, transactionVerifier = verifier
|
||||
, transactionIssuer = cfgOidcIssuer cfg
|
||||
, transactionClientId = cfgOidcClientId cfg
|
||||
, transactionRedirectUri = cfgOidcRedirectUri cfg
|
||||
, transactionReturnTarget = "/"
|
||||
}
|
||||
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
|
||||
result <- runJOSE $
|
||||
encodeCompact <$> signJWT key (newJWSHeaderProtected HS256) claims
|
||||
pure $ case result of
|
||||
Left (_ :: JWTError) -> Left "OIDC transaction creation failed"
|
||||
Right token -> Right (TE.decodeUtf8 (BL.toStrict token))
|
||||
|
||||
verifyTransaction :: Config -> Text -> IO (Either Text TransactionClaims)
|
||||
verifyTransaction cfg compact = do
|
||||
let key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
|
||||
settings =
|
||||
defaultJWTValidationSettings (== "nuthatch-oidc-callback")
|
||||
& issuerPredicate .~ (== "nuthatch")
|
||||
& algorithms .~ singleton HS256
|
||||
result <- runJOSE $ do
|
||||
jwt <- decodeCompact (BL.fromStrict (TE.encodeUtf8 compact))
|
||||
verifyJWT settings key (jwt :: SignedJWT)
|
||||
pure $ case result of
|
||||
Left (_ :: JWTError) -> Left "OIDC transaction validation failed"
|
||||
Right claims -> Right claims
|
||||
|
||||
extendClaims :: ClaimsSet -> [(Key, A.Value)] -> A.Value
|
||||
extendClaims registered fields =
|
||||
case A.toJSON registered of
|
||||
A.Object object ->
|
||||
A.Object (foldr (uncurry KM.insert) object fields)
|
||||
value -> value
|
||||
|
||||
requiredStringOrUri
|
||||
:: Text
|
||||
-> Maybe StringOrURI
|
||||
-> Either Text Text
|
||||
requiredStringOrUri label value =
|
||||
case A.toJSON <$> value of
|
||||
Just (A.String text) -> Right text
|
||||
_ -> Left ("OIDC ID token is missing " <> label)
|
||||
|
||||
requiredDate :: Text -> Maybe NumericDate -> Either Text UTCTime
|
||||
requiredDate _ (Just (NumericDate value)) = Right value
|
||||
requiredDate label Nothing = Left ("OIDC ID token is missing " <> label)
|
||||
|
||||
randomBase64Url :: Int -> IO Text
|
||||
randomBase64Url size =
|
||||
TE.decodeUtf8 . B64.encodeUnpadded <$> getEntropy size
|
||||
|
||||
constantTimeTextEq :: Text -> Text -> Bool
|
||||
constantTimeTextEq left right =
|
||||
let leftBytes = TE.encodeUtf8 left
|
||||
rightBytes = TE.encodeUtf8 right
|
||||
in BS.length leftBytes == BS.length rightBytes
|
||||
&& BA.constEq
|
||||
(hash leftBytes :: Digest SHA256)
|
||||
(hash rightBytes :: Digest SHA256)
|
||||
|
||||
catchOidcHttp :: Text -> IO (Either Text value) -> IO (Either Text value)
|
||||
catchOidcHttp message action =
|
||||
action `catch` \(_ :: HttpException) -> pure (Left message)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
module Nuthatch.Ui
|
||||
( loginPage
|
||||
, browserScript
|
||||
( browserScript
|
||||
, browsePage
|
||||
, htmlResponse
|
||||
, escapeHtml
|
||||
|
|
@ -30,19 +29,6 @@ escapeHtml =
|
|||
'\'' -> "'"
|
||||
c -> T.singleton c
|
||||
|
||||
loginPage :: Text -> Text
|
||||
loginPage err =
|
||||
page "Nuthatch login" $
|
||||
T.unlines
|
||||
[ "<h1>Nuthatch</h1>"
|
||||
, "<p>Development login (OIDC is not wired in the MVP).</p>"
|
||||
, if T.null err then "" else "<p class=\"err\">" <> escapeHtml err <> "</p>"
|
||||
, "<form method=\"post\" action=\"/login\">"
|
||||
, " <label>Username <input name=\"username\" required autofocus></label>"
|
||||
, " <button type=\"submit\">Sign in</button>"
|
||||
, "</form>"
|
||||
]
|
||||
|
||||
browsePage
|
||||
:: SessionUser
|
||||
-> Root
|
||||
|
|
|
|||
Loading…
Reference in a new issue