Replace raw HTTP dispatch with typed Servant API

app/Main.hs

@@ -12,7 +12,6 @@ import           Network.Wai.Handler.Warp
   , setPort
   )
 import           Nuthatch
-import           Nuthatch.Config (Config (..))
 import           Nuthatch.Db (migrate, query_, withDb)
 import           Nuthatch.Redis (withRedis)
 import           Nuthatch.S3 (newS3)

nuthatch.cabal

@@ -23,6 +23,12 @@ common shared
     TupleSections
     NamedFieldPuns
     FlexibleContexts
+    FlexibleInstances
+    DataKinds
+    TypeOperators
+    TypeFamilies
+    MultiParamTypeClasses
+    UndecidableInstances
 
   ghc-options:
     -Wall
@@ -51,6 +57,8 @@ common shared
     , http-client           >= 0.7 && < 0.8
     , http-client-tls       >= 0.3 && < 0.4
     , http-conduit          >= 2.3 && < 2.4
+    , http-api-data         >= 0.7 && < 0.8
+    , http-media            >= 0.8 && < 0.9
     , http-types            >= 0.12 && < 0.13
     , memory                >= 0.18 && < 0.19
     , mime-types            >= 0.1 && < 0.2
@@ -59,6 +67,8 @@ common shared
     , postgresql-simple     >= 0.7 && < 0.8
     , resource-pool         >= 0.4 && < 0.5
     , scientific            >= 0.3 && < 0.4
+    , servant               >= 0.20 && < 0.21
+    , servant-server        >= 0.20 && < 0.21
     , stm                   >= 2.5 && < 2.6
     , temporary             >= 1.3 && < 1.4
     , text                  >= 2.0 && < 2.2
@@ -77,6 +87,7 @@ library
   hs-source-dirs:  src
   exposed-modules:
     Nuthatch
+    Nuthatch.Api
     Nuthatch.App
     Nuthatch.Audit
     Nuthatch.Config

src/Nuthatch/Api.hs

