ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Complete runtime resilience and audit controls

Browse source
This commit is contained in:
ms2k 2026-07-19 03:41:01 +09:00
commit 728abdbbf1
11 changed files with 1466 additions and 251 deletions
Download patch file Download diff file Expand all files Collapse all files

10
src/Nuthatch/Api.hs
View file

@ -105,7 +105,7 @@ data SessionContext = SessionContext
{ sessionUser :: SessionUser
, sessionCsrf :: Maybe CsrfToken
}
deriving stock (Eq, Show)
deriving stock (Eq)
data SessionAuth
@ -170,7 +170,7 @@ data DeleteRequest = DeleteRequest
, deleteOperationId :: OperationId
, deleteCsrf :: CsrfToken
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance FromJSON DeleteRequest where
parseJSON = withObject "DeleteRequest" $ \o ->
@ -185,7 +185,7 @@ data DeletePrefixRequest = DeletePrefixRequest
, deletePrefixPath :: RelativePath
, deletePrefixCsrf :: CsrfToken
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance FromJSON DeletePrefixRequest where
parseJSON = withObject "DeletePrefixRequest" $ \o ->
@ -378,7 +378,7 @@ data SessionResponse = SessionResponse
, sessionResponseDisplay :: Maybe Text
, sessionResponseCsrf :: CsrfToken
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance ToJSON SessionResponse where
toJSON response = object
@ -416,7 +416,7 @@ data DeleteBatchRequest = DeleteBatchRequest
, deleteBatchCsrf :: CsrfToken
, deleteBatchItems :: [DeleteBatchItem]
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance FromJSON DeleteBatchRequest where
parseJSON = withObject "DeleteBatchRequest" $ \o ->

355
src/Nuthatch/App.hs
View file

