Replace raw HTTP dispatch with typed Servant API
This commit is contained in:
parent
06d1383456
commit
435d4fea4c
1 changed files with 1625 additions and 445 deletions
|
|
@ -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 "¬ice=" <> notice)
|
||||
<> (if T.null err then "" else "&error=" <> err)
|
||||
|
||||
contentSha256 :: BL.ByteString -> ContentSha256
|
||||
contentSha256 body =
|
||||
ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
|
||||
(hashlazy body :: Digest SHA256)
|
||||
|
||||
sanitizeFilename :: Text -> Text
|
||||
sanitizeFilename =
|
||||
T.map $ \c -> if c `elem` ("\"\\\r\n" :: String) then '_' else c
|
||||
|
||||
lastSeg :: Text -> Text
|
||||
lastSeg t =
|
||||
case reverse (T.splitOn "/" t) of
|
||||
(x : _) -> x
|
||||
[] -> t
|
||||
|
||||
json :: Status -> A.Value -> Response
|
||||
json st v =
|
||||
responseLBS st [(hContentType, "application/json")] (A.encode v)
|
||||
|
||||
text :: Status -> Text -> Response
|
||||
text st t =
|
||||
responseLBS st [(hContentType, "text/plain; charset=utf-8")]
|
||||
(BL.fromStrict (TE.encodeUtf8 t))
|
||||
|
||||
redirect :: Text -> Response
|
||||
redirect loc =
|
||||
responseLBS status302 [(hLocation, TE.encodeUtf8 loc)] ""
|
||||
|
||||
setCookie :: Config -> Text -> Text -> Bool -> (HeaderName, BS.ByteString)
|
||||
setCookie _cfg name value httpOnly =
|
||||
( "Set-Cookie"
|
||||
, TE.encodeUtf8 $
|
||||
name <> "=" <> value
|
||||
<> "; Path=/"
|
||||
<> "; SameSite=Lax"
|
||||
<> (if httpOnly then "; HttpOnly" else "")
|
||||
)
|
||||
|
||||
clearCookie :: Config -> Text -> (HeaderName, BS.ByteString)
|
||||
clearCookie _cfg name =
|
||||
( "Set-Cookie"
|
||||
, TE.encodeUtf8 (name <> "=; Path=/; Max-Age=0; SameSite=Lax")
|
||||
)
|
||||
|
||||
parseCookies :: [Header] -> [(BS.ByteString, BS.ByteString)]
|
||||
parseCookies :: [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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue