Complete bounded browser and API product behavior
This commit is contained in:
parent
619c2911d2
commit
ea55108f44
1 changed files with 2117 additions and 399 deletions
|
|
@ -6,6 +6,7 @@ module Nuthatch.App
|
|||
, authenticationHandler
|
||||
, loginResponse
|
||||
, dispatchAndFinalize
|
||||
, collectKeysBoundedWith
|
||||
, PutFailure (..)
|
||||
, runPut
|
||||
, runDelete
|
||||
|
|
@ -19,29 +20,36 @@ import Control.Exception
|
|||
, throwIO
|
||||
, try
|
||||
)
|
||||
import Control.Monad (forever, when)
|
||||
import Control.Monad (forM, forever, when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Retry
|
||||
( retrying )
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (isRight)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.UUID (toText)
|
||||
import Data.UUID.V4 (nextRandom)
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.Word (Word64)
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import GHC.Clock (getMonotonicTimeNSec)
|
||||
import Network.HTTP.Types
|
||||
( hContentType
|
||||
, hCookie
|
||||
, hLocation
|
||||
, methodGet
|
||||
, status200
|
||||
, status400
|
||||
, status404
|
||||
, status405
|
||||
, urlDecode
|
||||
)
|
||||
import Network.Wai (Request (..), responseLBS)
|
||||
import qualified Network.HTTP.Types.URI as URI
|
||||
import Network.Wai (Request (..), responseFile, responseLBS)
|
||||
import Nuthatch.Api
|
||||
import Nuthatch.Audit (audit)
|
||||
import Nuthatch.Config (Config (..))
|
||||
|
|
@ -82,13 +90,14 @@ import Nuthatch.Streaming
|
|||
, UploadStreamError (..)
|
||||
)
|
||||
import Nuthatch.Types
|
||||
import Nuthatch.Ui (browsePage, browserScript)
|
||||
import Nuthatch.Ui (browserScript, productPage)
|
||||
import Servant
|
||||
import Servant.Server.Experimental.Auth
|
||||
( AuthHandler
|
||||
, mkAuthHandler
|
||||
)
|
||||
import Servant.Types.SourceT (SourceT)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Timeout (timeout)
|
||||
import Web.Cookie
|
||||
( defaultSetCookie
|
||||
|
|
@ -145,6 +154,8 @@ server env =
|
|||
pure (HealthResponse True)
|
||||
:<|> handleReady env
|
||||
:<|> pure (BrowserScript browserScript)
|
||||
:<|> handleAppRequest
|
||||
:<|> staticAssetsServer
|
||||
:<|> handleLoginRequest env
|
||||
:<|> handleOidcCallback env
|
||||
:<|> handleLogoutRequest env
|
||||
|
|
@ -153,6 +164,78 @@ server env =
|
|||
:<|> handleUploadRequest env
|
||||
:<|> handleDeleteRequest env
|
||||
:<|> handleDeletePrefixRequest env
|
||||
:<|>
|
||||
( handleSessionRequest
|
||||
:<|> handleBrowseRequest env
|
||||
:<|> handleDownloadRequest env
|
||||
:<|> handleUploadRequest env
|
||||
:<|> handleDeleteRequest env
|
||||
:<|> handleDeletePlanRequest env
|
||||
:<|> handleDeleteBatchRequest env
|
||||
)
|
||||
|
||||
handleAppRequest
|
||||
:: SessionContext
|
||||
-> Handler (Headers '[Header "Content-Security-Policy" Text] HtmlPage)
|
||||
handleAppRequest _ = do
|
||||
page <- liftIO (TIO.readFile "web/dist/index.html")
|
||||
pure (addHeader applicationContentSecurityPolicy (HtmlPage page))
|
||||
|
||||
handleSessionRequest :: SessionContext -> Handler SessionResponse
|
||||
handleSessionRequest session =
|
||||
case sessionCsrf session of
|
||||
Nothing -> throwOperationError err403 AuthenticationRequired
|
||||
Just csrf ->
|
||||
let user = sessionUser session
|
||||
in pure SessionResponse
|
||||
{ sessionResponseUserId = suUserId user
|
||||
, sessionResponseDisplay = suDisplay user
|
||||
, sessionResponseCsrf = csrf
|
||||
}
|
||||
|
||||
applicationContentSecurityPolicy :: Text
|
||||
applicationContentSecurityPolicy =
|
||||
"default-src 'none'; script-src 'self'; style-src 'self'; connect-src 'self'; \
|
||||
\base-uri 'none'; form-action 'self'; frame-ancestors 'none'; object-src 'none'"
|
||||
|
||||
staticAssetsServer :: SessionContext -> Server Raw
|
||||
staticAssetsServer _ =
|
||||
Tagged $ \request sendResponse ->
|
||||
case (requestMethod request, pathInfo request) of
|
||||
(method, [asset])
|
||||
| method == methodGet
|
||||
, validAssetName asset -> do
|
||||
let path = "web/dist/assets/" <> T.unpack asset
|
||||
exists <- doesFileExist path
|
||||
if exists
|
||||
then sendResponse $
|
||||
responseFile
|
||||
status200
|
||||
[ (hContentType, assetContentType asset)
|
||||
, ("X-Content-Type-Options", "nosniff")
|
||||
, ("Cache-Control", "public, max-age=31536000, immutable")
|
||||
]
|
||||
path
|
||||
Nothing
|
||||
else sendResponse (responseLBS status404 [] "")
|
||||
(method, _) | method /= methodGet ->
|
||||
sendResponse (responseLBS status405 [] "")
|
||||
_ ->
|
||||
sendResponse (responseLBS status404 [] "")
|
||||
where
|
||||
validAssetName asset =
|
||||
not (T.null asset)
|
||||
&& T.all
|
||||
(\character ->
|
||||
character >= 'a' && character <= 'z'
|
||||
|| character >= 'A' && character <= 'Z'
|
||||
|| character >= '0' && character <= '9'
|
||||
|| character `elem` (".-_" :: String))
|
||||
asset
|
||||
assetContentType asset
|
||||
| ".js" `T.isSuffixOf` asset = "text/javascript; charset=utf-8"
|
||||
| ".css" `T.isSuffixOf` asset = "text/css; charset=utf-8"
|
||||
| otherwise = "application/octet-stream"
|
||||
|
||||
authenticationHandler :: Config -> AuthHandler Request SessionContext
|
||||
authenticationHandler cfg = mkAuthHandler $ \request -> do
|
||||
|
|
@ -255,7 +338,7 @@ loginResponse cfg token csrf =
|
|||
(expiredCookieValue
|
||||
(cfgOidcTransactionCookieName cfg)
|
||||
"/oidc/callback") $
|
||||
addHeader "/" NoContent
|
||||
addHeader "/app" NoContent
|
||||
|
||||
handleLogoutRequest
|
||||
:: Env
|
||||
|
|
@ -282,38 +365,30 @@ handleBrowseRequest
|
|||
-> Maybe SearchQuery
|
||||
-> Maybe PaginationToken
|
||||
-> Handler BrowseView
|
||||
handleBrowseRequest env session selectedRoot selectedPrefix search _continuation = do
|
||||
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
|
||||
Nothing -> do
|
||||
listed <- listEntries env user root prefix
|
||||
(unPaginationToken <$> continuation)
|
||||
pure (fmap (\(entries, next) -> (entries, next, False)) listed)
|
||||
Just query -> do
|
||||
found <- searchEntries env user root (unSearchQuery query)
|
||||
pure (fmap (\(entries, partial) -> (entries, Nothing, partial)) found)
|
||||
(entries, nextContinuation, partial) <- 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
|
||||
, browseContinuation = PaginationToken <$> nextContinuation
|
||||
, browsePartial = partial
|
||||
}
|
||||
csrf = maybe "" unCsrfToken (sessionCsrf session)
|
||||
pure BrowseView
|
||||
{ browseViewHtml = HtmlPage
|
||||
(browsePage
|
||||
user
|
||||
root
|
||||
prefix
|
||||
csrf
|
||||
uploadOperation
|
||||
deleteOperations
|
||||
entries
|
||||
Nothing
|
||||
"")
|
||||
{ browseViewHtml = HtmlPage (productPage entries)
|
||||
, browseViewJson = response
|
||||
}
|
||||
|
||||
|
|
@ -322,8 +397,11 @@ handleDownloadRequest
|
|||
-> SessionContext
|
||||
-> Root
|
||||
-> RelativePath
|
||||
-> Maybe Text
|
||||
-> Handler DownloadSuccess
|
||||
handleDownloadRequest env session root path = do
|
||||
handleDownloadRequest env session root path requestedRange = do
|
||||
when (requestedRange /= Nothing) $
|
||||
throwOperationError err416 DownloadRangeUnsupported
|
||||
let user = sessionUser session
|
||||
key = buildObjectKey root (suUserId user) path
|
||||
metadata <- liftIO (headObject (envS3 env) key)
|
||||
|
|
@ -339,11 +417,12 @@ handleDownloadRequest env session root path = do
|
|||
[ ("root", A.toJSON (rootLabel root))
|
||||
, ("bytes", A.toJSON (oiSize info))
|
||||
]
|
||||
let filename = sanitizeFilename (basename path)
|
||||
let filename = basename path
|
||||
pure $
|
||||
addHeader ("attachment; filename=\"" <> filename <> "\"") $
|
||||
addHeader (contentDisposition filename) $
|
||||
addHeader "nosniff" $
|
||||
addHeader (oiSize info) body
|
||||
addHeader "sandbox" $
|
||||
addHeader (oiSize info) body
|
||||
|
||||
handleUploadRequest
|
||||
:: Env
|
||||
|
|
@ -457,19 +536,81 @@ handleDeletePrefixRequest
|
|||
-> SessionContext
|
||||
-> DeletePrefixRequest
|
||||
-> Handler DeletePrefixResponse
|
||||
handleDeletePrefixRequest env session request = do
|
||||
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
|
||||
"use delete-plan and delete-batch with client operation ids")
|
||||
|
||||
handleDeletePlanRequest
|
||||
:: Env
|
||||
-> SessionContext
|
||||
-> Root
|
||||
-> RelativePath
|
||||
-> Maybe PaginationToken
|
||||
-> Handler DeletePlanResponse
|
||||
handleDeletePlanRequest env session root path continuation = do
|
||||
let user = sessionUser session
|
||||
rootPrefix = case root of
|
||||
Personal -> "users/" <> unUserId (suUserId user) <> "/"
|
||||
Shared -> "shared/"
|
||||
objectPrefix = rootPrefix <> unRelativePath path <> "/"
|
||||
listed <- liftIO $
|
||||
listObjects
|
||||
(envS3 env)
|
||||
objectPrefix
|
||||
Nothing
|
||||
(unPaginationToken <$> continuation)
|
||||
(cfgDeletePageSize (envConfig env))
|
||||
page <- either
|
||||
(throwOperationError status502Error
|
||||
. DeletePrefixMutationRejected
|
||||
. renderS3Error)
|
||||
pure
|
||||
listed
|
||||
paths <- either
|
||||
(throwOperationError err409 . DeletePrefixMutationRejected)
|
||||
pure
|
||||
result
|
||||
pure (DeletePrefixResponse count)
|
||||
(traverse
|
||||
(validateRelativePath . T.drop (T.length rootPrefix) . fst)
|
||||
(lpObjects page))
|
||||
pure DeletePlanResponse
|
||||
{ deletePlanPaths = paths
|
||||
, deletePlanContinuation = PaginationToken <$> lpContinuationToken page
|
||||
}
|
||||
|
||||
handleDeleteBatchRequest
|
||||
:: Env
|
||||
-> SessionContext
|
||||
-> DeleteBatchRequest
|
||||
-> Handler DeleteBatchResponse
|
||||
handleDeleteBatchRequest env session request = do
|
||||
requireCsrf DeletePrefixCsrfRejected session (deleteBatchCsrf request)
|
||||
let items = deleteBatchItems request
|
||||
when (null items || length items > cfgDeletePageSize (envConfig env)) $
|
||||
throwOperationError err409
|
||||
(DeletePrefixMutationRejected "delete batch size is invalid")
|
||||
results <- liftIO $ forM items $ \item -> do
|
||||
outcome <- runDelete
|
||||
env
|
||||
(sessionUser session)
|
||||
(deleteBatchRoot request)
|
||||
(deleteBatchPath item)
|
||||
(deleteBatchOperationId item)
|
||||
pure $ case outcome of
|
||||
Left message -> DeleteItemResponse
|
||||
{ deleteItemPath = deleteBatchPath item
|
||||
, deleteItemOperationId = deleteBatchOperationId item
|
||||
, deleteItemResult = Nothing
|
||||
, deleteItemError = Just message
|
||||
}
|
||||
Right result -> DeleteItemResponse
|
||||
{ deleteItemPath = deleteBatchPath item
|
||||
, deleteItemOperationId = deleteBatchOperationId item
|
||||
, deleteItemResult = Just result
|
||||
, deleteItemError = Nothing
|
||||
}
|
||||
pure (DeleteBatchResponse results)
|
||||
|
||||
requireCsrf :: A.ToJSON error => error -> SessionContext -> CsrfToken -> Handler ()
|
||||
requireCsrf csrfError session provided =
|
||||
|
|
@ -530,12 +671,16 @@ 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
|
||||
contentDisposition :: Text -> Text
|
||||
contentDisposition filename =
|
||||
"attachment; filename=\"" <> fallback <> "\"; filename*=UTF-8''" <> encoded
|
||||
where
|
||||
fallback = T.map safeAscii filename
|
||||
encoded = TE.decodeUtf8 (URI.urlEncode True (TE.encodeUtf8 filename))
|
||||
safeAscii character
|
||||
| character >= ' ' && character <= '~'
|
||||
&& character `notElem` ("\"\\;" :: String) = character
|
||||
| otherwise = '_'
|
||||
|
||||
runPut
|
||||
:: Env
|
||||
|
|
@ -570,7 +715,7 @@ runPut env user root rel op size sha body = do
|
|||
Just outcome ->
|
||||
case outcome of
|
||||
AdmitConflict -> pure (Right MutationConflict)
|
||||
AdmitRejected reason _ -> pure (Left (PutRejected reason))
|
||||
AdmitRejected _ _ -> pure (Right MutationRejected)
|
||||
AdmitReplay MutationPending _ -> pure (Right MutationPending)
|
||||
AdmitReplay result _ -> pure (Right result)
|
||||
AdmitPrepared rec ->
|
||||
|
|
@ -579,7 +724,6 @@ runPut env user root rel op size sha body = do
|
|||
user
|
||||
root
|
||||
rec
|
||||
PutSettlementFailed
|
||||
(PutDispatchFailed (PutObjectStoreError S3TransportError))
|
||||
(putObjectStream
|
||||
(envS3 env)
|
||||
|
|
@ -591,17 +735,13 @@ runPut env user root rel op size sha body = do
|
|||
body
|
||||
>>= pure . either (Left . PutDispatchFailed) Right)
|
||||
|
||||
data PutFailure
|
||||
= PutRejected Text
|
||||
| PutDispatchFailed PutObjectError
|
||||
| PutSettlementFailed
|
||||
newtype PutFailure
|
||||
= PutDispatchFailed PutObjectError
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
throwPutFailure :: PutFailure -> Handler a
|
||||
throwPutFailure failure =
|
||||
case failure of
|
||||
PutRejected reason ->
|
||||
throwOperationError err409 (UploadMutationRejected reason)
|
||||
PutDispatchFailed (PutObjectStreamError streamError) ->
|
||||
case streamError of
|
||||
UploadStreamInvalid message ->
|
||||
|
|
@ -619,9 +759,6 @@ throwPutFailure failure =
|
|||
PutDispatchFailed (PutObjectStoreError err) ->
|
||||
throwOperationError err409
|
||||
(UploadMutationRejected (renderS3Error err))
|
||||
PutSettlementFailed ->
|
||||
throwOperationError err409
|
||||
(UploadMutationRejected "mutation failed after store settlement")
|
||||
|
||||
runDelete
|
||||
:: Env
|
||||
|
|
@ -652,7 +789,7 @@ runDelete env user root rel op = do
|
|||
Just outcome ->
|
||||
case outcome of
|
||||
AdmitConflict -> pure (Right MutationConflict)
|
||||
AdmitRejected reason _ -> pure (Left reason)
|
||||
AdmitRejected _ _ -> pure (Right MutationRejected)
|
||||
AdmitReplay MutationPending _ -> pure (Right MutationPending)
|
||||
AdmitReplay result _ -> pure (Right result)
|
||||
AdmitPrepared rec ->
|
||||
|
|
@ -661,70 +798,19 @@ runDelete env user root rel op = do
|
|||
user
|
||||
root
|
||||
rec
|
||||
"mutation failed after store settlement"
|
||||
"object request timed out"
|
||||
(deleteObject (envS3 env) key
|
||||
>>= pure . either (Left . renderS3Error) Right)
|
||||
|
||||
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 (renderS3Error 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
|
||||
-> Root
|
||||
-> MutationRecord
|
||||
-> failure
|
||||
-> failure
|
||||
-> IO (Either failure ())
|
||||
-> IO (Either failure MutationResult)
|
||||
dispatchAndFinalize env user root rec settlementFailure timeoutFailure dispatch = do
|
||||
dispatchAndFinalize env user root rec timeoutFailure dispatch = do
|
||||
let cfg = envConfig env
|
||||
requestTimeoutSec = cfgObjectRequestTimeoutSec cfg
|
||||
prepared <- withTransaction (envDb env) $ \conn -> do
|
||||
|
|
@ -759,8 +845,7 @@ dispatchAndFinalize env user root rec settlementFailure timeoutFailure dispatch
|
|||
cacheInvalidatePrefixes (envRedis env) (suUserId user) root
|
||||
(listCacheAncestorPrefixes (mrRelativePath rec))
|
||||
pure (Right MutationSucceeded)
|
||||
Just MutationFailed ->
|
||||
pure (Left settlementFailure)
|
||||
Just MutationFailed -> pure (Right MutationFailed)
|
||||
Just other -> pure (Right other)
|
||||
Nothing -> pure (Right MutationPending)
|
||||
|
||||
|
|
@ -773,8 +858,14 @@ observeObject s3 key = do
|
|||
Left S3NotFound -> pure ObjectAbsent
|
||||
Left err -> pure (ObjectUnavailable (renderS3Error err))
|
||||
|
||||
listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
|
||||
listEntries env user root prefix = do
|
||||
listEntries
|
||||
:: Env
|
||||
-> SessionUser
|
||||
-> Root
|
||||
-> Text
|
||||
-> Maybe Text
|
||||
-> IO (Either Text ([ListEntry], Maybe Text))
|
||||
listEntries env user root prefix continuation = do
|
||||
let cacheKey =
|
||||
"nuthatch:list:"
|
||||
<> unUserId (suUserId user)
|
||||
|
|
@ -783,6 +874,8 @@ listEntries env user root prefix = do
|
|||
<> ":"
|
||||
<> prefix
|
||||
<> ":"
|
||||
<> T.pack (show (cfgBrowsePageSize (envConfig env)))
|
||||
<> ":"
|
||||
s3Prefix =
|
||||
case root of
|
||||
Personal -> "users/" <> unUserId (suUserId user) <> "/" <> prefixSlash
|
||||
|
|
@ -791,11 +884,18 @@ listEntries env user root prefix = do
|
|||
| T.null prefix = ""
|
||||
| T.isSuffixOf "/" prefix = prefix
|
||||
| otherwise = prefix <> "/"
|
||||
cached <- cacheGet (envRedis env) cacheKey
|
||||
cached <- case continuation of
|
||||
Nothing -> cacheGet (envRedis env) cacheKey
|
||||
Just _ -> pure Nothing
|
||||
case cached >>= A.decodeStrict of
|
||||
Just entries -> pure (Right entries)
|
||||
Just result -> pure (Right result)
|
||||
Nothing -> do
|
||||
page <- listObjects (envS3 env) s3Prefix (Just "/") Nothing 1000
|
||||
page <- listObjects
|
||||
(envS3 env)
|
||||
s3Prefix
|
||||
(Just "/")
|
||||
continuation
|
||||
(cfgBrowsePageSize (envConfig env))
|
||||
case page of
|
||||
Left err -> pure (Left (renderS3Error err))
|
||||
Right lp -> do
|
||||
|
|
@ -827,23 +927,37 @@ listEntries env user root prefix = do
|
|||
, not (T.isSuffixOf "/" rel)
|
||||
]
|
||||
entries = folders <> files
|
||||
cacheSet (envRedis env) cacheKey (cfgListCacheTtlSec (envConfig env))
|
||||
(BL.toStrict (A.encode entries))
|
||||
pure (Right entries)
|
||||
result = (entries, lpContinuationToken lp)
|
||||
when (continuation == Nothing) $
|
||||
cacheSet (envRedis env) cacheKey (cfgListCacheTtlSec (envConfig env))
|
||||
(BL.toStrict (A.encode result))
|
||||
pure (Right result)
|
||||
|
||||
searchEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
|
||||
searchEntries
|
||||
:: Env
|
||||
-> SessionUser
|
||||
-> Root
|
||||
-> Text
|
||||
-> IO (Either Text ([ListEntry], Bool))
|
||||
searchEntries env user root q = do
|
||||
let s3Prefix =
|
||||
case root of
|
||||
Personal -> "users/" <> unUserId (suUserId user) <> "/"
|
||||
Shared -> "shared/"
|
||||
needle = T.toLower q
|
||||
keysResult <- collectKeysBounded (envS3 env) s3Prefix (cfgSearchMaxKeys (envConfig env))
|
||||
needle = T.toCaseFold q
|
||||
started <- getMonotonicTimeNSec
|
||||
let deadline =
|
||||
started + fromInteger (cfgSearchTimeoutMs (envConfig env) * 1000000)
|
||||
keysResult <- collectKeysBounded
|
||||
(envS3 env)
|
||||
s3Prefix
|
||||
(cfgSearchMaxKeys (envConfig env))
|
||||
deadline
|
||||
pure $ case keysResult of
|
||||
Left err -> Left err
|
||||
Right keys ->
|
||||
Right (keys, partial) ->
|
||||
Right
|
||||
[ ListEntry
|
||||
( [ ListEntry
|
||||
{ leName = lastSeg rel
|
||||
, leIsPrefix = False
|
||||
, leSize = Just sz
|
||||
|
|
@ -853,24 +967,54 @@ searchEntries env user root q = do
|
|||
, T.isPrefixOf s3Prefix k
|
||||
, let rel = T.drop (T.length s3Prefix) k
|
||||
, not (T.null rel)
|
||||
, needle `T.isInfixOf` T.toLower rel
|
||||
, needle `T.isInfixOf` T.toCaseFold rel
|
||||
]
|
||||
, partial
|
||||
)
|
||||
|
||||
collectKeysBounded :: S3 -> Text -> Int -> IO (Either Text [(Text, Integer)])
|
||||
collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
|
||||
collectKeysBounded
|
||||
:: S3
|
||||
-> Text
|
||||
-> Int
|
||||
-> Word64
|
||||
-> IO (Either Text ([(Text, Integer)], Bool))
|
||||
collectKeysBounded s3 prefix =
|
||||
collectKeysBoundedWith
|
||||
getMonotonicTimeNSec
|
||||
(\continuation limit ->
|
||||
first renderS3Error
|
||||
<$> listObjects s3 prefix Nothing continuation limit)
|
||||
|
||||
collectKeysBoundedWith
|
||||
:: IO Word64
|
||||
-> (Maybe Text -> Int -> IO (Either Text ListPage))
|
||||
-> Int
|
||||
-> Word64
|
||||
-> IO (Either Text ([(Text, Integer)], Bool))
|
||||
collectKeysBoundedWith currentTime listPage maxKeys deadline =
|
||||
go Nothing [] 0
|
||||
where
|
||||
go mTok acc n
|
||||
| n >= maxKeys = pure (Right (take maxKeys acc))
|
||||
| n >= maxKeys = pure (Right (take maxKeys acc, True))
|
||||
| otherwise = do
|
||||
page <- listObjects s3 prefix Nothing mTok (min 1000 (maxKeys - n))
|
||||
case page of
|
||||
Left err -> pure (Left (renderS3Error err))
|
||||
Right lp -> do
|
||||
let acc' = acc <> lpObjects lp
|
||||
n' = length acc'
|
||||
if lpIsTruncated lp && n' < maxKeys
|
||||
then go (lpContinuationToken lp) acc' n'
|
||||
else pure (Right (take maxKeys acc'))
|
||||
now <- currentTime
|
||||
if now >= deadline
|
||||
then pure (Right (take maxKeys acc, True))
|
||||
else do
|
||||
let remainingMicros =
|
||||
fromIntegral ((deadline - now + 999) `div` 1000)
|
||||
timedPage <- timeout remainingMicros $
|
||||
listPage mTok (min 1000 (maxKeys - n))
|
||||
case timedPage of
|
||||
Nothing -> pure (Right (take maxKeys acc, True))
|
||||
Just (Left err) -> pure (Left err)
|
||||
Just (Right lp) -> do
|
||||
let acc' = acc <> lpObjects lp
|
||||
n' = length acc'
|
||||
if lpIsTruncated lp && n' < maxKeys
|
||||
then go (lpContinuationToken lp) acc' n'
|
||||
else pure
|
||||
(Right (take maxKeys acc', lpIsTruncated lp))
|
||||
|
||||
runRecovery :: Env -> IO ()
|
||||
runRecovery env = forever $ do
|
||||
|
|
|
|||
Loading…
Reference in a new issue