@ -16,11 +16,13 @@ module Nuthatch.App
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (mapConcurrently_)
import Control.Exception
( SomeException
( IOException
, SomeException
, fromException
, throwIO
, try
, tryJust
)
import Control.Monad (forM, forever, when)
import Control.Monad (forM, forM_, forever, when)
import Control.Monad.IO.Class (liftIO)
import Control.Retry
( retrying )
@ -35,7 +37,7 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import Data.Word (Word64)
import Database.PostgreSQL.Simple (Only (..))
import Database.PostgreSQL.Simple (Only (..), SqlError)
import GHC.Clock (getMonotonicTimeNSec)
import Network.HTTP.Types
( hContentType
@ -51,7 +53,7 @@ import Network.HTTP.Types
import qualified Network.HTTP.Types.URI as URI
import Network.Wai (Request (..), responseFile, responseLBS)
import Nuthatch.Api
import Nuthatch.Audit (audit)
import Nuthatch.Audit (audit, objectKeyFields)
import Nuthatch.Config (Config (..))
import Nuthatch.Db (Db, ensurePersonalPool, withTransaction)
import qualified Nuthatch.Db as Db
@ -60,6 +62,7 @@ import Nuthatch.Paths
import Nuthatch.Protocol
import Nuthatch.Redis
( Redis
, cacheGeneration
, cacheGet
, cacheInvalidatePrefixes
, cacheSet
@ -68,6 +71,7 @@ import Nuthatch.Redis
)
import Nuthatch.Recovery
( recoveryRetryPolicy
, trySynchronous
)
import Nuthatch.S3
( ListPage (..)
@ -242,10 +246,20 @@ authenticationHandler cfg = mkAuthHandler $ \request -> do
let cookies = requestCookies request
sessionName = TE.encodeUtf8 (cfgCookieName cfg)
csrfName = TE.encodeUtf8 (cfgCsrfCookieName cfg)
token <- maybe (throwError loginRequired) pure (lookup sessionName cookies)
token <- case lookup sessionName cookies of
Nothing -> do
liftIO $ audit "authentication" "rejected" Nothing
[("reason", A.String "missing_session")]
throwError loginRequired
Just value -> pure value
sessionToken <- parseCookieValue validateSessionToken token
verified <- liftIO (verifySession cfg sessionToken)
user <- either (const (throwError loginRequired)) pure verified
user <- case verified of
Left _ -> do
liftIO $ audit "authentication" "rejected" Nothing
[("reason", A.String "invalid_session")]
throwError loginRequired
Right value -> pure value
csrf <- traverse
(parseCookieValue validateCsrfToken)
(lookup csrfName cookies)
@ -260,17 +274,19 @@ authenticationHandler cfg = mkAuthHandler $ \request -> do
}
parseCookieValue validate bytes =
case TE.decodeUtf8' bytes of
Left _ -> throwOperationError err400 MalformedAuthentication
Left _ -> rejectMalformed
Right value ->
either
(const (throwOperationError err400 MalformedAuthentication))
pure
(validate value)
either (const rejectMalformed) pure (validate value)
rejectMalformed = do
liftIO $ audit "authentication" "rejected" Nothing
[("reason", A.String "malformed_credential")]
throwOperationError err400 MalformedAuthentication
handleReady :: Env -> Handler ReadyResponse
handleReady env = do
pg <- liftIO $
try (Db.query_ (envDb env) "SELECT 1") :: Handler (Either SomeException [Only Int])
trySynchronous (Db.query_ (envDb env) "SELECT 1")
:: Handler (Either SomeException [Only Int])
case pg of
Right _ -> pure (ReadyResponse True)
Left _ -> throwOperationError err503 ReadyDependencyUnavailable
@ -281,10 +297,13 @@ handleLoginRequest
handleLoginRequest env = do
let cfg = envConfig env
authorizationResult <- liftIO (beginAuthorization cfg)
authorization <- either
(const (throwOperationError err502 OidcAuthorizationFailed))
pure
authorizationResult
authorization <- case authorizationResult of
Left _ -> do
liftIO $ audit "login_start" "rejected" Nothing
[("reason", A.String "provider_unavailable")]
throwOperationError err502 OidcAuthorizationFailed
Right value -> pure value
liftIO $ audit "login_start" "ok" Nothing []
pure $
addHeader
(cookieValue
@ -304,10 +323,12 @@ 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)
transactionBytes <- case lookup transactionName cookies of
Nothing -> rejectCallback "missing_transaction"
Just value -> pure value
transaction <- case TE.decodeUtf8' transactionBytes of
Right value | not (T.null value) && T.length value <= 8192 -> pure value
_ -> rejectCallback "malformed_transaction"
identityResult <- liftIO (redeemAuthorizationCode cfg transaction state code)
identity <- case identityResult of
Left reason -> do
@ -323,12 +344,21 @@ handleOidcCallback env code state cookieHeader = do
(identitySubject identity)
(identityDisplay identity)
token <- either
(const (throwOperationError err500 (SessionCreationFailed "session creation failed")))
(\_ -> do
liftIO $ audit "login" "rejected" (Just (unUserId uid))
[("reason", A.String "session_creation_failed")]
throwOperationError err500
(SessionCreationFailed "session creation failed"))
pure
tokenResult
csrf <- liftIO newCsrfToken
liftIO $ audit "login" "ok" (Just (unUserId uid)) []
pure (loginResponse cfg token csrf)
where
rejectCallback reason = do
liftIO $ audit "login" "rejected" Nothing
[("reason", A.String reason)]
throwOperationError err400 OidcCallbackRejected
loginResponse :: Config -> SessionToken -> CsrfToken -> LoginSuccess
loginResponse cfg token csrf =
@ -346,8 +376,10 @@ handleLogoutRequest
-> CsrfToken
-> Handler LogoutSuccess
handleLogoutRequest env session providedCsrf = do
requireCsrf LogoutCsrfRejected session providedCsrf
requireCsrf "logout" LogoutCsrfRejected session providedCsrf
let cfg = envConfig env
liftIO $ audit "logout" "ok"
(Just (unUserId (suUserId (sessionUser session)))) []
pure $
addHeader (expiredCookieValue (cfgCookieName cfg) "/") $
addHeader (expiredCookieValue (cfgCsrfCookieName cfg) "/") $
@ -414,9 +446,9 @@ handleDownloadRequest env session root path requestedRange = do
let inspect = inspectBandwidth env user
body = getObjectSource (envS3 env) key (transferPieceSize env) inspect
liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
[ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON (oiSize info))
]
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON (oiSize info))
] <> objectKeyAudit (envConfig env) path)
let filename = basename path
pure $
addHeader (contentDisposition filename) $
@ -436,24 +468,49 @@ handleUploadRequest
-> SourceIO BS.ByteString
-> Handler UploadResponse
handleUploadRequest env session root path operation declaredSize contentIdentity providedCsrf bodySource = do
requireCsrf UploadCsrfRejected session providedCsrf
requireCsrf "put" UploadCsrfRejected session providedCsrf
let user = sessionUser session
size = unDeclaredSize declaredSize
configuredMaximum = cfgMaxObjectBytes (envConfig env)
when (size > configuredMaximum) $
when (size > configuredMaximum) $ do
liftIO $ audit "put" "rejected" (Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String "object_too_large")
] <> objectKeyAudit (envConfig env) path)
throwOperationError err413 UploadTooLarge
requireUploadBandwidth env user size
outcome <- liftIO $
runPut env user root path operation size contentIdentity bodySource
result <- either
throwPutFailure
pure
outcome
requireUploadBandwidth env user root path operation size
putAttempt <- liftIO $
tryRecoveryDependency
(runPut env user root path operation size contentIdentity bodySource)
outcome <- case putAttempt of
Left _ -> do
liftIO $ audit "put" "failed" (Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String "database_unavailable")
] <> objectKeyAudit (envConfig env) path)
throwOperationError err503
(UploadMutationRejected "database unavailable")
Right value -> pure value
result <- case outcome of
Left failure -> do
liftIO $ audit "put" "failed" (Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String (putFailureReason failure))
] <> objectKeyAudit (envConfig env) path)
throwPutFailure failure
Right value -> pure value
liftIO $ audit "put" (mutationAuditResult result) (Just (unUserId (suUserId user)))
[ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
]
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
] <> mutationReasonFields result
<> objectKeyAudit (envConfig env) path)
pure UploadResponse
{ uploadResponseOperationId = operation
, uploadResponseResult = result
@ -474,8 +531,15 @@ requireDownloadBandwidth env user size = do
Right False -> throwOperationError err429 DownloadBandwidthExceeded
Right True -> pure ()
requireUploadBandwidth :: Env -> SessionUser -> Integer -> Handler ()
requireUploadBandwidth env user size = do
requireUploadBandwidth
:: Env
-> SessionUser
-> Root
-> RelativePath
-> OperationId
-> Integer
-> Handler ()
requireUploadBandwidth env user root path operation size = do
available <- liftIO $
throttleCheck
(envRedis env)
@ -483,9 +547,19 @@ requireUploadBandwidth env user size = do
(suUserId user)
(min size (toInteger (transferPieceSize env)))
case available of
Left _ -> throwOperationError err503 UploadThrottleUnavailable
Right False -> throwOperationError err429 UploadBandwidthExceeded
Left _ -> reject "throttle_unavailable" err503 UploadThrottleUnavailable
Right False ->
reject "bandwidth_exceeded" err429 UploadBandwidthExceeded
Right True -> pure ()
where
reject reason status response = do
liftIO $ audit "put" "rejected" (Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON size)
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String reason)
] <> objectKeyAudit (envConfig env) path)
throwOperationError status response
inspectBandwidth :: Env -> SessionUser -> BS.ByteString -> IO ()
inspectBandwidth env user chunk = do
@ -509,21 +583,40 @@ handleDeleteRequest
-> DeleteRequest
-> Handler DeleteResponse
handleDeleteRequest env session request = do
requireCsrf DeleteCsrfRejected session (deleteCsrf request)
requireCsrf "delete" DeleteCsrfRejected session (deleteCsrf request)
let user = sessionUser session
operation = deleteOperationId request
root = deleteRoot request
outcome <- liftIO $
runDelete env user root (deletePath request) operation
result <- either
(throwOperationError err409 . DeleteMutationRejected)
pure
outcome
deleteAttempt <- liftIO $
tryRecoveryDependency
(runDelete env user root (deletePath request) operation)
outcome <- case deleteAttempt of
Left _ -> do
liftIO $ audit "delete" "failed"
(Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String "database_unavailable")
] <> objectKeyAudit (envConfig env) (deletePath request))
throwOperationError err503
(DeleteMutationRejected "database unavailable")
Right value -> pure value
result <- case outcome of
Left reason -> do
liftIO $ audit "delete" "failed"
(Just (unUserId (suUserId user)))
([ ("root", A.toJSON (rootLabel root))
, ("operation_id", A.toJSON (unOperationId operation))
, ("reason", A.String "object_store_unavailable")
] <> objectKeyAudit (envConfig env) (deletePath request))
throwOperationError err409 (DeleteMutationRejected reason)
Right value -> pure value
liftIO $ audit "delete" (mutationAuditResult result)
(Just (unUserId (suUserId user)))
[ ("root", A.toJSON (rootLabel root))
, ("operation_id", A.toJSON (unOperationId operation))
]
([ ("root", A.toJSON (rootLabel root))
, ("operation_id", A.toJSON (unOperationId operation))
] <> mutationReasonFields result
<> objectKeyAudit (envConfig env) (deletePath request))
pure DeleteResponse
{ deleteResponseOperationId = operation
, deleteResponseResult = result
@ -536,8 +629,13 @@ handleDeletePrefixRequest
-> SessionContext
-> DeletePrefixRequest
-> Handler DeletePrefixResponse
handleDeletePrefixRequest _env session request = do
requireCsrf DeletePrefixCsrfRejected session (deletePrefixCsrf request)
handleDeletePrefixRequest env session request = do
requireCsrf "delete_prefix" DeletePrefixCsrfRejected session (deletePrefixCsrf request)
liftIO $ audit "delete_prefix" "rejected"
(Just (unUserId (suUserId (sessionUser session))))
([ ("root", A.toJSON (rootLabel (deletePrefixRoot request)))
, ("reason", A.String "paged_delete_required")
] <> objectKeyAudit (envConfig env) (deletePrefixPath request))
throwOperationError err409
(DeletePrefixMutationRejected
"use delete-plan and delete-batch with client operation ids")
@ -585,18 +683,41 @@ handleDeleteBatchRequest
-> DeleteBatchRequest
-> Handler DeleteBatchResponse
handleDeleteBatchRequest env session request = do
requireCsrf DeletePrefixCsrfRejected session (deleteBatchCsrf request)
requireCsrf "delete_batch" DeletePrefixCsrfRejected session (deleteBatchCsrf request)
let items = deleteBatchItems request
when (null items || length items > cfgDeletePageSize (envConfig env)) $
when (null items || length items > cfgDeletePageSize (envConfig env)) $ do
liftIO $ audit "delete_batch" "rejected"
(Just (unUserId (suUserId (sessionUser session))))
[ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
, ("reason", A.String "invalid_batch_size")
]
throwOperationError err409
(DeletePrefixMutationRejected "delete batch size is invalid")
results <- liftIO $ forM items $ \item -> do
outcome <- runDelete
env
(sessionUser session)
(deleteBatchRoot request)
(deleteBatchPath item)
(deleteBatchOperationId item)
results <- forM items $ \item -> do
deleteAttempt <- liftIO $ tryRecoveryDependency $
runDelete
env
(sessionUser session)
(deleteBatchRoot request)
(deleteBatchPath item)
(deleteBatchOperationId item)
let outcome = case deleteAttempt of
Left _ -> Left "database unavailable"
Right value -> value
failureReason = case deleteAttempt of
Left _ -> "database_unavailable"
Right (Left _) -> "object_store_unavailable"
Right (Right _) -> ""
liftIO $ audit "delete" (either (const "failed") mutationAuditResult outcome)
(Just (unUserId (suUserId (sessionUser session))))
([ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
, ("operation_id", A.toJSON
(unOperationId (deleteBatchOperationId item)))
] <> either
(const [("reason", A.String failureReason)])
mutationReasonFields
outcome
<> objectKeyAudit (envConfig env) (deleteBatchPath item))
pure $ case outcome of
Left message -> DeleteItemResponse
{ deleteItemPath = deleteBatchPath item
@ -612,11 +733,23 @@ handleDeleteBatchRequest env session request = do
}
pure (DeleteBatchResponse results)
requireCsrf :: A.ToJSON error => error -> SessionContext -> CsrfToken -> Handler ()
requireCsrf csrfError session provided =
requireCsrf
:: A.ToJSON error
=> Text
-> error
-> SessionContext
-> CsrfToken
-> Handler ()
requireCsrf action csrfError session provided =
case sessionCsrf session of
Just expected | constantTimeEq expected provided -> pure ()
_ -> throwOperationError err403 csrfError
_ -> do
liftIO $ audit "authorization" "rejected"
(Just (unUserId (suUserId (sessionUser session))))
[ ("reason", A.String "csrf_rejected")
, ("operation", A.String action)
]
throwOperationError err403 csrfError
throwOperationError :: A.ToJSON error => ServerError -> error -> Handler a
throwOperationError serverError operationError =
@ -671,6 +804,34 @@ mutationAuditResult MutationFailed = "failed"
mutationAuditResult MutationRejected = "rejected"
mutationAuditResult MutationConflict = "conflict"
mutationReasonFields :: MutationResult -> [(Text, A.Value)]
mutationReasonFields MutationSucceeded = []
mutationReasonFields MutationPending =
[("reason", A.String "settlement_pending")]
mutationReasonFields MutationFailed =
[("reason", A.String "store_effect_failed")]
mutationReasonFields MutationRejected =
[("reason", A.String "admission_rejected")]
mutationReasonFields MutationConflict =
[("reason", A.String "operation_conflict")]
putFailureReason :: PutFailure -> Text
putFailureReason (PutDispatchFailed (PutObjectStreamError streamError)) =
case streamError of
UploadStreamInvalid _ -> "invalid_body"
UploadStreamSizeMismatch -> "size_mismatch"
UploadStreamIdentityMismatch -> "content_identity_mismatch"
putFailureReason (PutDispatchFailed (PutObjectBandwidthError bandwidthError)) =
case bandwidthError of
BandwidthUnavailable -> "throttle_unavailable"
BandwidthExceeded -> "bandwidth_exceeded"
putFailureReason (PutDispatchFailed (PutObjectStoreError _)) =
"object_store_unavailable"
objectKeyAudit :: Config -> RelativePath -> [(Text, A.Value)]
objectKeyAudit cfg =
objectKeyFields (cfgAuditObjectKeys cfg) . unRelativePath
contentDisposition :: Text -> Text
contentDisposition filename =
"attachment; filename=\"" <> fallback <> "\"; filename*=UTF-8''" <> encoded
@ -866,9 +1027,13 @@ listEntries
-> Maybe Text
-> IO (Either Text ([ListEntry], Maybe Text))
listEntries env user root prefix continuation = do
let cacheKey =
generation <- cacheGeneration (envRedis env) (suUserId user) root
let cacheOwner = case root of
Personal -> unUserId (suUserId user)
Shared -> "shared"
cacheKey =
"nuthatch:list:"
<> unUserId (suUserId user)
<> cacheOwner
<> ":"
<> rootLabel root
<> ":"
@ -876,6 +1041,7 @@ listEntries env user root prefix continuation = do
<> ":"
<> T.pack (show (cfgBrowsePageSize (envConfig env)))
<> ":"
<> maybe "unavailable" TE.decodeUtf8 generation
s3Prefix =
case root of
Personal -> "users/" <> unUserId (suUserId user) <> "/" <> prefixSlash
@ -884,9 +1050,9 @@ listEntries env user root prefix continuation = do
| T.null prefix = ""
| T.isSuffixOf "/" prefix = prefix
| otherwise = prefix <> "/"
cached <- case continuation of
Nothing -> cacheGet (envRedis env) cacheKey
Just _ -> pure Nothing
cached <- case (continuation, generation) of
(Nothing, Just _) -> cacheGet (envRedis env) cacheKey
_ -> pure Nothing
case cached >>= A.decodeStrict of
Just result -> pure (Right result)
Nothing -> do
@ -928,8 +1094,11 @@ listEntries env user root prefix continuation = do
]
entries = folders <> files
result = (entries, lpContinuationToken lp)
when (continuation == Nothing) $
cacheSet (envRedis env) cacheKey (cfgListCacheTtlSec (envConfig env))
when (continuation == Nothing && generation /= Nothing) $
cacheSet
(envRedis env)
cacheKey
(cfgListCacheTtlSec (envConfig env))
(BL.toStrict (A.encode result))
pure (Right result)
@ -1018,9 +1187,26 @@ collectKeysBoundedWith currentTime listPage maxKeys deadline =
runRecovery :: Env -> IO ()
runRecovery env = forever $ do
recoverOnce env
recovered <- tryRecoveryDependency (recoverOnce env)
case recovered of
Left _ ->
audit "dependency_runtime" "unavailable" Nothing
[ ("dependency", A.String "postgresql")
, ("reason", A.String "recovery_cycle_failed")
]
Right () -> pure ()
threadDelay (5 * 1000000)
tryRecoveryDependency :: IO value -> IO (Either SomeException value)
tryRecoveryDependency =
tryJust $ \exception ->
case ( fromException exception :: Maybe SqlError
, fromException exception :: Maybe IOException
) of
(Just _, _) -> Just exception
(_, Just _) -> Just exception
_ -> Nothing
recoverOnce :: Env -> IO ()
recoverOnce env = do
let grace = cfgRecoveryGraceSec (envConfig env)
@ -1051,6 +1237,15 @@ finalizeRecovered env rec = do
observed <- observeObjectWithRetry env rec
result <- withTransaction (envDb env) $ \conn ->
finalizeFromObservation conn rec observed
forM_ result $ \mutationResult ->
audit "recovery_mutation" (mutationAuditResult mutationResult)
(Just (unUserId (mrUserId rec)))
([ ("root", A.toJSON (rootLabel (recordRoot rec)))
, ("operation_id", A.toJSON (unOperationId (mrOperationId rec)))
] <> mutationReasonFields mutationResult
<> objectKeyAudit
(envConfig env)
(mrRelativePath rec))
when (result == Just MutationSucceeded) $
cacheInvalidatePrefixes
(envRedis env)
@ -1098,13 +1293,3 @@ lastSeg t =
requestCookies :: Request -> [(BS.ByteString, BS.ByteString)]
requestCookies request =
maybe [] parseCookies (lookup hCookie (requestHeaders request))
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

