ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

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

Browse source
This commit is contained in:
ms2k 2026-07-17 21:43:03 +09:00
commit 6bc08bd7bf
22 changed files with 3123 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

25
.env.example Normal file
View file

@ -0,0 +1,25 @@
NUTHATCH_LISTEN=127.0.0.1:8080
NUTHATCH_PUBLIC_BASE_URL=http://127.0.0.1:8080
NUTHATCH_JWT_SECRET=dev-only-change-me-to-a-long-random-string
NUTHATCH_SESSION_HOURS=12
NUTHATCH_COOKIE_NAME=nuthatch_session
NUTHATCH_CSRF_COOKIE_NAME=nuthatch_csrf
NUTHATCH_PG_CONN=host=127.0.0.1 port=5432 user=nuthatch password=nuthatch dbname=nuthatch
NUTHATCH_REDIS_URL=redis://127.0.0.1:6379/0
NUTHATCH_S3_ENDPOINT=http://127.0.0.1:9000
NUTHATCH_S3_REGION=us-east-1
NUTHATCH_S3_BUCKET=nuthatch
NUTHATCH_S3_ACCESS_KEY=minioadmin
NUTHATCH_S3_SECRET_KEY=minioadmin
NUTHATCH_S3_PATH_STYLE=true
NUTHATCH_PERSONAL_QUOTA_BYTES=1073741824
NUTHATCH_SHARED_QUOTA_BYTES=10737418240
NUTHATCH_MAX_OBJECT_BYTES=104857600
NUTHATCH_THROTTLE_BYTES_PER_SEC=10485760
NUTHATCH_THROTTLE_BURST_BYTES=20971520
NUTHATCH_LIST_CACHE_TTL_SEC=30
NUTHATCH_SEARCH_MAX_KEYS=500
NUTHATCH_AUTH_MODE=dev

31
.gitignore vendored
View file