@@ -0,0 +1,572 @@
+module Nuthatch.Api
+  ( Api
+  , HealthEndpoint
+  , ReadyEndpoint
+  , LoginPageEndpoint
+  , BrowserScriptEndpoint
+  , LoginEndpoint
+  , LoginSuccess
+  , LogoutEndpoint
+  , LogoutSuccess
+  , BrowseEndpoint
+  , DownloadEndpoint
+  , DownloadSuccess
+  , UploadEndpoint
+  , DeleteEndpoint
+  , DeletePrefixEndpoint
+  , api
+  , HTML
+  , JavaScript
+  , HtmlPage (..)
+  , BrowserScript (..)
+  , SessionContext (..)
+  , SessionAuth
+  , BrowsePrefix (..)
+  , PaginationToken (..)
+  , SearchQuery (..)
+  , DeclaredSize (..)
+  , DevUsername (..)
+  , LoginRequest (..)
+  , LoginResponse (..)
+  , LoginView (..)
+  , HealthResponse (..)
+  , ReadyResponse (..)
+  , BrowseResponse (..)
+  , BrowseView (..)
+  , DeleteRequest (..)
+  , DeletePrefixRequest (..)
+  , DeletePrefixResponse (..)
+  , UploadResponse (..)
+  , DeleteResponse (..)
+  , Throws
+  , BoundaryError (..)
+  , AuthenticationError (..)
+  , ReadyError (..)
+  , LoginError (..)
+  , LogoutError (..)
+  , BrowseError (..)
+  , DownloadError (..)
+  , UploadError (..)
+  , DeleteError (..)
+  , DeletePrefixError (..)
+  , validatePaginationToken
+  ) where
+
+import           Data.Aeson
+  ( FromJSON (..)
+  , ToJSON (..)
+  , Value
+  , object
+  , withObject
+  , (.:)
+  , (.=)
+  )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import           Data.Char (isControl)
+import           Data.Proxy (Proxy (..))
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import           Network.HTTP.Media ((//), (/:))
+import           Nuthatch.Types
+import           Servant.API
+import           Servant.Server (HasServer (..))
+import           Servant.Server.Experimental.Auth (AuthServerData)
+import           Web.FormUrlEncoded (FromForm (..), lookupUnique)
+
+data HTML
+data JavaScript
+
+instance Accept HTML where
+  contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+instance Accept JavaScript where
+  contentType _ = "text" // "javascript" /: ("charset", "utf-8")
+
+newtype HtmlPage = HtmlPage { unHtmlPage :: Text }
+  deriving stock (Eq, Show)
+
+instance MimeRender HTML HtmlPage where
+  mimeRender _ = BL.fromStrict . TE.encodeUtf8 . unHtmlPage
+
+newtype BrowserScript = BrowserScript { unBrowserScript :: Text }
+  deriving stock (Eq, Show)
+
+instance MimeRender JavaScript BrowserScript where
+  mimeRender _ = BL.fromStrict . TE.encodeUtf8 . unBrowserScript
+
+data SessionContext = SessionContext
+  { sessionUser :: SessionUser
+  , sessionCsrf :: Maybe CsrfToken
+  }
+  deriving stock (Eq, Show)
+
+data SessionAuth
+
+type instance AuthServerData (AuthProtect SessionAuth) = SessionContext
+
+newtype BrowsePrefix = BrowsePrefix { unBrowsePrefix :: Maybe RelativePath }
+  deriving stock (Eq, Show)
+
+newtype PaginationToken = PaginationToken { unPaginationToken :: Text }
+  deriving stock (Eq, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype SearchQuery = SearchQuery { unSearchQuery :: Text }
+  deriving stock (Eq, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype DeclaredSize = DeclaredSize { unDeclaredSize :: Integer }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+newtype DevUsername = DevUsername { unDevUsername :: Text }
+  deriving stock (Eq, Show)
+
+data LoginRequest = LoginRequest
+  { loginUsername :: DevUsername
+  }
+  deriving stock (Eq, Show)
+
+instance FromJSON LoginRequest where
+  parseJSON = withObject "LoginRequest" $ \o -> do
+    raw <- o .: "username"
+    LoginRequest <$> either (fail . T.unpack) pure (validateDevUsername raw)
+
+instance FromForm LoginRequest where
+  fromForm form = do
+    raw <- lookupUnique "username" form
+    LoginRequest <$> validateDevUsername raw
+
+data LoginResponse = LoginResponse
+  { loginUserId :: UserId
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON LoginResponse where
+  toJSON response = object ["user_id" .= loginUserId response]
+
+data LoginView = LoginView
+  { loginViewHtml :: HtmlPage
+  , loginViewJson :: LoginResponse
+  }
+  deriving stock (Eq, Show)
+
+instance MimeRender HTML LoginView where
+  mimeRender proxy = mimeRender proxy . loginViewHtml
+
+instance ToJSON LoginView where
+  toJSON = toJSON . loginViewJson
+
+newtype HealthResponse = HealthResponse { healthOk :: Bool }
+  deriving stock (Eq, Show)
+
+instance ToJSON HealthResponse where
+  toJSON response = object ["ok" .= healthOk response]
+
+newtype ReadyResponse = ReadyResponse { ready :: Bool }
+  deriving stock (Eq, Show)
+
+instance ToJSON ReadyResponse where
+  toJSON response = object ["ready" .= ready response]
+
+data BrowseResponse = BrowseResponse
+  { browseEntries      :: [ListEntry]
+  , browseContinuation :: Maybe PaginationToken
+  , browsePartial      :: Bool
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON BrowseResponse where
+  toJSON response = object
+    [ "entries" .= browseEntries response
+    , "continuation" .= browseContinuation response
+    , "partial" .= browsePartial response
+    ]
+
+data BrowseView = BrowseView
+  { browseViewHtml :: HtmlPage
+  , browseViewJson :: BrowseResponse
+  }
+  deriving stock (Eq, Show)
+
+instance MimeRender HTML BrowseView where
+  mimeRender proxy = mimeRender proxy . browseViewHtml
+
+instance ToJSON BrowseView where
+  toJSON = toJSON . browseViewJson
+
+data DeleteRequest = DeleteRequest
+  { deleteRoot        :: Root
+  , deletePath        :: RelativePath
+  , deleteOperationId :: OperationId
+  , deleteCsrf        :: CsrfToken
+  }
+  deriving stock (Eq, Show)
+
+instance FromJSON DeleteRequest where
+  parseJSON = withObject "DeleteRequest" $ \o ->
+    DeleteRequest
+      <$> o .: "root"
+      <*> o .: "path"
+      <*> o .: "operation_id"
+      <*> o .: "csrf"
+
+data DeletePrefixRequest = DeletePrefixRequest
+  { deletePrefixRoot :: Root
+  , deletePrefixPath :: RelativePath
+  , deletePrefixCsrf :: CsrfToken
+  }
+  deriving stock (Eq, Show)
+
+instance FromJSON DeletePrefixRequest where
+  parseJSON = withObject "DeletePrefixRequest" $ \o ->
+    DeletePrefixRequest
+      <$> o .: "root"
+      <*> o .: "path"
+      <*> o .: "csrf"
+
+newtype DeletePrefixResponse = DeletePrefixResponse
+  { deletedObjectCount :: Int
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON DeletePrefixResponse where
+  toJSON response = object ["deleted" .= deletedObjectCount response]
+
+data UploadResponse = UploadResponse
+  { uploadResponseOperationId :: OperationId
+  , uploadResponseResult      :: MutationResult
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON UploadResponse where
+  toJSON response = object
+    [ "operation_id" .= uploadResponseOperationId response
+    , "result" .= mutationResultText (uploadResponseResult response)
+    ]
+
+data DeleteResponse = DeleteResponse
+  { deleteResponseOperationId :: OperationId
+  , deleteResponseResult      :: MutationResult
+  }
+  deriving stock (Eq, Show)
+
+instance ToJSON DeleteResponse where
+  toJSON response = object
+    [ "operation_id" .= deleteResponseOperationId response
+    , "result" .= mutationResultText (deleteResponseResult response)
+    ]
+
+data Throws error
+
+instance HasServer endpoint context =>
+    HasServer (Throws error :> endpoint) context where
+  type ServerT (Throws error :> endpoint) m = ServerT endpoint m
+  route _ = route (Proxy :: Proxy endpoint)
+  hoistServerWithContext _ context transform server =
+    hoistServerWithContext
+      (Proxy :: Proxy endpoint)
+      context
+      transform
+      server
+
+instance HasLink endpoint => HasLink (Throws error :> endpoint) where
+  type MkLink (Throws error :> endpoint) result = MkLink endpoint result
+  toLink convert _ = toLink convert (Proxy :: Proxy endpoint)
+
+data BoundaryError = InvalidUtf8
+  deriving stock (Eq, Show)
+
+instance ToJSON BoundaryError where
+  toJSON InvalidUtf8 =
+    errorValue "invalid_utf8" "request paths and query values must be valid UTF-8" Nothing
+
+data AuthenticationError
+  = AuthenticationRequired
+  | MalformedAuthentication
+  deriving stock (Eq, Show)
+
+instance ToJSON AuthenticationError where
+  toJSON AuthenticationRequired =
+    errorValue "authentication_required" "login required" Nothing
+  toJSON MalformedAuthentication =
+    errorValue "malformed_authentication" "authentication data is malformed" Nothing
+
+data ReadyError = ReadyDependencyUnavailable
+  deriving stock (Eq, Show)
+
+instance ToJSON ReadyError where
+  toJSON ReadyDependencyUnavailable =
+    errorValue "dependency_unavailable" "PostgreSQL is unavailable" Nothing
+
+data LoginError
+  = InvalidUsername
+  | SessionCreationFailed Text
+  deriving stock (Eq, Show)
+
+instance ToJSON LoginError where
+  toJSON InvalidUsername =
+    errorValue "invalid_username" "username must be one token" Nothing
+  toJSON (SessionCreationFailed message) =
+    errorValue "session_error" message Nothing
+
+data LogoutError = LogoutCsrfRejected
+  deriving stock (Eq, Show)
+
+instance ToJSON LogoutError where
+  toJSON LogoutCsrfRejected =
+    errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
+
+newtype BrowseError = BrowseObjectStoreFailed Text
+  deriving stock (Eq, Show)
+
+instance ToJSON BrowseError where
+  toJSON (BrowseObjectStoreFailed message) =
+    errorValue "object_store_error" message Nothing
+
+data DownloadError
+  = DownloadObjectStoreFailed Text
+  | DownloadNotFound
+  | DownloadThrottleUnavailable
+  | DownloadBandwidthExceeded
+  deriving stock (Eq, Show)
+
+instance ToJSON DownloadError where
+  toJSON (DownloadObjectStoreFailed message) =
+    errorValue "object_store_error" message Nothing
+  toJSON DownloadNotFound =
+    errorValue "not_found" "object not found" Nothing
+  toJSON DownloadThrottleUnavailable =
+    errorValue "throttle_unavailable" "bandwidth throttle unavailable" Nothing
+  toJSON DownloadBandwidthExceeded =
+    errorValue "bandwidth_exceeded" "bandwidth limit exceeded" Nothing
+
+data UploadError
+  = UploadCsrfRejected
+  | UploadInvalidBodyStream Text
+  | UploadSizeMismatch
+  | UploadTooLarge
+  | UploadContentIdentityMismatch
+  | UploadThrottleUnavailable
+  | UploadBandwidthExceeded
+  | UploadMutationRejected Text
+  deriving stock (Eq, Show)
+
+instance ToJSON UploadError where
+  toJSON UploadCsrfRejected =
+    errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
+  toJSON (UploadInvalidBodyStream message) =
+    errorValue "invalid_body_stream" message Nothing
+  toJSON UploadSizeMismatch =
+    errorValue "size_mismatch" "request body does not match declared size" Nothing
+  toJSON UploadTooLarge =
+    errorValue "object_too_large" "object too large" Nothing
+  toJSON UploadContentIdentityMismatch =
+    errorValue "content_identity_mismatch" "request body digest does not match" Nothing
+  toJSON UploadThrottleUnavailable =
+    errorValue "throttle_unavailable" "bandwidth throttle unavailable" Nothing
+  toJSON UploadBandwidthExceeded =
+    errorValue "bandwidth_exceeded" "bandwidth limit exceeded" Nothing
+  toJSON (UploadMutationRejected message) =
+    errorValue "mutation_rejected" message Nothing
+
+data DeleteError
+  = DeleteCsrfRejected
+  | DeleteMutationRejected Text
+  deriving stock (Eq, Show)
+
+instance ToJSON DeleteError where
+  toJSON DeleteCsrfRejected =
+    errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
+  toJSON (DeleteMutationRejected message) =
+    errorValue "mutation_rejected" message Nothing
+
+data DeletePrefixError
+  = DeletePrefixCsrfRejected
+  | DeletePrefixMutationRejected Text
+  deriving stock (Eq, Show)
+
+instance ToJSON DeletePrefixError where
+  toJSON DeletePrefixCsrfRejected =
+    errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
+  toJSON (DeletePrefixMutationRejected message) =
+    errorValue "prefix_mutation_rejected" message Nothing
+
+errorValue :: Text -> Text -> Maybe Value -> Value
+errorValue code message details = object
+  [ "error" .= code
+  , "message" .= message
+  , "details" .= details
+  ]
+
+type HealthEndpoint =
+  "healthz" :> Get '[JSON] HealthResponse
+
+type ReadyEndpoint =
+  "readyz" :> Throws ReadyError :> Get '[JSON] ReadyResponse
+
+type LoginPageEndpoint =
+  "login" :> Get '[HTML] HtmlPage
+
+type BrowserScriptEndpoint =
+  "nuthatch.js" :> Get '[JavaScript] BrowserScript
+
+type LoginSuccess =
+  Headers
+    '[ Header "Set-Cookie" Text
+     , Header "Set-Cookie" Text
+     , Header "X-CSRF-Token" CsrfToken
+     ]
+    LoginView
+
+type LoginEndpoint =
+  "login"
+    :> Throws LoginError
+    :> ReqBody '[JSON, FormUrlEncoded] LoginRequest
+    :> Post '[HTML, JSON] LoginSuccess
+
+type LogoutSuccess =
+  Headers
+    '[ Header "Set-Cookie" Text
+     , Header "Set-Cookie" Text
+     ]
+    NoContent
+
+type LogoutEndpoint =
+  "logout"
+    :> AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws LogoutError
+    :> Header' '[Required, Strict] "X-CSRF-Token" CsrfToken
+    :> Post '[JSON] LogoutSuccess
+
+type BrowseEndpoint =
+  AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws BrowseError
+    :> QueryParam "root" Root
+    :> QueryParam "prefix" BrowsePrefix
+    :> QueryParam "q" SearchQuery
+    :> QueryParam "continuation" PaginationToken
+    :> Get '[HTML, JSON] BrowseView
+
+type DownloadSuccess =
+  Headers
+    '[ Header "Content-Disposition" Text
+     , Header "X-Content-Type-Options" Text
+     ]
+    (SourceIO BS.ByteString)
+
+type DownloadEndpoint =
+  "download"
+    :> AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws DownloadError
+    :> QueryParam' '[Required, Strict] "root" Root
+    :> QueryParam' '[Required, Strict] "path" RelativePath
+    :> StreamGet NoFraming OctetStream DownloadSuccess
+
+type UploadEndpoint =
+  "upload"
+    :> AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws UploadError
+    :> QueryParam' '[Required, Strict] "root" Root
+    :> QueryParam' '[Required, Strict] "path" RelativePath
+    :> QueryParam' '[Required, Strict] "operation_id" OperationId
+    :> Header' '[Required, Strict] "X-Declared-Size" DeclaredSize
+    :> Header' '[Required, Strict] "X-Content-SHA256" ContentSha256
+    :> Header' '[Required, Strict] "X-CSRF-Token" CsrfToken
+    :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString)
+    :> Post '[JSON] UploadResponse
+
+type DeleteEndpoint =
+  "delete"
+    :> AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws DeleteError
+    :> ReqBody '[JSON] DeleteRequest
+    :> Post '[JSON] DeleteResponse
+
+type DeletePrefixEndpoint =
+  "delete-prefix"
+    :> AuthProtect SessionAuth
+    :> Throws AuthenticationError
+    :> Throws DeletePrefixError
+    :> ReqBody '[JSON] DeletePrefixRequest
+    :> Post '[JSON] DeletePrefixResponse
+
+type Api =
+       HealthEndpoint
+  :<|> ReadyEndpoint
+  :<|> LoginPageEndpoint
+  :<|> BrowserScriptEndpoint
+  :<|> LoginEndpoint
+  :<|> LogoutEndpoint
+  :<|> BrowseEndpoint
+  :<|> DownloadEndpoint
+  :<|> UploadEndpoint
+  :<|> DeleteEndpoint
+  :<|> DeletePrefixEndpoint
+
+api :: Proxy Api
+api = Proxy
+
+instance ToHttpApiData BrowsePrefix where
+  toUrlPiece (BrowsePrefix Nothing) = ""
+  toUrlPiece (BrowsePrefix (Just path)) = unRelativePath path
+
+instance FromHttpApiData BrowsePrefix where
+  parseUrlPiece "" = Right (BrowsePrefix Nothing)
+  parseUrlPiece raw = BrowsePrefix . Just <$> validateRelativePath raw
+
+instance ToHttpApiData PaginationToken where
+  toUrlPiece = unPaginationToken
+
+instance FromHttpApiData PaginationToken where
+  parseUrlPiece = validatePaginationToken
+
+instance ToHttpApiData SearchQuery where
+  toUrlPiece = unSearchQuery
+
+instance FromHttpApiData SearchQuery where
+  parseUrlPiece raw
+    | T.null raw = Left "search query must not be empty"
+    | T.length raw > 512 = Left "search query is too long"
+    | T.any isControl raw = Left "search query contains a control character"
+    | otherwise = Right (SearchQuery raw)
+
+instance ToHttpApiData DeclaredSize where
+  toUrlPiece = T.pack . show . unDeclaredSize
+
+instance FromHttpApiData DeclaredSize where
+  parseUrlPiece raw =
+    case reads (T.unpack raw) of
+      [(size, "")] | size > 0 -> Right (DeclaredSize size)
+      _ -> Left "declared size must be a positive integer"
+
+validatePaginationToken :: Text -> Either Text PaginationToken
+validatePaginationToken raw
+  | T.null raw = Left "pagination token must not be empty"
+  | T.length raw > 2048 = Left "pagination token is too long"
+  | T.any isControl raw = Left "pagination token contains a control character"
+  | otherwise = Right (PaginationToken raw)
+
+validateDevUsername :: Text -> Either Text DevUsername
+validateDevUsername raw
+  | T.null raw = Left "username must not be empty"
+  | T.length raw > 128 = Left "username is too long"
+  | T.any invalidCharacter raw = Left "username must be one printable token"
+  | otherwise = Right (DevUsername raw)
+  where
+    invalidCharacter character =
+      isControl character || character `elem` (" \t\r\n" :: String)
+
+mutationResultText :: MutationResult -> Text
+mutationResultText MutationPending   = "pending"
+mutationResultText MutationSucceeded = "succeeded"
+mutationResultText MutationFailed    = "failed"
+mutationResultText MutationRejected  = "rejected"
+mutationResultText MutationConflict  = "conflict"

src/Nuthatch/App.hs

@@ -2,12 +2,17 @@ module Nuthatch.App
   ( Env (..)
   , newEnv
   , application
+  , utf8Boundary
+  , authenticationHandler
+  , loginResponse
   , runRecovery
   ) where
 
 import           Control.Concurrent (threadDelay)
 import           Control.Exception (SomeException, try)
-import           Control.Monad (forever, void, when)
+import           Control.Monad (forever, unless, void, when)
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans.Except (runExceptT)
 import           Crypto.Hash (Digest, SHA256, hashlazy)
 import qualified Data.Aeson as A
 import qualified Data.ByteArray as BA
@@ -15,6 +20,7 @@ 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.Either (isRight)
 import           Data.Maybe (fromMaybe, listToMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as T
@@ -23,30 +29,14 @@ import           Data.UUID (toText)
 import           Data.UUID.V4 (nextRandom)
 import           Database.PostgreSQL.Simple (Connection, Only (..))
 import           Network.HTTP.Types
-  ( Header
+  ( hContentType
-  , HeaderName
-  , Status (..)
-  , hContentDisposition
-  , hContentType
   , hLocation
-  , status200
-  , status302
   , status400
-  , status403
+  , urlDecode
-  , status404
-  , status413
-  , status429
-  , status500
-  , status503
   )
-import           Network.Wai
+import qualified Network.HTTP.Types as HTTP
-  ( Application
+import           Network.Wai (Request (..), responseLBS)
-  , Request (..)
+import           Nuthatch.Api
-  , Response
-  , ResponseReceived
-  , responseLBS
-  )
-import           Network.Wai.Parse (FileInfo (..), lbsBackEnd, parseRequestBody)
 import           Nuthatch.Audit (audit)
 import           Nuthatch.Config (Config (..))
 import           Nuthatch.Db (Db, ensurePersonalPool, withTransaction)
@@ -66,7 +56,13 @@ import           Nuthatch.S3
   )
 import           Nuthatch.Session
 import           Nuthatch.Types
-import           Nuthatch.Ui
+import           Nuthatch.Ui (browsePage, browserScript, loginPage)
+import           Servant
+import           Servant.Server.Experimental.Auth
+  ( AuthHandler
+  , mkAuthHandler
+  )
+import           Servant.Types.SourceT (runSourceT, source)
 
 data Env = Env
   { envConfig :: Config
@@ -79,277 +75,349 @@ newEnv :: Config -> Db -> Redis -> S3 -> Env
 newEnv = Env
 
 application :: Env -> Application
-application env req respond =
+application env =
-  case (requestMethod req, pathInfo req) of
+  utf8Boundary $
-    ("GET", ["healthz"]) ->
+    serveWithContext
-      respond (json status200 (A.object ["ok" A..= True]))
+      api
-    ("GET", ["readyz"]) ->
+      (authenticationHandler (envConfig env) :. EmptyContext)
-      respond =<< readiness env
+      (server 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
+utf8Boundary :: Application -> Application
-readiness env = do
+utf8Boundary downstream request sendResponse
-  pg <- try $ Db.query_ (envDb env) "SELECT 1" :: IO (Either SomeException [Only Int])
+  | requestUtf8Valid request = downstream request sendResponse
-  pure $ case pg of
+  | otherwise =
-    Right _ -> json status200 (A.object ["ready" A..= True])
+      sendResponse $
-    Left _  -> json status503 (A.object ["ready" A..= False])
+        responseLBS status400
+          [(hContentType, "application/json")]
+          (A.encode InvalidUtf8)
 
-handleLogin :: Env -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+requestUtf8Valid :: Request -> Bool
-handleLogin env req respond = do
+requestUtf8Valid request =
-  (params, _) <- parseRequestBody lbsBackEnd req
+  validUtf8 (urlDecode False (rawPathInfo request))
-  let username =
+    && all validQueryItem (queryString request)
-        T.strip . TE.decodeUtf8 . fromMaybe "" $
+  where
-          lookup "username" params
+    validQueryItem (name, value) =
-  if T.null username || T.any (`elem` (" \t\r\n" :: String)) username
+      validUtf8 name && maybe True validUtf8 value
-    then respond (htmlResponse status400 (loginPage "Enter a single username token."))
+    validUtf8 = isRight . TE.decodeUtf8'
-    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
+server :: Env -> Server Api
-handleLogout env respond =
+server env =
-  respond $
+       pure (HealthResponse True)
-    responseLBS status302
+  :<|> handleReady env
-      [ (hLocation, "/login")
+  :<|> pure (HtmlPage (loginPage ""))
-      , clearCookie (envConfig env) (cfgCookieName (envConfig env))
+  :<|> pure (BrowserScript browserScript)
-      , clearCookie (envConfig env) (cfgCsrfCookieName (envConfig env))
+  :<|> handleLoginRequest env
-      ]
+  :<|> handleLogoutRequest env
-      ""
+  :<|> handleBrowseRequest env
+  :<|> handleDownloadRequest env
+  :<|> handleUploadRequest env
+  :<|> handleDeleteRequest env
+  :<|> handleDeletePrefixRequest env
 
-withSession
+authenticationHandler :: Config -> AuthHandler Request SessionContext
+authenticationHandler cfg = mkAuthHandler $ \request -> do
+  let cookies = parseCookies (requestHeaders request)
+      sessionName = TE.encodeUtf8 (cfgCookieName cfg)
+      csrfName = TE.encodeUtf8 (cfgCsrfCookieName cfg)
+  token <- maybe (throwError loginRequired) pure (lookup sessionName cookies)
+  sessionToken <- parseCookieValue validateSessionToken token
+  verified <- liftIO (verifySession cfg sessionToken)
+  user <- either (const (throwError loginRequired)) pure verified
+  csrf <- traverse
+    (parseCookieValue validateCsrfToken)
+    (lookup csrfName cookies)
+  pure SessionContext
+    { sessionUser = user
+    , sessionCsrf = csrf
+    }
+  where
+    loginRequired = err303
+      { errHeaders = [(hLocation, "/login")]
+      , errBody = A.encode AuthenticationRequired
+      }
+    parseCookieValue validate bytes =
+      case TE.decodeUtf8' bytes of
+        Left _ -> throwOperationError err400 MalformedAuthentication
+        Right value ->
+          either
+            (const (throwOperationError err400 MalformedAuthentication))
+            pure
+            (validate value)
+
+handleReady :: Env -> Handler ReadyResponse
+handleReady env = do
+  pg <- liftIO $
+    try (Db.query_ (envDb env) "SELECT 1") :: Handler (Either SomeException [Only Int])
+  case pg of
+    Right _ -> pure (ReadyResponse True)
+    Left _ -> throwOperationError err503 ReadyDependencyUnavailable
+
+handleLoginRequest
   :: Env
-  -> Request
+  -> LoginRequest
-  -> (Response -> IO ResponseReceived)
+  -> Handler LoginSuccess
-  -> (Env -> Request -> SessionUser -> Text -> (Response -> IO ResponseReceived) -> IO ResponseReceived)
+handleLoginRequest env request = do
-  -> IO ResponseReceived
+  let username = unDevUsername (loginUsername request)
-withSession env req respond handler = do
+  let uid = encodeUserId "nuthatch-dev" username
-  let cookies = parseCookies (requestHeaders req)
       cfg = envConfig env
-  case lookup (TE.encodeUtf8 (cfgCookieName cfg)) cookies of
+  liftIO (ensurePersonalPool (envDb env) cfg uid)
-    Nothing -> respond (redirect "/login")
+  tokenResult <- liftIO (mintSession cfg "nuthatch-dev" username (Just username))
-    Just raw -> do
+  token <- either
-      verified <- verifySession cfg (TE.decodeUtf8 raw)
+    (throwOperationError err500 . SessionCreationFailed)
-      case verified of
+    pure
-        Left _ -> respond (redirect "/login")
+    tokenResult
-        Right user -> do
+  csrf <- liftIO newCsrfToken
-          csrf <- case lookup (TE.encodeUtf8 (cfgCsrfCookieName cfg)) cookies of
+  liftIO $ audit "login" "ok" (Just (unUserId uid)) []
-            Just c  -> pure (TE.decodeUtf8 c)
+  pure (loginResponse cfg uid token csrf)
-            Nothing -> newCsrfToken
-          handler env req user csrf respond
 
-handleBrowse
+loginResponse
-  :: Env
+  :: Config
-  -> Request
+  -> UserId
-  -> SessionUser
+  -> SessionToken
-  -> Text
+  -> CsrfToken
-  -> (Response -> IO ResponseReceived)
+  -> LoginSuccess
-  -> IO ResponseReceived
+loginResponse cfg uid token csrf =
-handleBrowse env req user csrf respond = do
+  addHeader (cookieValue cfg (cfgCookieName cfg) (unSessionToken token) True) $
-  let qs = queryString req
+    addHeader (cookieValue cfg (cfgCsrfCookieName cfg) (unCsrfToken csrf) False) $
-      root = fromMaybe Personal (parseRoot =<< (TE.decodeUtf8 <$> join (lookup "root" qs)))
+      addHeader csrf (LoginView
-      prefix = maybe "" TE.decodeUtf8 (join (lookup "prefix" qs))
+        { loginViewHtml = HtmlPage
-      q = maybe "" TE.decodeUtf8 (join (lookup "q" qs))
+            "<!doctype html><html><head><meta charset=\"utf-8\"><meta http-equiv=\"refresh\" content=\"0;url=/\"></head><body><a href=\"/\">Continue to Nuthatch</a></body></html>"
-      notice = maybe "" TE.decodeUtf8 (join (lookup "notice" qs))
+        , loginViewJson = LoginResponse uid
-      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
+handleLogoutRequest
   :: Env
-  -> Request
+  -> SessionContext
-  -> SessionUser
+  -> CsrfToken
-  -> Text
+  -> Handler LogoutSuccess
-  -> (Response -> IO ResponseReceived)
+handleLogoutRequest env session providedCsrf = do
-  -> IO ResponseReceived
+  requireCsrf LogoutCsrfRejected session providedCsrf
-handleDownload env req user _csrf respond = do
+  let cfg = envConfig env
-  let qs = queryString req
+  pure $
-      mRoot = parseRoot =<< (TE.decodeUtf8 <$> join (lookup "root" qs))
+    addHeader (expiredCookieValue (cfgCookieName cfg)) $
-      mPath = TE.decodeUtf8 <$> join (lookup "path" qs)
+      addHeader (expiredCookieValue (cfgCsrfCookieName cfg)) NoContent
-  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
+handleBrowseRequest
   :: Env
-  -> Request
+  -> SessionContext
-  -> SessionUser
+  -> Maybe Root
-  -> Text
+  -> Maybe BrowsePrefix
-  -> (Response -> IO ResponseReceived)
+  -> Maybe SearchQuery
-  -> IO ResponseReceived
+  -> Maybe PaginationToken
-handleUpload env req user csrf respond = do
+  -> Handler BrowseView
-  (params, files) <- parseRequestBody lbsBackEnd req
+handleBrowseRequest env session selectedRoot selectedPrefix search _continuation = do
-  let providedCsrf = maybe "" TE.decodeUtf8 (lookup "csrf" params)
+  let user = sessionUser session
-  if not (constantTimeEq csrf providedCsrf)
+      root = fromMaybe Personal selectedRoot
-    then respond (text status403 "csrf validation failed")
+      prefix = maybe "" browsePrefixText selectedPrefix
-    else do
+  liftIO (ensurePersonalPool (envDb env) (envConfig env) (suUserId user))
-      let root = fromMaybe Personal (parseRoot . TE.decodeUtf8 =<< lookup "root" params)
+  result <- liftIO $ case search of
-          prefix = maybe "" TE.decodeUtf8 (lookup "prefix" params)
+    Nothing -> listEntries env user root prefix
-      case lookup "file" files of
+    Just query -> searchEntries env user root (unSearchQuery query)
-        Nothing ->
+  entries <- either
-          respond (redirect (browseUrl root prefix "" "missing file"))
+    (throwOperationError status502Error . BrowseObjectStoreFailed)
-        Just fileInfo -> do
+    pure
-          let name = TE.decodeUtf8 (fileName fileInfo)
+    result
-              content = fileContent fileInfo
+  uploadOperation <- liftIO (toText <$> nextRandom)
-              size = toInteger (BL.length content)
+  deleteOperations <- liftIO (mapM (\_ -> toText <$> nextRandom) entries)
-          if size <= 0
+  let response = BrowseResponse
-            then respond (redirect (browseUrl root prefix "" "empty file"))
+        { browseEntries = entries
-            else if size > cfgMaxObjectBytes (envConfig env)
+        , browseContinuation = Nothing
-              then respond (text status413 "object too large")
+        , browsePartial = False
-              else case validateRelativePath (joinPath prefix name) of
+        }
-                Left err -> respond (redirect (browseUrl root prefix "" err))
+      csrf = maybe "" unCsrfToken (sessionCsrf session)
-                Right rel -> do
+  pure BrowseView
-                  allowed <- throttleTake (envRedis env) (envConfig env) (suUserId user) size
+    { browseViewHtml = HtmlPage
-                  case allowed of
+        (browsePage
-                    Left _ -> respond (text status503 "bandwidth throttle unavailable")
+          user
-                    Right False -> respond (text status429 "bandwidth limit exceeded")
+          root
-                    Right True -> do
+          prefix
-                      let sha = contentSha256 content
+          csrf
-                      op <- parseOperationId params
+          uploadOperation
-                      outcome <- runPut env user root rel op size sha content
+          deleteOperations
-                      case outcome of
+          entries
-                        Left err ->
+          Nothing
-                          respond (redirect (browseUrl root prefix "" err))
+          "")
-                        Right MutationSucceeded -> do
+    , browseViewJson = response
-                          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
+handleDownloadRequest
   :: Env
-  -> Request
+  -> SessionContext
-  -> SessionUser
+  -> Root
-  -> Text
+  -> RelativePath
-  -> (Response -> IO ResponseReceived)
+  -> Handler DownloadSuccess
-  -> IO ResponseReceived
+handleDownloadRequest env session root path = do
-handleDelete env req user csrf respond = do
+  let user = sessionUser session
-  (params, _) <- parseRequestBody lbsBackEnd req
+      key = buildObjectKey root (suUserId user) path
-  let providedCsrf = maybe "" TE.decodeUtf8 (lookup "csrf" params)
+  metadata <- liftIO (headObject (envS3 env) key)
-  if not (constantTimeEq csrf providedCsrf)
+  info <- case metadata of
-    then respond (text status403 "csrf validation failed")
+    Left message -> throwOperationError status502Error
-    else do
+      (DownloadObjectStoreFailed message)
-      let root = fromMaybe Personal (parseRoot . TE.decodeUtf8 =<< lookup "root" params)
+    Right Nothing -> throwOperationError err404 DownloadNotFound
-          rawPath = maybe "" TE.decodeUtf8 (lookup "path" params)
+    Right (Just value) -> pure value
-          isPrefix = maybe False (== "1") (TE.decodeUtf8 <$> lookup "prefix_delete" params)
+  throttle <- liftIO $
-          parent = parentOf rawPath
+    throttleTake (envRedis env) (envConfig env) (suUserId user) (oiSize info)
-      if isPrefix
+  case throttle of
-        then do
+    Left _ -> throwOperationError err503 DownloadThrottleUnavailable
-          result <- deletePrefix env user root rawPath
+    Right False -> throwOperationError err429 DownloadBandwidthExceeded
-          case result of
+    Right True -> pure ()
-            Left err -> respond (redirect (browseUrl root parent "" err))
+  result <- liftIO (getObjectBytes (envS3 env) key)
-            Right n ->
+  body <- either
-              respond
+    (throwOperationError status502Error . DownloadObjectStoreFailed)
-                (redirect
+    pure
-                  (browseUrl root parent ("deleted " <> T.pack (show n) <> " object(s)") ""))
+    result
-        else
+  liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
-          case validateRelativePath rawPath of
+    [ ("root", A.toJSON (rootLabel root))
-            Left err -> respond (redirect (browseUrl root parent "" err))
+    , ("bytes", A.toJSON (oiSize info))
-            Right rel -> do
+    ]
-              op <- parseOperationId params
+  let filename = sanitizeFilename (basename path)
-              outcome <- runDelete env user root rel op
+  pure $
-              case outcome of
+    addHeader ("attachment; filename=\"" <> filename <> "\"") $
-                Left err -> respond (redirect (browseUrl root parent "" err))
+      addHeader "nosniff" (source (BL.toChunks body))
-                Right MutationSucceeded -> do
+
-                  audit "delete" "ok" (Just (unUserId (suUserId user)))
+handleUploadRequest
-                    [ ("root", A.toJSON (rootLabel root))
+  :: Env
-                    , ("operation_id", A.toJSON (unOperationId op))
+  -> SessionContext
-                    ]
+  -> Root
-                  respond (redirect (browseUrl root parent "deleted" ""))
+  -> RelativePath
-                Right MutationRejected ->
+  -> OperationId
-                  respond (redirect (browseUrl root parent "" "delete rejected"))
+  -> DeclaredSize
-                Right MutationPending ->
+  -> ContentSha256
-                  respond (redirect (browseUrl root parent "" "delete still pending; retry same operation id"))
+  -> CsrfToken
-                Right other ->
+  -> SourceIO BS.ByteString
-                  respond (redirect (browseUrl root parent "" ("delete " <> T.pack (show other))))
+  -> Handler UploadResponse
+handleUploadRequest env session root path operation declaredSize contentIdentity providedCsrf bodySource = do
+  requireCsrf UploadCsrfRejected session providedCsrf
+  chunksResult <- liftIO (runExceptT (runSourceT bodySource))
+  chunks <- either
+    (throwOperationError err400 . UploadInvalidBodyStream . T.pack)
+    pure
+    chunksResult
+  let user = sessionUser session
+      body = BL.fromChunks chunks
+      size = unDeclaredSize declaredSize
+      actualSize = toInteger (BL.length body)
+      configuredMaximum = cfgMaxObjectBytes (envConfig env)
+  unless (actualSize == size) $
+    throwOperationError err400 UploadSizeMismatch
+  when (size > configuredMaximum) $
+    throwOperationError err413 UploadTooLarge
+  unless (contentSha256 body == contentIdentity) $
+    throwOperationError err400 UploadContentIdentityMismatch
+  throttle <- liftIO $
+    throttleTake (envRedis env) (envConfig env) (suUserId user) size
+  case throttle of
+    Left _ -> throwOperationError err503 UploadThrottleUnavailable
+    Right False -> throwOperationError err429 UploadBandwidthExceeded
+    Right True -> pure ()
+  outcome <- liftIO (runPut env user root path operation size contentIdentity body)
+  result <- either
+    (throwOperationError err409 . UploadMutationRejected)
+    pure
+    outcome
+  liftIO $ audit "put" (mutationAuditResult result) (Just (unUserId (suUserId user)))
+    [ ("root", A.toJSON (rootLabel root))
+    , ("bytes", A.toJSON size)
+    , ("operation_id", A.toJSON (unOperationId operation))
+    ]
+  pure UploadResponse
+    { uploadResponseOperationId = operation
+    , uploadResponseResult = result
+    }
+
+handleDeleteRequest
+  :: Env
+  -> SessionContext
+  -> DeleteRequest
+  -> Handler DeleteResponse
+handleDeleteRequest env session request = do
+  requireCsrf DeleteCsrfRejected session (deleteCsrf request)
+  let user = sessionUser session
+      operation = deleteOperationId request
+      root = deleteRoot request
+  outcome <- liftIO $
+    runDelete env user root (deletePath request) operation
+  result <- either
+    (throwOperationError err409 . DeleteMutationRejected)
+    pure
+    outcome
+  liftIO $ audit "delete" (mutationAuditResult result)
+    (Just (unUserId (suUserId user)))
+    [ ("root", A.toJSON (rootLabel root))
+    , ("operation_id", A.toJSON (unOperationId operation))
+    ]
+  pure DeleteResponse
+    { deleteResponseOperationId = operation
+    , deleteResponseResult = result
+    }
+
+handleDeletePrefixRequest
+  :: Env
+  -> SessionContext
+  -> DeletePrefixRequest
+  -> Handler DeletePrefixResponse
+handleDeletePrefixRequest env session request = do
+  requireCsrf DeletePrefixCsrfRejected session (deletePrefixCsrf request)
+  result <- liftIO $
+    deletePrefix
+      env
+      (sessionUser session)
+      (deletePrefixRoot request)
+      (unRelativePath (deletePrefixPath request))
+  count <- either
+    (throwOperationError err409 . DeletePrefixMutationRejected)
+    pure
+    result
+  pure (DeletePrefixResponse count)
+
+requireCsrf :: A.ToJSON error => error -> SessionContext -> CsrfToken -> Handler ()
+requireCsrf csrfError session provided =
+  case sessionCsrf session of
+    Just expected | constantTimeEq expected provided -> pure ()
+    _ -> throwOperationError err403 csrfError
+
+throwOperationError :: A.ToJSON error => ServerError -> error -> Handler a
+throwOperationError serverError operationError =
+  throwError serverError
+    { errBody = A.encode operationError
+    , errHeaders = ("Content-Type", "application/json") : errHeaders serverError
+    }
+
+status502Error :: ServerError
+status502Error = ServerError
+  { errHTTPCode = 502
+  , errReasonPhrase = "Bad Gateway"
+  , errBody = ""
+  , errHeaders = []
+  }
+
+browsePrefixText :: BrowsePrefix -> Text
+browsePrefixText (BrowsePrefix Nothing) = ""
+browsePrefixText (BrowsePrefix (Just path)) = unRelativePath path
+
+cookieValue :: Config -> Text -> Text -> Bool -> Text
+cookieValue _cfg name value httpOnly =
+  name <> "=" <> value
+    <> "; Path=/; SameSite=Lax"
+    <> if httpOnly then "; HttpOnly" else ""
+
+expiredCookieValue :: Text -> Text
+expiredCookieValue name =
+  name <> "=; Path=/; Max-Age=0; SameSite=Lax"
+
+mutationAuditResult :: MutationResult -> Text
+mutationAuditResult MutationSucceeded = "ok"
+mutationAuditResult MutationPending   = "pending"
+mutationAuditResult MutationFailed    = "failed"
+mutationAuditResult MutationRejected  = "rejected"
+mutationAuditResult MutationConflict  = "conflict"
+
+sanitizeFilename :: Text -> Text
+sanitizeFilename =
+  T.map $ \character ->
+    if character `elem` ("\"\\\r\n" :: String)
+      then '_'
+      else character
 
 runPut
   :: Env
@@ -406,6 +474,55 @@ runDelete env user root rel op = do
       _ <- deleteObject (envS3 env) key
       pure ()
 
+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 message -> pure (Left message)
+    Right keys -> do
+      let rootPrefix =
+            case root of
+              Personal -> "users/" <> unUserId (suUserId user) <> "/"
+              Shared   -> "shared/"
+          relativePaths =
+            [ RelativePath relative
+            | key <- keys
+            , T.isPrefixOf rootPrefix key
+            , let relative = T.drop (T.length rootPrefix) key
+            , not (T.null relative)
+            ]
+      results <- mapM
+        (\relativePath -> do
+            operation <- OperationId . toText <$> nextRandom
+            runDelete env user root relativePath operation)
+        relativePaths
+      let deleted = length [() | Right MutationSucceeded <- results]
+          failure = listToMaybe [message | Left message <- results]
+      pure (maybe (Right deleted) Left failure)
+  where
+    withSlash path
+      | T.isSuffixOf "/" path = path
+      | otherwise = path <> "/"
+
+collectKeys :: S3 -> Text -> IO (Either Text [Text])
+collectKeys s3 prefix = go Nothing []
+  where
+    go continuation accumulated = do
+      page <- listObjects s3 prefix Nothing continuation 1000
+      case page of
+        Left message -> pure (Left message)
+        Right result -> do
+          let accumulated' = accumulated <> map fst (lpObjects result)
+          if lpIsTruncated result
+            then go (lpContinuationToken result) accumulated'
+            else pure (Right accumulated')
+
 dispatchAndFinalize
   :: Env
   -> SessionUser
@@ -472,57 +589,6 @@ finalizeFromObservation conn rec observed =
       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 =
@@ -665,78 +731,18 @@ recoverOne env rec =
       pure ()
     _ -> pure ()
 
-parseOperationId :: [(BS.ByteString, BS.ByteString)] -> IO OperationId
-parseOperationId params =
-  case lookup "operation_id" params of
-    Just raw | not (BS.null raw) ->
-      pure (OperationId (TE.decodeUtf8 raw))
-    _ ->
-      OperationId . toText <$> nextRandom
-
-joinPath :: Text -> Text -> Text
-joinPath prefix name
-  | T.null prefix = name
-  | T.isSuffixOf "/" prefix = prefix <> name
-  | otherwise = prefix <> "/" <> name
-
-parentOf :: Text -> Text
-parentOf path =
-  case reverse (T.splitOn "/" path) of
-    (_ : rest) -> T.intercalate "/" (reverse rest)
-    _          -> ""
-
-browseUrl :: Root -> Text -> Text -> Text -> Text
-browseUrl root prefix notice err =
-  "/?root=" <> rootLabel root
-    <> (if T.null prefix then "" else "&prefix=" <> prefix)
-    <> (if T.null notice then "" else "&notice=" <> notice)
-    <> (if T.null err then "" else "&error=" <> err)
-
 contentSha256 :: BL.ByteString -> ContentSha256
 contentSha256 body =
   ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
     (hashlazy body :: Digest SHA256)
 
-sanitizeFilename :: Text -> Text
-sanitizeFilename =
-  T.map $ \c -> if c `elem` ("\"\\\r\n" :: String) then '_' else c
-
 lastSeg :: Text -> Text
 lastSeg t =
   case reverse (T.splitOn "/" t) of
     (x : _) -> x
     []      -> t
 
-json :: Status -> A.Value -> Response
+parseCookies :: [HTTP.Header] -> [(BS.ByteString, BS.ByteString)]
-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 -> []
@@ -751,9 +757,3 @@ trimBS :: BS.ByteString -> BS.ByteString
 trimBS = BS8.dropWhile isSpace . BS8.dropWhileEnd isSpace
   where
     isSpace c = c == ' ' || c == '\t'
-
-join :: Maybe (Maybe a) -> Maybe a
-join = fromMaybe Nothing
-
-status502 :: Status
-status502 = Status 502 "Bad Gateway"

src/Nuthatch/Paths.hs

@@ -10,33 +10,11 @@ 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 qualified Data.Text.Normalize as TN
 import           Nuthatch.Types
 
-validateRelativePath :: Text -> Either Text RelativePath
-validateRelativePath raw = do
-  if T.null raw
-    then Left "path must not be empty"
-    else if T.head raw == '/' || T.last raw == '/'
-      then Left "path must not begin or end with a separator"
-    else if TN.normalize TN.NFC raw /= raw
-      then Left "path must be NFC-normalized"
-    else do
-      let segments = T.splitOn "/" raw
-      mapM_ validateSegment segments
-      pure (RelativePath raw)
-  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

src/Nuthatch/Session.hs

@@ -24,7 +24,7 @@ import           Nuthatch.Paths (encodeUserId)
 import           Nuthatch.Types
 import           System.Entropy (getEntropy)
 
-mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text Text)
+mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text SessionToken)
 mintSession cfg iss sub display = do
   now <- floor <$> getPOSIXTime
   let expAt = now + cfgSessionHours cfg * 3600
@@ -43,10 +43,10 @@ mintSession cfg iss sub display = do
         , "oidc_subject" A..= sub
         ] <> maybe [] (\d -> ["display" A..= d]) display
       token = signJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) header payload
-  pure (Right token)
+  pure (validateSessionToken token)
 
-verifySession :: Config -> Text -> IO (Either Text SessionUser)
+verifySession :: Config -> SessionToken -> IO (Either Text SessionUser)
-verifySession cfg token = do
+verifySession cfg (SessionToken token) = do
   now <- floor <$> getPOSIXTime
   pure $ do
     claims <- verifyJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) token
@@ -120,13 +120,13 @@ claimInt obj key =
         _                        -> Left ("invalid integer claim " <> key)
     _ -> Left ("missing claim " <> key)
 
-newCsrfToken :: IO Text
+newCsrfToken :: IO CsrfToken
 newCsrfToken = do
   bytes <- getEntropy 32
-  pure (TE.decodeUtf8 (B64.encodeUnpadded bytes))
+  pure (CsrfToken (TE.decodeUtf8 (B64.encodeUnpadded bytes)))
 
-constantTimeEq :: Text -> Text -> Bool
+constantTimeEq :: CsrfToken -> CsrfToken -> Bool
-constantTimeEq a b =
+constantTimeEq (CsrfToken a) (CsrfToken b) =
   let ba = TE.encodeUtf8 a
       bb = TE.encodeUtf8 b
   in BS.length ba == BS.length bb

src/Nuthatch/Types.hs

@@ -5,6 +5,8 @@ module Nuthatch.Types
   , ExternalState (..)
   , UserId (..)
   , OperationId (..)
+  , SessionToken (..)
+  , CsrfToken (..)
   , ContentSha256 (..)
   , ObjectKey (..)
   , RelativePath (..)
@@ -20,13 +22,30 @@ module Nuthatch.Types
   , parseState
   , externalLabel
   , parseExternal
+  , validateRelativePath
+  , validateOperationId
+  , validateContentSha256
+  , validateSessionToken
+  , validateCsrfToken
   , sharedPool
   , personalPool
   ) where
 
-import           Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))
+import           Data.Aeson
+  ( FromJSON (..)
+  , ToJSON (..)
+  , object
+  , withObject
+  , withText
+  , (.:)
+  , (.:?)
+  , (.=)
+  )
+import           Data.Char (isAsciiLower, isAsciiUpper, isControl, isDigit)
 import           Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Normalize as TN
+import           Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
 
 data Root = Personal | Shared
   deriving stock (Eq, Show)
@@ -99,7 +118,22 @@ newtype UserId = UserId { unUserId :: Text }
 
 newtype OperationId = OperationId { unOperationId :: Text }
   deriving stock (Eq, Ord, Show)
-  deriving newtype (ToJSON, FromJSON)
+  deriving newtype (ToJSON)
+
+instance FromJSON OperationId where
+  parseJSON = withText "OperationId" $
+    either (fail . T.unpack) pure . validateOperationId
+
+newtype SessionToken = SessionToken { unSessionToken :: Text }
+  deriving stock (Eq, Ord, Show)
+
+newtype CsrfToken = CsrfToken { unCsrfToken :: Text }
+  deriving stock (Eq, Ord, Show)
+  deriving newtype (ToJSON)
+
+instance FromJSON CsrfToken where
+  parseJSON = withText "CsrfToken" $
+    either (fail . T.unpack) pure . validateCsrfToken
 
 newtype ContentSha256 = ContentSha256 { unContentSha256 :: Text }
   deriving stock (Eq, Ord, Show)
@@ -111,7 +145,11 @@ newtype ObjectKey = ObjectKey { unObjectKey :: Text }
 
 newtype RelativePath = RelativePath { unRelativePath :: Text }
   deriving stock (Eq, Ord, Show)
-  deriving newtype (ToJSON, FromJSON)
+  deriving newtype (ToJSON)
+
+instance FromJSON RelativePath where
+  parseJSON = withText "RelativePath" $
+    either (fail . T.unpack) pure . validateRelativePath
 
 newtype PoolId = PoolId { unPoolId :: Text }
   deriving stock (Eq, Ord, Show)
@@ -162,3 +200,118 @@ data MutationResult
   | MutationRejected
   | MutationConflict
   deriving stock (Eq, Show)
+
+instance ToJSON Root where
+  toJSON = toJSON . rootLabel
+
+instance FromJSON Root where
+  parseJSON = withText "Root" $ \raw ->
+    maybe (fail "root must be personal or shared") pure (strictRoot raw)
+
+instance ToHttpApiData Root where
+  toUrlPiece = rootLabel
+
+instance FromHttpApiData Root where
+  parseUrlPiece raw =
+    maybe (Left "root must be personal or shared") Right (strictRoot raw)
+
+instance ToHttpApiData RelativePath where
+  toUrlPiece = unRelativePath
+
+instance FromHttpApiData RelativePath where
+  parseUrlPiece = validateRelativePath
+
+instance ToHttpApiData OperationId where
+  toUrlPiece = unOperationId
+
+instance FromHttpApiData OperationId where
+  parseUrlPiece = validateOperationId
+
+instance ToHttpApiData CsrfToken where
+  toUrlPiece = unCsrfToken
+
+instance FromHttpApiData CsrfToken where
+  parseUrlPiece = validateCsrfToken
+
+instance ToHttpApiData ContentSha256 where
+  toUrlPiece = unContentSha256
+
+instance FromHttpApiData ContentSha256 where
+  parseUrlPiece = validateContentSha256
+
+validateRelativePath :: Text -> Either Text RelativePath
+validateRelativePath raw = do
+  if T.null raw
+    then Left "path must not be empty"
+    else if T.head raw == '/' || T.last raw == '/'
+      then Left "path must not begin or end with a separator"
+    else if TN.normalize TN.NFC raw /= raw
+      then Left "path must be NFC-normalized"
+    else do
+      mapM_ validateSegment (T.splitOn "/" raw)
+      pure (RelativePath raw)
+  where
+    validateSegment segment
+      | T.null segment = Left "empty path segment"
+      | segment == "." || segment == ".." =
+          Left "path segment may not be . or .."
+      | T.any (== '\\') segment = Left "backslash is not allowed"
+      | T.any isControl segment = Left "control characters are not allowed"
+      | otherwise = Right ()
+
+validateOperationId :: Text -> Either Text OperationId
+validateOperationId raw
+  | T.null raw = Left "operation id must not be empty"
+  | T.length raw > 128 = Left "operation id is too long"
+  | T.any (not . operationCharacter) raw =
+      Left "operation id must contain only URL-safe ASCII characters"
+  | otherwise = Right (OperationId raw)
+  where
+    operationCharacter character =
+      isAsciiLower character
+        || isAsciiUpper character
+        || isDigit character
+        || character `elem` ("-._~" :: String)
+
+validateContentSha256 :: Text -> Either Text ContentSha256
+validateContentSha256 raw
+  | T.length raw /= 64 =
+      Left "content SHA-256 must contain 64 hexadecimal characters"
+  | T.any (not . hexadecimal) raw =
+      Left "content SHA-256 must use lowercase hexadecimal"
+  | otherwise = Right (ContentSha256 raw)
+  where
+    hexadecimal character =
+      isDigit character || character >= 'a' && character <= 'f'
+
+validateSessionToken :: Text -> Either Text SessionToken
+validateSessionToken raw
+  | T.length raw > 8192 = Left "session token is too long"
+  | otherwise =
+      case T.splitOn "." raw of
+        [header, payload, signature]
+          | all validSegment [header, payload, signature] ->
+              Right (SessionToken raw)
+        _ -> Left "session token must be compact JOSE"
+  where
+    validSegment segment =
+      not (T.null segment) && T.all base64UrlCharacter segment
+
+validateCsrfToken :: Text -> Either Text CsrfToken
+validateCsrfToken raw
+  | T.length raw /= 43 = Left "CSRF token must encode 32 bytes"
+  | T.all base64UrlCharacter raw = Right (CsrfToken raw)
+  | otherwise = Left "CSRF token must use unpadded Base64url"
+
+base64UrlCharacter :: Char -> Bool
+base64UrlCharacter character =
+  isAsciiLower character
+    || isAsciiUpper character
+    || isDigit character
+    || character == '-'
+    || character == '_'
+
+strictRoot :: Text -> Maybe Root
+strictRoot "personal" = Just Personal
+strictRoot "shared"   = Just Shared
+strictRoot _          = Nothing

src/Nuthatch/Ui.hs

@@ -1,5 +1,6 @@
 module Nuthatch.Ui
   ( loginPage
+  , browserScript
   , browsePage
   , htmlResponse
   , escapeHtml
@@ -61,7 +62,10 @@ browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
     , "    Signed in as <strong>"
         <> escapeHtml (maybe (unUserId (suUserId user)) id (suDisplay user))
         <> "</strong>"
-    , "    · <a href=\"/logout\">Log out</a>"
+    , "    · <form class=\"inline\" data-nuthatch=\"logout\">"
+    , "      <input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
+    , "      <button type=\"submit\">Log out</button>"
+    , "    </form>"
     , "  </div>"
     , "</header>"
     , if T.null notice then "" else "<p class=\"ok\">" <> escapeHtml notice <> "</p>"
@@ -76,7 +80,7 @@ browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
     , breadcrumbs root prefix
     , "<section>"
     , "  <h2>Upload</h2>"
-    , "  <form method=\"post\" action=\"/upload\" enctype=\"multipart/form-data\">"
+    , "  <form method=\"post\" action=\"/upload\" enctype=\"multipart/form-data\" data-nuthatch=\"upload\">"
     , "    <input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
     , "    <input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml uploadOp <> "\">"
     , "    <input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
@@ -150,7 +154,7 @@ renderEntry root csrf opId entry =
 
 deleteForm :: Root -> Text -> Text -> Text -> Bool -> Text
 deleteForm root path csrf opId isPrefix =
-  "<form class=\"inline\" method=\"post\" action=\"/delete\" onsubmit=\"return confirm('Delete "
+  "<form class=\"inline\" method=\"post\" action=\"/delete\" data-nuthatch=\"delete\" onsubmit=\"return confirm('Delete "
     <> escapeHtml path <> "?');\">"
     <> "<input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
     <> "<input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml opId <> "\">"
@@ -184,7 +188,49 @@ page title body =
     , "button{cursor:pointer}"
     , "</style>"
     , "<meta http-equiv=\"Content-Security-Policy\" content=\"default-src 'self'; style-src 'unsafe-inline'; img-src 'none'; object-src 'none'\">"
+    , "<script src=\"/nuthatch.js\" defer></script>"
     , "</head><body>"
     , body
     , "</body></html>"
     ]
+
+browserScript :: Text
+browserScript = T.unlines
+  [ "const hex = bytes => Array.from(new Uint8Array(bytes), byte => byte.toString(16).padStart(2, '0')).join('');"
+  , "const fail = async response => { if (!response.ok) throw new Error((await response.json()).message || response.statusText); };"
+  , "document.addEventListener('submit', async event => {"
+  , "  const form = event.target.closest('form[data-nuthatch]');"
+  , "  if (!form) return;"
+  , "  event.preventDefault();"
+  , "  const fields = new FormData(form);"
+  , "  try {"
+  , "    if (form.dataset.nuthatch === 'logout') {"
+  , "      const response = await fetch('/logout', { method: 'POST', headers: { 'X-CSRF-Token': fields.get('csrf') } });"
+  , "      await fail(response);"
+  , "      location.assign('/login');"
+  , "      return;"
+  , "    }"
+  , "    if (form.dataset.nuthatch === 'upload') {"
+  , "      const file = fields.get('file');"
+  , "      const prefix = fields.get('prefix');"
+  , "      const path = prefix ? `${prefix}/${file.name}` : file.name;"
+  , "      const digest = hex(await crypto.subtle.digest('SHA-256', await file.arrayBuffer()));"
+  , "      const query = new URLSearchParams({ root: fields.get('root'), path, operation_id: fields.get('operation_id') });"
+  , "      const response = await fetch(`/upload?${query}`, { method: 'POST', headers: { 'Content-Type': 'application/octet-stream', 'X-Declared-Size': String(file.size), 'X-Content-SHA256': digest, 'X-CSRF-Token': fields.get('csrf') }, body: file });"
+  , "      await fail(response);"
+  , "      location.reload();"
+  , "      return;"
+  , "    }"
+  , "    const prefixDelete = fields.get('prefix_delete') === '1';"
+  , "    const endpoint = prefixDelete ? '/delete-prefix' : '/delete';"
+  , "    const request = prefixDelete"
+  , "      ? { root: fields.get('root'), path: fields.get('path'), csrf: fields.get('csrf') }"
+  , "      : { root: fields.get('root'), path: fields.get('path'), operation_id: fields.get('operation_id'), csrf: fields.get('csrf') };"
+  , "    const response = await fetch(endpoint, { method: 'POST', headers: { 'Content-Type': 'application/json' }, body: JSON.stringify(request) });"
+  , "    await fail(response);"
+  , "    location.reload();"
+  , "  } catch (error) {"
+  , "    alert(error.message);"
+  , "  }"
+  , "});"
+  ]

test/Spec.hs

@@ -1,8 +1,14 @@
 module Main (main) where
 
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
 import           Data.Either (isLeft)
+import           Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
 import           Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import           Hedgehog
   ( Gen
   , Property
@@ -13,11 +19,35 @@ import           Hedgehog
   )
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
+import           Network.HTTP.Types
+  ( HeaderName
+  , methodGet
+  , methodPost
+  , status200
+  , status400
+  , status404
+  , status405
+  )
+import           Network.Wai (Request (..))
+import           Network.Wai.Test
+  ( SRequest (..)
+  , SResponse (..)
+  , defaultRequest
+  , runSession
+  , setPath
+  , srequest
+  )
+import           Nuthatch.Api
+import           Nuthatch.App
+  ( authenticationHandler
+  , loginResponse
+  , utf8Boundary
+  )
+import           Nuthatch.Config (AuthMode (..), Config (..))
 import           Nuthatch.Paths
   ( buildObjectKey
   , encodeUserId
   , listCacheAncestorPrefixes
-  , validateRelativePath
   )
 import           Nuthatch.Protocol
   ( MutationRecord (..)
@@ -31,8 +61,13 @@ import           Nuthatch.Protocol
   , terminalExpiryEligible
   )
 import           Nuthatch.Types
+import           Nuthatch.Session (mintSession)
+import           Nuthatch.Ui (browsePage, browserScript, loginPage)
+import           Servant
+import           Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
+import           Servant.Types.SourceT (source)
 import           Test.Tasty (TestTree, defaultMain, testGroup)
-import           Test.Tasty.HUnit ((@?=), testCase)
+import           Test.Tasty.HUnit ((@?=), assertBool, testCase)
 import           Test.Tasty.Hedgehog (testProperty)
 
 main :: IO ()
@@ -43,6 +78,7 @@ tests = testGroup "nuthatch-unit"
   [ pathTests
   , identityTests
   , protocolTests
+  , apiTests
   ]
 
 pathTests :: TestTree
@@ -76,6 +112,391 @@ protocolTests = testGroup "mutation protocol decisions"
   , testProperty "only stale active records are recovery eligible" propRecoveryTiming
   ]
 
+apiTests :: TestTree
+apiTests = testGroup "typed HTTP boundary"
+  [ testCase "Servant selects routes and methods" testRouteSelection
+  , testCase "valid query values reach a typed handler" testValidDecoding
+  , testCase "invalid roots and paths fail before handler execution" testInvalidDomains
+  , testCase "malformed UTF-8 fails before handler execution" testMalformedUtf8
+  , testCase "upload headers and operation ids decode before streaming handler execution"
+      testUploadDecoding
+  , testCase "upload and download bodies use Servant streaming endpoints"
+      testStreamingEndpoints
+  , testCase "operation-specific JSON requests and responses remain distinct"
+      testOperationRepresentations
+  , testCase "operation-specific errors have closed distinct representations" $ do
+      let loginError = A.encode InvalidUsername
+          deleteError = A.encode (DeleteMutationRejected "locked")
+          prefixError = A.encode (DeletePrefixMutationRejected "partial")
+      assertBool "login errors carry the login-specific code"
+        ("invalid_username" `BS.isInfixOf` BL.toStrict loginError)
+      assertBool "delete errors carry the mutation-specific code"
+        ("mutation_rejected" `BS.isInfixOf` BL.toStrict deleteError)
+      assertBool "operation errors must not share one representation"
+        (loginError /= deleteError && deleteError /= prefixError)
+      assertBool "prefix errors carry their operation-specific code"
+        ("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
+  , testCase "production authentication validates cookies and login emits both cookies"
+      testAuthenticationBoundary
+  , testCase "retained browser forms are wired to the typed API bridge"
+      testBrowserBridge
+  , testCase "links derive from the type-level API" $
+      show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
+        @?= "healthz"
+  ]
+
+testRouteSelection :: IO ()
+testRouteSelection = do
+  calls <- newIORef 0
+  response <- apiRequest calls methodGet "/healthz" [] ""
+  simpleStatus response @?= status200
+  readIORef calls >>= (@?= 1)
+  writeIORef calls 0
+  wrongMethod <- apiRequest calls methodPost "/healthz" [] ""
+  simpleStatus wrongMethod @?= status405
+  readIORef calls >>= (@?= 0)
+  missing <- apiRequest calls methodGet "/missing" [] ""
+  simpleStatus missing @?= status404
+  readIORef calls >>= (@?= 0)
+
+testValidDecoding :: IO ()
+testValidDecoding = do
+  calls <- newIORef 0
+  response <- apiRequest calls methodGet
+    "/?root=personal&prefix=docs%2Freports&q=quarterly&continuation=next"
+    []
+    ""
+  simpleStatus response @?= status200
+  readIORef calls >>= (@?= 1)
+
+testInvalidDomains :: IO ()
+testInvalidDomains = do
+  calls <- newIORef 0
+  invalidRoot <- apiRequest calls methodGet "/?root=PERSONAL" [] ""
+  simpleStatus invalidRoot @?= status400
+  invalidPath <- apiRequest calls methodGet "/?prefix=docs%2F..%2Fprivate" [] ""
+  simpleStatus invalidPath @?= status400
+  readIORef calls >>= (@?= 0)
+
+testMalformedUtf8 :: IO ()
+testMalformedUtf8 = do
+  calls <- newIORef 0
+  response <- apiRequest calls methodGet "/?q=%FF" [] ""
+  simpleStatus response @?= status400
+  readIORef calls >>= (@?= 0)
+
+testUploadDecoding :: IO ()
+testUploadDecoding = do
+  calls <- newIORef 0
+  let csrf = BS.replicate 43 97
+  let headers =
+        [ ("Content-Type", "application/octet-stream")
+        , ("X-Declared-Size", "4")
+        , ("X-Content-SHA256", BS.replicate 64 97)
+        , ("X-CSRF-Token", csrf)
+        ]
+  response <- apiRequest calls methodPost
+    "/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
+    headers
+    "body"
+  simpleStatus response @?= status400
+  invalidSize <- apiRequest calls methodPost
+    "/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
+    (replaceHeader "X-Declared-Size" "zero" headers)
+    "body"
+  simpleStatus invalidSize @?= status400
+  invalidPagination <- apiRequest calls methodGet "/?continuation=" [] ""
+  simpleStatus invalidPagination @?= status400
+  readIORef calls >>= (@?= 0)
+
+testStreamingEndpoints :: IO ()
+testStreamingEndpoints = do
+  calls <- newIORef 0
+  let csrf = BS.replicate 43 97
+  let headers =
+        [ ("Content-Type", "application/octet-stream")
+        , ("X-Declared-Size", "4")
+        , ("X-Content-SHA256", BS.replicate 64 97)
+        , ("X-CSRF-Token", csrf)
+        ]
+  upload <- apiRequest calls methodPost
+    "/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
+    headers
+    "body"
+  simpleStatus upload @?= status200
+  download <- apiRequest calls methodGet
+    "/download?root=shared&path=docs%2Ffile.txt"
+    []
+    ""
+  simpleStatus download @?= status200
+  simpleBody download @?= "body"
+  lookup "Content-Disposition" (simpleHeaders download)
+    @?= Just "attachment; filename=\"file.txt\""
+  lookup "X-Content-Type-Options" (simpleHeaders download)
+    @?= Just "nosniff"
+  readIORef calls >>= (@?= 2)
+
+testOperationRepresentations :: IO ()
+testOperationRepresentations = do
+  calls <- newIORef 0
+  login <- apiRequest calls methodPost
+    "/login"
+    [ ("Content-Type", "application/json")
+    , ("Accept", "application/json")
+    ]
+    "{\"username\":\"alice\"}"
+  simpleStatus login @?= status200
+  assertBool "login response must carry a user identity"
+    ("user_id" `BS.isInfixOf` BL.toStrict (simpleBody login))
+  formLogin <- apiRequest calls methodPost
+    "/login"
+    [("Content-Type", "application/x-www-form-urlencoded")]
+    "username=bob"
+  simpleStatus formLogin @?= status200
+  assertBool "browser login response navigates into the UI"
+    ("continue" `BS.isInfixOf` BL.toStrict (simpleBody formLogin))
+  invalidLogin <- apiRequest calls methodPost
+    "/login"
+    [("Content-Type", "application/json")]
+    "{\"username\":\"two words\"}"
+  simpleStatus invalidLogin @?= status400
+  deletion <- apiRequest calls methodPost
+    "/delete"
+    [("Content-Type", "application/json")]
+    "{\"root\":\"shared\",\"path\":\"docs/file.txt\",\"operation_id\":\"delete-1\",\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
+  simpleStatus deletion @?= status200
+  assertBool "delete response must carry a mutation result"
+    ("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
+  malformed <- apiRequest calls methodPost
+    "/delete"
+    [("Content-Type", "application/json")]
+    "{\"root\":\"shared\",\"path\":\"../escape\"}"
+  simpleStatus malformed @?= status400
+  readIORef calls >>= (@?= 3)
+
+replaceHeader
+  :: HeaderName
+  -> BS.ByteString
+  -> [(HeaderName, BS.ByteString)]
+  -> [(HeaderName, BS.ByteString)]
+replaceHeader name value =
+  map $ \(headerName, headerValue) ->
+    if headerName == name
+      then (headerName, value)
+      else (headerName, headerValue)
+
+apiRequest
+  :: IORef Int
+  -> BS.ByteString
+  -> BS.ByteString
+  -> [(HeaderName, BS.ByteString)]
+  -> BL.ByteString
+  -> IO SResponse
+apiRequest calls method path headers body =
+  apiRequestWith (typedTestApplication calls) method path headers body
+
+apiRequestWith
+  :: Application
+  -> BS.ByteString
+  -> BS.ByteString
+  -> [(HeaderName, BS.ByteString)]
+  -> BL.ByteString
+  -> IO SResponse
+apiRequestWith app method path headers body =
+  runSession
+    (srequest
+      (SRequest
+        (setPath defaultRequest
+          { requestMethod = method
+          , requestHeaders = headers
+          }
+          path)
+        body))
+    app
+
+typedTestApplication :: IORef Int -> Application
+typedTestApplication calls =
+  utf8Boundary $
+    serveWithContext api (auth :. EmptyContext) (typedTestServer calls)
+  where
+    auth :: AuthHandler Request SessionContext
+    auth = mkAuthHandler $ \_ -> pure SessionContext
+      { sessionUser = SessionUser
+          { suIssuer = "issuer"
+          , suSubject = "subject"
+          , suUserId = UserId "user"
+          , suDisplay = Nothing
+          }
+      , sessionCsrf = Just
+          (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+      }
+
+typedTestServer :: IORef Int -> Server Api
+typedTestServer calls =
+       counted (HealthResponse True)
+  :<|> counted (ReadyResponse True)
+  :<|> counted (HtmlPage "login")
+  :<|> counted (BrowserScript "script")
+  :<|> (\_ -> counted
+        (addHeader "session=cookie"
+          (addHeader "csrf=cookie"
+            (addHeader (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+              (LoginView
+                (HtmlPage "continue")
+                (LoginResponse (UserId "user")))))))
+  :<|> (\_ _ -> counted
+        (addHeader "session=expired"
+          (addHeader "csrf=expired" NoContent)))
+  :<|> (\_ _ _ _ _ -> counted
+        (BrowseView
+          (HtmlPage "browse")
+          BrowseResponse
+            { browseEntries = []
+            , browseContinuation = Nothing
+            , browsePartial = False
+            }))
+  :<|> (\_ _ _ -> counted
+        (addHeader "attachment; filename=\"file.txt\""
+          (addHeader "nosniff" (source ["body"]))))
+  :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
+        { uploadResponseOperationId = operation
+        , uploadResponseResult = MutationSucceeded
+        })
+  :<|> (\_ request -> counted DeleteResponse
+        { deleteResponseOperationId = deleteOperationId request
+        , deleteResponseResult = MutationSucceeded
+        })
+  :<|> (\_ _ -> counted (DeletePrefixResponse 1))
+  where
+    counted :: a -> Handler a
+    counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
+
+testAuthenticationBoundary :: IO ()
+testAuthenticationBoundary = do
+  tokenResult <- mintSession testConfig "issuer" "subject" Nothing
+  token <- either (fail . T.unpack) pure tokenResult
+  let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+      responseHeaders = getHeaders
+        (loginResponse testConfig (UserId "user") token csrf)
+      cookieHeaders =
+        [ value
+        | (name, value) <- responseHeaders
+        , name == "Set-Cookie"
+        ]
+  length cookieHeaders @?= 2
+  assertBool "login sets the session cookie"
+    (any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
+  assertBool "login sets the CSRF cookie"
+    (any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
+
+  calls <- newIORef 0
+  let app = productionAuthTestApplication testConfig calls
+      cookie =
+        "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
+          <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
+  authenticated <- apiRequestWith app methodGet
+    "/?root=personal"
+    [("Cookie", cookie)]
+    ""
+  simpleStatus authenticated @?= status200
+  readIORef calls >>= (@?= 1)
+
+  writeIORef calls 0
+  malformed <- apiRequestWith app methodGet
+    "/?root=personal"
+    [("Cookie", "nuthatch_session=" <> BS.singleton 255
+      <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
+    ""
+  simpleStatus malformed @?= status400
+  readIORef calls >>= (@?= 0)
+
+  missingCsrf <- apiRequestWith app methodGet
+    "/?root=personal"
+    [("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
+    ""
+  simpleStatus missingCsrf @?= status200
+  readIORef calls >>= (@?= 1)
+
+testBrowserBridge :: IO ()
+testBrowserBridge = do
+  let csrf = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+      user = SessionUser
+        { suIssuer = "issuer"
+        , suSubject = "subject"
+        , suUserId = UserId "user"
+        , suDisplay = Just "User"
+        }
+      entry = ListEntry
+        { leName = "folder"
+        , leIsPrefix = True
+        , leSize = Nothing
+        , leRelativePath = "folder"
+        }
+      browse = browsePage
+        user
+        Personal
+        ""
+        csrf
+        "upload-1"
+        ["delete-1"]
+        [entry]
+        Nothing
+        ""
+  assertBool "login page loads the external bridge"
+    ("/nuthatch.js" `T.isInfixOf` loginPage "")
+  mapM_
+    (\marker -> assertBool ("browse page includes " <> T.unpack marker)
+      (marker `T.isInfixOf` browse))
+    [ "data-nuthatch=\"upload\""
+    , "data-nuthatch=\"delete\""
+    , "data-nuthatch=\"logout\""
+    ]
+  mapM_
+    (\endpoint -> assertBool ("bridge calls " <> T.unpack endpoint)
+      (endpoint `T.isInfixOf` browserScript))
+    [ "/upload"
+    , "/delete-prefix"
+    , "/logout"
+    ]
+
+productionAuthTestApplication :: Config -> IORef Int -> Application
+productionAuthTestApplication cfg calls =
+  utf8Boundary $
+    serveWithContext
+      api
+      (authenticationHandler cfg :. EmptyContext)
+      (typedTestServer calls)
+
+testConfig :: Config
+testConfig = Config
+  { cfgListenHost = "127.0.0.1"
+  , cfgListenPort = 8080
+  , cfgPublicBaseUrl = "https://nuthatch.example"
+  , cfgJwtSecret = "unit-test-secret-material"
+  , cfgSessionHours = 1
+  , cfgCookieName = "nuthatch_session"
+  , cfgCsrfCookieName = "nuthatch_csrf"
+  , cfgPgConn = ""
+  , cfgRedisHost = ""
+  , cfgRedisPort = 6379
+  , cfgRedisDb = 0
+  , cfgS3Endpoint = "https://s3.example"
+  , cfgS3Region = "test"
+  , cfgS3Bucket = "test"
+  , cfgS3AccessKey = "test"
+  , cfgS3SecretKey = "test"
+  , cfgS3PathStyle = True
+  , cfgPersonalQuotaBytes = 1024
+  , cfgSharedQuotaBytes = 1024
+  , cfgMaxObjectBytes = 1024
+  , cfgThrottleBytesPerSec = 1024
+  , cfgThrottleBurstBytes = 1024
+  , cfgListCacheTtlSec = 30
+  , cfgSearchMaxKeys = 100
+  , cfgRecoveryGraceSec = 30
+  , cfgAuthMode = AuthDev
+  }
+
 newtype ValidPath = ValidPath { getValidPath :: Text }
   deriving stock (Show)