40
src/Nuthatch/Audit.hs
View file

@ -1,22 +1,52 @@
module Nuthatch.Audit
( audit
, auditValue
, objectKeyFields
) where
import Data.Aeson (Value, encode, object, (.=))
import Data.Aeson (Value (String), encode, object, (.=))
import qualified Data.Aeson.Key as Key
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
audit :: Text -> Text -> Maybe Text -> [(Text, Value)] -> IO ()
audit action result mUser extra = do
now <- getCurrentTime
L8.putStrLn (encode (auditValue now action result mUser extra))
auditValue :: UTCTime -> Text -> Text -> Maybe Text -> [(Text, Value)] -> Value
auditValue now action result mUser extra =
let pairs =
[ "ts" .= iso8601Show now
, "action" .= action
, "result" .= result
]
]
<> maybe [] (\u -> ["user_id" .= u]) mUser
<> [ Key.fromText k .= v | (k, v) <- extra ]
L8.putStrLn (encode (object pairs))
<>
[ Key.fromText k .= v
| (k, v) <- extra
, k `Set.member` allowedExtraFields
]
in object pairs
objectKeyFields :: Bool -> Text -> [(Text, Value)]
objectKeyFields includeObjectKey objectKey
| includeObjectKey = [("object_key", String objectKey)]
| otherwise = []
allowedExtraFields :: Set Text
allowedExtraFields = Set.fromList
[ "attempt"
, "attempts"
, "bytes"
, "dependency"
, "object_key"
, "operation"
, "operation_id"
, "reason"
, "root"
]

