ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Replace raw HTTP dispatch with typed Servant API

Browse source
This commit is contained in:
ms2k 2026-07-18 13:17:40 +09:00
commit 435d4fea4c
6 changed files with 1625 additions and 445 deletions
Download patch file Download diff file Expand all files Collapse all files

572
src/Nuthatch/Api.hs Normal file
View file

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

798
src/Nuthatch/App.hs
View file

@ -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
, HeaderName
, Status (..)
, hContentDisposition
, hContentType
( hContentType
, hLocation
, status200
, status302
, status400
, status403
, status404
, status413
, status429
, status500
, status503
, urlDecode
)
import Network.Wai
( Application
, Request (..)
, Response
, ResponseReceived
, responseLBS
)
import Network.Wai.Parse (FileInfo (..), lbsBackEnd, parseRequestBody)
import qualified Network.HTTP.Types as HTTP
import Network.Wai (Request (..), responseLBS)
import Nuthatch.Api
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 =
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")
application env =
utf8Boundary $
serveWithContext
api
(authenticationHandler (envConfig env) :. EmptyContext)
(server env)
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])
utf8Boundary :: Application -> Application
utf8Boundary downstream request sendResponse
| requestUtf8Valid request = downstream request sendResponse
| otherwise =
sendResponse $
responseLBS status400
[(hContentType, "application/json")]
(A.encode InvalidUtf8)
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
]
""
requestUtf8Valid :: Request -> Bool
requestUtf8Valid request =
validUtf8 (urlDecode False (rawPathInfo request))
&& all validQueryItem (queryString request)
where
validQueryItem (name, value) =
validUtf8 name && maybe True validUtf8 value
validUtf8 = isRight . TE.decodeUtf8'
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))
]
""
server :: Env -> Server Api
server env =
pure (HealthResponse True)
:<|> handleReady env
:<|> pure (HtmlPage (loginPage ""))
:<|> pure (BrowserScript browserScript)
:<|> 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
-> (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)
-> LoginRequest
-> Handler LoginSuccess
handleLoginRequest env request = do
let username = unDevUsername (loginUsername request)
let uid = encodeUserId "nuthatch-dev" username
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
liftIO (ensurePersonalPool (envDb env) cfg uid)
tokenResult <- liftIO (mintSession cfg "nuthatch-dev" username (Just username))
token <- either
(throwOperationError err500 . SessionCreationFailed)
pure
tokenResult
csrf <- liftIO newCsrfToken
liftIO $ audit "login" "ok" (Just (unUserId uid)) []
pure (loginResponse cfg uid token csrf)
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))
loginResponse
:: Config
-> UserId
-> SessionToken
-> CsrfToken
-> LoginSuccess
loginResponse cfg uid token csrf =
addHeader (cookieValue cfg (cfgCookieName cfg) (unSessionToken token) True) $
addHeader (cookieValue cfg (cfgCsrfCookieName cfg) (unCsrfToken csrf) False) $
addHeader csrf (LoginView
{ loginViewHtml = HtmlPage
"<!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>"
, loginViewJson = LoginResponse uid
})
handleDownload
handleLogoutRequest
:: 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")
-> SessionContext
-> CsrfToken
-> Handler LogoutSuccess
handleLogoutRequest env session providedCsrf = do
requireCsrf LogoutCsrfRejected session providedCsrf
let cfg = envConfig env
pure $
addHeader (expiredCookieValue (cfgCookieName cfg)) $
addHeader (expiredCookieValue (cfgCsrfCookieName cfg)) NoContent
handleUpload
handleBrowseRequest
:: 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))))
-> SessionContext
-> Maybe Root
-> Maybe BrowsePrefix
-> Maybe SearchQuery
-> Maybe PaginationToken
-> Handler BrowseView
handleBrowseRequest env session selectedRoot selectedPrefix search _continuation = do
let user = sessionUser session
root = fromMaybe Personal selectedRoot
prefix = maybe "" browsePrefixText selectedPrefix
liftIO (ensurePersonalPool (envDb env) (envConfig env) (suUserId user))
result <- liftIO $ case search of
Nothing -> listEntries env user root prefix
Just query -> searchEntries env user root (unSearchQuery query)
entries <- either
(throwOperationError status502Error . BrowseObjectStoreFailed)
pure
result
uploadOperation <- liftIO (toText <$> nextRandom)
deleteOperations <- liftIO (mapM (\_ -> toText <$> nextRandom) entries)
let response = BrowseResponse
{ browseEntries = entries
, browseContinuation = Nothing
, browsePartial = False
}
csrf = maybe "" unCsrfToken (sessionCsrf session)
pure BrowseView
{ browseViewHtml = HtmlPage
(browsePage
user
root
prefix
csrf
uploadOperation
deleteOperations
entries
Nothing
"")
, browseViewJson = response
}
handleDelete
handleDownloadRequest
:: 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))))
-> SessionContext
-> Root
-> RelativePath
-> Handler DownloadSuccess
handleDownloadRequest env session root path = do
let user = sessionUser session
key = buildObjectKey root (suUserId user) path
metadata <- liftIO (headObject (envS3 env) key)
info <- case metadata of
Left message -> throwOperationError status502Error
(DownloadObjectStoreFailed message)
Right Nothing -> throwOperationError err404 DownloadNotFound
Right (Just value) -> pure value
throttle <- liftIO $
throttleTake (envRedis env) (envConfig env) (suUserId user) (oiSize info)
case throttle of
Left _ -> throwOperationError err503 DownloadThrottleUnavailable
Right False -> throwOperationError err429 DownloadBandwidthExceeded
Right True -> pure ()
result <- liftIO (getObjectBytes (envS3 env) key)
body <- either
(throwOperationError status502Error . DownloadObjectStoreFailed)
pure
result
liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
[ ("root", A.toJSON (rootLabel root))
, ("bytes", A.toJSON (oiSize info))
]
let filename = sanitizeFilename (basename path)
pure $
addHeader ("attachment; filename=\"" <> filename <> "\"") $
addHeader "nosniff" (source (BL.toChunks body))
handleUploadRequest
:: Env
-> SessionContext
-> Root
-> RelativePath
-> OperationId
-> DeclaredSize
-> ContentSha256
-> CsrfToken
-> SourceIO BS.ByteString
-> 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
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 :: [HTTP.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"

22
src/Nuthatch/Paths.hs
View file

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

16
src/Nuthatch/Session.hs
View file

@ -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 cfg token = do
verifySession :: Config -> SessionToken -> IO (Either Text SessionUser)
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 a b =
constantTimeEq :: CsrfToken -> CsrfToken -> Bool
constantTimeEq (CsrfToken a) (CsrfToken b) =
let ba = TE.encodeUtf8 a
bb = TE.encodeUtf8 b
in BS.length ba == BS.length bb

159
src/Nuthatch/Types.hs
View file

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

52
src/Nuthatch/Ui.hs
View file

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