Add Haskell MVP BFF with mutation protocol and local compose stack.

src/Nuthatch.hs

@@ -0,0 +1,7 @@
+module Nuthatch
+  ( module Nuthatch.App
+  , module Nuthatch.Config
+  ) where
+
+import           Nuthatch.App
+import           Nuthatch.Config

src/Nuthatch/App.hs

@@ -0,0 +1,759 @@
+module Nuthatch.App
+  ( Env (..)
+  , newEnv
+  , application
+  , runRecovery
+  ) where
+
+import           Control.Concurrent (threadDelay)
+import           Control.Exception (SomeException, try)
+import           Control.Monad (forever, void, when)
+import           Crypto.Hash (Digest, SHA256, hashlazy)
+import qualified Data.Aeson as A
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BL
+import           Data.Maybe (fromMaybe, listToMaybe)
+import           Data.Text (Text)
+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           Network.HTTP.Types
+  ( Header
+  , HeaderName
+  , Status (..)
+  , hContentDisposition
+  , hContentType
+  , hLocation
+  , status200
+  , status302
+  , status400
+  , status403
+  , status404
+  , status413
+  , status429
+  , status500
+  , status503
+  )
+import           Network.Wai
+  ( Application
+  , Request (..)
+  , Response
+  , ResponseReceived
+  , responseLBS
+  )
+import           Network.Wai.Parse (FileInfo (..), lbsBackEnd, parseRequestBody)
+import           Nuthatch.Audit (audit)
+import           Nuthatch.Config (Config (..))
+import           Nuthatch.Db (Db, ensurePersonalPool, withTransaction)
+import qualified Nuthatch.Db as Db
+import           Nuthatch.Paths
+import           Nuthatch.Protocol
+import           Nuthatch.Redis (Redis, cacheGet, cacheInvalidatePrefixes, cacheSet, throttleTake)
+import           Nuthatch.S3
+  ( ListPage (..)
+  , ObjectInfo (..)
+  , S3
+  , deleteObject
+  , getObjectBytes
+  , headObject
+  , listObjects
+  , putObject
+  )
+import           Nuthatch.Session
+import           Nuthatch.Types
+import           Nuthatch.Ui
+
+data Env = Env
+  { envConfig :: Config
+  , envDb     :: Db
+  , envRedis  :: Redis
+  , envS3     :: S3
+  }
+
+newEnv :: Config -> Db -> Redis -> S3 -> Env
+newEnv = Env
+
+application :: Env -> Application
+application env req respond =
+  case (requestMethod req, pathInfo req) of
+    ("GET", ["healthz"]) ->
+      respond (json status200 (A.object ["ok" A..= True]))
+    ("GET", ["readyz"]) ->
+      respond =<< readiness env
+    ("GET", ["login"]) ->
+      respond (htmlResponse status200 (loginPage ""))
+    ("POST", ["login"]) ->
+      handleLogin env req respond
+    ("GET", ["logout"]) ->
+      handleLogout env respond
+    ("POST", ["logout"]) ->
+      handleLogout env respond
+    ("GET", []) ->
+      withSession env req respond handleBrowse
+    ("GET", ["download"]) ->
+      withSession env req respond handleDownload
+    ("POST", ["upload"]) ->
+      withSession env req respond handleUpload
+    ("POST", ["delete"]) ->
+      withSession env req respond handleDelete
+    _ ->
+      respond (text status404 "not found")
+
+readiness :: Env -> IO Response
+readiness env = do
+  pg <- try $ Db.query_ (envDb env) "SELECT 1" :: IO (Either SomeException [Only Int])
+  pure $ case pg of
+    Right _ -> json status200 (A.object ["ready" A..= True])
+    Left _  -> json status503 (A.object ["ready" A..= False])
+
+handleLogin :: Env -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+handleLogin env req respond = do
+  (params, _) <- parseRequestBody lbsBackEnd req
+  let username =
+        T.strip . TE.decodeUtf8 . fromMaybe "" $
+          lookup "username" params
+  if T.null username || T.any (`elem` (" \t\r\n" :: String)) username
+    then respond (htmlResponse status400 (loginPage "Enter a single username token."))
+    else do
+      let uid = encodeUserId "nuthatch-dev" username
+      ensurePersonalPool (envDb env) (envConfig env) uid
+      tokenResult <- mintSession (envConfig env) "nuthatch-dev" username (Just username)
+      csrf <- newCsrfToken
+      case tokenResult of
+        Left err -> respond (htmlResponse status500 (loginPage err))
+        Right jwt -> do
+          audit "login" "ok" (Just (unUserId uid)) []
+          respond $
+            responseLBS status302
+              [ (hLocation, "/")
+              , setCookie (envConfig env) (cfgCookieName (envConfig env)) jwt True
+              , setCookie (envConfig env) (cfgCsrfCookieName (envConfig env)) csrf False
+              ]
+              ""
+
+handleLogout :: Env -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+handleLogout env respond =
+  respond $
+    responseLBS status302
+      [ (hLocation, "/login")
+      , clearCookie (envConfig env) (cfgCookieName (envConfig env))
+      , clearCookie (envConfig env) (cfgCsrfCookieName (envConfig env))
+      ]
+      ""
+
+withSession
+  :: Env
+  -> Request
+  -> (Response -> IO ResponseReceived)
+  -> (Env -> Request -> SessionUser -> Text -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
+  -> IO ResponseReceived
+withSession env req respond handler = do
+  let cookies = parseCookies (requestHeaders req)
+      cfg = envConfig env
+  case lookup (TE.encodeUtf8 (cfgCookieName cfg)) cookies of
+    Nothing -> respond (redirect "/login")
+    Just raw -> do
+      verified <- verifySession cfg (TE.decodeUtf8 raw)
+      case verified of
+        Left _ -> respond (redirect "/login")
+        Right user -> do
+          csrf <- case lookup (TE.encodeUtf8 (cfgCsrfCookieName cfg)) cookies of
+            Just c  -> pure (TE.decodeUtf8 c)
+            Nothing -> newCsrfToken
+          handler env req user csrf respond
+
+handleBrowse
+  :: Env
+  -> Request
+  -> SessionUser
+  -> Text
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
+handleBrowse env req user csrf respond = do
+  let qs = queryString req
+      root = fromMaybe Personal (parseRoot =<< (TE.decodeUtf8 <$> join (lookup "root" qs)))
+      prefix = maybe "" TE.decodeUtf8 (join (lookup "prefix" qs))
+      q = maybe "" TE.decodeUtf8 (join (lookup "q" qs))
+      notice = maybe "" TE.decodeUtf8 (join (lookup "notice" qs))
+      errQ = maybe "" TE.decodeUtf8 (join (lookup "error" qs))
+  ensurePersonalPool (envDb env) (envConfig env) (suUserId user)
+  entriesResult <-
+    if T.null q
+      then listEntries env user root prefix
+      else searchEntries env user root q
+  uploadOp <- toText <$> nextRandom
+  case entriesResult of
+    Left err ->
+      respond
+        (htmlResponse status500
+          (browsePage user root prefix csrf uploadOp [] [] (Just err) notice))
+    Right entries -> do
+      deleteOps <- mapM (\_ -> toText <$> nextRandom) entries
+      let mErr = if T.null errQ then Nothing else Just errQ
+      respond
+        (htmlResponse status200
+          (browsePage user root prefix csrf uploadOp deleteOps entries mErr notice))
+
+handleDownload
+  :: Env
+  -> Request
+  -> SessionUser
+  -> Text
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
+handleDownload env req user _csrf respond = do
+  let qs = queryString req
+      mRoot = parseRoot =<< (TE.decodeUtf8 <$> join (lookup "root" qs))
+      mPath = TE.decodeUtf8 <$> join (lookup "path" qs)
+  case (mRoot, mPath) of
+    (Just root, Just rawPath) ->
+      case validateRelativePath rawPath of
+        Left err -> respond (text status400 err)
+        Right rel -> do
+          let key = buildObjectKey root (suUserId user) rel
+          meta <- headObject (envS3 env) key
+          case meta of
+            Left err -> respond (text status502 err)
+            Right Nothing -> respond (text status404 "not found")
+            Right (Just info) -> do
+              allowed <- throttleTake (envRedis env) (envConfig env) (suUserId user) (oiSize info)
+              case allowed of
+                Left _ -> respond (text status503 "bandwidth throttle unavailable")
+                Right False -> respond (text status429 "bandwidth limit exceeded")
+                Right True -> do
+                  bodyResult <- getObjectBytes (envS3 env) key
+                  case bodyResult of
+                    Left err -> respond (text status502 err)
+                    Right body -> do
+                      audit "download" "ok" (Just (unUserId (suUserId user)))
+                        [ ("root", A.toJSON (rootLabel root))
+                        , ("bytes", A.toJSON (oiSize info))
+                        ]
+                      let filename = basename rel
+                          disp =
+                            "attachment; filename=\""
+                              <> TE.encodeUtf8 (sanitizeFilename filename)
+                              <> "\""
+                      respond $
+                        responseLBS status200
+                          [ (hContentType, "application/octet-stream")
+                          , (hContentDisposition, disp)
+                          , ("X-Content-Type-Options", "nosniff")
+                          ]
+                          body
+    _ -> respond (text status400 "root and path are required")
+
+handleUpload
+  :: Env
+  -> Request
+  -> SessionUser
+  -> Text
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
+handleUpload env req user csrf respond = do
+  (params, files) <- parseRequestBody lbsBackEnd req
+  let providedCsrf = maybe "" TE.decodeUtf8 (lookup "csrf" params)
+  if not (constantTimeEq csrf providedCsrf)
+    then respond (text status403 "csrf validation failed")
+    else do
+      let root = fromMaybe Personal (parseRoot . TE.decodeUtf8 =<< lookup "root" params)
+          prefix = maybe "" TE.decodeUtf8 (lookup "prefix" params)
+      case lookup "file" files of
+        Nothing ->
+          respond (redirect (browseUrl root prefix "" "missing file"))
+        Just fileInfo -> do
+          let name = TE.decodeUtf8 (fileName fileInfo)
+              content = fileContent fileInfo
+              size = toInteger (BL.length content)
+          if size <= 0
+            then respond (redirect (browseUrl root prefix "" "empty file"))
+            else if size > cfgMaxObjectBytes (envConfig env)
+              then respond (text status413 "object too large")
+              else case validateRelativePath (joinPath prefix name) of
+                Left err -> respond (redirect (browseUrl root prefix "" err))
+                Right rel -> do
+                  allowed <- throttleTake (envRedis env) (envConfig env) (suUserId user) size
+                  case allowed of
+                    Left _ -> respond (text status503 "bandwidth throttle unavailable")
+                    Right False -> respond (text status429 "bandwidth limit exceeded")
+                    Right True -> do
+                      let sha = contentSha256 content
+                      op <- parseOperationId params
+                      outcome <- runPut env user root rel op size sha content
+                      case outcome of
+                        Left err ->
+                          respond (redirect (browseUrl root prefix "" err))
+                        Right MutationSucceeded -> do
+                          audit "put" "ok" (Just (unUserId (suUserId user)))
+                            [ ("root", A.toJSON (rootLabel root))
+                            , ("bytes", A.toJSON size)
+                            , ("operation_id", A.toJSON (unOperationId op))
+                            ]
+                          respond (redirect (browseUrl root prefix "uploaded" ""))
+                        Right MutationRejected ->
+                          respond (redirect (browseUrl root prefix "" "upload rejected (quota or lock)"))
+                        Right MutationConflict ->
+                          respond (redirect (browseUrl root prefix "" "operation conflict"))
+                        Right MutationPending ->
+                          respond (redirect (browseUrl root prefix "" "upload still pending; retry same operation id"))
+                        Right other ->
+                          respond (redirect (browseUrl root prefix "" ("upload " <> T.pack (show other))))
+
+handleDelete
+  :: Env
+  -> Request
+  -> SessionUser
+  -> Text
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
+handleDelete env req user csrf respond = do
+  (params, _) <- parseRequestBody lbsBackEnd req
+  let providedCsrf = maybe "" TE.decodeUtf8 (lookup "csrf" params)
+  if not (constantTimeEq csrf providedCsrf)
+    then respond (text status403 "csrf validation failed")
+    else do
+      let root = fromMaybe Personal (parseRoot . TE.decodeUtf8 =<< lookup "root" params)
+          rawPath = maybe "" TE.decodeUtf8 (lookup "path" params)
+          isPrefix = maybe False (== "1") (TE.decodeUtf8 <$> lookup "prefix_delete" params)
+          parent = parentOf rawPath
+      if isPrefix
+        then do
+          result <- deletePrefix env user root rawPath
+          case result of
+            Left err -> respond (redirect (browseUrl root parent "" err))
+            Right n ->
+              respond
+                (redirect
+                  (browseUrl root parent ("deleted " <> T.pack (show n) <> " object(s)") ""))
+        else
+          case validateRelativePath rawPath of
+            Left err -> respond (redirect (browseUrl root parent "" err))
+            Right rel -> do
+              op <- parseOperationId params
+              outcome <- runDelete env user root rel op
+              case outcome of
+                Left err -> respond (redirect (browseUrl root parent "" err))
+                Right MutationSucceeded -> do
+                  audit "delete" "ok" (Just (unUserId (suUserId user)))
+                    [ ("root", A.toJSON (rootLabel root))
+                    , ("operation_id", A.toJSON (unOperationId op))
+                    ]
+                  respond (redirect (browseUrl root parent "deleted" ""))
+                Right MutationRejected ->
+                  respond (redirect (browseUrl root parent "" "delete rejected"))
+                Right MutationPending ->
+                  respond (redirect (browseUrl root parent "" "delete still pending; retry same operation id"))
+                Right other ->
+                  respond (redirect (browseUrl root parent "" ("delete " <> T.pack (show other))))
+
+runPut
+  :: Env
+  -> SessionUser
+  -> Root
+  -> RelativePath
+  -> OperationId
+  -> Integer
+  -> ContentSha256
+  -> BL.ByteString
+  -> IO (Either Text MutationResult)
+runPut env user root rel op size sha body = do
+  ensurePersonalPool (envDb env) (envConfig env) (suUserId user)
+  let uid = suUserId user
+      key = buildObjectKey root uid rel
+      pool = case root of
+        Personal -> personalPool uid
+        Shared   -> sharedPool
+  outcome <- withTransaction (envDb env) $ \conn ->
+    admitMutation conn uid Put op pool key rel size (Just sha)
+      (cfgMaxObjectBytes (envConfig env))
+  case outcome of
+    AdmitConflict -> pure (Right MutationConflict)
+    AdmitRejected reason _ -> pure (Left reason)
+    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
+      pure ()
+
+runDelete
+  :: Env
+  -> SessionUser
+  -> Root
+  -> RelativePath
+  -> OperationId
+  -> IO (Either Text MutationResult)
+runDelete env user root rel op = do
+  ensurePersonalPool (envDb env) (envConfig env) (suUserId user)
+  let uid = suUserId user
+      key = buildObjectKey root uid rel
+      pool = case root of
+        Personal -> personalPool uid
+        Shared   -> sharedPool
+  outcome <- withTransaction (envDb env) $ \conn ->
+    admitMutation conn uid Delete op pool key rel 0 Nothing
+      (cfgMaxObjectBytes (envConfig env))
+  case outcome of
+    AdmitConflict -> pure (Right MutationConflict)
+    AdmitRejected reason _ -> pure (Left reason)
+    AdmitReplay MutationPending _ -> pure (Right MutationPending)
+    AdmitReplay result _ -> pure (Right result)
+    AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
+      _ <- deleteObject (envS3 env) key
+      pure ()
+
+dispatchAndFinalize
+  :: Env
+  -> SessionUser
+  -> Root
+  -> MutationRecord
+  -> IO ()
+  -> IO (Either Text MutationResult)
+dispatchAndFinalize env user root rec dispatch = do
+  prepared <- withTransaction (envDb env) $ \conn -> do
+    moved <- markApplying conn rec
+    if not moved
+      then pure False
+      else markExternalPending conn rec
+  if not prepared
+    then pure (Right MutationPending)
+    else do
+      _ <- try dispatch :: IO (Either SomeException ())
+      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      finalized <- withTransaction (envDb env) $ \conn -> do
+        settled <- markExternalSettled conn rec
+        if not settled
+          then pure Nothing
+          else finalizeFromObservation conn rec observed
+      case finalized of
+        Just MutationSucceeded -> do
+          cacheInvalidatePrefixes (envRedis env) (suUserId user) root
+            (listCacheAncestorPrefixes (mrRelativePath rec))
+          pure (Right MutationSucceeded)
+        Just MutationFailed ->
+          pure (Left "mutation failed after store settlement")
+        Just other -> pure (Right other)
+        Nothing -> pure (Right MutationPending)
+
+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
+
+deletePrefix :: Env -> SessionUser -> Root -> Text -> IO (Either Text Int)
+deletePrefix env user root prefix = do
+  let listPrefix =
+        case root of
+          Personal ->
+            "users/" <> unUserId (suUserId user) <> "/" <> withSlash prefix
+          Shared ->
+            "shared/" <> withSlash prefix
+  keysResult <- collectKeys (envS3 env) listPrefix
+  case keysResult of
+    Left err -> pure (Left err)
+    Right keys -> do
+      let rootPrefix =
+            case root of
+              Personal -> "users/" <> unUserId (suUserId user) <> "/"
+              Shared   -> "shared/"
+          rels =
+            [ RelativePath rel
+            | k <- keys
+            , T.isPrefixOf rootPrefix k
+            , let rel = T.drop (T.length rootPrefix) k
+            , not (T.null rel)
+            ]
+      results <- mapM
+        (\rel -> do
+            op <- OperationId . toText <$> nextRandom
+            runDelete env user root rel op)
+        rels
+      let ok = length [ () | Right MutationSucceeded <- results ]
+          err = listToMaybe [ e | Left e <- results ]
+      pure $ maybe (Right ok) Left err
+  where
+    withSlash p
+      | T.null p = ""
+      | T.isSuffixOf "/" p = p
+      | otherwise = p <> "/"
+
+collectKeys :: S3 -> Text -> IO (Either Text [Text])
+collectKeys s3 prefix = go Nothing []
+  where
+    go mTok acc = do
+      page <- listObjects s3 prefix Nothing mTok 1000
+      case page of
+        Left err -> pure (Left err)
+        Right lp -> do
+          let keys = map fst (lpObjects lp)
+              acc' = acc <> keys
+          if lpIsTruncated lp
+            then go (lpContinuationToken lp) acc'
+            else pure (Right acc')
+
+listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
+listEntries env user root prefix = do
+  let cacheKey =
+        "nuthatch:list:"
+          <> unUserId (suUserId user)
+          <> ":"
+          <> rootLabel root
+          <> ":"
+          <> prefix
+          <> ":"
+      s3Prefix =
+        case root of
+          Personal -> "users/" <> unUserId (suUserId user) <> "/" <> prefixSlash
+          Shared   -> "shared/" <> prefixSlash
+      prefixSlash
+        | T.null prefix = ""
+        | T.isSuffixOf "/" prefix = prefix
+        | otherwise = prefix <> "/"
+  cached <- cacheGet (envRedis env) cacheKey
+  case cached >>= A.decodeStrict of
+    Just entries -> pure (Right entries)
+    Nothing -> do
+      page <- listObjects (envS3 env) s3Prefix (Just "/") Nothing 1000
+      case page of
+        Left err -> pure (Left err)
+        Right lp -> do
+          let rootPrefix =
+                case root of
+                  Personal -> "users/" <> unUserId (suUserId user) <> "/"
+                  Shared   -> "shared/"
+              folders =
+                [ ListEntry
+                    { leName = lastSeg (T.dropEnd 1 (T.drop (T.length rootPrefix) p))
+                    , leIsPrefix = True
+                    , leSize = Nothing
+                    , leRelativePath = T.dropEnd 1 (T.drop (T.length rootPrefix) p)
+                    }
+                | p <- lpPrefixes lp
+                , T.isPrefixOf rootPrefix p
+                ]
+              files =
+                [ ListEntry
+                    { leName = lastSeg rel
+                    , leIsPrefix = False
+                    , leSize = Just sz
+                    , leRelativePath = rel
+                    }
+                | (k, sz) <- lpObjects lp
+                , T.isPrefixOf rootPrefix k
+                , let rel = T.drop (T.length rootPrefix) k
+                , not (T.null rel)
+                , not (T.isSuffixOf "/" rel)
+                ]
+              entries = folders <> files
+          cacheSet (envRedis env) cacheKey (cfgListCacheTtlSec (envConfig env))
+            (BL.toStrict (A.encode entries))
+          pure (Right entries)
+
+searchEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
+searchEntries env user root q = do
+  let s3Prefix =
+        case root of
+          Personal -> "users/" <> unUserId (suUserId user) <> "/"
+          Shared   -> "shared/"
+      needle = T.toLower q
+  keysResult <- collectKeysBounded (envS3 env) s3Prefix (cfgSearchMaxKeys (envConfig env))
+  pure $ case keysResult of
+    Left err -> Left err
+    Right keys ->
+      Right
+        [ ListEntry
+            { leName = lastSeg rel
+            , leIsPrefix = False
+            , leSize = Just sz
+            , leRelativePath = rel
+            }
+        | (k, sz) <- keys
+        , T.isPrefixOf s3Prefix k
+        , let rel = T.drop (T.length s3Prefix) k
+        , not (T.null rel)
+        , needle `T.isInfixOf` T.toLower rel
+        ]
+
+collectKeysBounded :: S3 -> Text -> Int -> IO (Either Text [(Text, Integer)])
+collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
+  where
+    go mTok acc n
+      | n >= maxKeys = pure (Right (take maxKeys acc))
+      | otherwise = do
+          page <- listObjects s3 prefix Nothing mTok (min 1000 (maxKeys - n))
+          case page of
+            Left err -> pure (Left err)
+            Right lp -> do
+              let acc' = acc <> lpObjects lp
+                  n' = length acc'
+              if lpIsTruncated lp && n' < maxKeys
+                then go (lpContinuationToken lp) acc' n'
+                else pure (Right (take maxKeys acc'))
+
+runRecovery :: Env -> IO ()
+runRecovery env = forever $ do
+  _ <- try (recoverOnce env) :: IO (Either SomeException ())
+  threadDelay (5 * 1000000)
+
+recoverOnce :: Env -> IO ()
+recoverOnce env = do
+  let grace = cfgRecoveryGraceSec (envConfig env)
+  batch <- withTransaction (envDb env) $ \conn -> claimActiveBatch conn 20 grace
+  mapM_ (recoverOne env) batch
+
+recoverOne :: Env -> MutationRecord -> IO ()
+recoverOne env rec =
+  case (mrState rec, mrExternal rec) of
+    (Prepared, _) -> do
+      _ <- withTransaction (envDb env) $ \conn -> do
+        moved <- markApplying conn rec
+        when moved $ void (markSettledFromIdle conn rec)
+      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      _ <- withTransaction (envDb env) $ \conn ->
+        finalizeFromObservation conn rec observed
+      pure ()
+    (Applying, ExtIdle) -> do
+      _ <- withTransaction (envDb env) $ \conn -> markSettledFromIdle conn rec
+      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      _ <- withTransaction (envDb env) $ \conn ->
+        finalizeFromObservation conn rec observed
+      pure ()
+    (Applying, ExtPending) -> do
+      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      _ <- withTransaction (envDb env) $ \conn -> do
+        settled <- markExternalSettled conn rec
+        if settled
+          then finalizeFromObservation conn rec observed
+          else pure Nothing
+      pure ()
+    (Applying, ExtSettled) -> do
+      observed <- observeObject (envS3 env) (mrObjectKey rec)
+      _ <- withTransaction (envDb env) $ \conn ->
+        finalizeFromObservation conn rec observed
+      pure ()
+    _ -> pure ()
+
+parseOperationId :: [(BS.ByteString, BS.ByteString)] -> IO OperationId
+parseOperationId params =
+  case lookup "operation_id" params of
+    Just raw | not (BS.null raw) ->
+      pure (OperationId (TE.decodeUtf8 raw))
+    _ ->
+      OperationId . toText <$> nextRandom
+
+joinPath :: Text -> Text -> Text
+joinPath prefix name
+  | T.null prefix = name
+  | T.isSuffixOf "/" prefix = prefix <> name
+  | otherwise = prefix <> "/" <> name
+
+parentOf :: Text -> Text
+parentOf path =
+  case reverse (T.splitOn "/" path) of
+    (_ : rest) -> T.intercalate "/" (reverse rest)
+    _          -> ""
+
+browseUrl :: Root -> Text -> Text -> Text -> Text
+browseUrl root prefix notice err =
+  "/?root=" <> rootLabel root
+    <> (if T.null prefix then "" else "&prefix=" <> prefix)
+    <> (if T.null notice then "" else "&notice=" <> notice)
+    <> (if T.null err then "" else "&error=" <> err)
+
+contentSha256 :: BL.ByteString -> ContentSha256
+contentSha256 body =
+  ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
+    (hashlazy body :: Digest SHA256)
+
+sanitizeFilename :: Text -> Text
+sanitizeFilename =
+  T.map $ \c -> if c `elem` ("\"\\\r\n" :: String) then '_' else c
+
+lastSeg :: Text -> Text
+lastSeg t =
+  case reverse (T.splitOn "/" t) of
+    (x : _) -> x
+    []      -> t
+
+json :: Status -> A.Value -> Response
+json st v =
+  responseLBS st [(hContentType, "application/json")] (A.encode v)
+
+text :: Status -> Text -> Response
+text st t =
+  responseLBS st [(hContentType, "text/plain; charset=utf-8")]
+    (BL.fromStrict (TE.encodeUtf8 t))
+
+redirect :: Text -> Response
+redirect loc =
+  responseLBS status302 [(hLocation, TE.encodeUtf8 loc)] ""
+
+setCookie :: Config -> Text -> Text -> Bool -> (HeaderName, BS.ByteString)
+setCookie _cfg name value httpOnly =
+  ( "Set-Cookie"
+  , TE.encodeUtf8 $
+      name <> "=" <> value
+        <> "; Path=/"
+        <> "; SameSite=Lax"
+        <> (if httpOnly then "; HttpOnly" else "")
+  )
+
+clearCookie :: Config -> Text -> (HeaderName, BS.ByteString)
+clearCookie _cfg name =
+  ( "Set-Cookie"
+  , TE.encodeUtf8 (name <> "=; Path=/; Max-Age=0; SameSite=Lax")
+  )
+
+parseCookies :: [Header] -> [(BS.ByteString, BS.ByteString)]
+parseCookies headers =
+  case lookup "Cookie" headers of
+    Nothing -> []
+    Just raw ->
+      [ (trimBS k, trimBS (BS8.drop 1 v))
+      | part <- BS8.split ';' raw
+      , let (k, v) = BS8.break (== '=') part
+      , not (BS.null v)
+      ]
+
+trimBS :: BS.ByteString -> BS.ByteString
+trimBS = BS8.dropWhile isSpace . BS8.dropWhileEnd isSpace
+  where
+    isSpace c = c == ' ' || c == '\t'
+
+join :: Maybe (Maybe a) -> Maybe a
+join = fromMaybe Nothing
+
+status502 :: Status
+status502 = Status 502 "Bad Gateway"

src/Nuthatch/Audit.hs

@@ -0,0 +1,22 @@
+module Nuthatch.Audit
+  ( audit
+  ) where
+
+import           Data.Aeson (Value, encode, object, (.=))
+import qualified Data.Aeson.Key as Key
+import qualified Data.ByteString.Lazy.Char8 as L8
+import           Data.Text (Text)
+import           Data.Time.Clock (getCurrentTime)
+import           Data.Time.Format.ISO8601 (iso8601Show)
+
+audit :: Text -> Text -> Maybe Text -> [(Text, Value)] -> IO ()
+audit action result mUser extra = do
+  now <- getCurrentTime
+  let pairs =
+        [ "ts" .= iso8601Show now
+        , "action" .= action
+        , "result" .= result
+        ]
+          <> maybe [] (\u -> ["user_id" .= u]) mUser
+          <> [ Key.fromText k .= v | (k, v) <- extra ]
+  L8.putStrLn (encode (object pairs))

src/Nuthatch/Config.hs

@@ -0,0 +1,157 @@
+module Nuthatch.Config
+  ( Config (..)
+  , AuthMode (..)
+  , loadConfig
+  ) where
+
+import           Control.Monad (when)
+import           Data.Maybe (fromMaybe)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           System.Environment (lookupEnv)
+import           Text.Read (readMaybe)
+
+data AuthMode = AuthDev
+  deriving stock (Eq, Show)
+
+data Config = Config
+  { cfgListenHost          :: String
+  , cfgListenPort          :: Int
+  , cfgPublicBaseUrl       :: Text
+  , cfgJwtSecret           :: Text
+  , cfgSessionHours        :: Integer
+  , cfgCookieName          :: Text
+  , cfgCsrfCookieName      :: Text
+  , cfgPgConn              :: String
+  , cfgRedisHost           :: String
+  , cfgRedisPort           :: Int
+  , cfgRedisDb             :: Integer
+  , cfgS3Endpoint          :: Text
+  , cfgS3Region            :: Text
+  , cfgS3Bucket            :: Text
+  , cfgS3AccessKey         :: Text
+  , cfgS3SecretKey         :: Text
+  , cfgS3PathStyle         :: Bool
+  , cfgPersonalQuotaBytes  :: Integer
+  , cfgSharedQuotaBytes    :: Integer
+  , cfgMaxObjectBytes      :: Integer
+  , cfgThrottleBytesPerSec :: Integer
+  , cfgThrottleBurstBytes  :: Integer
+  , cfgListCacheTtlSec     :: Integer
+  , cfgSearchMaxKeys       :: Int
+  , cfgRecoveryGraceSec    :: Integer
+  , cfgAuthMode            :: AuthMode
+  }
+  deriving stock (Show)
+
+loadConfig :: IO Config
+loadConfig = do
+  listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
+  let (host, portText) = splitHostPort listen
+  port <- requireRead "NUTHATCH_LISTEN port" portText
+  publicBase <- T.pack . fromMaybe ("http://" <> listen) <$> lookupEnv "NUTHATCH_PUBLIC_BASE_URL"
+  jwtSecret <- T.pack . fromMaybe "dev-only-change-me-to-a-long-random-string" <$> lookupEnv "NUTHATCH_JWT_SECRET"
+  when (T.length jwtSecret < 16) $
+    fail "NUTHATCH_JWT_SECRET must be at least 16 characters"
+  sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
+  cookieName <- T.pack . fromMaybe "nuthatch_session" <$> lookupEnv "NUTHATCH_COOKIE_NAME"
+  csrfCookie <- T.pack . fromMaybe "nuthatch_csrf" <$> lookupEnv "NUTHATCH_CSRF_COOKIE_NAME"
+  pgConn <- fromMaybe "host=127.0.0.1 port=5432 user=nuthatch password=nuthatch dbname=nuthatch"
+    <$> lookupEnv "NUTHATCH_PG_CONN"
+  redisUrl <- fromMaybe "redis://127.0.0.1:6379/0" <$> lookupEnv "NUTHATCH_REDIS_URL"
+  (redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
+  s3Endpoint <- T.pack . fromMaybe "http://127.0.0.1:9000" <$> lookupEnv "NUTHATCH_S3_ENDPOINT"
+  s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
+  s3Bucket <- T.pack . fromMaybe "nuthatch" <$> lookupEnv "NUTHATCH_S3_BUCKET"
+  s3Access <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "NUTHATCH_S3_ACCESS_KEY"
+  s3Secret <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "NUTHATCH_S3_SECRET_KEY"
+  pathStyle <- envBool "NUTHATCH_S3_PATH_STYLE" True
+  personalQuota <- envInteger "NUTHATCH_PERSONAL_QUOTA_BYTES" (1024 * 1024 * 1024)
+  sharedQuota <- envInteger "NUTHATCH_SHARED_QUOTA_BYTES" (10 * 1024 * 1024 * 1024)
+  maxObject <- envInteger "NUTHATCH_MAX_OBJECT_BYTES" (100 * 1024 * 1024)
+  throttleRate <- envInteger "NUTHATCH_THROTTLE_BYTES_PER_SEC" (10 * 1024 * 1024)
+  throttleBurst <- envInteger "NUTHATCH_THROTTLE_BURST_BYTES" (20 * 1024 * 1024)
+  listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
+  searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
+  recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
+  authModeText <- fromMaybe "dev" <$> lookupEnv "NUTHATCH_AUTH_MODE"
+  authMode <- case authModeText of
+    "dev" -> pure AuthDev
+    other -> fail $ "unsupported NUTHATCH_AUTH_MODE: " <> other
+  pure Config
+    { cfgListenHost = host
+    , cfgListenPort = port
+    , cfgPublicBaseUrl = publicBase
+    , cfgJwtSecret = jwtSecret
+    , cfgSessionHours = sessionHours
+    , cfgCookieName = cookieName
+    , cfgCsrfCookieName = csrfCookie
+    , cfgPgConn = pgConn
+    , cfgRedisHost = redisHost
+    , cfgRedisPort = redisPort
+    , cfgRedisDb = redisDb
+    , cfgS3Endpoint = s3Endpoint
+    , cfgS3Region = s3Region
+    , cfgS3Bucket = s3Bucket
+    , cfgS3AccessKey = s3Access
+    , cfgS3SecretKey = s3Secret
+    , cfgS3PathStyle = pathStyle
+    , cfgPersonalQuotaBytes = personalQuota
+    , cfgSharedQuotaBytes = sharedQuota
+    , cfgMaxObjectBytes = maxObject
+    , cfgThrottleBytesPerSec = throttleRate
+    , cfgThrottleBurstBytes = throttleBurst
+    , cfgListCacheTtlSec = listTtl
+    , cfgSearchMaxKeys = searchMax
+    , cfgRecoveryGraceSec = recoveryGrace
+    , cfgAuthMode = authMode
+    }
+
+splitHostPort :: String -> (String, String)
+splitHostPort s =
+  case break (== ':') s of
+    (h, ':' : p) -> (h, p)
+    _            -> ("127.0.0.1", "8080")
+
+envInteger :: String -> Integer -> IO Integer
+envInteger name def = do
+  m <- lookupEnv name
+  case m of
+    Nothing -> pure def
+    Just v  -> requireRead name v
+
+envBool :: String -> Bool -> IO Bool
+envBool name def = do
+  m <- lookupEnv name
+  case fmap T.toLower (T.pack <$> m) of
+    Nothing      -> pure def
+    Just "1"     -> pure True
+    Just "true"  -> pure True
+    Just "yes"   -> pure True
+    Just "0"     -> pure False
+    Just "false" -> pure False
+    Just "no"    -> pure False
+    Just other   -> fail $ name <> ": invalid boolean " <> T.unpack other
+
+requireRead :: (Read a) => String -> String -> IO a
+requireRead name v =
+  case readMaybe v of
+    Just x  -> pure x
+    Nothing -> fail $ name <> ": cannot parse " <> v
+
+parseRedisUrl :: String -> IO (String, Int, Integer)
+parseRedisUrl url =
+  case T.stripPrefix "redis://" (T.pack url) of
+    Nothing -> fail "NUTHATCH_REDIS_URL must start with redis://"
+    Just rest -> do
+      let (hostPort, dbPart) =
+            case T.breakOn "/" rest of
+              (hp, d) | T.null d -> (hp, "/0")
+              (hp, d)            -> (hp, d)
+          (hostText, portText) =
+            case T.breakOn ":" hostPort of
+              (h, p) | T.null p -> (h, "6379")
+              (h, p)            -> (h, T.drop 1 p)
+      port <- requireRead "redis port" (T.unpack portText)
+      db <- requireRead "redis db" (T.unpack (T.drop 1 dbPart))
+      pure (T.unpack hostText, port, db)

src/Nuthatch/Db.hs

@@ -0,0 +1,140 @@
+module Nuthatch.Db
+  ( Db
+  , withDb
+  , migrate
+  , ensurePersonalPool
+  , withTransaction
+  , query
+  , query_
+  , execute
+  , execute_
+  , executeMany
+  ) where
+
+import           Control.Exception (bracket)
+import qualified Data.ByteString.Char8 as BS8
+import           Data.Pool
+  ( Pool
+  , defaultPoolConfig
+  , destroyAllResources
+  , newPool
+  , setNumStripes
+  , withResource
+  )
+import           Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
+import qualified Database.PostgreSQL.Simple as PG
+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
+
+withDb :: Config -> (Db -> IO a) -> IO a
+withDb cfg action = do
+  let mk = connectPostgreSQL (BS8.pack (cfgPgConn cfg))
+      poolCfg =
+        setNumStripes (Just 1) $
+          defaultPoolConfig mk close 30 10
+  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
+
+ensurePersonalPool :: Db -> Config -> UserId -> IO ()
+ensurePersonalPool db cfg uid = withResource db $ \conn -> 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 ()
+
+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
+
+query_ :: (PG.FromRow r) => Db -> PG.Query -> IO [r]
+query_ db q = withResource db $ \conn -> PG.query_ conn q
+
+execute :: (PG.ToRow q) => Db -> PG.Query -> q -> IO Int
+execute db q params = withResource db $ \conn -> fromIntegral <$> PG.execute conn q params
+
+execute_ :: Db -> PG.Query -> IO Int
+execute_ db q = withResource db $ \conn -> fromIntegral <$> PG.execute_ conn q
+
+executeMany :: (PG.ToRow q) => Db -> PG.Query -> [q] -> IO Int
+executeMany db q rows = withResource db $ \conn -> fromIntegral <$> PG.executeMany conn q rows
+
+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/Paths.hs

@@ -0,0 +1,60 @@
+module Nuthatch.Paths
+  ( validateRelativePath
+  , buildObjectKey
+  , listCacheAncestorPrefixes
+  , encodeUserId
+  , basename
+  ) where
+
+import           Crypto.Hash (Digest, SHA256, hash)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as B16
+import           Data.Char (isControl)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           Nuthatch.Types
+
+validateRelativePath :: Text -> Either Text RelativePath
+validateRelativePath raw = do
+  let path = T.dropWhile (== '/') raw
+  if T.null path
+    then Left "path must not be empty"
+    else do
+      let segments = T.splitOn "/" path
+      mapM_ validateSegment segments
+      pure (RelativePath path)
+  where
+    validateSegment seg
+      | T.null seg = Left "empty path segment"
+      | seg == "." || seg == ".." = Left "path segment may not be . or .."
+      | T.any (== '\\') seg = Left "backslash is not allowed"
+      | T.any isControl seg = Left "control characters are not allowed"
+      | otherwise = Right ()
+
+buildObjectKey :: Root -> UserId -> RelativePath -> ObjectKey
+buildObjectKey root uid (RelativePath path) =
+  ObjectKey $ case root of
+    Personal -> "users/" <> unUserId uid <> "/" <> path
+    Shared   -> "shared/" <> path
+
+listCacheAncestorPrefixes :: RelativePath -> [Text]
+listCacheAncestorPrefixes (RelativePath path) =
+  let segs = filter (not . T.null) (T.splitOn "/" path)
+  in case segs of
+       [] -> [""]
+       _  -> "" : init (scanl1 (\a b -> a <> "/" <> b) segs)
+
+encodeUserId :: Text -> Text -> UserId
+encodeUserId iss sub =
+  let material = TE.encodeUtf8 (iss <> "\0" <> sub)
+      digest = hash material :: Digest SHA256
+      hex = B16.encode (BS.pack (BA.unpack digest))
+  in UserId (TE.decodeUtf8 hex)
+
+basename :: RelativePath -> Text
+basename (RelativePath path) =
+  case reverse (T.splitOn "/" path) of
+    (x : _) -> x
+    []      -> path

src/Nuthatch/Protocol.hs

@@ -0,0 +1,441 @@
+-- | Short Postgres transactions for mutation authority; store I/O stays outside them.
+module Nuthatch.Protocol
+  ( AdmitOutcome (..)
+  , MutationRecord (..)
+  , ObjectObservation (..)
+  , admitMutation
+  , markApplying
+  , markExternalPending
+  , markExternalSettled
+  , markSettledFromIdle
+  , finalizeSuccess
+  , finalizeFailure
+  , claimActiveBatch
+  , lookupMutation
+  , lookupObjectMeta
+  , desiredMatches
+  , priorMatches
+  ) where
+
+import           Data.Maybe (listToMaybe, mapMaybe)
+import           Data.Text (Text)
+import           Database.PostgreSQL.Simple (Connection, Only (..), execute, query)
+import           Nuthatch.Types
+
+data MutationRecord = MutationRecord
+  { mrUserId        :: UserId
+  , mrKind          :: MutationKind
+  , mrOperationId   :: OperationId
+  , mrPoolId        :: PoolId
+  , mrObjectKey     :: ObjectKey
+  , mrRelativePath  :: RelativePath
+  , mrDeclaredSize  :: Integer
+  , mrContentSha256 :: Maybe ContentSha256
+  , mrPriorSize     :: Integer
+  , mrPriorSha256   :: Maybe ContentSha256
+  , mrGrowth        :: Integer
+  , mrState         :: MutationState
+  , mrExternal      :: ExternalState
+  }
+  deriving stock (Show)
+
+-- | Unavailable must not drive terminal finalize.
+data ObjectObservation
+  = ObjectPresent Integer (Maybe ContentSha256)
+  | ObjectAbsent
+  | ObjectUnavailable Text
+  deriving stock (Eq, Show)
+
+data AdmitOutcome
+  = AdmitPrepared MutationRecord
+  | AdmitReplay MutationResult MutationRecord
+  | AdmitRejected Text MutationRecord
+  | AdmitConflict
+  deriving stock (Show)
+
+type ResultRow =
+  ( Text, Text, Text, Text, Text, Text, Integer, Maybe Text
+  , Integer, Maybe Text, Integer, Text, Text
+  )
+
+rowToRecord :: ResultRow -> Maybe MutationRecord
+rowToRecord (user, kindT, op, pool, key, rel, size, csha, prior, psha, growth, stateT, extT) = do
+  kind <- parseKind kindT
+  state <- parseState stateT
+  ext <- parseExternal extT
+  pure MutationRecord
+    { mrUserId = UserId user
+    , mrKind = kind
+    , mrOperationId = OperationId op
+    , mrPoolId = PoolId pool
+    , mrObjectKey = ObjectKey key
+    , mrRelativePath = RelativePath rel
+    , mrDeclaredSize = size
+    , mrContentSha256 = ContentSha256 <$> csha
+    , mrPriorSize = prior
+    , mrPriorSha256 = ContentSha256 <$> psha
+    , mrGrowth = growth
+    , mrState = state
+    , mrExternal = ext
+    }
+
+lookupMutation :: Connection -> UserId -> MutationKind -> OperationId -> IO (Maybe MutationRecord)
+lookupMutation conn uid kind op = do
+  rows <- query conn
+    "SELECT user_id, kind, operation_id, pool_id, object_key, relative_path, \
+    \declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
+    \state, external_state FROM mutations \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+    (unUserId uid, kindLabel kind, unOperationId op)
+  pure (listToMaybe rows >>= rowToRecord)
+
+lookupObjectMeta :: Connection -> ObjectKey -> IO (Maybe (Integer, ContentSha256))
+lookupObjectMeta conn (ObjectKey key) = do
+  rows <- query conn
+    "SELECT size_bytes, content_sha256 FROM objects_meta WHERE object_key = ?"
+    (Only key)
+  pure $ case rows of
+    [(sz, sha)] -> Just (sz, ContentSha256 sha)
+    _           -> Nothing
+
+sameFingerprint :: MutationRecord -> MutationKind -> ObjectKey -> Integer -> Maybe ContentSha256 -> Bool
+sameFingerprint rec kind key size msha =
+  mrKind rec == kind
+    && mrObjectKey rec == key
+    && mrDeclaredSize rec == size
+    && mrContentSha256 rec == msha
+
+admitMutation
+  :: Connection
+  -> UserId
+  -> MutationKind
+  -> OperationId
+  -> PoolId
+  -> ObjectKey
+  -> RelativePath
+  -> Integer
+  -> Maybe ContentSha256
+  -> Integer
+  -> IO AdmitOutcome
+admitMutation conn uid kind op pool key rel size msha maxObject = do
+  existing <- lookupMutation conn uid kind op
+  case existing of
+    Just rec
+      | sameFingerprint rec kind key size msha ->
+          pure $ AdmitReplay (stateToResult (mrState rec)) rec
+      | otherwise -> pure AdmitConflict
+    Nothing -> do
+      priorMeta <- lookupObjectMeta conn key
+      let priorSize = maybe 0 fst priorMeta
+          priorSha = snd <$> priorMeta
+          desiredSize = case kind of
+            Put    -> size
+            Delete -> 0
+          growth = max 0 (desiredSize - priorSize)
+          baseRec state =
+            MutationRecord
+              { mrUserId = uid
+              , mrKind = kind
+              , mrOperationId = op
+              , mrPoolId = pool
+              , mrObjectKey = key
+              , mrRelativePath = rel
+              , mrDeclaredSize = size
+              , mrContentSha256 = msha
+              , mrPriorSize = priorSize
+              , mrPriorSha256 = priorSha
+              , mrGrowth = 0
+              , mrState = state
+              , mrExternal = ExtIdle
+              }
+
+      _ <- query conn
+        "SELECT 1 FROM pools WHERE pool_id = ? FOR UPDATE"
+        (Only (unPoolId pool)) :: IO [Only Int]
+
+      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)
+        else do
+          locked <- query conn
+            "SELECT 1 FROM key_locks WHERE object_key = ? FOR UPDATE"
+            (Only (unObjectKey key)) :: IO [Only Int]
+          if not (null locked)
+            then do
+              rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
+              pure (AdmitRejected "key locked by another mutation" rec)
+            else do
+              okQuota <- query conn
+                "SELECT 1 FROM pools \
+                \WHERE pool_id = ? AND used_bytes + reserved_bytes + ? <= limit_bytes"
+                (unPoolId pool, growth) :: IO [Only Int]
+              if null okQuota
+                then do
+                  rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
+                  pure (AdmitRejected "quota exceeded" rec)
+                else do
+                  n <- execute conn
+                    "INSERT INTO mutations \
+                    \(user_id, kind, operation_id, pool_id, object_key, relative_path, \
+                    \ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
+                    \ state, external_state) \
+                    \VALUES (?,?,?,?,?,?,?,?,?,?,?,'prepared','idle')"
+                    ( unUserId uid
+                    , kindLabel kind
+                    , unOperationId op
+                    , unPoolId pool
+                    , unObjectKey key
+                    , unRelativePath rel
+                    , size
+                    , unContentSha256 <$> msha
+                    , priorSize
+                    , unContentSha256 <$> priorSha
+                    , growth
+                    )
+                  if n /= 1
+                    then pure AdmitConflict
+                    else do
+                      lockN <- execute conn
+                        "INSERT INTO key_locks (object_key, user_id, kind, operation_id) \
+                        \VALUES (?,?,?,?) ON CONFLICT DO NOTHING"
+                        (unObjectKey key, unUserId uid, kindLabel kind, unOperationId op)
+                      if lockN /= 1
+                        then do
+                          _ <- execute conn
+                            "UPDATE mutations SET state = 'rejected', growth_bytes = 0, \
+                            \updated_at = now() \
+                            \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+                            (unUserId uid, kindLabel kind, unOperationId op)
+                          pure $ AdmitRejected "key locked by another mutation"
+                            (baseRec Rejected)
+                        else do
+                          _ <- execute conn
+                            "UPDATE pools SET reserved_bytes = reserved_bytes + ? WHERE pool_id = ?"
+                            (growth, unPoolId pool)
+                          pure $ AdmitPrepared MutationRecord
+                            { mrUserId = uid
+                            , mrKind = kind
+                            , mrOperationId = op
+                            , mrPoolId = pool
+                            , mrObjectKey = key
+                            , mrRelativePath = rel
+                            , mrDeclaredSize = size
+                            , mrContentSha256 = msha
+                            , mrPriorSize = priorSize
+                            , mrPriorSha256 = priorSha
+                            , mrGrowth = growth
+                            , mrState = Prepared
+                            , mrExternal = ExtIdle
+                            }
+
+insertTerminalRejected
+  :: Connection
+  -> UserId
+  -> MutationKind
+  -> OperationId
+  -> PoolId
+  -> ObjectKey
+  -> RelativePath
+  -> Integer
+  -> Maybe ContentSha256
+  -> Integer
+  -> Maybe ContentSha256
+  -> IO MutationRecord
+insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha = do
+  _ <- execute conn
+    "INSERT INTO mutations \
+    \(user_id, kind, operation_id, pool_id, object_key, relative_path, \
+    \ declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
+    \ state, external_state) \
+    \VALUES (?,?,?,?,?,?,?,?,?,?,0,'rejected','idle') \
+    \ON CONFLICT DO NOTHING"
+    ( unUserId uid
+    , kindLabel kind
+    , unOperationId op
+    , unPoolId pool
+    , unObjectKey key
+    , unRelativePath rel
+    , size
+    , unContentSha256 <$> msha
+    , priorSize
+    , unContentSha256 <$> priorSha
+    )
+  pure MutationRecord
+    { mrUserId = uid
+    , mrKind = kind
+    , mrOperationId = op
+    , mrPoolId = pool
+    , mrObjectKey = key
+    , mrRelativePath = rel
+    , mrDeclaredSize = size
+    , mrContentSha256 = msha
+    , mrPriorSize = priorSize
+    , mrPriorSha256 = priorSha
+    , mrGrowth = 0
+    , mrState = Rejected
+    , mrExternal = ExtIdle
+    }
+
+stateToResult :: MutationState -> MutationResult
+stateToResult Prepared  = MutationPending
+stateToResult Applying  = MutationPending
+stateToResult Succeeded = MutationSucceeded
+stateToResult Failed    = MutationFailed
+stateToResult Rejected  = MutationRejected
+
+markApplying :: Connection -> MutationRecord -> IO Bool
+markApplying conn rec = do
+  n <- execute conn
+    "UPDATE mutations SET state = 'applying', updated_at = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? AND state = 'prepared'"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+  pure (n == 1)
+
+markExternalPending :: Connection -> MutationRecord -> IO Bool
+markExternalPending conn rec = do
+  n <- execute conn
+    "UPDATE mutations SET external_state = 'pending', updated_at = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? \
+    \AND state = 'applying' AND external_state = 'idle'"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+  pure (n == 1)
+
+markExternalSettled :: Connection -> MutationRecord -> IO Bool
+markExternalSettled conn rec = do
+  n <- execute conn
+    "UPDATE mutations SET external_state = 'settled', updated_at = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? \
+    \AND state = 'applying' AND external_state = 'pending'"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+  pure (n == 1)
+
+markSettledFromIdle :: Connection -> MutationRecord -> IO Bool
+markSettledFromIdle conn rec = do
+  n <- execute conn
+    "UPDATE mutations SET external_state = 'settled', updated_at = now() \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? \
+    \AND state = 'applying' AND external_state = 'idle'"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+  pure (n == 1)
+
+finalizeSuccess :: Connection -> MutationRecord -> Integer -> Maybe ContentSha256 -> IO Bool
+finalizeSuccess conn rec finalSize finalSha = do
+  rows <- query conn
+    "SELECT state, external_state, growth_bytes, prior_size FROM mutations \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+      :: IO [(Text, Text, Integer, Integer)]
+  case rows of
+    [(st, ext, growth, prior)]
+      | st == "applying" && ext == "settled" -> do
+          let pool = mrPoolId rec
+          _ <- execute conn
+            "UPDATE pools SET used_bytes = used_bytes - ? + ?, \
+            \reserved_bytes = reserved_bytes - ? WHERE pool_id = ?"
+            (prior, finalSize, growth, unPoolId pool)
+          case mrKind rec of
+            Put -> do
+              let sha = maybe "" unContentSha256 finalSha
+              _ <- execute conn
+                "INSERT INTO objects_meta (object_key, pool_id, size_bytes, content_sha256, updated_at) \
+                \VALUES (?,?,?,?, now()) \
+                \ON CONFLICT (object_key) DO UPDATE SET \
+                \  size_bytes = EXCLUDED.size_bytes, \
+                \  content_sha256 = EXCLUDED.content_sha256, \
+                \  updated_at = now()"
+                (unObjectKey (mrObjectKey rec), unPoolId pool, finalSize, sha)
+              pure ()
+            Delete -> do
+              _ <- execute conn
+                "DELETE FROM objects_meta WHERE object_key = ?"
+                (Only (unObjectKey (mrObjectKey rec)))
+              pure ()
+          _ <- execute conn
+            "UPDATE mutations SET state = 'succeeded', external_state = 'idle', updated_at = now() \
+            \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+            (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+          _ <- execute conn
+            "DELETE FROM key_locks WHERE object_key = ? AND user_id = ? AND kind = ? AND operation_id = ?"
+            ( unObjectKey (mrObjectKey rec)
+            , unUserId (mrUserId rec)
+            , kindLabel (mrKind rec)
+            , unOperationId (mrOperationId rec)
+            )
+          pure True
+    _ -> pure False
+
+finalizeFailure :: Connection -> MutationRecord -> IO Bool
+finalizeFailure conn rec = do
+  rows <- query conn
+    "SELECT state, external_state, growth_bytes FROM mutations \
+    \WHERE user_id = ? AND kind = ? AND operation_id = ? FOR UPDATE"
+    (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+      :: IO [(Text, Text, Integer)]
+  case rows of
+    [(st, ext, growth)]
+      | st == "applying" && ext == "settled" -> do
+          _ <- execute conn
+            "UPDATE pools SET reserved_bytes = reserved_bytes - ? WHERE pool_id = ?"
+            (growth, unPoolId (mrPoolId rec))
+          _ <- execute conn
+            "UPDATE mutations SET state = 'failed', external_state = 'idle', updated_at = now() \
+            \WHERE user_id = ? AND kind = ? AND operation_id = ?"
+            (unUserId (mrUserId rec), kindLabel (mrKind rec), unOperationId (mrOperationId rec))
+          _ <- execute conn
+            "DELETE FROM key_locks WHERE object_key = ? AND user_id = ? AND kind = ? AND operation_id = ?"
+            ( unObjectKey (mrObjectKey rec)
+            , unUserId (mrUserId rec)
+            , kindLabel (mrKind rec)
+            , unOperationId (mrOperationId rec)
+            )
+          pure True
+    _ -> pure False
+
+-- | updated_at advances on state transitions only, not during a long put body.
+claimActiveBatch :: Connection -> Int -> Integer -> IO [MutationRecord]
+claimActiveBatch conn limit graceSec = do
+  rows <- query conn
+    "SELECT user_id, kind, operation_id, pool_id, object_key, relative_path, \
+    \declared_size, content_sha256, prior_size, prior_sha256, growth_bytes, \
+    \state, external_state FROM mutations \
+    \WHERE state IN ('prepared', 'applying') \
+    \AND updated_at < now() - (? * interval '1 second') \
+    \ORDER BY updated_at ASC \
+    \FOR UPDATE SKIP LOCKED \
+    \LIMIT ?"
+    (graceSec, limit)
+  pure (mapMaybe rowToRecord rows)
+
+desiredMatches :: MutationRecord -> ObjectObservation -> Bool
+desiredMatches rec = \case
+  ObjectUnavailable _ -> False
+  ObjectAbsent ->
+    case mrKind rec of
+      Delete -> True
+      Put    -> False
+  ObjectPresent sz msha ->
+    case mrKind rec of
+      Delete -> sz == 0
+      Put ->
+        sz == mrDeclaredSize rec
+          && case (mrContentSha256 rec, msha) of
+               (Just want, Just got) -> want == got
+               -- Some stores omit custom metadata on HEAD.
+               (Just _, Nothing)     -> True
+               (Nothing, _)          -> True
+
+priorMatches :: MutationRecord -> ObjectObservation -> Bool
+priorMatches rec obs =
+  let priorEmpty = mrPriorSize rec == 0 && mrPriorSha256 rec == Nothing
+  in case obs of
+       ObjectUnavailable _ -> False
+       ObjectAbsent -> priorEmpty
+       ObjectPresent sz msha ->
+         sz == mrPriorSize rec
+           && ( case (mrPriorSha256 rec, msha) of
+                  (Just want, Just got) -> want == got
+                  (Nothing, Nothing)    -> True
+                  (Just _, Nothing)     -> False
+                  (Nothing, Just _)     -> mrPriorSize rec == sz
+              )

src/Nuthatch/Redis.hs

@@ -0,0 +1,114 @@
+module Nuthatch.Redis
+  ( Redis
+  , withRedis
+  , cacheGet
+  , cacheSet
+  , cacheInvalidatePrefixes
+  , throttleTake
+  ) where
+
+import           Control.Exception (SomeException, try)
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           Data.Time.Clock.POSIX (getPOSIXTime)
+import           Database.Redis
+  ( ConnectInfo (..)
+  , Connection
+  , Reply
+  , checkedConnect
+  , defaultConnectInfo
+  , del
+  , get
+  , runRedis
+  , setex
+  )
+import qualified Database.Redis as R
+import           Nuthatch.Config (Config (..))
+import           Nuthatch.Types
+
+type Redis = Connection
+
+withRedis :: Config -> (Redis -> IO a) -> IO a
+withRedis cfg action = do
+  conn <- checkedConnect defaultConnectInfo
+    { connectHost = cfgRedisHost cfg
+    , connectPort = R.PortNumber (fromIntegral (cfgRedisPort cfg))
+    , connectDatabase = cfgRedisDb cfg
+    }
+  action conn
+
+cacheGet :: Redis -> Text -> IO (Maybe ByteString)
+cacheGet conn key = do
+  result <- try (runRedis conn (get (TE.encodeUtf8 key)))
+              :: IO (Either SomeException (Either Reply (Maybe ByteString)))
+  pure $ case result of
+    Left _                 -> Nothing
+    Right (Right (Just v)) -> Just v
+    _                      -> Nothing
+
+cacheSet :: Redis -> Text -> Integer -> ByteString -> IO ()
+cacheSet conn key ttl value = do
+  _ <- try (runRedis conn (setex (TE.encodeUtf8 key) ttl value))
+        :: IO (Either SomeException (Either Reply R.Status))
+  pure ()
+
+cacheInvalidatePrefixes :: Redis -> UserId -> Root -> [Text] -> IO ()
+cacheInvalidatePrefixes conn uid root prefixes = do
+  let ks =
+        [ TE.encodeUtf8
+            ("nuthatch:list:" <> unUserId uid <> ":" <> rootLabel root <> ":" <> p <> ":")
+        | p <- prefixes
+        ]
+  case ks of
+    [] -> pure ()
+    _  -> do
+      _ <- try (runRedis conn (del ks))
+            :: IO (Either SomeException (Either Reply Integer))
+      pure ()
+
+throttleTake :: Redis -> Config -> UserId -> Integer -> IO (Either Text Bool)
+throttleTake conn cfg uid bytes = do
+  now <- floor <$> getPOSIXTime
+  let key = TE.encodeUtf8 ("nuthatch:throttle:" <> unUserId uid)
+      rate = cfgThrottleBytesPerSec cfg
+      burst = cfgThrottleBurstBytes cfg
+      script =
+        BS8.unlines
+          [ "local key = KEYS[1]"
+          , "local rate = tonumber(ARGV[1])"
+          , "local burst = tonumber(ARGV[2])"
+          , "local now = tonumber(ARGV[3])"
+          , "local need = tonumber(ARGV[4])"
+          , "local data = redis.call('HMGET', key, 'tokens', 'ts')"
+          , "local tokens = tonumber(data[1])"
+          , "local ts = tonumber(data[2])"
+          , "if tokens == nil then tokens = burst end"
+          , "if ts == nil then ts = now end"
+          , "local delta = math.max(0, now - ts)"
+          , "tokens = math.min(burst, tokens + delta * rate)"
+          , "if tokens < need then"
+          , "  redis.call('HMSET', key, 'tokens', tokens, 'ts', now)"
+          , "  redis.call('EXPIRE', key, 3600)"
+          , "  return 0"
+          , "end"
+          , "tokens = tokens - need"
+          , "redis.call('HMSET', key, 'tokens', tokens, 'ts', now)"
+          , "redis.call('EXPIRE', key, 3600)"
+          , "return 1"
+          ]
+  result <- try (runRedis conn $
+    R.eval script [key]
+      [ BS8.pack (show rate)
+      , BS8.pack (show burst)
+      , BS8.pack (show (now :: Integer))
+      , BS8.pack (show bytes)
+      ]) :: IO (Either SomeException (Either Reply Integer))
+  pure $ case result of
+    Left _ -> Left "redis unavailable"
+    Right (Right 1) -> Right True
+    Right (Right 0) -> Right False
+    Right (Right other) -> Left ("unexpected throttle reply: " <> T.pack (show other))
+    Right (Left err) -> Left (T.pack (show err))

src/Nuthatch/S3.hs

@@ -0,0 +1,401 @@
+module Nuthatch.S3
+  ( S3
+  , ObjectInfo (..)
+  , ListPage (..)
+  , newS3
+  , putObject
+  , getObjectBytes
+  , headObject
+  , deleteObject
+  , listObjects
+  ) 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 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           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           Network.HTTP.Client.TLS (tlsManagerSettings)
+import           Network.HTTP.Types (Header, RequestHeaders, statusCode)
+import           Network.HTTP.Types.URI (parseQuery)
+import           Nuthatch.Config (Config (..))
+import           Nuthatch.Types
+import qualified Text.XML as XML
+
+data S3 = S3
+  { s3Manager   :: Manager
+  , s3Endpoint  :: Text
+  , s3Region    :: Text
+  , s3Bucket    :: Text
+  , s3AccessKey :: Text
+  , s3SecretKey :: Text
+  , s3PathStyle :: Bool
+  }
+
+data ObjectInfo = ObjectInfo
+  { oiSize   :: Integer
+  , oiSha256 :: Maybe ContentSha256
+  }
+  deriving stock (Show)
+
+data ListPage = ListPage
+  { lpPrefixes          :: [Text]
+  , lpObjects           :: [(Text, Integer)]
+  , lpContinuationToken :: Maybe Text
+  , lpIsTruncated       :: Bool
+  }
+  deriving stock (Show)
+
+newS3 :: Config -> IO S3
+newS3 cfg = do
+  mgr <- newManager tlsManagerSettings
+  pure S3
+    { s3Manager = mgr
+    , s3Endpoint = cfgS3Endpoint cfg
+    , s3Region = cfgS3Region cfg
+    , 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")
+  | 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
+            }
+      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)))
+
+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))
+
+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))
+
+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))
+
+listObjects
+  :: S3
+  -> Text
+  -> 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
+           }
+  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)
+
+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
+    }
+
+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
+    }
+
+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
+
+bucketUrlPath :: S3 -> String
+bucketUrlPath s3 =
+  let bucket = T.unpack (s3Bucket s3)
+  in if s3PathStyle s3 then "/" <> bucket else "/"
+
+escapePath :: String -> String
+escapePath = concatMap escapeChar
+  where
+    escapeChar c
+      | c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~/" :: String) = [c]
+      | otherwise =
+          let (q, r) = fromEnum c `divMod` 16
+              hex = "0123456789ABCDEF"
+          in ['%', hex !! q, hex !! r]
+
+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 }
+
+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
+    Nothing ->
+      let h = host req
+          p = port req
+      in if p == 80 || p == 443
+           then h
+           else h <> ":" <> BS8.pack (show p)
+
+pathURL :: Request -> String
+pathURL req =
+  case BS8.unpack (path req) of
+    "" -> "/"
+    p  -> p
+
+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