282
src/Nuthatch/Config.hs
View file

@ -1,18 +1,32 @@
module Nuthatch.Config
( Config (..)
, Secret
, secret
, revealSecret
, loadConfig
, parseRedisUri
, validateAbsoluteUri
) where
import Control.Exception (SomeException, try)
import Control.Monad (when)
import qualified Data.ByteString as BS
import Data.List (nub)
import Data.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Env
import Nuthatch.Streaming (maximumMultipartBytes)
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
import qualified Text.URI as URI
newtype Secret value = Secret value
secret :: value -> Secret value
secret = Secret
revealSecret :: Secret value -> value
revealSecret (Secret value) = value
data Config = Config
{ cfgListenHost :: String
@ -20,7 +34,7 @@ data Config = Config
, cfgTlsCertPath :: FilePath
, cfgTlsKeyPath :: FilePath
, cfgPublicBaseUrl :: Text
, cfgJwtSecret :: Text
, cfgJwtSecret :: Secret Text
, cfgSessionHours :: Integer
, cfgCookieName :: Text
, cfgCsrfCookieName :: Text
@ -28,19 +42,19 @@ data Config = Config
, cfgOidcIssuer :: Text
, cfgOidcClientId :: Text
, cfgOidcAdditionalAudiences :: [Text]
, cfgOidcClientSecret :: Text
, cfgOidcClientSecret :: Secret Text
, cfgOidcRedirectUri :: Text
, cfgOidcTransactionMinutes :: Integer
, cfgOidcMaxIdTokenSeconds :: Integer
, cfgPgConn :: String
, cfgPgConn :: Secret String
, cfgRedisHost :: String
, cfgRedisPort :: Int
, cfgRedisDb :: Integer
, cfgS3Endpoint :: Text
, cfgS3Region :: Text
, cfgS3Bucket :: Text
, cfgS3AccessKey :: Text
, cfgS3SecretKey :: Text
, cfgS3AccessKey :: Secret Text
, cfgS3SecretKey :: Secret Text
, cfgS3PathStyle :: Bool
, cfgPersonalQuotaBytes :: Integer
, cfgSharedQuotaBytes :: Integer
@ -55,53 +69,62 @@ data Config = Config
, cfgRecoveryGraceSec :: Integer
, cfgIdempotencyWindowSec :: Integer
, cfgObjectRequestTimeoutSec :: Integer
, cfgStartupAttempts :: Int
, cfgStartupDelayMs :: Int
, cfgAuditObjectKeys :: Bool
}
loadConfig :: IO Config
loadConfig = do
listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
listen <- envString "NUTHATCH_LISTEN" "127.0.0.1:8080"
let (host, portText) = splitHostPort listen
port <- requireRead "NUTHATCH_LISTEN port" portText
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 (BS.length (TE.encodeUtf8 jwtSecret) < 32) $
port <- parseValue "NUTHATCH_LISTEN port" portText
when (T.null (T.pack host) || port <= 0 || port > 65535) $
fail "NUTHATCH_LISTEN must contain a host and port between 1 and 65535"
tlsCertPath <- envString "NUTHATCH_TLS_CERT_PATH" "/tls/tls.crt"
tlsKeyPath <- envString "NUTHATCH_TLS_KEY_PATH" "/tls/tls.key"
publicBase <- requireText "NUTHATCH_PUBLIC_BASE_URL"
>>= validateAbsoluteUri "NUTHATCH_PUBLIC_BASE_URL" ["https"]
jwtSecretText <- requireTextSecret "NUTHATCH_JWT_SECRET"
when (BS.length (TE.encodeUtf8 jwtSecretText) < 32) $
fail "NUTHATCH_JWT_SECRET must be at least 32 bytes"
let jwtSecret = secret jwtSecretText
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)
cookieName <- T.pack <$> envString "NUTHATCH_COOKIE_NAME" "nuthatch_session"
csrfCookie <- T.pack <$> envString "NUTHATCH_CSRF_COOKIE_NAME" "nuthatch_csrf"
transactionCookie <- T.pack <$>
envString "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME" "nuthatch_oidc"
oidcIssuerValue <- requireText "NUTHATCH_OIDC_ISSUER"
oidcIssuer <- T.dropWhileEnd (== '/') <$>
validateAbsoluteUri "NUTHATCH_OIDC_ISSUER" ["http", "https"] oidcIssuerValue
oidcClientId <- requireText "NUTHATCH_OIDC_CLIENT_ID"
additionalAudienceValue <- T.strip . T.pack <$>
envString "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES" ""
let oidcAdditionalAudiences
| T.null additionalAudienceValue = []
| otherwise = map T.strip (T.splitOn "," additionalAudienceValue)
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"
oidcClientSecret <- secret <$> requireTextSecret "NUTHATCH_OIDC_CLIENT_SECRET"
oidcRedirectUri <- requireText "NUTHATCH_OIDC_REDIRECT_URI"
>>= validateAbsoluteUri "NUTHATCH_OIDC_REDIRECT_URI" ["https"]
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
s3Endpoint <- T.pack <$> requireEnv "NUTHATCH_S3_ENDPOINT"
s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
s3Bucket <- T.pack <$> requireEnv "NUTHATCH_S3_BUCKET"
s3Access <- T.pack <$> requireEnv "NUTHATCH_S3_ACCESS_KEY"
s3Secret <- T.pack <$> requireEnv "NUTHATCH_S3_SECRET_KEY"
pgConn <- secret <$> requireStringSecret "NUTHATCH_PG_CONN"
redisUrl <- requireText "NUTHATCH_REDIS_URL"
(redisHost, redisPort, redisDb) <- parseRedisUri redisUrl
s3Endpoint <- requireText "NUTHATCH_S3_ENDPOINT"
>>= validateOriginUri "NUTHATCH_S3_ENDPOINT" ["http", "https"]
s3Region <- T.pack <$> envString "NUTHATCH_S3_REGION" "us-east-1"
s3Bucket <- requireText "NUTHATCH_S3_BUCKET"
s3Access <- secret <$> requireTextSecret "NUTHATCH_S3_ACCESS_KEY"
s3Secret <- secret <$> requireTextSecret "NUTHATCH_S3_SECRET_KEY"
pathStyle <- envBool "NUTHATCH_S3_PATH_STYLE" True
personalQuota <- envInteger "NUTHATCH_PERSONAL_QUOTA_BYTES" (1024 * 1024 * 1024)
sharedQuota <- envInteger "NUTHATCH_SHARED_QUOTA_BYTES" (10 * 1024 * 1024 * 1024)
@ -115,27 +138,34 @@ loadConfig = do
when (throttleBurst <= 0 || throttleBurst > luaExactIntegerMax) $
fail "NUTHATCH_THROTTLE_BURST_BYTES exceeds the exact throttle range"
listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
browsePageSize <- fromInteger <$> envInteger "NUTHATCH_BROWSE_PAGE_SIZE" 200
searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
browsePageSize <- envBoundedInt "NUTHATCH_BROWSE_PAGE_SIZE" 200 1 1000
searchMax <- envBoundedInt "NUTHATCH_SEARCH_MAX_KEYS" 500 1 100000
searchTimeoutMs <- envInteger "NUTHATCH_SEARCH_TIMEOUT_MS" 2000
deletePageSize <- fromInteger <$> envInteger "NUTHATCH_DELETE_PAGE_SIZE" 100
deletePageSize <- envBoundedInt "NUTHATCH_DELETE_PAGE_SIZE" 100 1 1000
recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
objectRequestTimeout <- envInteger "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC" 300
startupAttempts <- envBoundedInt "NUTHATCH_STARTUP_ATTEMPTS" 60 1 1000
startupDelayMs <- envBoundedInt "NUTHATCH_STARTUP_DELAY_MS" 1000 1 60000
auditObjectKeys <- envBool "NUTHATCH_AUDIT_OBJECT_KEYS" False
when (recoveryGrace <= 0) $
fail "NUTHATCH_RECOVERY_GRACE_SEC must be positive"
when (idempotencyWindow <= 0) $
fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
when (objectRequestTimeout <= 0) $
fail "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC must be positive"
when (browsePageSize <= 0 || browsePageSize > 1000) $
fail "NUTHATCH_BROWSE_PAGE_SIZE must be between 1 and 1000"
when (searchMax <= 0 || searchMax > 100000) $
fail "NUTHATCH_SEARCH_MAX_KEYS must be between 1 and 100000"
when (sessionHours <= 0 || sessionHours > 168) $
fail "NUTHATCH_SESSION_HOURS must be between 1 and 168"
when (oidcTransactionMinutes <= 0 || oidcTransactionMinutes > 60) $
fail "NUTHATCH_OIDC_TRANSACTION_MINUTES must be between 1 and 60"
when (oidcMaxIdTokenSeconds <= 0 || oidcMaxIdTokenSeconds > 86400) $
fail "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS must be between 1 and 86400"
when (personalQuota <= 0 || sharedQuota <= 0) $
fail "configured quotas must be positive"
when (listTtl <= 0 || listTtl > 86400) $
fail "NUTHATCH_LIST_CACHE_TTL_SEC must be between 1 and 86400"
when (searchTimeoutMs <= 0 || searchTimeoutMs > 60000) $
fail "NUTHATCH_SEARCH_TIMEOUT_MS must be between 1 and 60000"
when (deletePageSize <= 0 || deletePageSize > 1000) $
fail "NUTHATCH_DELETE_PAGE_SIZE must be between 1 and 1000"
pure Config
{ cfgListenHost = host
, cfgListenPort = port
@ -177,6 +207,9 @@ loadConfig = do
, cfgRecoveryGraceSec = recoveryGrace
, cfgIdempotencyWindowSec = idempotencyWindow
, cfgObjectRequestTimeoutSec = objectRequestTimeout
, cfgStartupAttempts = startupAttempts
, cfgStartupDelayMs = startupDelayMs
, cfgAuditObjectKeys = auditObjectKeys
}
luaExactIntegerMax :: Integer
@ -184,56 +217,117 @@ luaExactIntegerMax = 9007199254740991
splitHostPort :: String -> (String, String)
splitHostPort s =
case break (== ':') s of
(h, ':' : p) -> (h, p)
_ -> ("127.0.0.1", "8080")
requireEnv :: String -> IO String
requireEnv name = do
value <- lookupEnv name
case value of
Just present | not (null present) -> pure present
_ -> fail $ name <> " is required"
case span (/= ':') s of
(h, ':' : p) | not (null h) && not (null p) -> (h, p)
_ -> ("", "")
envInteger :: String -> Integer -> IO Integer
envInteger name def = do
m <- lookupEnv name
case m of
Nothing -> pure def
Just v -> requireRead name v
envInteger name defaultValue =
Env.parse configInfo (Env.var Env.auto name (Env.def defaultValue))
envBoundedInt :: String -> Integer -> Integer -> Integer -> IO Int
envBoundedInt name defaultValue minimumValue maximumValue = do
value <- envInteger name defaultValue
when (value < minimumValue || value > maximumValue) $
fail
(name <> " must be between "
<> show minimumValue <> " and " <> show maximumValue)
pure (fromInteger value)
envBool :: String -> Bool -> IO Bool
envBool name def = do
m <- lookupEnv name
case fmap T.toLower (T.pack <$> m) of
Nothing -> pure def
Just "1" -> pure True
Just "true" -> pure True
Just "yes" -> pure True
Just "0" -> pure False
Just "false" -> pure False
Just "no" -> pure False
Just other -> fail $ name <> ": invalid boolean " <> T.unpack other
envBool name defaultValue =
Env.parse configInfo $
Env.var (Env.eitherReader parseBoolean) name (Env.def defaultValue)
where
parseBoolean value =
case map toLowerAscii value of
"1" -> Right True
"true" -> Right True
"yes" -> Right True
"0" -> Right False
"false" -> Right False
"no" -> Right False
_ -> Left "expected true or false"
toLowerAscii c
| c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
| otherwise = c
requireRead :: (Read a) => String -> String -> IO a
requireRead name v =
case readMaybe v of
Just x -> pure x
Nothing -> fail $ name <> ": cannot parse " <> v
envString :: String -> String -> IO String
envString name defaultValue =
Env.parse configInfo (Env.var Env.str name (Env.def defaultValue))
parseRedisUrl :: String -> IO (String, Int, Integer)
parseRedisUrl url =
case T.stripPrefix "redis://" (T.pack url) of
Nothing -> fail "NUTHATCH_REDIS_URL must start with redis://"
Just rest -> do
let (hostPort, dbPart) =
case T.breakOn "/" rest of
(hp, d) | T.null d -> (hp, "/0")
(hp, d) -> (hp, d)
(hostText, portText) =
case T.breakOn ":" hostPort of
(h, p) | T.null p -> (h, "6379")
(h, p) -> (h, T.drop 1 p)
port <- requireRead "redis port" (T.unpack portText)
db <- requireRead "redis db" (T.unpack (T.drop 1 dbPart))
pure (T.unpack hostText, port, db)
requireText :: String -> IO Text
requireText name = T.pack <$>
Env.parse configInfo (Env.var Env.nonempty name mempty)
requireTextSecret :: String -> IO Text
requireTextSecret name = T.pack <$>
Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))
requireStringSecret :: String -> IO String
requireStringSecret name =
Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))
parseValue :: Read value => String -> String -> IO value
parseValue name value =
case reads value of
[(parsed, "")] -> pure parsed
_ -> fail (name <> " is invalid")
configInfo :: Env.Info Env.Error -> Env.Info Env.Error
configInfo = Env.header "Nuthatch configuration"
validateAbsoluteUri :: String -> [Text] -> Text -> IO Text
validateAbsoluteUri name allowedSchemes value = do
parsed <- try (URI.mkURI value) :: IO (Either SomeException URI.URI)
uri <- either (const (fail (name <> " is not a valid URI"))) pure parsed
scheme <- maybe (fail (name <> " must be absolute"))
(pure . T.toLower . URI.unRText)
(URI.uriScheme uri)
when (scheme `notElem` allowedSchemes) $
fail (name <> " uses an unsupported scheme")
authority <- either
(const (fail (name <> " must contain an authority")))
pure
(URI.uriAuthority uri)
when (URI.authUserInfo authority /= Nothing) $
fail (name <> " must not contain credentials")
when (T.null (URI.unRText (URI.authHost authority))) $
fail (name <> " must contain a host")
pure (URI.render uri)
validateOriginUri :: String -> [Text] -> Text -> IO Text
validateOriginUri name allowedSchemes value = do
rendered <- validateAbsoluteUri name allowedSchemes value
parsed <- URI.mkURI rendered
when
(URI.uriPath parsed /= Nothing
|| not (null (URI.uriQuery parsed))
|| URI.uriFragment parsed /= Nothing) $
fail (name <> " must be an origin without path, query, or fragment")
pure rendered
parseRedisUri :: Text -> IO (String, Int, Integer)
parseRedisUri value = do
rendered <- validateAbsoluteUri "NUTHATCH_REDIS_URL" ["redis"] value
parsed <- URI.mkURI rendered
authority <- either
(const (fail "NUTHATCH_REDIS_URL must contain an authority"))
pure
(URI.uriAuthority parsed)
when (not (null (URI.uriQuery parsed)) || URI.uriFragment parsed /= Nothing) $
fail "NUTHATCH_REDIS_URL must not contain a query or fragment"
database <- case URI.uriPath parsed of
Nothing -> pure 0
Just (_, segment :| []) ->
parseValue "NUTHATCH_REDIS_URL database" (T.unpack (URI.unRText segment))
_ -> fail "NUTHATCH_REDIS_URL must contain at most one database path segment"
let port = maybe 6379 fromIntegral (URI.authPort authority)
when (database < 0 || database > 15) $
fail "NUTHATCH_REDIS_URL database must be between 0 and 15"
let renderedHost = URI.unRText (URI.authHost authority)
connectionHost =
fromMaybeText renderedHost (T.stripPrefix "[" renderedHost >>= T.stripSuffix "]")
pure (T.unpack connectionHost, port, database)
where
fromMaybeText fallback = maybe fallback id

