ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Harden mutation admission and storage observation

Browse source
This commit is contained in:
ms2k 2026-07-18 15:22:57 +09:00
commit 1b1d8b06c7
13 changed files with 969 additions and 461 deletions
Download patch file Download diff file Expand all files Collapse all files

17
Dockerfile
View file

@ -19,11 +19,12 @@ COPY app ./app
COPY src ./src
COPY test ./test
RUN cabal build exe:nuthatch \
RUN cabal build exe:nuthatch exe:nuthatch-wp04-integration \
&& mkdir -p /out \
&& cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch
&& cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch \
&& cp "$(cabal list-bin exe:nuthatch-wp04-integration)" /out/nuthatch-wp04-integration
FROM debian:bookworm-slim AS runtime
FROM debian:bookworm-slim AS runtime-base
RUN apt-get update \
&& apt-get install -y --no-install-recommends \
@ -33,7 +34,6 @@ RUN apt-get update \
&& rm -rf /var/lib/apt/lists/*
WORKDIR /app
COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
COPY sql ./sql
ENV NUTHATCH_LISTEN=0.0.0.0:8080 \
@ -49,5 +49,14 @@ ENV NUTHATCH_LISTEN=0.0.0.0:8080 \
NUTHATCH_S3_PATH_STYLE=true \
NUTHATCH_AUTH_MODE=dev
FROM runtime-base AS test-runtime
COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
COPY --from=build /out/nuthatch-wp04-integration /usr/local/bin/nuthatch-wp04-integration
FROM runtime-base AS runtime
COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
EXPOSE 8080
CMD ["nuthatch"]

5
Makefile
View file

@ -1,4 +1,4 @@
.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-frontend build-frontend mvp-up mvp-down mvp-build mvp-logs mvp-ps
.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-frontend build-frontend mvp-up mvp-down mvp-build mvp-logs mvp-ps
COMPOSE := nerdctl compose -f deploy/docker-compose.yml
@ -14,6 +14,9 @@ check-fixture-lib:
check-kind-matrix:
./tests/kind/matrix-run.sh
check-storage-foundation:
./tests/kind/wp04-run.sh
check-frontend:
npm --prefix web run check

12
app/Main.hs
View file

@ -15,7 +15,7 @@ import Nuthatch
import Nuthatch.Db (migrate, query_, withDb)
import Nuthatch.Redis (withRedis)
import Nuthatch.S3 (newS3)
import System.Directory (doesFileExist)
import System.Directory (doesDirectoryExist)
import System.FilePath ((</>))
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
@ -62,14 +62,14 @@ waitForPostgres cfg = go (60 :: Int)
findSchema :: IO FilePath
findSchema = do
let candidates =
[ "sql" </> "001_schema.sql"
, ".." </> "sql" </> "001_schema.sql"
, "/app/sql" </> "001_schema.sql"
[ "sql"
, ".." </> "sql"
, "/app/sql"
]
existing <- mapM (\p -> doesFileExist p >>= \e -> pure (e, p)) candidates
existing <- mapM (\p -> doesDirectoryExist p >>= \e -> pure (e, p)) candidates
pure $ case [p | (True, p) <- existing] of
(p : _) -> p
[] -> "sql/001_schema.sql"
[] -> "sql"
readHost :: String -> HostPreference
readHost = fromString

20
nuthatch.cabal
View file

@ -9,6 +9,7 @@ category: Network
build-type: Simple
extra-source-files:
sql/001_schema.sql
sql/002_pool_limit_guard.sql
common shared
default-language: Haskell2010
@ -43,12 +44,14 @@ common shared
build-depends:
, aeson >= 2.1 && < 2.3
, async >= 2.2 && < 2.3
, aws >= 0.25.2 && < 0.26
, base >= 4.18 && < 5
, base16-bytestring >= 1.0 && < 1.1
, base64-bytestring >= 1.2 && < 1.3
, bytestring >= 0.11 && < 0.13
, case-insensitive >= 1.2 && < 1.3
, containers >= 0.6 && < 0.8
, conduit >= 1.3 && < 1.4
, crypton >= 0.34 && < 1.1
, directory >= 1.3 && < 1.4
, entropy >= 0.4 && < 0.5
@ -65,7 +68,9 @@ common shared
, mtl >= 2.3 && < 2.4
, network-uri >= 2.6 && < 2.8
, postgresql-simple >= 0.7 && < 0.8
, postgresql-migration >= 0.2.1.8 && < 0.3
, resource-pool >= 0.4 && < 0.5
, resourcet >= 1.3 && < 1.4
, scientific >= 0.3 && < 0.4
, servant >= 0.20 && < 0.21
, servant-server >= 0.20 && < 0.21
@ -112,6 +117,21 @@ executable nuthatch
-rtsopts
-with-rtsopts=-N
executable nuthatch-wp04-integration
import: shared
main-is: Integration.hs
hs-source-dirs: test
build-depends:
, nuthatch
, base
, async
, bytestring
, text
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
test-suite nuthatch-unit
import: shared
type: exitcode-stdio-1.0

56
sql/002_pool_limit_guard.sql Normal file
View file

@ -0,0 +1,56 @@
ALTER TABLE mutations
DROP CONSTRAINT IF EXISTS mutations_kind_check,
DROP CONSTRAINT IF EXISTS mutations_declared_size_check,
DROP CONSTRAINT IF EXISTS mutations_prior_size_check,
DROP CONSTRAINT IF EXISTS mutations_growth_bytes_check,
DROP CONSTRAINT IF EXISTS mutations_state_check,
DROP CONSTRAINT IF EXISTS mutations_external_state_check;
ALTER TABLE mutations
ADD CONSTRAINT mutations_kind_check
CHECK (kind IN ('put', 'delete')),
ADD CONSTRAINT mutations_declared_size_check
CHECK (declared_size >= 0),
ADD CONSTRAINT mutations_prior_size_check
CHECK (prior_size >= 0),
ADD CONSTRAINT mutations_growth_bytes_check
CHECK (growth_bytes >= 0),
ADD CONSTRAINT mutations_state_check
CHECK (state IN ('prepared', 'applying', 'succeeded', 'failed', 'rejected')),
ADD CONSTRAINT mutations_external_state_check
CHECK (external_state IN ('idle', 'pending', 'settled'));
ALTER TABLE key_locks
ADD COLUMN IF NOT EXISTS acquired_at TIMESTAMPTZ NOT NULL DEFAULT now(),
DROP CONSTRAINT IF EXISTS key_locks_user_id_kind_operation_id_fkey;
ALTER TABLE key_locks
ADD CONSTRAINT key_locks_user_id_kind_operation_id_fkey
FOREIGN KEY (user_id, kind, operation_id)
REFERENCES mutations (user_id, kind, operation_id);
ALTER TABLE objects_meta
DROP CONSTRAINT IF EXISTS objects_meta_size_bytes_check;
ALTER TABLE objects_meta
ADD CONSTRAINT objects_meta_size_bytes_check
CHECK (size_bytes >= 0);
CREATE INDEX IF NOT EXISTS mutations_active_key_idx
ON mutations (object_key)
WHERE state IN ('prepared', 'applying');
CREATE INDEX IF NOT EXISTS mutations_active_idx
ON mutations (state)
WHERE state IN ('prepared', 'applying');
UPDATE pools
SET limit_bytes = used_bytes + reserved_bytes
WHERE used_bytes + reserved_bytes > limit_bytes;
ALTER TABLE pools
DROP CONSTRAINT IF EXISTS pools_live_bytes_within_limit;
ALTER TABLE pools
ADD CONSTRAINT pools_live_bytes_within_limit
CHECK (used_bytes + reserved_bytes <= limit_bytes);

55
src/Nuthatch/App.hs
View file

@ -27,7 +27,7 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.UUID (toText)
import Data.UUID.V4 (nextRandom)
import Database.PostgreSQL.Simple (Connection, Only (..))
import Database.PostgreSQL.Simple (Only (..))
import Network.HTTP.Types
( hContentType
, hLocation
@ -53,6 +53,7 @@ import Nuthatch.S3
, headObject
, listObjects
, putObject
, renderS3Error
)
import Nuthatch.Session
import Nuthatch.Types
@ -252,7 +253,7 @@ handleDownloadRequest env session root path = do
metadata <- liftIO (headObject (envS3 env) key)
info <- case metadata of
Left message -> throwOperationError status502Error
(DownloadObjectStoreFailed message)
(DownloadObjectStoreFailed (renderS3Error message))
Right Nothing -> throwOperationError err404 DownloadNotFound
Right (Just value) -> pure value
throttle <- liftIO $
@ -263,7 +264,7 @@ handleDownloadRequest env session root path = do
Right True -> pure ()
result <- liftIO (getObjectBytes (envS3 env) key)
body <- either
(throwOperationError status502Error . DownloadObjectStoreFailed)
(throwOperationError status502Error . DownloadObjectStoreFailed . renderS3Error)
pure
result
liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
@ -445,7 +446,7 @@ runPut env user root rel op size sha body = do
AdmitReplay MutationPending _ -> pure (Right MutationPending)
AdmitReplay result _ -> pure (Right result)
AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
_ <- putObject (envS3 env) key size sha body
_ <- putObject (envS3 env) key size (Just sha) body
pure ()
runDelete
@ -516,7 +517,7 @@ collectKeys s3 prefix = go Nothing []
go continuation accumulated = do
page <- listObjects s3 prefix Nothing continuation 1000
case page of
Left message -> pure (Left message)
Left message -> pure (Left (renderS3Error message))
Right result -> do
let accumulated' = accumulated <> map fst (lpObjects result)
if lpIsTruncated result
@ -559,35 +560,17 @@ dispatchAndFinalize env user root rec dispatch = do
observeObject :: S3 -> ObjectKey -> IO ObjectObservation
observeObject s3 key = do
result <- headObject s3 key
pure $ case result of
Right (Just info) -> ObjectPresent (oiSize info) (oiSha256 info)
Right Nothing -> ObjectAbsent
Left err -> ObjectUnavailable err
finalizeFromObservation
:: Connection
-> MutationRecord
-> ObjectObservation
-> IO (Maybe MutationResult)
finalizeFromObservation conn rec observed =
case observed of
ObjectUnavailable _ -> pure Nothing
_ | desiredMatches rec observed -> do
let (finalSize, finalSha) =
case mrKind rec of
Put ->
( mrDeclaredSize rec
, mrContentSha256 rec
)
Delete -> (0, Nothing)
ok <- finalizeSuccess conn rec finalSize finalSha
pure $ if ok then Just MutationSucceeded else Nothing
_ | priorMatches rec observed -> do
ok <- finalizeFailure conn rec
pure $ if ok then Just MutationFailed else Nothing
_ -> do
ok <- finalizeFailure conn rec
pure $ if ok then Just MutationFailed else Nothing
case result of
Right (Just info@ObjectInfo { oiSha256 = Just _ }) ->
pure (ObjectPresent (oiSize info) (oiSha256 info))
Right (Just _) -> do
body <- getObjectBytes s3 key
pure $ case body of
Right bytes ->
ObjectPresent (toInteger (BL.length bytes)) (Just (contentSha256 bytes))
Left err -> ObjectUnavailable (renderS3Error err)
Right Nothing -> pure ObjectAbsent
Left err -> pure (ObjectUnavailable (renderS3Error err))
listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
listEntries env user root prefix = do
@ -613,7 +596,7 @@ listEntries env user root prefix = do
Nothing -> do
page <- listObjects (envS3 env) s3Prefix (Just "/") Nothing 1000
case page of
Left err -> pure (Left err)
Left err -> pure (Left (renderS3Error err))
Right lp -> do
let rootPrefix =
case root of
@ -680,7 +663,7 @@ collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
| otherwise = do
page <- listObjects s3 prefix Nothing mTok (min 1000 (maxKeys - n))
case page of
Left err -> pure (Left err)
Left err -> pure (Left (renderS3Error err))
Right lp -> do
let acc' = acc <> lpObjects lp
n' = length acc'

113
src/Nuthatch/Db.hs
View file

@ -3,6 +3,7 @@ module Nuthatch.Db
, withDb
, migrate
, ensurePersonalPool
, configurePoolLimit
, withTransaction
, query
, query_
@ -11,7 +12,7 @@ module Nuthatch.Db
, executeMany
) where
import Control.Exception (bracket)
import Control.Exception (bracket, throwIO)
import qualified Data.ByteString.Char8 as BS8
import Data.Pool
( Pool
@ -23,11 +24,15 @@ import Data.Pool
)
import Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
import qualified Database.PostgreSQL.Simple as PG
import Database.PostgreSQL.Simple.Migration
( MigrationCommand (..)
, MigrationResult (..)
, defaultOptions
, runMigration
)
import qualified Database.PostgreSQL.Simple.Transaction as PGT
import Database.PostgreSQL.Simple.Types (Query (..))
import Nuthatch.Config (Config (..))
import Nuthatch.Types
import System.Directory (doesFileExist)
type Db = Pool Connection
@ -40,43 +45,39 @@ withDb cfg action = do
bracket (newPool poolCfg) destroyAllResources action
migrate :: Db -> FilePath -> Config -> IO ()
migrate db schemaPath cfg = withResource db $ \conn -> do
exists <- doesFileExist schemaPath
sql <- if exists then readFile schemaPath else pure builtinSchema
mapM_ (runStatement conn) (splitStatements sql)
_ <- PG.execute conn
"INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes) \
\VALUES (?, ?, 0, 0) ON CONFLICT (pool_id) DO UPDATE SET limit_bytes = EXCLUDED.limit_bytes"
(unPoolId sharedPool, cfgSharedQuotaBytes cfg)
pure ()
runStatement :: Connection -> String -> IO ()
runStatement conn stmt =
let trimmed = dropWhile (`elem` (" \t\r\n" :: String)) stmt
in if null trimmed
then pure ()
else do
_ <- PG.execute_ conn (Query (BS8.pack trimmed))
pure ()
splitStatements :: String -> [String]
splitStatements = filter (not . null . trim) . splitOn ';'
where
trim = dropWhile (`elem` (" \t\r\n" :: String))
splitOn _ [] = []
splitOn c xs =
let (h, t) = break (== c) xs
in h : case t of
[] -> []
(_:rest) -> splitOn c rest
migrate db migrationDirectory cfg = withResource db $ \conn -> do
result <- runMigration conn defaultOptions $
MigrationInitialization
<> MigrationDirectory migrationDirectory
<> MigrationValidation (MigrationDirectory migrationDirectory)
case result of
MigrationSuccess ->
PGT.withTransaction conn $
configurePoolLimitConnection conn sharedPool (cfgSharedQuotaBytes cfg)
MigrationError name -> throwIO (userError ("migration failed: " <> name))
ensurePersonalPool :: Db -> Config -> UserId -> IO ()
ensurePersonalPool db cfg uid = withResource db $ \conn -> do
ensurePersonalPool db cfg uid =
configurePoolLimit db (personalPool uid) (cfgPersonalQuotaBytes cfg)
configurePoolLimit :: Db -> PoolId -> Integer -> IO ()
configurePoolLimit db pool limitBytes =
withResource db $ \conn ->
PGT.withTransaction conn (configurePoolLimitConnection conn pool limitBytes)
configurePoolLimitConnection :: Connection -> PoolId -> Integer -> IO ()
configurePoolLimitConnection conn pool limitBytes = do
_ <- PG.execute conn
"INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes) \
\VALUES (?, ?, 0, 0) ON CONFLICT (pool_id) DO NOTHING"
(unPoolId (personalPool uid), cfgPersonalQuotaBytes cfg)
pure ()
(unPoolId pool, limitBytes)
changed <- PG.execute conn
"UPDATE pools SET limit_bytes = ? \
\WHERE pool_id = ? AND used_bytes + reserved_bytes <= ?"
(limitBytes, unPoolId pool, limitBytes)
if changed == 1
then pure ()
else throwIO (userError "pool limit is below live usage and reservations")
query :: (PG.ToRow q, PG.FromRow r) => Db -> PG.Query -> q -> IO [r]
query db q params = withResource db $ \conn -> PG.query conn q params
@ -96,45 +97,3 @@ executeMany db q rows = withResource db $ \conn -> fromIntegral <$> PG.executeMa
withTransaction :: Db -> (Connection -> IO a) -> IO a
withTransaction db action =
withResource db $ \conn -> PGT.withTransaction conn (action conn)
builtinSchema :: String
builtinSchema =
unlines
[ "CREATE TABLE IF NOT EXISTS pools ("
, " pool_id TEXT PRIMARY KEY,"
, " limit_bytes BIGINT NOT NULL CHECK (limit_bytes > 0),"
, " used_bytes BIGINT NOT NULL DEFAULT 0 CHECK (used_bytes >= 0),"
, " reserved_bytes BIGINT NOT NULL DEFAULT 0 CHECK (reserved_bytes >= 0)"
, ");"
, "CREATE TABLE IF NOT EXISTS mutations ("
, " user_id TEXT NOT NULL,"
, " kind TEXT NOT NULL,"
, " operation_id TEXT NOT NULL,"
, " pool_id TEXT NOT NULL REFERENCES pools (pool_id),"
, " object_key TEXT NOT NULL,"
, " relative_path TEXT NOT NULL,"
, " declared_size BIGINT NOT NULL,"
, " content_sha256 TEXT,"
, " prior_size BIGINT NOT NULL,"
, " prior_sha256 TEXT,"
, " growth_bytes BIGINT NOT NULL,"
, " state TEXT NOT NULL,"
, " external_state TEXT NOT NULL DEFAULT 'idle',"
, " created_at TIMESTAMPTZ NOT NULL DEFAULT now(),"
, " updated_at TIMESTAMPTZ NOT NULL DEFAULT now(),"
, " PRIMARY KEY (user_id, kind, operation_id)"
, ");"
, "CREATE TABLE IF NOT EXISTS key_locks ("
, " object_key TEXT PRIMARY KEY,"
, " user_id TEXT NOT NULL,"
, " kind TEXT NOT NULL,"
, " operation_id TEXT NOT NULL"
, ");"
, "CREATE TABLE IF NOT EXISTS objects_meta ("
, " object_key TEXT PRIMARY KEY,"
, " pool_id TEXT NOT NULL REFERENCES pools (pool_id),"
, " size_bytes BIGINT NOT NULL,"
, " content_sha256 TEXT NOT NULL,"
, " updated_at TIMESTAMPTZ NOT NULL DEFAULT now()"
, ");"
]

35
src/Nuthatch/Protocol.hs
View file

@ -20,6 +20,7 @@ module Nuthatch.Protocol
, recoveryEligible
, desiredMatches
, priorMatches
, finalizeFromObservation
) where
import Data.Maybe (listToMaybe, mapMaybe)
@ -138,6 +139,11 @@ admitMutation
-> Integer
-> IO AdmitOutcome
admitMutation conn uid kind op pool key rel size msha maxObject = do
let identity =
unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
_ <- query conn
"SELECT pg_advisory_xact_lock(hashtextextended(?, 0))"
(Only identity) :: IO [Only ()]
existing <- lookupMutation conn uid kind op
case existing of
Just rec
@ -169,11 +175,13 @@ admitMutation conn uid kind op pool key rel size msha maxObject = do
, mrExternal = ExtIdle
}
_ <- query conn
poolRows <- query conn
"SELECT 1 FROM pools WHERE pool_id = ? FOR UPDATE"
(Only (unPoolId pool)) :: IO [Only Int]
if kind == Put && (size <= 0 || size > maxObject)
if null poolRows
then pure AdmitConflict
else if kind == Put && (size <= 0 || size > maxObject)
then do
rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
pure (AdmitRejected "invalid object size" rec)
@ -458,3 +466,26 @@ priorMatches rec obs =
(Just _, Nothing) -> False
(Nothing, Just _) -> mrPriorSize rec == sz
)
finalizeFromObservation
:: Connection
-> MutationRecord
-> ObjectObservation
-> IO (Maybe MutationResult)
finalizeFromObservation conn rec observed =
case observed of
ObjectUnavailable _ -> pure Nothing
_ | desiredMatches rec observed -> do
let (finalSize, finalSha) =
case mrKind rec of
Put ->
( mrDeclaredSize rec
, mrContentSha256 rec
)
Delete -> (0, Nothing)
ok <- finalizeSuccess conn rec finalSize finalSha
pure $ if ok then Just MutationSucceeded else Nothing
_ | priorMatches rec observed -> do
ok <- finalizeFailure conn rec
pure $ if ok then Just MutationFailed else Nothing
_ -> pure Nothing

606
src/Nuthatch/S3.hs
View file

@ -1,5 +1,6 @@
module Nuthatch.S3
( S3
, S3Error (..)
, ObjectInfo (..)
, ListPage (..)
, newS3
@ -8,57 +9,59 @@ module Nuthatch.S3
, headObject
, deleteObject
, listObjects
, renderS3Error
) where
import Crypto.Hash (Digest, SHA256, hash, hashlazy)
import Crypto.MAC.HMAC (HMAC, hmac)
import Data.ByteArray (convert)
import qualified Data.ByteString as BS
import qualified Aws
import qualified Aws.Aws as AwsRun
import qualified Aws.Core as AwsCore
import qualified Aws.S3 as S3
import Control.Applicative ((<|>))
import Control.Exception (SomeException, fromException, try)
import Control.Monad.Trans.Resource (runResourceT)
import Crypto.Hash
( Context
, SHA256
, hashFinalize
, hashInit
, hashUpdate
)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (mk, original)
import Data.Char (toLower)
import Data.List (sort)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Network.HTTP.Client
( Manager
, Request (..)
, RequestBody (..)
, Response (..)
, httpLbs
, newManager
, parseRequest
, responseTimeoutNone
, setQueryString
)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (Header, RequestHeaders, statusCode)
import Network.HTTP.Types.URI (parseQuery)
import Network.HTTP.Types.Status (statusCode)
import Network.URI (URI (..), URIAuth (..), parseURI)
import Nuthatch.Config (Config (..))
import Nuthatch.Types
import qualified Text.XML as XML
import Text.Read (readMaybe)
data S3 = S3
{ s3Manager :: Manager
, s3Endpoint :: Text
, s3Region :: Text
{ s3Configuration :: Aws.Configuration
, s3Service :: S3.S3Configuration Aws.NormalQuery
, s3Manager :: HTTP.Manager
, s3Bucket :: Text
, s3AccessKey :: Text
, s3SecretKey :: Text
, s3PathStyle :: Bool
}
data S3Error
= S3NotFound
| S3ServiceError Int
| S3TransportError
| S3ResponseError
deriving stock (Eq, Show)
data ObjectInfo = ObjectInfo
{ oiSize :: Integer
, oiSha256 :: Maybe ContentSha256
}
deriving stock (Show)
deriving stock (Eq, Show)
data ListPage = ListPage
{ lpPrefixes :: [Text]
@ -66,86 +69,112 @@ data ListPage = ListPage
, lpContinuationToken :: Maybe Text
, lpIsTruncated :: Bool
}
deriving stock (Show)
deriving stock (Eq, Show)
newS3 :: Config -> IO S3
newS3 cfg = do
mgr <- newManager tlsManagerSettings
(protocol, endpointHost, endpointPort) <- parseEndpoint (cfgS3Endpoint cfg)
credentials <- Aws.makeCredentials
(TE.encodeUtf8 (cfgS3AccessKey cfg))
(TE.encodeUtf8 (cfgS3SecretKey cfg))
let defaultPort = case protocol of
AwsCore.HTTP -> 80
AwsCore.HTTPS -> 443
signedHost =
if endpointPort == defaultPort
then endpointHost
else endpointHost <> ":" <> BS8.pack (show endpointPort)
managerSettings =
tlsManagerSettings
{ HTTP.managerResponseTimeout =
HTTP.responseTimeoutMicro (30 * 1000000)
-- The SDK signs the authority verbatim; http-client resolves only its host.
, HTTP.managerModifyRequest = \request ->
let requestHost = HTTP.host request
portSuffix = ":" <> BS8.pack (show endpointPort)
(networkHost, authority) =
if endpointPort == defaultPort
then (requestHost, requestHost)
else case BS8.stripSuffix portSuffix requestHost of
Just hostWithoutPort -> (hostWithoutPort, requestHost)
Nothing -> (requestHost, requestHost <> portSuffix)
in pure request
{ HTTP.host = networkHost
, HTTP.requestHeaders =
("Host", authority)
: filter ((/= "Host") . fst) (HTTP.requestHeaders request)
}
}
manager <- HTTP.newManager managerSettings
let configuration = Aws.Configuration
{ Aws.timeInfo = Aws.Timestamp
, Aws.credentials = credentials
, Aws.logger = \_ _ -> pure ()
, Aws.proxy = Nothing
}
requestStyle =
if cfgS3PathStyle cfg then S3.PathStyle else S3.BucketStyle
service =
(S3.s3v4 protocol signedHost False S3.SignWithEffort)
{ S3.s3Region = Just (TE.encodeUtf8 (cfgS3Region cfg))
, S3.s3RequestStyle = requestStyle
, S3.s3Port = endpointPort
}
pure S3
{ s3Manager = mgr
, s3Endpoint = cfgS3Endpoint cfg
, s3Region = cfgS3Region cfg
{ s3Configuration = configuration
, s3Service = service
, s3Manager = manager
, s3Bucket = cfgS3Bucket cfg
, s3AccessKey = cfgS3AccessKey cfg
, s3SecretKey = cfgS3SecretKey cfg
, s3PathStyle = cfgS3PathStyle cfg
}
putObject :: S3 -> ObjectKey -> Integer -> ContentSha256 -> BL.ByteString -> IO (Either Text ())
putObject s3 key size sha body
| toInteger (BL.length body) /= size = pure (Left "body size mismatch")
| ContentSha256 (TE.decodeUtf8 (hexSha256Lazy body)) /= sha =
pure (Left "content sha256 mismatch")
putObject
:: S3
-> ObjectKey
-> Integer
-> Maybe ContentSha256
-> BL.ByteString
-> IO (Either S3Error ())
putObject store (ObjectKey key) size sha body
| toInteger (BL.length body) /= size = pure (Left S3ResponseError)
| otherwise = do
now <- getCurrentTime
req0 <- mkObjectRequest s3 "PUT" key [] now
let payloadHash = hexSha256Lazy body
req = signRequest s3 now payloadHash req0
{ requestBody = RequestBodyLBS body
, requestHeaders =
[ (mk "content-length", BS8.pack (show size))
, (mk "content-type", "application/octet-stream")
, (mk "x-amz-meta-nuthatch-sha256", TE.encodeUtf8 (unContentSha256 sha))
]
<> requestHeaders req0
let request =
(S3.putObject (s3Bucket store) key (HTTP.RequestBodyLBS body))
{ S3.poContentType = Just "application/octet-stream"
, S3.poMetadata = maybe []
(\identity ->
[("nuthatch-sha256", unContentSha256 identity)])
sha
}
resp <- httpLbs req (s3Manager s3)
let code = statusCode (responseStatus resp)
pure $ if code >= 200 && code < 300
then Right ()
else Left ("s3 put failed: HTTP " <> T.pack (show code)
<> " " <> TE.decodeUtf8 (BL.toStrict (responseBody resp)))
result <- try (runMemory store request)
:: IO (Either SomeException S3.PutObjectResponse)
pure (either (Left . classifyException) (const (Right ())) result)
getObjectBytes :: S3 -> ObjectKey -> IO (Either Text BL.ByteString)
getObjectBytes s3 key = do
now <- getCurrentTime
req0 <- mkObjectRequest s3 "GET" key [] now
let req = signRequest s3 now (hexSha256Lazy "") req0
resp <- httpLbs req (s3Manager s3)
let code = statusCode (responseStatus resp)
pure $ if code == 200
then Right (responseBody resp)
else Left ("s3 get failed: HTTP " <> T.pack (show code))
getObjectBytes :: S3 -> ObjectKey -> IO (Either S3Error BL.ByteString)
getObjectBytes store (ObjectKey key) = do
result <- getObjectMemory store key
pure $ result >>= \(_, body) -> Right body
headObject :: S3 -> ObjectKey -> IO (Either Text (Maybe ObjectInfo))
headObject s3 key = do
now <- getCurrentTime
req0 <- mkObjectRequest s3 "HEAD" key [] now
let req = signRequest s3 now (hexSha256Lazy "") req0
resp <- httpLbs req (s3Manager s3)
let code = statusCode (responseStatus resp)
pure $ case code of
200 ->
let headers = responseHeaders resp
size = lookupHeader "content-length" headers >>= readInteger
sha = ContentSha256 . TE.decodeUtf8
<$> lookupHeader "x-amz-meta-nuthatch-sha256" headers
in case size of
Just sz -> Right (Just ObjectInfo { oiSize = sz, oiSha256 = sha })
Nothing -> Left "s3 head missing content-length"
404 -> Right Nothing
_ -> Left ("s3 head failed: HTTP " <> T.pack (show code))
headObject :: S3 -> ObjectKey -> IO (Either S3Error (Maybe ObjectInfo))
headObject store (ObjectKey key) = do
result <- try (runMemory store (S3.headObject (s3Bucket store) key))
:: IO (Either SomeException S3.HeadObjectMemoryResponse)
case result of
Left err -> pure (Left (classifyException err))
Right (S3.HeadObjectMemoryResponse Nothing) -> pure (Right Nothing)
Right (S3.HeadObjectMemoryResponse (Just _)) -> do
object <- observeObjectStream store key
pure (Just <$> object)
deleteObject :: S3 -> ObjectKey -> IO (Either Text ())
deleteObject s3 key = do
now <- getCurrentTime
req0 <- mkObjectRequest s3 "DELETE" key [] now
let req = signRequest s3 now (hexSha256Lazy "") req0
resp <- httpLbs req (s3Manager s3)
let code = statusCode (responseStatus resp)
pure $ if code == 204 || code == 200 || code == 404
then Right ()
else Left ("s3 delete failed: HTTP " <> T.pack (show code))
deleteObject :: S3 -> ObjectKey -> IO (Either S3Error ())
deleteObject store (ObjectKey key) = do
result <- try (runMemory store (S3.DeleteObject key (s3Bucket store)))
:: IO (Either SomeException S3.DeleteObjectResponse)
pure $ case result of
Left err ->
case classifyException err of
S3NotFound -> Right ()
other -> Left other
Right _ -> Right ()
listObjects
:: S3
@ -153,249 +182,160 @@ listObjects
-> Maybe Text
-> Maybe Text
-> Int
-> IO (Either Text ListPage)
listObjects s3 prefix delimiter continuation maxKeys = do
now <- getCurrentTime
let qs =
[ ("list-type", Just "2")
, ("prefix", Just (TE.encodeUtf8 prefix))
, ("max-keys", Just (BS8.pack (show maxKeys)))
]
<> maybe [] (\d -> [("delimiter", Just (TE.encodeUtf8 d))]) delimiter
<> maybe [] (\t -> [("continuation-token", Just (TE.encodeUtf8 t))]) continuation
req0 <- mkBucketRequest s3 "GET" qs now
let req = signRequest s3 now (hexSha256Lazy "") req0
resp <- httpLbs req (s3Manager s3)
let code = statusCode (responseStatus resp)
body = responseBody resp
if code /= 200
then pure (Left ("s3 list failed: HTTP " <> T.pack (show code)
<> " " <> TE.decodeUtf8 (BL.toStrict body)))
else pure (parseListXml body)
parseListXml :: BL.ByteString -> Either Text ListPage
parseListXml body =
case XML.parseLBS XML.def body of
Left err -> Left (T.pack (show err))
Right (XML.Document _ root _) ->
let elems = descendantElements root
textUnder localName =
[ t
| e <- elems
, elementLocal e == localName
, t <- elementTexts e
]
objects =
mapMaybe objectFrom
[ e | e <- elems, elementLocal e == "Contents" ]
prefixes =
concatMap elementTexts
[ e | e <- elems, elementLocal e == "Prefix"
-- List Prefix also names the request prefix; common prefixes end with '/'.
, any (T.isSuffixOf "/") (elementTexts e)
]
truncated =
case textUnder "IsTruncated" of
(t : _) -> T.toLower t == "true"
_ -> False
token =
case textUnder "NextContinuationToken" of
(t : _) | not (T.null t) -> Just t
_ -> Nothing
in Right ListPage
{ lpPrefixes = prefixes
, lpObjects = objects
, lpContinuationToken = token
, lpIsTruncated = truncated
-> IO (Either S3Error ListPage)
listObjects store prefix delimiter continuation maxKeys = do
let request =
(S3.getBucket (s3Bucket store))
{ S3.gbPrefix = Just prefix
, S3.gbDelimiter = delimiter
, S3.gbMarker = continuation
, S3.gbMaxKeys = Just maxKeys
}
result <- try (runMemory store request)
:: IO (Either SomeException S3.GetBucketResponse)
pure $ case result of
Left err -> Left (classifyException err)
Right response ->
Right ListPage
{ lpPrefixes = S3.gbrCommonPrefixes response
, lpObjects =
map (\object -> (S3.objectKey object, S3.objectSize object))
(S3.gbrContents response)
, lpContinuationToken =
S3.gbrNextMarker response
<|> fallbackMarker response
, lpIsTruncated = S3.gbrIsTruncated response
}
where
elementLocal e = XML.nameLocalName (XML.elementName e)
elementTexts e =
[ t
| XML.NodeContent t <- XML.elementNodes e
]
descendantElements e =
e :
concat
[ descendantElements child
| XML.NodeElement child <- XML.elementNodes e
]
objectFrom e = do
let children = [ c | XML.NodeElement c <- XML.elementNodes e ]
childText name =
listToMaybe
[ t
| c <- children
, elementLocal c == name
, t <- elementTexts c
]
key <- childText "Key"
sizeText <- childText "Size"
size <- case reads (T.unpack sizeText) of
[(n, "")] -> Just n
_ -> Nothing
pure (key, size)
fallbackMarker response =
if S3.gbrIsTruncated response
then S3.objectKey <$> lastMaybe (S3.gbrContents response)
else Nothing
mkObjectRequest :: S3 -> BS.ByteString -> ObjectKey -> [Header] -> UTCTime -> IO Request
mkObjectRequest s3 method (ObjectKey key) headers _now = do
let path = objectUrlPath s3 key
base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
pure base
{ method = method
, requestHeaders = headers
, responseTimeout = responseTimeoutNone
}
renderS3Error :: S3Error -> Text
renderS3Error S3NotFound = "object not found"
renderS3Error (S3ServiceError code) =
"object store returned HTTP " <> T.pack (show code)
renderS3Error S3TransportError = "object store transport failed"
renderS3Error S3ResponseError = "object store response was invalid"
mkBucketRequest :: S3 -> BS.ByteString -> [(BS.ByteString, Maybe BS.ByteString)] -> UTCTime -> IO Request
mkBucketRequest s3 method qs _now = do
let path = bucketUrlPath s3
base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
pure $ setQueryString qs base
{ method = method
, responseTimeout = responseTimeoutNone
}
runMemory
:: ( Aws.Transaction request response
, Aws.AsMemoryResponse response
, Aws.MemoryResponse response ~ memoryResponse
, Aws.ServiceConfiguration request Aws.NormalQuery
~ S3.S3Configuration Aws.NormalQuery
)
=> S3
-> request
-> IO memoryResponse
runMemory store =
AwsRun.memoryAws
(s3Configuration store)
(s3Service store)
(s3Manager store)
objectUrlPath :: S3 -> Text -> String
objectUrlPath s3 key =
let bucket = T.unpack (s3Bucket s3)
encodedKey = escapePath (T.unpack key)
in if s3PathStyle s3
then "/" <> bucket <> "/" <> encodedKey
else "/" <> encodedKey
getObjectMemory
:: S3
-> Text
-> IO (Either S3Error (S3.ObjectMetadata, BL.ByteString))
getObjectMemory store key = do
result <- try (runMemory store (S3.getObject (s3Bucket store) key))
:: IO (Either SomeException S3.GetObjectMemoryResponse)
pure $ case result of
Left err -> Left (classifyException err)
Right (S3.GetObjectMemoryResponse metadata response) ->
Right (metadata, HTTP.responseBody response)
bucketUrlPath :: S3 -> String
bucketUrlPath s3 =
let bucket = T.unpack (s3Bucket s3)
in if s3PathStyle s3 then "/" <> bucket else "/"
escapePath :: String -> String
escapePath = concatMap escapeChar
observeObjectStream :: S3 -> Text -> IO (Either S3Error ObjectInfo)
observeObjectStream store key = do
result <- try (runResourceT getInfo)
:: IO (Either SomeException ObjectInfo)
pure (either (Left . classifyException) Right result)
where
escapeChar c
| c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~/" :: String) = [c]
| otherwise =
let (q, r) = fromEnum c `divMod` 16
hex = "0123456789ABCDEF"
in ['%', hex !! q, hex !! r]
getInfo = do
response <- AwsRun.pureAws
(s3Configuration store)
(s3Service store)
(s3Manager store)
(S3.getObject (s3Bucket store) key)
let metadata = S3.gorMetadata response
httpResponse = S3.gorResponse response
knownSize =
lookup "Content-Length" (HTTP.responseHeaders httpResponse)
>>= readMaybe . BS8.unpack
knownIdentity =
lookup "nuthatch-sha256" (S3.omUserMetadata metadata)
>>= either (const Nothing) Just . validateContentSha256
case (knownSize, knownIdentity) of
(Just size, Just identity) ->
pure ObjectInfo
{ oiSize = size
, oiSha256 = Just identity
}
_ -> do
(size, context) <- C.runConduit $
HTTP.responseBody httpResponse
C..| CL.fold updateDigest (0, hashInit)
pure ObjectInfo
{ oiSize = size
, oiSha256 = Just (contextIdentity context)
}
updateDigest (size, context) chunk =
(size + toInteger (BS8.length chunk), hashUpdate context chunk)
signRequest :: S3 -> UTCTime -> BS.ByteString -> Request -> Request
signRequest s3 now payloadHash req =
let amzDate = BS8.pack (formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" now)
dateStamp = BS8.take 8 amzDate
region = TE.encodeUtf8 (s3Region s3)
service = "s3" :: BS.ByteString
credentialScope =
dateStamp <> "/" <> region <> "/" <> service <> "/aws4_request"
headers0 :: RequestHeaders
headers0 =
filter (\(n, _) -> n /= mk "authorization") (requestHeaders req)
<> [ (mk "x-amz-content-sha256", payloadHash)
, (mk "x-amz-date", amzDate)
, (mk "host", hostHeader req)
]
sortedHeaders = sortOnHeader headers0
signedHeaderNames = map (BS8.map toLower . original . fst) sortedHeaders
signedHeaders = BS8.intercalate ";" signedHeaderNames
canonicalHeaders =
BS8.concat
[ BS8.map toLower (original name) <> ":" <> BS8.dropWhile (== ' ') value <> "\n"
| (name, value) <- sortedHeaders
]
canonicalQuery = canonicalQueryString req
canonicalUri = BS8.pack (pathURL req)
canonicalRequest =
method req <> "\n"
<> canonicalUri <> "\n"
<> canonicalQuery <> "\n"
<> canonicalHeaders <> "\n"
<> signedHeaders <> "\n"
<> payloadHash
stringToSign =
"AWS4-HMAC-SHA256\n"
<> amzDate <> "\n"
<> credentialScope <> "\n"
<> hexSha256 canonicalRequest
signingKey =
hmacSHA256
(hmacSHA256
(hmacSHA256
(hmacSHA256 (TE.encodeUtf8 ("AWS4" <> s3SecretKey s3)) dateStamp)
region)
service)
"aws4_request"
signature = hexEncode (hmacSHA256 signingKey stringToSign)
auth =
"AWS4-HMAC-SHA256 Credential="
<> TE.encodeUtf8 (s3AccessKey s3)
<> "/"
<> credentialScope
<> ", SignedHeaders="
<> signedHeaders
<> ", Signature="
<> signature
in req { requestHeaders = (mk "authorization", auth) : headers0 }
contextIdentity :: Context SHA256 -> ContentSha256
contextIdentity =
ContentSha256
. TE.decodeUtf8
. B16.encode
. BA.convert
. hashFinalize
sortOnHeader :: RequestHeaders -> RequestHeaders
sortOnHeader = sortOn (\(n, _) -> BS8.map toLower (original n))
where
sortOn f = map snd . sort . map (\x -> (f x, x))
hostHeader :: Request -> BS.ByteString
hostHeader req =
case lookup (mk "Host") (requestHeaders req) of
Just h -> h
classifyException :: SomeException -> S3Error
classifyException exception =
case fromException exception of
Just serviceError
| statusCode (S3.s3StatusCode serviceError) == 404 -> S3NotFound
| otherwise ->
S3ServiceError (statusCode (S3.s3StatusCode serviceError))
Nothing ->
let h = host req
p = port req
in if p == 80 || p == 443
then h
else h <> ":" <> BS8.pack (show p)
case fromException exception :: Maybe HTTP.HttpException of
Just (HTTP.HttpExceptionRequest _ content) ->
case content of
HTTP.StatusCodeException response _
| statusCode (HTTP.responseStatus response) == 404 -> S3NotFound
| otherwise ->
S3ServiceError (statusCode (HTTP.responseStatus response))
_ -> S3TransportError
Just (HTTP.InvalidUrlException _ _) -> S3ResponseError
Nothing -> S3ResponseError
pathURL :: Request -> String
pathURL req =
case BS8.unpack (path req) of
"" -> "/"
p -> p
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe values = Just (last values)
canonicalQueryString :: Request -> BS.ByteString
canonicalQueryString req =
let pairs = parseQuery (queryString req)
enc = escapeQuery
encoded =
sort
[ enc k <> "=" <> enc (fromMaybe "" v)
| (k, v) <- pairs
]
in BS8.intercalate "&" encoded
escapeQuery :: BS.ByteString -> BS.ByteString
escapeQuery = BS8.concatMap escape1
where
escape1 c
| c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~" :: String)
= BS8.singleton c
| otherwise =
let (q, r) = fromEnum c `divMod` 16
hex = "0123456789ABCDEF"
in BS8.pack ['%', hex !! q, hex !! r]
hmacSHA256 :: BS.ByteString -> BS.ByteString -> BS.ByteString
hmacSHA256 key msg = convert (hmac key msg :: HMAC SHA256)
hexSha256 :: BS.ByteString -> BS.ByteString
hexSha256 = hexEncode . convert . (hash :: BS.ByteString -> Digest SHA256)
hexSha256Lazy :: BL.ByteString -> BS.ByteString
hexSha256Lazy = hexEncode . convert . (hashlazy :: BL.ByteString -> Digest SHA256)
hexEncode :: BS.ByteString -> BS.ByteString
hexEncode = B16.encode
lookupHeader :: BS.ByteString -> RequestHeaders -> Maybe BS.ByteString
lookupHeader name headers = lookup (mk name) headers
readInteger :: BS.ByteString -> Maybe Integer
readInteger bs =
case reads (BS8.unpack bs) of
[(n, "")] -> Just n
_ -> Nothing
parseEndpoint :: Text -> IO (AwsCore.Protocol, BS8.ByteString, Int)
parseEndpoint raw =
case parseURI (T.unpack raw) of
Just URI
{ uriScheme
, uriAuthority = Just URIAuth
{ uriUserInfo = ""
, uriRegName
, uriPort
}
, uriPath = ""
, uriQuery = ""
, uriFragment = ""
}
| uriScheme == "http:" || uriScheme == "https:" -> do
port <- case uriPort of
"" -> pure (if uriScheme == "https:" then 443 else 80)
':' : value ->
maybe (fail "invalid S3 endpoint port") pure (readMaybe value)
_ -> fail "invalid S3 endpoint port"
let protocol =
if uriScheme == "https:" then AwsCore.HTTPS else AwsCore.HTTP
pure (protocol, BS8.pack uriRegName, port)
_ -> fail "NUTHATCH_S3_ENDPOINT must be an absolute HTTP(S) origin"

416
test/Integration.hs Normal file
View file

@ -0,0 +1,416 @@
module Main (main) where
import Control.Concurrent.Async (concurrently, mapConcurrently)
import Control.Exception (SomeException, try)
import Control.Monad (unless)
import Crypto.Hash (Digest, SHA256, hashlazy)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as BL
import Data.List (sort)
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Database.PostgreSQL.Simple (Only (..))
import Nuthatch.Config (Config (..), loadConfig)
import Nuthatch.Db
( Db
, configurePoolLimit
, ensurePersonalPool
, migrate
, withDb
, withTransaction
)
import qualified Nuthatch.Db as Db
import Nuthatch.Protocol
import Nuthatch.S3
import Nuthatch.Types
main :: IO ()
main = do
config <- loadConfig
withDb config $ \database -> do
migrate database "sql" config
migrate database "sql" config
emptyCatalog <- schemaCatalog database
resetSchema database
installLegacySchema database
migrate database "sql" config
migrate database "sql" config
adoptedCatalog <- schemaCatalog database
assertEqual "legacy and empty migration schema equivalence"
emptyCatalog adoptedCatalog
verifySchema database
verifyAdmission database config
store <- newS3 config
verifyStorage config store
putStrLn "WP-04 integration gate passed"
verifySchema :: Db -> IO ()
verifySchema database = do
tables <- Db.query_ database
"SELECT table_name FROM information_schema.tables \
\WHERE table_schema = 'public' \
\AND table_name IN ('pools','mutations','key_locks','objects_meta','schema_migrations') \
\ORDER BY table_name"
:: IO [Only Text]
assertEqual "authoritative schema tables"
["key_locks", "mutations", "objects_meta", "pools", "schema_migrations"]
(map fromOnly tables)
constraints <- Db.query_ database
"SELECT count(*) FROM pg_constraint \
\WHERE conname = 'pools_live_bytes_within_limit' \
\AND conrelid = 'pools'::regclass"
:: IO [Only Int]
assertEqual "pool limit constraint" [Only 1] constraints
migrations <- Db.query_ database
"SELECT filename FROM schema_migrations ORDER BY filename"
:: IO [Only Text]
assertEqual "migration history"
["001_schema.sql", "002_pool_limit_guard.sql"]
(map fromOnly migrations)
schemaCatalog :: Db -> IO [Text]
schemaCatalog database = do
rows <- Db.query_ database
"SELECT description FROM ( \
\SELECT 'column|' || table_name || '|' || ordinal_position::text || '|' \
\ || column_name || '|' || data_type || '|' || is_nullable || '|' \
\ || COALESCE(column_default, '') AS description \
\FROM information_schema.columns \
\WHERE table_schema = 'public' \
\UNION ALL \
\SELECT 'constraint|' || c.relname || '|' || con.conname || '|' \
\ || con.contype::text || '|' || pg_get_constraintdef(con.oid) \
\FROM pg_constraint con \
\JOIN pg_class c ON c.oid = con.conrelid \
\JOIN pg_namespace n ON n.oid = c.relnamespace \
\WHERE n.nspname = 'public' \
\UNION ALL \
\SELECT 'index|' || tablename || '|' || indexname || '|' || indexdef \
\FROM pg_indexes WHERE schemaname = 'public' \
\) catalog ORDER BY description"
:: IO [Only Text]
pure (map fromOnly rows)
resetSchema :: Db -> IO ()
resetSchema database = do
_ <- Db.execute_ database
"DROP TABLE IF EXISTS schema_migrations, key_locks, objects_meta, \
\mutations, pools CASCADE"
pure ()
installLegacySchema :: Db -> IO ()
installLegacySchema database = do
mapM_ (Db.execute_ database)
[ "CREATE TABLE pools ( \
\pool_id TEXT PRIMARY KEY, \
\limit_bytes BIGINT NOT NULL CHECK (limit_bytes > 0), \
\used_bytes BIGINT NOT NULL DEFAULT 0 CHECK (used_bytes >= 0), \
\reserved_bytes BIGINT NOT NULL DEFAULT 0 CHECK (reserved_bytes >= 0))"
, "CREATE TABLE mutations ( \
\user_id TEXT NOT NULL, kind TEXT NOT NULL, operation_id TEXT NOT NULL, \
\pool_id TEXT NOT NULL REFERENCES pools (pool_id), object_key TEXT NOT NULL, \
\relative_path TEXT NOT NULL, declared_size BIGINT NOT NULL, \
\content_sha256 TEXT, prior_size BIGINT NOT NULL, prior_sha256 TEXT, \
\growth_bytes BIGINT NOT NULL, state TEXT NOT NULL, \
\external_state TEXT NOT NULL DEFAULT 'idle', \
\created_at TIMESTAMPTZ NOT NULL DEFAULT now(), \
\updated_at TIMESTAMPTZ NOT NULL DEFAULT now(), \
\PRIMARY KEY (user_id, kind, operation_id))"
, "CREATE TABLE key_locks ( \
\object_key TEXT PRIMARY KEY, user_id TEXT NOT NULL, kind TEXT NOT NULL, \
\operation_id TEXT NOT NULL)"
, "CREATE TABLE objects_meta ( \
\object_key TEXT PRIMARY KEY, \
\pool_id TEXT NOT NULL REFERENCES pools (pool_id), \
\size_bytes BIGINT NOT NULL, content_sha256 TEXT NOT NULL, \
\updated_at TIMESTAMPTZ NOT NULL DEFAULT now())"
]
pure ()
verifyAdmission :: Db -> Config -> IO ()
verifyAdmission database config = do
resetAuthority database 100
replayOutcomes <- mapConcurrently
(const (admit database "same-operation" "same-key" 10))
[1 .. 8 :: Int]
assertEqual "one first request" 1 (countPrepared replayOutcomes)
assertEqual "stable concurrent replay" 7 (countReplay replayOutcomes)
assertAuthority database 1 10
resetAuthority database 100
conflictOutcomes <- mapConcurrently
(\size -> admit database "conflicting-operation" "conflicting-key" size)
[10, 11]
assertEqual "one conflicting first request" 1 (countPrepared conflictOutcomes)
assertEqual "conflicting reuse" 1 (countConflict conflictOutcomes)
assertAuthority database 1 (mrGrowth (preparedRecord conflictOutcomes))
resetAuthority database 100
keyOutcomes <- mapConcurrently
(\operation -> admit database operation "locked-key" 10)
["key-operation-a", "key-operation-b"]
assertEqual "one same-key authority" 1 (countPrepared keyOutcomes)
assertEqual "one same-key rejection" 1 (countRejected keyOutcomes)
assertAuthority database 1 10
resetAuthority database 10
quotaOutcomes <- mapConcurrently
(\(operation, key) -> admit database operation key 8)
[("quota-operation-a", "quota-key-a"), ("quota-operation-b", "quota-key-b")]
assertEqual "one quota reservation" 1 (countPrepared quotaOutcomes)
assertEqual "one quota rejection" 1 (countRejected quotaOutcomes)
assertAuthority database 1 8
lower <- try (configurePoolLimit database sharedPool 7)
:: IO (Either SomeException ())
assert "unsafe pool limit reduction rejected" (isLeft lower)
configurePoolLimit database sharedPool 20
pool <- Db.query database
"SELECT limit_bytes, used_bytes, reserved_bytes FROM pools WHERE pool_id = ?"
(Only (unPoolId sharedPool))
:: IO [(Integer, Integer, Integer)]
assertEqual "safe pool limit reconfiguration" [(20, 0, 8)] pool
let personalUser = UserId "personal-limit-user"
personal = personalPool personalUser
ensurePersonalPool database
config { cfgPersonalQuotaBytes = 30 }
personalUser
ensurePersonalPool database
config { cfgPersonalQuotaBytes = 40 }
personalUser
_ <- Db.execute database
"UPDATE pools SET reserved_bytes = 35 WHERE pool_id = ?"
(Only (unPoolId personal))
personalLower <- try
(ensurePersonalPool database
config { cfgPersonalQuotaBytes = 34 }
personalUser)
:: IO (Either SomeException ())
assert "unsafe personal limit reduction rejected" (isLeft personalLower)
personalPoolRow <- Db.query database
"SELECT limit_bytes, used_bytes, reserved_bytes FROM pools WHERE pool_id = ?"
(Only (unPoolId personal))
:: IO [(Integer, Integer, Integer)]
assertEqual "personal limit reconfiguration" [(40, 0, 35)] personalPoolRow
resetAuthority database 100
(racingAdmission, racingLimit) <- concurrently
(admit database "limit-race-operation" "limit-race-key" 80)
(try (configurePoolLimit database sharedPool 50)
:: IO (Either SomeException ()))
racingPool <- Db.query database
"SELECT limit_bytes, used_bytes, reserved_bytes FROM pools WHERE pool_id = ?"
(Only (unPoolId sharedPool))
:: IO [(Integer, Integer, Integer)]
case (racingAdmission, racingLimit, racingPool) of
(AdmitPrepared _, Left _, [(100, 0, 80)]) ->
assertAuthority database 1 80
(AdmitRejected _ _, Right (), [(50, 0, 0)]) ->
assertAuthority database 0 0
other -> fail ("unsafe admission/limit race result: " <> show other)
resetAuthority database 100
observationOutcome <- admit database
"observation-operation"
"observation-key"
10
let observationRecord = preparedRecord [observationOutcome]
thirdState =
ObjectPresent 10
(Just (ContentSha256
"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"))
settled <- withTransaction database $ \connection -> do
applying <- markApplying connection observationRecord
pending <- markExternalPending connection observationRecord
externalSettled <- markExternalSettled connection observationRecord
pure (applying && pending && externalSettled)
assert "observation fixture reached applying/settled" settled
unavailable <- withTransaction database $ \connection ->
finalizeFromObservation connection observationRecord
(ObjectUnavailable "timeout")
ambiguous <- withTransaction database $ \connection ->
finalizeFromObservation connection observationRecord thirdState
assertEqual "unavailable observation remains non-terminal" Nothing unavailable
assertEqual "third-state observation remains non-terminal" Nothing ambiguous
assertAuthority database 1 10
durableState <- Db.query database
"SELECT state, external_state FROM mutations \
\WHERE user_id = ? AND kind = ? AND operation_id = ?"
( "integration-user" :: Text
, "put" :: Text
, "observation-operation" :: Text
)
:: IO [(Text, Text)]
assertEqual "ambiguous observation retains mutation authority"
[("applying", "settled")]
durableState
verifyStorage :: Config -> S3 -> IO ()
verifyStorage config store = do
let fallbackKey = ObjectKey "shared/fallback.bin"
fallbackBody = BL.replicate (5 * 1024 * 1024) 0
fallbackIdentity =
ContentSha256
"c036cbb7553a909f8b8877d4461924307f27ecb66cff928eeeafd569c3887e29"
expectRight "put object without identity metadata"
=<< putObject store fallbackKey
(toInteger (BL.length fallbackBody))
Nothing
fallbackBody
fallbackHead <- expectJust "observe object without identity metadata"
=<< headObject store fallbackKey
assertEqual "streaming digest fallback size"
(toInteger (BL.length fallbackBody))
(oiSize fallbackHead)
assertEqual "streaming digest fallback identity"
(Just fallbackIdentity)
(oiSha256 fallbackHead)
expectRight "delete fallback object" =<< deleteObject store fallbackKey
let unicodeKey = ObjectKey "shared/문서/βeta.txt"
firstBody = "same-size-a"
secondBody = "same-size-b"
firstIdentity = contentIdentity firstBody
secondIdentity = contentIdentity secondBody
expectRight "put Unicode key"
=<< putObject store unicodeKey (toInteger (BL.length firstBody))
(Just firstIdentity) firstBody
fetched <- expectRight "get Unicode key" =<< getObjectBytes store unicodeKey
assertEqual "Unicode key round trip" firstBody fetched
firstHead <- expectJust "head Unicode key" =<< headObject store unicodeKey
assertEqual "head size" (toInteger (BL.length firstBody)) (oiSize firstHead)
assertEqual "head metadata" (Just firstIdentity) (oiSha256 firstHead)
expectRight "overwrite same-size content"
=<< putObject store unicodeKey (toInteger (BL.length secondBody))
(Just secondIdentity) secondBody
secondHead <- expectJust "head overwritten key" =<< headObject store unicodeKey
assert "same-size content identity differs"
(oiSha256 firstHead /= oiSha256 secondHead)
let paged =
[ (ObjectKey "shared/page/α", "a")
, (ObjectKey "shared/page/β", "b")
, (ObjectKey "shared/page/γ", "c")
]
mapM_
(\(key, body) ->
expectRight "put paged key"
=<< putObject store key (toInteger (BL.length body))
(Just (contentIdentity body)) body)
paged
keys <- collectPages store "shared/page/" Nothing []
assertEqual "paginated Unicode list"
(sort [unObjectKey key | (key, _) <- paged])
(sort keys)
missing <- getObjectBytes store (ObjectKey "shared/missing")
assertEqual "typed not-found error" (Left S3NotFound) missing
deniedStore <- newS3 config
{ cfgS3SecretKey = cfgS3SecretKey config <> "-invalid" }
denied <- listObjects deniedStore "" Nothing Nothing 1
case denied of
Left (S3ServiceError code) ->
assert "typed provider rejection" (code >= 400 && code < 500)
other -> fail ("expected typed provider rejection, got " <> show other)
expectRight "delete Unicode key" =<< deleteObject store unicodeKey
absent <- headObject store unicodeKey
assertEqual "deleted key absent" (Right Nothing) absent
collectPages :: S3 -> Text -> Maybe Text -> [Text] -> IO [Text]
collectPages store prefix marker accumulated = do
page <- expectRight "list page" =<< listObjects store prefix Nothing marker 1
let accumulated' = accumulated <> map fst (lpObjects page)
if lpIsTruncated page
then case lpContinuationToken page of
Nothing -> fail "truncated list omitted continuation marker"
Just next -> collectPages store prefix (Just next) accumulated'
else pure accumulated'
admit :: Db -> Text -> Text -> Integer -> IO AdmitOutcome
admit database operation key size =
withTransaction database $ \connection ->
admitMutation
connection
(UserId "integration-user")
Put
(OperationId operation)
sharedPool
(ObjectKey ("shared/" <> key))
(RelativePath key)
size
(Just fixedIdentity)
1000
resetAuthority :: Db -> Integer -> IO ()
resetAuthority database limitBytes = do
_ <- Db.execute_ database
"TRUNCATE key_locks, mutations, objects_meta, pools CASCADE"
configurePoolLimit database sharedPool limitBytes
assertAuthority :: Db -> Int -> Integer -> IO ()
assertAuthority database expectedLocks expectedReserved = do
locks <- Db.query_ database "SELECT count(*) FROM key_locks"
:: IO [Only Int]
reservations <- Db.query database
"SELECT reserved_bytes FROM pools WHERE pool_id = ?"
(Only (unPoolId sharedPool))
:: IO [Only Integer]
assertEqual "active key locks" [Only expectedLocks] locks
assertEqual "reserved bytes" [Only expectedReserved] reservations
countPrepared :: [AdmitOutcome] -> Int
countPrepared outcomes = length [() | AdmitPrepared _ <- outcomes]
countReplay :: [AdmitOutcome] -> Int
countReplay outcomes = length [() | AdmitReplay MutationPending _ <- outcomes]
countConflict :: [AdmitOutcome] -> Int
countConflict outcomes = length [() | AdmitConflict <- outcomes]
countRejected :: [AdmitOutcome] -> Int
countRejected outcomes = length [() | AdmitRejected _ _ <- outcomes]
preparedRecord :: [AdmitOutcome] -> MutationRecord
preparedRecord outcomes =
case [record | AdmitPrepared record <- outcomes] of
[record] -> record
_ -> error "expected exactly one prepared record"
fixedIdentity :: ContentSha256
fixedIdentity =
ContentSha256 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
contentIdentity :: BL.ByteString -> ContentSha256
contentIdentity =
ContentSha256
. TE.decodeUtf8
. B16.encode
. BA.convert
. (hashlazy :: BL.ByteString -> Digest SHA256)
expectRight :: String -> Either S3Error value -> IO value
expectRight label result =
case result of
Left err -> fail (label <> ": " <> show err)
Right value -> pure value
expectJust :: String -> Either S3Error (Maybe value) -> IO value
expectJust label result = do
value <- expectRight label result
case value of
Nothing -> fail (label <> ": object absent")
Just present -> pure present
assert :: String -> Bool -> IO ()
assert label condition =
unless condition (fail label)
assertEqual :: (Eq value, Show value) => String -> value -> value -> IO ()
assertEqual label expected actual =
unless (expected == actual) $
fail (label <> ": expected " <> show expected <> ", got " <> show actual)
isLeft :: Either left right -> Bool
isLeft (Left _) = True
isLeft (Right _) = False

15
test/Spec.hs
View file

@ -108,6 +108,21 @@ protocolTests = testGroup "mutation protocol decisions"
[ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
, testProperty "quota growth and admission preserve the limit" propQuotaInvariant
, testProperty "object observations match the independent classifier" propObservations
, testCase "unavailable observations match no terminal state" $ do
let rec = sampleMutation Put (ObjectKey "shared/file") 10
(Just (ContentSha256 "desired"))
observation = ObjectUnavailable "timeout"
desiredMatches rec observation @?= False
priorMatches rec observation @?= False
, testCase "ambiguous same-size content matches no terminal state" $ do
let rec = (sampleMutation Put (ObjectKey "shared/file") 10
(Just (ContentSha256 "desired")))
{ mrPriorSize = 10
, mrPriorSha256 = Just (ContentSha256 "prior")
}
observation = ObjectPresent 10 (Just (ContentSha256 "other"))
desiredMatches rec observation @?= False
priorMatches rec observation @?= False
, testProperty "only settled terminal records are expiry eligible" propExpiryEligibility
, testProperty "only stale active records are recovery eligible" propRecoveryTiming
]

27
tests/kind/wp04-job.yaml.in Normal file
View file

@ -0,0 +1,27 @@
apiVersion: batch/v1
kind: Job
metadata:
name: @@JOB_NAME@@
namespace: nuthatch-testbed
spec:
activeDeadlineSeconds: 300
backoffLimit: 0
ttlSecondsAfterFinished: 300
template:
spec:
automountServiceAccountToken: false
enableServiceLinks: false
restartPolicy: Never
containers:
- name: storage-foundation
image: @@TEST_IMAGE@@
imagePullPolicy: Never
command: [nuthatch-wp04-integration]
args: ["+RTS", "-N2", "-RTS"]
envFrom:
- configMapRef: {name: @@PROFILE_NAME@@}
env:
- {name: NUTHATCH_REDIS_URL, value: "redis://127.0.0.1:6379/0"}
resources:
requests: {cpu: 100m, memory: 32Mi}
limits: {cpu: "2", memory: 96Mi}

49
tests/kind/wp04-run.sh Executable file
View file

@ -0,0 +1,49 @@
#!/usr/bin/env bash
set -euo pipefail
ROOT="$(cd "$(dirname "$0")/../.." && pwd)"
source "$ROOT/tests/kind/lib.sh"
USER_KUBECONFIG_BEFORE="$(user_kubeconfig_digest)"
SUCCEEDED=false
OWNS_FIXTURE=false
APP_IMAGE=nuthatch-wp04:local
cleanup() {
local status=$?
trap - EXIT INT TERM
if [[ "${NUTHATCH_TESTBED_RETAIN:-0}" = 1 ]] && [[ "$SUCCEEDED" != true ]]; then
printf 'retained kubeconfig: %s\n' "$KUBECONFIG_PATH"
printf 'retained context: %s\n' "$CONTEXT"
exit "$status"
fi
if [[ "$OWNS_FIXTURE" = true ]]; then
destroy_fixture || status=1
fi
if [[ "$(user_kubeconfig_digest)" != "$USER_KUBECONFIG_BEFORE" ]]; then
printf 'user kubeconfig changed unexpectedly\n' >&2
status=1
fi
exit "$status"
}
trap cleanup EXIT
trap 'exit 130' INT
trap 'exit 143' TERM
acquire_fixture_lock
OWNS_FIXTURE=true
setup_fixture durable target
"$NUTHATCH_REAL_NERDCTL" --namespace default build \
--file "$ROOT/Dockerfile" \
--target test-runtime \
--tag "$APP_IMAGE" \
"$ROOT"
load_local_image "$APP_IMAGE" default
run_job_matrix \
wp04-storage \
"$TESTBED/wp04-job.yaml.in" \
"$APP_IMAGE" \
durable target
SUCCEEDED=true
printf 'Nuthatch WP-04 storage foundation passed\n'