@ -1,5 +1,32 @@
# Development scratchpad and journal (external repos)
scratchpad
docs/journal
# TLC working directories
/docs/protocol/states/ /docs/protocol/states/
/states/ /states/
# Kind fixture runtime
/tests/kind/.runtime/ /tests/kind/.runtime/
docs/journal
scratchpad # Cabal / GHC
/dist-newstyle/
/dist/
/cabal.project.local
/cabal.project.local~
/.ghc.environment.*
/*.eventlog
/*.prof
/*.hp
/*.ps
/*.aux
# Local env
.env
.env.*
!.env.example
# Editor / OS noise
*~
*.swp
.DS_Store

53
Dockerfile Normal file
View file

@ -0,0 +1,53 @@
FROM haskell:9.10.3-slim-bookworm AS build
RUN apt-get update \
&& apt-get install -y --no-install-recommends \
libpq-dev \
pkg-config \
zlib1g-dev \
ca-certificates \
&& rm -rf /var/lib/apt/lists/*
WORKDIR /src
COPY nuthatch.cabal cabal.project ./
RUN cabal update \
&& cabal build --only-dependencies all
COPY sql ./sql
COPY app ./app
COPY src ./src
COPY test ./test
RUN cabal build exe:nuthatch \
&& mkdir -p /out \
&& cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch
FROM debian:bookworm-slim AS runtime
RUN apt-get update \
&& apt-get install -y --no-install-recommends \
libpq5 \
ca-certificates \
curl \
&& rm -rf /var/lib/apt/lists/*
WORKDIR /app
COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
COPY sql ./sql
ENV NUTHATCH_LISTEN=0.0.0.0:8080 \
NUTHATCH_PUBLIC_BASE_URL=http://127.0.0.1:8080 \
NUTHATCH_JWT_SECRET=dev-only-change-me-to-a-long-random-string \
NUTHATCH_PG_CONN="host=postgres port=5432 user=nuthatch password=nuthatch dbname=nuthatch" \
NUTHATCH_REDIS_URL=redis://redis:6379/0 \
NUTHATCH_S3_ENDPOINT=http://minio:9000 \
NUTHATCH_S3_REGION=us-east-1 \
NUTHATCH_S3_BUCKET=nuthatch \
NUTHATCH_S3_ACCESS_KEY=minioadmin \
NUTHATCH_S3_SECRET_KEY=minioadmin \
NUTHATCH_S3_PATH_STYLE=true \
NUTHATCH_AUTH_MODE=dev
EXPOSE 8080
CMD ["nuthatch"]

20
Makefile
View file

@ -1,7 +1,25 @@
.PHONY: check-dependencies check-fixture-lib .PHONY: check-dependencies check-fixture-lib mvp-up mvp-down mvp-build mvp-logs mvp-ps
COMPOSE := nerdctl compose -f deploy/docker-compose.yml
check-dependencies: check-dependencies:
./tests/kind/run.sh ./tests/kind/run.sh
check-fixture-lib: check-fixture-lib:
./tests/kind/lib-test.sh ./tests/kind/lib-test.sh
mvp-build:
$(COMPOSE) build nuthatch
mvp-up:
$(COMPOSE) up --build -d
@echo "Nuthatch MVP: http://127.0.0.1:8080 (dev login with any single-token username)"
mvp-down:
$(COMPOSE) down -v
mvp-logs:
$(COMPOSE) logs -f nuthatch
mvp-ps:
$(COMPOSE) ps

76
app/Main.hs Normal file
View file

@ -0,0 +1,76 @@
module Main (main) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (SomeException, try)
import Data.String (fromString)
import Database.PostgreSQL.Simple (Only (..))
import Network.Wai.Handler.Warp
( HostPreference
, defaultSettings
, runSettings
, setHost
, setPort
)
import Nuthatch
import Nuthatch.Config (Config (..))
import Nuthatch.Db (migrate, query_, withDb)
import Nuthatch.Redis (withRedis)
import Nuthatch.S3 (newS3)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
cfg <- loadConfig
waitForPostgres cfg
withDb cfg $ \db -> do
schemaPath <- findSchema
migrate db schemaPath cfg
withRedis cfg $ \redis -> do
s3 <- newS3 cfg
let env = newEnv cfg db redis s3
_ <- forkIO (runRecovery env)
let settings =
setPort (cfgListenPort cfg) $
setHost (readHost (cfgListenHost cfg)) defaultSettings
putStrLn $
"nuthatch listening on "
<> cfgListenHost cfg
<> ":"
<> show (cfgListenPort cfg)
<> " (auth="
<> show (cfgAuthMode cfg)
<> ")"
runSettings settings (application env)
waitForPostgres :: Config -> IO ()
waitForPostgres cfg = go (60 :: Int)
where
go 0 = fail "postgres did not become ready"
go n = do
result <- try $ withDb cfg $ \db -> do
_ <- query_ db "SELECT 1" :: IO [Only Int]
pure ()
case result of
Right () -> pure ()
Left (e :: SomeException) -> do
putStrLn $ "waiting for postgres (" <> show n <> "): " <> show e
threadDelay 1000000
go (n - 1)
findSchema :: IO FilePath
findSchema = do
let candidates =
[ "sql" </> "001_schema.sql"
, ".." </> "sql" </> "001_schema.sql"
, "/app/sql" </> "001_schema.sql"
]
existing <- mapM (\p -> doesFileExist p >>= \e -> pure (e, p)) candidates
pure $ case [p | (True, p) <- existing] of
(p : _) -> p
[] -> "sql/001_schema.sql"
readHost :: String -> HostPreference
readHost = fromString

7
cabal.project Normal file
View file

@ -0,0 +1,7 @@
packages: .
package *
optimization: 2
constraints:
crypton >= 0.34

48
deploy/docker-compose.yml Normal file
View file

@ -0,0 +1,48 @@
services:
postgres:
image: postgres:16-alpine
environment:
POSTGRES_USER: nuthatch
POSTGRES_PASSWORD: nuthatch
POSTGRES_DB: nuthatch
redis:
image: redis:7-alpine
minio:
image: minio/minio:RELEASE.2025-04-22T22-12-26Z
command: server /data --console-address ":9001"
environment:
MINIO_ROOT_USER: minioadmin
MINIO_ROOT_PASSWORD: minioadmin
minio-init:
image: minio/mc:RELEASE.2025-04-16T18-13-26Z
entrypoint:
- /bin/sh
- -c
- |
until mc alias set local http://minio:9000 minioadmin minioadmin; do sleep 1; done
mc mb --ignore-existing local/nuthatch
exit 0
nuthatch:
build:
context: ..
dockerfile: Dockerfile
environment:
NUTHATCH_LISTEN: 0.0.0.0:8080
NUTHATCH_PUBLIC_BASE_URL: http://127.0.0.1:8080
NUTHATCH_JWT_SECRET: dev-only-change-me-to-a-long-random-string
NUTHATCH_PG_CONN: host=postgres port=5432 user=nuthatch password=nuthatch dbname=nuthatch
NUTHATCH_REDIS_URL: redis://redis:6379/0
NUTHATCH_S3_ENDPOINT: http://minio:9000
NUTHATCH_S3_REGION: us-east-1
NUTHATCH_S3_BUCKET: nuthatch
NUTHATCH_S3_ACCESS_KEY: minioadmin
NUTHATCH_S3_SECRET_KEY: minioadmin
NUTHATCH_S3_PATH_STYLE: "true"
NUTHATCH_AUTH_MODE: dev
ports:
- "8080:8080"
restart: on-failure

114
nuthatch.cabal Normal file
View file

@ -0,0 +1,114 @@
cabal-version: 3.0
name: nuthatch
version: 0.1.0.0
synopsis: User-facing S3 BFF
license: NONE
author: Nuthatch
maintainer: nuthatch@localhost
category: Network
build-type: Simple
extra-source-files:
sql/001_schema.sql
common shared
default-language: Haskell2010
default-extensions:
OverloadedStrings
RecordWildCards
DeriveGeneric
DerivingStrategies
GeneralizedNewtypeDeriving
LambdaCase
ScopedTypeVariables
TupleSections
NamedFieldPuns
FlexibleContexts
ghc-options:
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wmissing-export-lists
-Wpartial-fields
-Wredundant-constraints
build-depends:
, aeson >= 2.1 && < 2.3
, async >= 2.2 && < 2.3
, base >= 4.18 && < 5
, base16-bytestring >= 1.0 && < 1.1
, base64-bytestring >= 1.2 && < 1.3
, bytestring >= 0.11 && < 0.13
, case-insensitive >= 1.2 && < 1.3
, containers >= 0.6 && < 0.8
, crypton >= 0.34 && < 1.1
, directory >= 1.3 && < 1.4
, entropy >= 0.4 && < 0.5
, filepath >= 1.4 && < 1.6
, hedis >= 0.15 && < 0.16
, http-client >= 0.7 && < 0.8
, http-client-tls >= 0.3 && < 0.4
, http-conduit >= 2.3 && < 2.4
, http-types >= 0.12 && < 0.13
, memory >= 0.18 && < 0.19
, mime-types >= 0.1 && < 0.2
, mtl >= 2.3 && < 2.4
, network-uri >= 2.6 && < 2.8
, postgresql-simple >= 0.7 && < 0.8
, resource-pool >= 0.4 && < 0.5
, scientific >= 0.3 && < 0.4
, stm >= 2.5 && < 2.6
, temporary >= 1.3 && < 1.4
, text >= 2.0 && < 2.2
, time >= 1.12 && < 1.15
, transformers >= 0.6 && < 0.7
, unordered-containers >= 0.2 && < 0.3
, uuid >= 1.3 && < 1.4
, wai >= 3.2 && < 3.3
, wai-extra >= 3.1 && < 3.2
, warp >= 3.3 && < 3.5
, xml-conduit >= 1.9 && < 1.11
library
import: shared
hs-source-dirs: src
exposed-modules:
Nuthatch
Nuthatch.App
Nuthatch.Audit
Nuthatch.Config
Nuthatch.Db
Nuthatch.Paths
Nuthatch.Protocol
Nuthatch.Redis
Nuthatch.S3
Nuthatch.Session
Nuthatch.Types
Nuthatch.Ui
executable nuthatch
import: shared
main-is: Main.hs
hs-source-dirs: app
build-depends:
, nuthatch
, base
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
test-suite nuthatch-unit
import: shared
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
build-depends:
, nuthatch
, base
, bytestring
, text
ghc-options:
-threaded

61
sql/001_schema.sql Normal file
View file

@ -0,0 +1,61 @@
-- Durable quota and mutation protocol state for Nuthatch.
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)
);
INSERT INTO pools (pool_id, limit_bytes, used_bytes, reserved_bytes)
VALUES ('shared', 10737418240, 0, 0)
ON CONFLICT (pool_id) DO NOTHING;
CREATE TABLE IF NOT EXISTS mutations (
user_id TEXT NOT NULL,
kind TEXT NOT NULL CHECK (kind IN ('put', 'delete')),
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 CHECK (declared_size >= 0),
content_sha256 TEXT,
prior_size BIGINT NOT NULL CHECK (prior_size >= 0),
prior_sha256 TEXT,
growth_bytes BIGINT NOT NULL CHECK (growth_bytes >= 0),
state TEXT NOT NULL CHECK (
state IN ('prepared', 'applying', 'succeeded', 'failed', 'rejected')
),
external_state TEXT NOT NULL DEFAULT 'idle' CHECK (
external_state IN ('idle', 'pending', 'settled')
),
created_at TIMESTAMPTZ NOT NULL DEFAULT now(),
updated_at TIMESTAMPTZ NOT NULL DEFAULT now(),
PRIMARY KEY (user_id, kind, operation_id)
);
CREATE INDEX IF NOT EXISTS mutations_active_key_idx
ON mutations (object_key)
WHERE state IN ('prepared', 'applying');
CREATE INDEX IF NOT EXISTS mutations_active_idx
ON mutations (state)
WHERE state IN ('prepared', 'applying');
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,
acquired_at TIMESTAMPTZ NOT NULL DEFAULT now(),
FOREIGN KEY (user_id, kind, operation_id)
REFERENCES mutations (user_id, kind, operation_id)
);
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 CHECK (size_bytes >= 0),
content_sha256 TEXT NOT NULL,
updated_at TIMESTAMPTZ NOT NULL DEFAULT now()
);

7
src/Nuthatch.hs Normal file
View file

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

759
src/Nuthatch/App.hs Normal file
View file

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

22
src/Nuthatch/Audit.hs Normal file
View file

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

157
src/Nuthatch/Config.hs Normal file
View file

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

140
src/Nuthatch/Db.hs Normal file
View file

@ -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()"
, ");"
]

60
src/Nuthatch/Paths.hs Normal file
View file

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

441
src/Nuthatch/Protocol.hs Normal file
View file

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

114
src/Nuthatch/Redis.hs Normal file
View file

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

401
src/Nuthatch/S3.hs Normal file
View file

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

135
src/Nuthatch/Session.hs Normal file
View file

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

164
src/Nuthatch/Types.hs Normal file
View file

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

Some files were not shown because too many files have changed in this diff Show more