32
src/Nuthatch/Db.hs
View file

@ -12,7 +12,8 @@ module Nuthatch.Db
, executeMany
) where
import Control.Exception (bracket, throwIO)
import Control.Exception (bracket, finally, throwIO)
import Control.Monad (void)
import qualified Data.ByteString.Char8 as BS8
import Data.Pool
( Pool
@ -22,7 +23,12 @@ import Data.Pool
, setNumStripes
, withResource
)
import Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
import Database.PostgreSQL.Simple
( Connection
, Only
, close
, connectPostgreSQL
)
import qualified Database.PostgreSQL.Simple as PG
import Database.PostgreSQL.Simple.Migration
( MigrationCommand (..)
@ -31,14 +37,14 @@ import Database.PostgreSQL.Simple.Migration
, runMigration
)
import qualified Database.PostgreSQL.Simple.Transaction as PGT
import Nuthatch.Config (Config (..))
import Nuthatch.Config (Config (..), revealSecret)
import Nuthatch.Types
type Db = Pool Connection
withDb :: Config -> (Db -> IO a) -> IO a
withDb cfg action = do
let mk = connectPostgreSQL (BS8.pack (cfgPgConn cfg))
let mk = connectPostgreSQL (BS8.pack (revealSecret (cfgPgConn cfg)))
poolCfg =
setNumStripes (Just 1) $
defaultPoolConfig mk close 30 10
@ -46,10 +52,20 @@ withDb cfg action = do
migrate :: Db -> FilePath -> Config -> IO ()
migrate db migrationDirectory cfg = withResource db $ \conn -> do
result <- runMigration conn defaultOptions $
MigrationInitialization
<> MigrationDirectory migrationDirectory
<> MigrationValidation (MigrationDirectory migrationDirectory)
void
(PG.query_ conn
"SELECT pg_advisory_lock(564741953576419031) IS NULL"
:: IO [Only Bool])
result <-
runMigration conn defaultOptions
( MigrationInitialization
<> MigrationDirectory migrationDirectory
<> MigrationValidation (MigrationDirectory migrationDirectory)
)
`finally` void
(PG.query_ conn
"SELECT pg_advisory_unlock(564741953576419031)"
:: IO [Only Bool])
case result of
MigrationSuccess ->
PGT.withTransaction conn $

14
src/Nuthatch/Oidc.hs
View file

@ -66,14 +66,14 @@ import Network.HTTP.Simple
, setRequestMethod
)
import Network.HTTP.Types.URI (renderQuery)
import Nuthatch.Config (Config (..))
import Nuthatch.Config (Config (..), revealSecret)
import System.Entropy (getEntropy)
data AuthorizationRequest = AuthorizationRequest
{ authorizationLocation :: Text
, authorizationTransaction :: Text
}
deriving stock (Eq, Show)
deriving stock (Eq)
data OidcIdentity = OidcIdentity
{ identityIssuer :: Text
@ -115,7 +115,7 @@ data TransactionClaims = TransactionClaims
, transactionRedirectUri :: Text
, transactionReturnTarget :: Text
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance HasClaimsSet TransactionClaims where
claimsSet update claims =
@ -157,7 +157,7 @@ data IdTokenClaims = IdTokenClaims
, idTokenName :: Maybe Text
, idTokenPreferred :: Maybe Text
}
deriving stock (Eq, Show)
deriving stock (Eq)
instance HasClaimsSet IdTokenClaims where
claimsSet update claims =
@ -281,7 +281,7 @@ exchangeCode cfg discovery transaction code = do
let request =
applyBasicAuth
(TE.encodeUtf8 (cfgOidcClientId cfg))
(TE.encodeUtf8 (cfgOidcClientSecret cfg)) $
(TE.encodeUtf8 (revealSecret (cfgOidcClientSecret cfg))) $
setRequestMethod "POST" $
setRequestBodyURLEncoded
[ ("grant_type", "authorization_code")
@ -410,7 +410,7 @@ mintTransaction cfg state nonce verifier = do
, transactionRedirectUri = cfgOidcRedirectUri cfg
, transactionReturnTarget = "/"
}
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
result <- runJOSE $
encodeCompact <$> signJWT key (newJWSHeaderProtected HS256) claims
pure $ case result of
@ -419,7 +419,7 @@ mintTransaction cfg state nonce verifier = do
verifyTransaction :: Config -> Text -> IO (Either Text TransactionClaims)
verifyTransaction cfg compact = do
let key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
let key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
settings =
defaultJWTValidationSettings (== "nuthatch-oidc-callback")
& issuerPredicate .~ (== "nuthatch")

27
src/Nuthatch/Redis.hs
View file

@ -3,6 +3,7 @@ module Nuthatch.Redis
, withRedis
, cacheGet
, cacheSet
, cacheGeneration
, cacheInvalidatePrefixes
, throttleCheck
, throttleTake
@ -18,10 +19,11 @@ import Database.Redis
( ConnectInfo (..)
, Connection
, Reply
, checkedConnect
, connect
, defaultConnectInfo
, del
, get
, incr
, runRedis
, setex
)
@ -34,7 +36,7 @@ type Redis = Connection
withRedis :: Config -> (Redis -> IO a) -> IO a
withRedis cfg action = do
conn <- checkedConnect defaultConnectInfo
conn <- connect defaultConnectInfo
{ connectHost = cfgRedisHost cfg
, connectPort = R.PortNumber (fromIntegral (cfgRedisPort cfg))
, connectDatabase = cfgRedisDb cfg
@ -56,6 +58,16 @@ cacheSet conn key ttl value = do
:: IO (Either SomeException (Either Reply R.Status))
pure ()
cacheGeneration :: Redis -> UserId -> Root -> IO (Maybe ByteString)
cacheGeneration conn uid root = do
let key = TE.encodeUtf8 (cacheGenerationKey uid root)
result <- trySynchronous (runRedis conn (get key))
:: IO (Either SomeException (Either Reply (Maybe ByteString)))
pure $ case result of
Right (Right Nothing) -> Just "0"
Right (Right value) -> value
_ -> Nothing
cacheInvalidatePrefixes :: Redis -> UserId -> Root -> [Text] -> IO ()
cacheInvalidatePrefixes conn uid root prefixes = do
let ks =
@ -69,6 +81,17 @@ cacheInvalidatePrefixes conn uid root prefixes = do
_ <- trySynchronous (runRedis conn (del ks))
:: IO (Either SomeException (Either Reply Integer))
pure ()
_ <- trySynchronous $
runRedis conn (incr (TE.encodeUtf8 (cacheGenerationKey uid root)))
:: IO (Either SomeException (Either Reply Integer))
pure ()
cacheGenerationKey :: UserId -> Root -> Text
cacheGenerationKey uid root =
"nuthatch:list-generation:"
<> case root of
Personal -> unUserId uid <> ":personal"
Shared -> "shared"
throttleCheck :: Redis -> Config -> UserId -> Integer -> IO (Either Text Bool)
throttleCheck conn cfg uid bytes =

45
src/Nuthatch/Runtime.hs Normal file
View file

@ -0,0 +1,45 @@
module Nuthatch.Runtime
( retryStartup
) where
import Control.Exception (SomeException)
import Control.Retry
( RetryStatus (..)
, constantDelay
, limitRetries
, retrying
)
import Data.Aeson (Value (String), toJSON)
import Data.Either (isLeft)
import Data.Text (Text)
import qualified Data.Text as T
import Nuthatch.Audit (audit)
import Nuthatch.Recovery (trySynchronous)
retryStartup :: Int -> Int -> Text -> IO value -> IO value
retryStartup attempts delayMs dependency action = do
result <- retrying policy shouldRetry $ \_ ->
tryStartup action
case result of
Right value -> pure value
Left _ -> do
audit "dependency_startup" "exhausted" Nothing
[ ("dependency", String dependency)
, ("attempts", toJSON attempts)
]
fail ("startup dependency unavailable: " <> T.unpack dependency)
where
policy =
limitRetries (max 0 (attempts - 1))
<> constantDelay (max 1 delayMs * 1000)
shouldRetry status outcome = do
if isLeft outcome
then audit "dependency_startup" "retry" Nothing
[ ("dependency", String dependency)
, ("attempt", toJSON (rsIterNumber status + 1))
]
else pure ()
pure (isLeft outcome)
tryStartup :: IO value -> IO (Either SomeException value)
tryStartup = trySynchronous

6
src/Nuthatch/S3.hs
View file

@ -61,7 +61,7 @@ import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (statusCode)
import Network.URI (URI (..), URIAuth (..), parseURI)
import Nuthatch.Config (Config (..))
import Nuthatch.Config (Config (..), revealSecret)
import Nuthatch.Streaming
( BandwidthError (..)
, UploadStreamError (..)
@ -116,8 +116,8 @@ newS3 :: Config -> IO S3
newS3 cfg = do
(protocol, endpointHost, endpointPort) <- parseEndpoint (cfgS3Endpoint cfg)
credentials <- Aws.makeCredentials
(TE.encodeUtf8 (cfgS3AccessKey cfg))
(TE.encodeUtf8 (cfgS3SecretKey cfg))
(TE.encodeUtf8 (revealSecret (cfgS3AccessKey cfg)))
(TE.encodeUtf8 (revealSecret (cfgS3SecretKey cfg)))
let defaultPort = case protocol of
AwsCore.HTTP -> 80
AwsCore.HTTPS -> 443

6
src/Nuthatch/Session.hs
View file

@ -45,7 +45,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (addUTCTime, getCurrentTime)
import Nuthatch.Config (Config (..))
import Nuthatch.Config (Config (..), revealSecret)
import Nuthatch.Paths (encodeUserId)
import Nuthatch.Types
import System.Entropy (getEntropy)
@ -108,7 +108,7 @@ mintSession cfg issuer subject display = do
, oidcSubject = subject
, displayName = display
}
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
header = newJWSHeaderProtected HS256
encodeCompact <$> signJWT key header claims
pure $ case result of
@ -126,7 +126,7 @@ verifySession cfg (SessionToken token) = do
defaultJWTValidationSettings (== applicationAudience)
& issuerPredicate .~ (== applicationIssuer)
& algorithms .~ singleton HS256
key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
verifyJWT settings key (jwt :: SignedJWT)
pure $ case result of
Left (_ :: JWTError) -> Left "session token validation failed"

4
src/Nuthatch/Types.hs
View file

@ -125,10 +125,10 @@ instance FromJSON OperationId where
either (fail . T.unpack) pure . validateOperationId
newtype SessionToken = SessionToken { unSessionToken :: Text }
deriving stock (Eq, Ord, Show)
deriving stock (Eq, Ord)
newtype CsrfToken = CsrfToken { unCsrfToken :: Text }
deriving stock (Eq, Ord, Show)
deriving stock (Eq, Ord)
deriving newtype (ToJSON)
instance FromJSON CsrfToken where