Harden mutation admission and storage observation

Dockerfile

@@ -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"]

Makefile

@@ -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
 

app/Main.hs

@@ -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"
-        , ".." </> "sql" </> "001_schema.sql"
+        , ".." </> "sql"
-        , "/app/sql" </> "001_schema.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

nuthatch.cabal

@@ -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

sql/002_pool_limit_guard.sql

@@ -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);

src/Nuthatch/App.hs

@@ -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
+  case result of
-    Right (Just info) -> ObjectPresent (oiSize info) (oiSha256 info)
+    Right (Just info@ObjectInfo { oiSha256 = Just _ }) ->
-    Right Nothing     -> ObjectAbsent
+      pure (ObjectPresent (oiSize info) (oiSha256 info))
-    Left err          -> ObjectUnavailable err
+    Right (Just _) -> do
-
+      body <- getObjectBytes s3 key
-finalizeFromObservation
+      pure $ case body of
-  :: Connection
+        Right bytes ->
-  -> MutationRecord
+          ObjectPresent (toInteger (BL.length bytes)) (Just (contentSha256 bytes))
-  -> ObjectObservation
+        Left err -> ObjectUnavailable (renderS3Error err)
-  -> IO (Maybe MutationResult)
+    Right Nothing -> pure ObjectAbsent
-finalizeFromObservation conn rec observed =
+    Left err -> pure (ObjectUnavailable (renderS3Error err))
-  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
 
 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'

src/Nuthatch/Db.hs

@@ -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
+migrate db migrationDirectory cfg = withResource db $ \conn -> do
-  exists <- doesFileExist schemaPath
+  result <- runMigration conn defaultOptions $
-  sql <- if exists then readFile schemaPath else pure builtinSchema
+    MigrationInitialization
-  mapM_ (runStatement conn) (splitStatements sql)
+      <> MigrationDirectory migrationDirectory
-  _ <- PG.execute conn
+      <> MigrationValidation (MigrationDirectory migrationDirectory)
-    "INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes) \
+  case result of
-    \VALUES (?, ?, 0, 0) ON CONFLICT (pool_id) DO UPDATE SET limit_bytes = EXCLUDED.limit_bytes"
+    MigrationSuccess ->
-    (unPoolId sharedPool, cfgSharedQuotaBytes cfg)
+      PGT.withTransaction conn $
-  pure ()
+        configurePoolLimitConnection conn sharedPool (cfgSharedQuotaBytes cfg)
-
+    MigrationError name -> throwIO (userError ("migration failed: " <> name))
-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
 
 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)
+    (unPoolId pool, limitBytes)
-  pure ()
+  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()"
-    , ");"
-    ]

src/Nuthatch/Protocol.hs

@@ -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

src/Nuthatch/S3.hs

@@ -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 qualified Aws
-import           Crypto.MAC.HMAC (HMAC, hmac)
+import qualified Aws.Aws as AwsRun
-import           Data.ByteArray (convert)
+import qualified Aws.Core as AwsCore
-import qualified Data.ByteString as BS
+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 qualified Data.Conduit as C
-import           Data.Char (toLower)
+import qualified Data.Conduit.List as CL
-import           Data.List (sort)
-import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
-import           Data.Time.Clock (UTCTime, getCurrentTime)
+import qualified Network.HTTP.Client as HTTP
-import           Data.Time.Format (defaultTimeLocale, formatTime)
-import           Network.HTTP.Client
-  ( Manager
-  , Request (..)
-  , RequestBody (..)
-  , Response (..)
-  , httpLbs
-  , newManager
-  , parseRequest
-  , responseTimeoutNone
-  , setQueryString
-  )
 import           Network.HTTP.Client.TLS (tlsManagerSettings)
-import           Network.HTTP.Types (Header, RequestHeaders, statusCode)
+import           Network.HTTP.Types.Status (statusCode)
-import           Network.HTTP.Types.URI (parseQuery)
+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
+  { s3Configuration :: Aws.Configuration
-  , s3Endpoint  :: Text
+  , s3Service       :: S3.S3Configuration Aws.NormalQuery
-  , s3Region    :: Text
+  , 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
+    { s3Configuration = configuration
-    , s3Endpoint = cfgS3Endpoint cfg
+    , s3Service = service
-    , s3Region = cfgS3Region cfg
+    , 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
-putObject s3 key size sha body
+  :: S3
-  | toInteger (BL.length body) /= size = pure (Left "body size mismatch")
+  -> ObjectKey
-  | ContentSha256 (TE.decodeUtf8 (hexSha256Lazy body)) /= sha =
+  -> Integer
-      pure (Left "content sha256 mismatch")
+  -> 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
+      let request =
-      req0 <- mkObjectRequest s3 "PUT" key [] now
+            (S3.putObject (s3Bucket store) key (HTTP.RequestBodyLBS body))
-      let payloadHash = hexSha256Lazy body
+              { S3.poContentType = Just "application/octet-stream"
-          req = signRequest s3 now payloadHash req0
+              , S3.poMetadata = maybe []
-            { requestBody = RequestBodyLBS body
+                  (\identity ->
-            , requestHeaders =
+                    [("nuthatch-sha256", unContentSha256 identity)])
-                [ (mk "content-length", BS8.pack (show size))
+                  sha
-                , (mk "content-type", "application/octet-stream")
-                , (mk "x-amz-meta-nuthatch-sha256", TE.encodeUtf8 (unContentSha256 sha))
-                ]
-                  <> requestHeaders req0
               }
-      resp <- httpLbs req (s3Manager s3)
+      result <- try (runMemory store request)
-      let code = statusCode (responseStatus resp)
+        :: IO (Either SomeException S3.PutObjectResponse)
-      pure $ if code >= 200 && code < 300
+      pure (either (Left . classifyException) (const (Right ())) result)
-        then Right ()
-        else Left ("s3 put failed: HTTP " <> T.pack (show code)
-                    <> " " <> TE.decodeUtf8 (BL.toStrict (responseBody resp)))
 
-getObjectBytes :: S3 -> ObjectKey -> IO (Either Text BL.ByteString)
+getObjectBytes :: S3 -> ObjectKey -> IO (Either S3Error BL.ByteString)
-getObjectBytes s3 key = do
+getObjectBytes store (ObjectKey key) = do
-  now <- getCurrentTime
+  result <- getObjectMemory store key
-  req0 <- mkObjectRequest s3 "GET" key [] now
+  pure $ result >>= \(_, body) -> Right body
-  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))
 
-headObject :: S3 -> ObjectKey -> IO (Either Text (Maybe ObjectInfo))
+headObject :: S3 -> ObjectKey -> IO (Either S3Error (Maybe ObjectInfo))
-headObject s3 key = do
+headObject store (ObjectKey key) = do
-  now <- getCurrentTime
+  result <- try (runMemory store (S3.headObject (s3Bucket store) key))
-  req0 <- mkObjectRequest s3 "HEAD" key [] now
+    :: IO (Either SomeException S3.HeadObjectMemoryResponse)
-  let req = signRequest s3 now (hexSha256Lazy "") req0
+  case result of
-  resp <- httpLbs req (s3Manager s3)
+    Left err -> pure (Left (classifyException err))
-  let code = statusCode (responseStatus resp)
+    Right (S3.HeadObjectMemoryResponse Nothing) -> pure (Right Nothing)
-  pure $ case code of
+    Right (S3.HeadObjectMemoryResponse (Just _)) -> do
-    200 ->
+      object <- observeObjectStream store key
-      let headers = responseHeaders resp
+      pure (Just <$> object)
-          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))
 
-deleteObject :: S3 -> ObjectKey -> IO (Either Text ())
+deleteObject :: S3 -> ObjectKey -> IO (Either S3Error ())
-deleteObject s3 key = do
+deleteObject store (ObjectKey key) = do
-  now <- getCurrentTime
+  result <- try (runMemory store (S3.DeleteObject key (s3Bucket store)))
-  req0 <- mkObjectRequest s3 "DELETE" key [] now
+    :: IO (Either SomeException S3.DeleteObjectResponse)
-  let req = signRequest s3 now (hexSha256Lazy "") req0
+  pure $ case result of
-  resp <- httpLbs req (s3Manager s3)
+    Left err ->
-  let code = statusCode (responseStatus resp)
+      case classifyException err of
-  pure $ if code == 204 || code == 200 || code == 404
+        S3NotFound -> Right ()
-    then Right ()
+        other -> Left other
-    else Left ("s3 delete failed: HTTP " <> T.pack (show code))
+    Right _ -> Right ()
 
 listObjects
   :: S3
@@ -153,249 +182,160 @@ listObjects
   -> Maybe Text
   -> Maybe Text
   -> Int
-  -> IO (Either Text ListPage)
+  -> IO (Either S3Error ListPage)
-listObjects s3 prefix delimiter continuation maxKeys = do
+listObjects store prefix delimiter continuation maxKeys = do
-  now <- getCurrentTime
+  let request =
-  let qs =
+        (S3.getBucket (s3Bucket store))
-        [ ("list-type", Just "2")
+          { S3.gbPrefix = Just prefix
-        , ("prefix", Just (TE.encodeUtf8 prefix))
+          , S3.gbDelimiter = delimiter
-        , ("max-keys", Just (BS8.pack (show maxKeys)))
+          , S3.gbMarker = continuation
-        ]
+          , S3.gbMaxKeys = Just maxKeys
-          <> maybe [] (\d -> [("delimiter", Just (TE.encodeUtf8 d))]) delimiter
+          }
-          <> maybe [] (\t -> [("continuation-token", Just (TE.encodeUtf8 t))]) continuation
+  result <- try (runMemory store request)
-  req0 <- mkBucketRequest s3 "GET" qs now
+    :: IO (Either SomeException S3.GetBucketResponse)
-  let req = signRequest s3 now (hexSha256Lazy "") req0
+  pure $ case result of
-  resp <- httpLbs req (s3Manager s3)
+    Left err -> Left (classifyException err)
-  let code = statusCode (responseStatus resp)
+    Right response ->
-      body = responseBody resp
+      Right ListPage
-  if code /= 200
+        { lpPrefixes = S3.gbrCommonPrefixes response
-    then pure (Left ("s3 list failed: HTTP " <> T.pack (show code)
+        , lpObjects =
-                      <> " " <> TE.decodeUtf8 (BL.toStrict body)))
+            map (\object -> (S3.objectKey object, S3.objectSize object))
-    else pure (parseListXml body)
+              (S3.gbrContents response)
-
+        , lpContinuationToken =
-parseListXml :: BL.ByteString -> Either Text ListPage
+            S3.gbrNextMarker response
-parseListXml body =
+              <|> fallbackMarker response
-  case XML.parseLBS XML.def body of
+        , lpIsTruncated = S3.gbrIsTruncated response
-    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
         }
   where
-    elementLocal e = XML.nameLocalName (XML.elementName e)
+    fallbackMarker response =
-    elementTexts e =
+      if S3.gbrIsTruncated response
-      [ t
+        then S3.objectKey <$> lastMaybe (S3.gbrContents response)
-      | XML.NodeContent t <- XML.elementNodes e
+        else Nothing
-      ]
-    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)
 
-mkObjectRequest :: S3 -> BS.ByteString -> ObjectKey -> [Header] -> UTCTime -> IO Request
+renderS3Error :: S3Error -> Text
-mkObjectRequest s3 method (ObjectKey key) headers _now = do
+renderS3Error S3NotFound = "object not found"
-  let path = objectUrlPath s3 key
+renderS3Error (S3ServiceError code) =
-  base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
+  "object store returned HTTP " <> T.pack (show code)
-  pure base
+renderS3Error S3TransportError = "object store transport failed"
-    { method = method
+renderS3Error S3ResponseError = "object store response was invalid"
-    , requestHeaders = headers
-    , responseTimeout = responseTimeoutNone
-    }
 
-mkBucketRequest :: S3 -> BS.ByteString -> [(BS.ByteString, Maybe BS.ByteString)] -> UTCTime -> IO Request
+runMemory
-mkBucketRequest s3 method qs _now = do
+  :: ( Aws.Transaction request response
-  let path = bucketUrlPath s3
+     , Aws.AsMemoryResponse response
-  base <- parseRequest (T.unpack (s3Endpoint s3) <> path)
+     , Aws.MemoryResponse response ~ memoryResponse
-  pure $ setQueryString qs base
+     , Aws.ServiceConfiguration request Aws.NormalQuery
-    { method = method
+         ~ S3.S3Configuration Aws.NormalQuery
-    , responseTimeout = responseTimeoutNone
+     )
-    }
+  => S3
+  -> request
+  -> IO memoryResponse
+runMemory store =
+  AwsRun.memoryAws
+    (s3Configuration store)
+    (s3Service store)
+    (s3Manager store)
 
-objectUrlPath :: S3 -> Text -> String
+getObjectMemory
-objectUrlPath s3 key =
+  :: S3
-  let bucket = T.unpack (s3Bucket s3)
+  -> Text
-      encodedKey = escapePath (T.unpack key)
+  -> IO (Either S3Error (S3.ObjectMetadata, BL.ByteString))
-  in if s3PathStyle s3
+getObjectMemory store key = do
-       then "/" <> bucket <> "/" <> encodedKey
+  result <- try (runMemory store (S3.getObject (s3Bucket store) key))
-       else "/" <> encodedKey
+    :: 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
+observeObjectStream :: S3 -> Text -> IO (Either S3Error ObjectInfo)
-bucketUrlPath s3 =
+observeObjectStream store key = do
-  let bucket = T.unpack (s3Bucket s3)
+  result <- try (runResourceT getInfo)
-  in if s3PathStyle s3 then "/" <> bucket else "/"
+    :: IO (Either SomeException ObjectInfo)
-
+  pure (either (Left . classifyException) Right result)
-escapePath :: String -> String
-escapePath = concatMap escapeChar
   where
-    escapeChar c
+    getInfo = do
-      | c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~/" :: String) = [c]
+      response <- AwsRun.pureAws
-      | otherwise =
+        (s3Configuration store)
-          let (q, r) = fromEnum c `divMod` 16
+        (s3Service store)
-              hex = "0123456789ABCDEF"
+        (s3Manager store)
-          in ['%', hex !! q, hex !! r]
+        (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
+contextIdentity :: Context SHA256 -> ContentSha256
-signRequest s3 now payloadHash req =
+contextIdentity =
-  let amzDate = BS8.pack (formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ" now)
+  ContentSha256
-      dateStamp = BS8.take 8 amzDate
+    . TE.decodeUtf8
-      region = TE.encodeUtf8 (s3Region s3)
+    . B16.encode
-      service = "s3" :: BS.ByteString
+    . BA.convert
-      credentialScope =
+    . hashFinalize
-        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 }
 
-sortOnHeader :: RequestHeaders -> RequestHeaders
+classifyException :: SomeException -> S3Error
-sortOnHeader = sortOn (\(n, _) -> BS8.map toLower (original n))
+classifyException exception =
-  where
+  case fromException exception of
-    sortOn f = map snd . sort . map (\x -> (f x, x))
+    Just serviceError
-
+      | statusCode (S3.s3StatusCode serviceError) == 404 -> S3NotFound
-hostHeader :: Request -> BS.ByteString
+      | otherwise ->
-hostHeader req =
+          S3ServiceError (statusCode (S3.s3StatusCode serviceError))
-  case lookup (mk "Host") (requestHeaders req) of
-    Just h -> h
     Nothing ->
-      let h = host req
+      case fromException exception :: Maybe HTTP.HttpException of
-          p = port req
+        Just (HTTP.HttpExceptionRequest _ content) ->
-      in if p == 80 || p == 443
+          case content of
-           then h
+            HTTP.StatusCodeException response _
-           else h <> ":" <> BS8.pack (show p)
+              | statusCode (HTTP.responseStatus response) == 404 -> S3NotFound
+              | otherwise ->
+                  S3ServiceError (statusCode (HTTP.responseStatus response))
+            _ -> S3TransportError
+        Just (HTTP.InvalidUrlException _ _) -> S3ResponseError
+        Nothing -> S3ResponseError
 
-pathURL :: Request -> String
+lastMaybe :: [a] -> Maybe a
-pathURL req =
+lastMaybe [] = Nothing
-  case BS8.unpack (path req) of
+lastMaybe values = Just (last values)
-    "" -> "/"
-    p  -> p
 
-canonicalQueryString :: Request -> BS.ByteString
+parseEndpoint :: Text -> IO (AwsCore.Protocol, BS8.ByteString, Int)
-canonicalQueryString req =
+parseEndpoint raw =
-  let pairs = parseQuery (queryString req)
+  case parseURI (T.unpack raw) of
-      enc = escapeQuery
+    Just URI
-      encoded =
+      { uriScheme
-        sort
+      , uriAuthority = Just URIAuth
-          [ enc k <> "=" <> enc (fromMaybe "" v)
+          { uriUserInfo = ""
-          | (k, v) <- pairs
+          , uriRegName
-          ]
+          , uriPort
-  in BS8.intercalate "&" encoded
+          }
-
+      , uriPath = ""
-escapeQuery :: BS.ByteString -> BS.ByteString
+      , uriQuery = ""
-escapeQuery = BS8.concatMap escape1
+      , uriFragment = ""
-  where
+      }
-    escape1 c
+        | uriScheme == "http:" || uriScheme == "https:" -> do
-      | c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~" :: String)
+            port <- case uriPort of
-          = BS8.singleton c
+              "" -> pure (if uriScheme == "https:" then 443 else 80)
-      | otherwise =
+              ':' : value ->
-          let (q, r) = fromEnum c `divMod` 16
+                maybe (fail "invalid S3 endpoint port") pure (readMaybe value)
-              hex = "0123456789ABCDEF"
+              _ -> fail "invalid S3 endpoint port"
-          in BS8.pack ['%', hex !! q, hex !! r]
+            let protocol =
-
+                  if uriScheme == "https:" then AwsCore.HTTPS else AwsCore.HTTP
-hmacSHA256 :: BS.ByteString -> BS.ByteString -> BS.ByteString
+            pure (protocol, BS8.pack uriRegName, port)
-hmacSHA256 key msg = convert (hmac key msg :: HMAC SHA256)
+    _ -> fail "NUTHATCH_S3_ENDPOINT must be an absolute HTTP(S) origin"
-
-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

test/Integration.hs

@@ -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

test/Spec.hs

@@ -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
   ]

tests/kind/wp04-job.yaml.in

@@ -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}

tests/kind/wp04-run.sh

@@ -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'