src/Nuthatch/Session.hs

@@ -0,0 +1,135 @@
+module Nuthatch.Session
+  ( mintSession
+  , verifySession
+  , newCsrfToken
+  , constantTimeEq
+  ) where
+
+import           Crypto.Hash (Digest, SHA256, hash)
+import           Crypto.MAC.HMAC (HMAC, hmac)
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KM
+import           Data.ByteArray (convert)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64.URL as B64
+import qualified Data.ByteString.Lazy as BL
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           Data.Time.Clock.POSIX (getPOSIXTime)
+import           Nuthatch.Config (Config (..))
+import           Nuthatch.Paths (encodeUserId)
+import           Nuthatch.Types
+import           System.Entropy (getEntropy)
+
+mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text Text)
+mintSession cfg iss sub display = do
+  now <- floor <$> getPOSIXTime
+  let expAt = now + cfgSessionHours cfg * 3600
+      uid = encodeUserId iss sub
+      header = A.object
+        [ "alg" A..= ("HS256" :: Text)
+        , "typ" A..= ("JWT" :: Text)
+        ]
+      payload = A.object $
+        [ "iss" A..= ("nuthatch" :: Text)
+        , "aud" A..= ("nuthatch" :: Text)
+        , "iat" A..= now
+        , "exp" A..= expAt
+        , "sub" A..= unUserId uid
+        , "oidc_issuer" A..= iss
+        , "oidc_subject" A..= sub
+        ] <> maybe [] (\d -> ["display" A..= d]) display
+      token = signJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) header payload
+  pure (Right token)
+
+verifySession :: Config -> Text -> IO (Either Text SessionUser)
+verifySession cfg token = do
+  now <- floor <$> getPOSIXTime
+  pure $ do
+    claims <- verifyJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) token
+    expAt <- claimInt claims "exp"
+    if expAt < now
+      then Left "session expired"
+      else do
+        iss <- claimText claims "oidc_issuer"
+        sub <- claimText claims "oidc_subject"
+        let display = either (const Nothing) Just (claimText claims "display")
+            uid = encodeUserId iss sub
+        pure SessionUser
+          { suIssuer = iss
+          , suSubject = sub
+          , suUserId = uid
+          , suDisplay = display
+          }
+
+signJwt :: BS.ByteString -> A.Value -> A.Value -> Text
+signJwt secret header payload =
+  let h = b64Json header
+      p = b64Json payload
+      signingInput = h <> "." <> p
+      sig = b64Raw (hmacSha256 secret signingInput)
+  in TE.decodeUtf8 (signingInput <> "." <> sig)
+
+verifyJwt :: BS.ByteString -> Text -> Either Text A.Object
+verifyJwt secret token =
+  case T.splitOn "." token of
+    [h, p, s] -> do
+      let signingInput = TE.encodeUtf8 (h <> "." <> p)
+          expected = b64Raw (hmacSha256 secret signingInput)
+      if not (BA.constEq expected (TE.encodeUtf8 s))
+        then Left "invalid session signature"
+        else do
+          payloadBytes <- b64Decode (TE.encodeUtf8 p)
+          case A.eitherDecodeStrict payloadBytes of
+            Left err -> Left (T.pack err)
+            Right (A.Object obj) -> Right obj
+            Right _ -> Left "jwt payload must be an object"
+    _ -> Left "malformed session token"
+
+hmacSha256 :: BS.ByteString -> BS.ByteString -> BS.ByteString
+hmacSha256 secret msg =
+  convert (hmac secret msg :: HMAC SHA256)
+
+b64Json :: A.Value -> BS.ByteString
+b64Json = B64.encodeUnpadded . BL.toStrict . A.encode
+
+b64Raw :: BS.ByteString -> BS.ByteString
+b64Raw = B64.encodeUnpadded
+
+b64Decode :: BS.ByteString -> Either Text BS.ByteString
+b64Decode bs =
+  case B64.decode bs of
+    Left err -> Left (T.pack err)
+    Right x  -> Right x
+
+claimText :: A.Object -> Text -> Either Text Text
+claimText obj key =
+  case KM.lookup (Key.fromText key) obj of
+    Just (A.String t) -> Right t
+    _                 -> Left ("missing claim " <> key)
+
+claimInt :: A.Object -> Text -> Either Text Integer
+claimInt obj key =
+  case KM.lookup (Key.fromText key) obj of
+    Just v ->
+      case A.fromJSON v of
+        A.Success (i :: Integer) -> Right i
+        _                        -> Left ("invalid integer claim " <> key)
+    _ -> Left ("missing claim " <> key)
+
+newCsrfToken :: IO Text
+newCsrfToken = do
+  bytes <- getEntropy 32
+  pure (TE.decodeUtf8 (B64.encodeUnpadded bytes))
+
+constantTimeEq :: Text -> Text -> Bool
+constantTimeEq a b =
+  let ba = TE.encodeUtf8 a
+      bb = TE.encodeUtf8 b
+  in BS.length ba == BS.length bb
+     && BA.constEq
+          (hash ba :: Digest SHA256)
+          (hash bb :: Digest SHA256)

