Add Haskell MVP BFF with mutation protocol and local compose stack.
This commit is contained in:
parent
5759938f3f
commit
6bc08bd7bf
22 changed files with 3123 additions and 3 deletions
25
.env.example
Normal file
25
.env.example
Normal 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
31
.gitignore
vendored
|
|
@ -1,5 +1,32 @@
|
|||
# Development scratchpad and journal (external repos)
|
||||
scratchpad
|
||||
docs/journal
|
||||
|
||||
# TLC working directories
|
||||
/docs/protocol/states/
|
||||
/states/
|
||||
|
||||
# Kind fixture 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
53
Dockerfile
Normal 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
20
Makefile
|
|
@ -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:
|
||||
./tests/kind/run.sh
|
||||
|
||||
check-fixture-lib:
|
||||
./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
76
app/Main.hs
Normal 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
7
cabal.project
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
packages: .
|
||||
|
||||
package *
|
||||
optimization: 2
|
||||
|
||||
constraints:
|
||||
crypton >= 0.34
|
||||
48
deploy/docker-compose.yml
Normal file
48
deploy/docker-compose.yml
Normal 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
114
nuthatch.cabal
Normal 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
61
sql/001_schema.sql
Normal 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
7
src/Nuthatch.hs
Normal 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
759
src/Nuthatch/App.hs
Normal 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 "¬ice=" <> 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
22
src/Nuthatch/Audit.hs
Normal 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
157
src/Nuthatch/Config.hs
Normal 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
140
src/Nuthatch/Db.hs
Normal 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
60
src/Nuthatch/Paths.hs
Normal 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
441
src/Nuthatch/Protocol.hs
Normal 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
114
src/Nuthatch/Redis.hs
Normal 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
401
src/Nuthatch/S3.hs
Normal 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
135
src/Nuthatch/Session.hs
Normal 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
164
src/Nuthatch/Types.hs
Normal 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
Loading…
Reference in a new issue