src/Nuthatch/Types.hs

@@ -0,0 +1,164 @@
+module Nuthatch.Types
+  ( Root (..)
+  , MutationKind (..)
+  , MutationState (..)
+  , ExternalState (..)
+  , UserId (..)
+  , OperationId (..)
+  , ContentSha256 (..)
+  , ObjectKey (..)
+  , RelativePath (..)
+  , PoolId (..)
+  , SessionUser (..)
+  , ListEntry (..)
+  , MutationResult (..)
+  , rootLabel
+  , parseRoot
+  , kindLabel
+  , parseKind
+  , stateLabel
+  , parseState
+  , externalLabel
+  , parseExternal
+  , sharedPool
+  , personalPool
+  ) where
+
+import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))
+import           Data.Text (Text)
+import qualified Data.Text as T
+
+data Root = Personal | Shared
+  deriving stock (Eq, Show)
+
+rootLabel :: Root -> Text
+rootLabel Personal = "personal"
+rootLabel Shared   = "shared"
+
+parseRoot :: Text -> Maybe Root
+parseRoot t = case T.toLower t of
+  "personal" -> Just Personal
+  "shared"   -> Just Shared
+  _          -> Nothing
+
+data MutationKind = Put | Delete
+  deriving stock (Eq, Show)
+
+kindLabel :: MutationKind -> Text
+kindLabel Put    = "put"
+kindLabel Delete = "delete"
+
+parseKind :: Text -> Maybe MutationKind
+parseKind t = case T.toLower t of
+  "put"    -> Just Put
+  "delete" -> Just Delete
+  _        -> Nothing
+
+data MutationState
+  = Prepared
+  | Applying
+  | Succeeded
+  | Failed
+  | Rejected
+  deriving stock (Eq, Show)
+
+stateLabel :: MutationState -> Text
+stateLabel Prepared  = "prepared"
+stateLabel Applying  = "applying"
+stateLabel Succeeded = "succeeded"
+stateLabel Failed    = "failed"
+stateLabel Rejected  = "rejected"
+
+parseState :: Text -> Maybe MutationState
+parseState t = case T.toLower t of
+  "prepared"  -> Just Prepared
+  "applying"  -> Just Applying
+  "succeeded" -> Just Succeeded
+  "failed"    -> Just Failed
+  "rejected"  -> Just Rejected
+  _           -> Nothing
+
+data ExternalState = ExtIdle | ExtPending | ExtSettled
+  deriving stock (Eq, Show)
+
+externalLabel :: ExternalState -> Text
+externalLabel ExtIdle    = "idle"
+externalLabel ExtPending = "pending"
+externalLabel ExtSettled = "settled"
+
+parseExternal :: Text -> Maybe ExternalState
+parseExternal t = case T.toLower t of
+  "idle"    -> Just ExtIdle
+  "pending" -> Just ExtPending
+  "settled" -> Just ExtSettled
+  _         -> Nothing
+
+newtype UserId = UserId { unUserId :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype OperationId = OperationId { unOperationId :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype ContentSha256 = ContentSha256 { unContentSha256 :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype ObjectKey = ObjectKey { unObjectKey :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype RelativePath = RelativePath { unRelativePath :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype PoolId = PoolId { unPoolId :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+sharedPool :: PoolId
+sharedPool = PoolId "shared"
+
+personalPool :: UserId -> PoolId
+personalPool (UserId u) = PoolId ("personal:" <> u)
+
+data SessionUser = SessionUser
+  { suIssuer  :: Text
+  , suSubject :: Text
+  , suUserId  :: UserId
+  , suDisplay :: Maybe Text
+  }
+  deriving stock (Eq, Show)
+
+data ListEntry = ListEntry
+  { leName         :: Text
+  , leIsPrefix     :: Bool
+  , leSize         :: Maybe Integer
+  , leRelativePath :: Text
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON ListEntry where
+  toJSON e = object
+    [ "name" .= leName e
+    , "is_prefix" .= leIsPrefix e
+    , "size" .= leSize e
+    , "path" .= leRelativePath e
+    ]
+
+instance FromJSON ListEntry where
+  parseJSON = withObject "ListEntry" $ \o ->
+    ListEntry
+      <$> o .: "name"
+      <*> o .: "is_prefix"
+      <*> o .:? "size"
+      <*> o .: "path"
+
+data MutationResult
+  = MutationPending
+  | MutationSucceeded
+  | MutationFailed
+  | MutationRejected
+  | MutationConflict
+  deriving stock (Eq, Show)

src/Nuthatch/Ui.hs

@@ -0,0 +1,190 @@
+module Nuthatch.Ui
+  ( loginPage
+  , browsePage
+  , htmlResponse
+  , escapeHtml
+  ) where
+
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Data.Text.Lazy (fromStrict)
+import qualified Data.Text.Lazy.Encoding as TLE
+import           Network.HTTP.Types (Status, hContentType)
+import           Network.Wai (Response, responseLBS)
+import           Nuthatch.Types
+
+htmlResponse :: Status -> Text -> Response
+htmlResponse status body =
+  responseLBS status
+    [(hContentType, "text/html; charset=utf-8")]
+    (TLE.encodeUtf8 (fromStrict body))
+
+escapeHtml :: Text -> Text
+escapeHtml =
+  T.concatMap $ \case
+    '&'  -> "&"
+    '<'  -> "&lt;"
+    '>'  -> "&gt;"
+    '"'  -> "&quot;"
+    '\'' -> "&#39;"
+    c    -> T.singleton c
+
+loginPage :: Text -> Text
+loginPage err =
+  page "Nuthatch login" $
+    T.unlines
+      [ "<h1>Nuthatch</h1>"
+      , "<p>Development login (OIDC is not wired in the MVP).</p>"
+      , if T.null err then "" else "<p class=\"err\">" <> escapeHtml err <> "</p>"
+      , "<form method=\"post\" action=\"/login\">"
+      , "  <label>Username <input name=\"username\" required autofocus></label>"
+      , "  <button type=\"submit\">Sign in</button>"
+      , "</form>"
+      ]
+
+browsePage
+  :: SessionUser
+  -> Root
+  -> Text
+  -> Text
+  -> Text
+  -> [Text]
+  -> [ListEntry]
+  -> Maybe Text
+  -> Text
+  -> Text
+browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
+  page "Nuthatch" $ T.unlines $
+    [ "<header>"
+    , "  <h1>Nuthatch</h1>"
+    , "  <div class=\"meta\">"
+    , "    Signed in as <strong>"
+        <> escapeHtml (maybe (unUserId (suUserId user)) id (suDisplay user))
+        <> "</strong>"
+    , "    · <a href=\"/logout\">Log out</a>"
+    , "  </div>"
+    , "</header>"
+    , if T.null notice then "" else "<p class=\"ok\">" <> escapeHtml notice <> "</p>"
+    , maybe "" (\e -> "<p class=\"err\">" <> escapeHtml e <> "</p>") mError
+    , "<nav class=\"roots\">"
+    , rootLink Personal root prefix
+    , rootLink Shared root prefix
+    , "</nav>"
+    , "<p class=\"path\">/" <> escapeHtml (rootLabel root)
+        <> if T.null prefix then "" else "/" <> escapeHtml prefix
+        <> "</p>"
+    , breadcrumbs root prefix
+    , "<section>"
+    , "  <h2>Upload</h2>"
+    , "  <form method=\"post\" action=\"/upload\" enctype=\"multipart/form-data\">"
+    , "    <input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
+    , "    <input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml uploadOp <> "\">"
+    , "    <input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
+    , "    <input type=\"hidden\" name=\"prefix\" value=\"" <> escapeHtml prefix <> "\">"
+    , "    <input type=\"file\" name=\"file\" required>"
+    , "    <button type=\"submit\">Upload</button>"
+    , "  </form>"
+    , "</section>"
+    , "<section>"
+    , "  <h2>Search</h2>"
+    , "  <form method=\"get\" action=\"/\">"
+    , "    <input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
+    , "    <input type=\"hidden\" name=\"prefix\" value=\"" <> escapeHtml prefix <> "\">"
+    , "    <input name=\"q\" placeholder=\"substring in key\">"
+    , "    <button type=\"submit\">Search</button>"
+    , "  </form>"
+    , "</section>"
+    , "<section>"
+    , "  <h2>Contents</h2>"
+    , "  <table><thead><tr><th>Name</th><th>Size</th><th></th></tr></thead><tbody>"
+    ]
+    <> zipWith (renderEntry root csrf) deleteOps entries
+    <>
+    [ "  </tbody></table>"
+    , if null entries then "<p><em>Empty</em></p>" else ""
+    , "</section>"
+    ]
+
+rootLink :: Root -> Root -> Text -> Text
+rootLink target current prefix =
+  let label = if target == Shared then "Shared" else "Personal"
+      cls = if target == current then "active" else ""
+  in "<a class=\"" <> cls <> "\" href=\"/?root=" <> rootLabel target
+       <> if target == current && not (T.null prefix)
+            then "&prefix=" <> prefix
+            else ""
+       <> "\">" <> label <> "</a>"
+
+breadcrumbs :: Root -> Text -> Text
+breadcrumbs root prefix
+  | T.null prefix = ""
+  | otherwise =
+      let segs = T.splitOn "/" prefix
+          steps = zip segs (scanl1 (\a b -> a <> "/" <> b) segs)
+          links =
+            ("<a href=\"/?root=" <> rootLabel root <> "\">root</a>")
+              : [ "<a href=\"/?root=" <> rootLabel root <> "&prefix=" <> path <> "\">"
+                    <> escapeHtml name <> "</a>"
+                | (name, path) <- steps
+                ]
+      in "<p class=\"crumbs\">" <> T.intercalate " / " links <> "</p>"
+
+renderEntry :: Root -> Text -> Text -> ListEntry -> Text
+renderEntry root csrf opId entry =
+  if leIsPrefix entry
+    then
+      let next = leRelativePath entry
+      in "<tr><td colspan=\"2\"><a href=\"/?root=" <> rootLabel root
+           <> "&prefix=" <> next <> "\">" <> escapeHtml (leName entry) <> "/</a></td>"
+           <> "<td>"
+           <> deleteForm root next csrf opId True
+           <> "</td></tr>"
+    else
+      "<tr><td><a href=\"/download?root=" <> rootLabel root
+        <> "&path=" <> leRelativePath entry <> "\">"
+        <> escapeHtml (leName entry) <> "</a></td><td>"
+        <> maybe "-" (T.pack . show) (leSize entry)
+        <> "</td><td>"
+        <> deleteForm root (leRelativePath entry) csrf opId False
+        <> "</td></tr>"
+
+deleteForm :: Root -> Text -> Text -> Text -> Bool -> Text
+deleteForm root path csrf opId isPrefix =
+  "<form class=\"inline\" method=\"post\" action=\"/delete\" onsubmit=\"return confirm('Delete "
+    <> escapeHtml path <> "?');\">"
+    <> "<input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
+    <> "<input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml opId <> "\">"
+    <> "<input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
+    <> "<input type=\"hidden\" name=\"path\" value=\"" <> escapeHtml path <> "\">"
+    <> "<input type=\"hidden\" name=\"prefix_delete\" value=\""
+    <> (if isPrefix then "1" else "0") <> "\">"
+    <> "<button type=\"submit\">Delete</button></form>"
+
+page :: Text -> Text -> Text
+page title body =
+  T.unlines
+    [ "<!DOCTYPE html>"
+    , "<html lang=\"en\"><head>"
+    , "<meta charset=\"utf-8\">"
+    , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">"
+    , "<title>" <> escapeHtml title <> "</title>"
+    , "<style>"
+    , "body{font-family:system-ui,sans-serif;margin:2rem auto;max-width:900px;line-height:1.4;color:#122}"
+    , "header{display:flex;justify-content:space-between;align-items:baseline;gap:1rem}"
+    , "a{color:#0b57d0;text-decoration:none}a:hover{text-decoration:underline}"
+    , "nav.roots a{margin-right:1rem;padding:.2rem .5rem;border-radius:4px}"
+    , "nav.roots a.active{background:#e8eefc;font-weight:600}"
+    , "table{width:100%;border-collapse:collapse;margin-top:.5rem}"
+    , "th,td{text-align:left;padding:.4rem .3rem;border-bottom:1px solid #ddd}"
+    , "form.inline{display:inline}"
+    , ".err{color:#a40000;background:#fde8e8;padding:.5rem .75rem;border-radius:4px}"
+    , ".ok{color:#0d5a0d;background:#e7f6e7;padding:.5rem .75rem;border-radius:4px}"
+    , "section{margin:1.5rem 0}"
+    , "input,button{font:inherit;margin:.25rem .25rem .25rem 0}"
+    , "button{cursor:pointer}"
+    , "</style>"
+    , "<meta http-equiv=\"Content-Security-Policy\" content=\"default-src 'self'; style-src 'unsafe-inline'; img-src 'none'; object-src 'none'\">"
+    , "</head><body>"
+    , body
+    , "</body></html>"
+    ]