Complete bounded browser and API product behavior
This commit is contained in:
parent
619c2911d2
commit
ea55108f44
4 changed files with 2117 additions and 399 deletions
|
|
@ -3,6 +3,9 @@ module Nuthatch.Api
|
|||
, HealthEndpoint
|
||||
, ReadyEndpoint
|
||||
, BrowserScriptEndpoint
|
||||
, AppEndpoint
|
||||
, StaticAssetsEndpoint
|
||||
, ProductApi
|
||||
, LoginEndpoint
|
||||
, LoginStart
|
||||
, OidcCallbackEndpoint
|
||||
|
|
@ -33,6 +36,12 @@ module Nuthatch.Api
|
|||
, DeleteRequest (..)
|
||||
, DeletePrefixRequest (..)
|
||||
, DeletePrefixResponse (..)
|
||||
, SessionResponse (..)
|
||||
, DeletePlanResponse (..)
|
||||
, DeleteBatchItem (..)
|
||||
, DeleteBatchRequest (..)
|
||||
, DeleteItemResponse (..)
|
||||
, DeleteBatchResponse (..)
|
||||
, UploadResponse (..)
|
||||
, DeleteResponse (..)
|
||||
, Throws
|
||||
|
|
@ -296,6 +305,7 @@ instance ToJSON BrowseError where
|
|||
data DownloadError
|
||||
= DownloadObjectStoreFailed Text
|
||||
| DownloadNotFound
|
||||
| DownloadRangeUnsupported
|
||||
| DownloadThrottleUnavailable
|
||||
| DownloadBandwidthExceeded
|
||||
deriving stock (Eq, Show)
|
||||
|
|
@ -305,6 +315,8 @@ instance ToJSON DownloadError where
|
|||
errorValue "object_store_error" message Nothing
|
||||
toJSON DownloadNotFound =
|
||||
errorValue "not_found" "object not found" Nothing
|
||||
toJSON DownloadRangeUnsupported =
|
||||
errorValue "range_not_supported" "Range downloads are not supported" Nothing
|
||||
toJSON DownloadThrottleUnavailable =
|
||||
errorValue "throttle_unavailable" "bandwidth throttle unavailable" Nothing
|
||||
toJSON DownloadBandwidthExceeded =
|
||||
|
|
@ -361,6 +373,82 @@ instance ToJSON DeletePrefixError where
|
|||
toJSON (DeletePrefixMutationRejected message) =
|
||||
errorValue "prefix_mutation_rejected" message Nothing
|
||||
|
||||
data SessionResponse = SessionResponse
|
||||
{ sessionResponseUserId :: UserId
|
||||
, sessionResponseDisplay :: Maybe Text
|
||||
, sessionResponseCsrf :: CsrfToken
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON SessionResponse where
|
||||
toJSON response = object
|
||||
[ "user_id" .= sessionResponseUserId response
|
||||
, "display" .= sessionResponseDisplay response
|
||||
, "csrf" .= sessionResponseCsrf response
|
||||
]
|
||||
|
||||
data DeletePlanResponse = DeletePlanResponse
|
||||
{ deletePlanPaths :: [RelativePath]
|
||||
, deletePlanContinuation :: Maybe PaginationToken
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeletePlanResponse where
|
||||
toJSON response = object
|
||||
[ "paths" .= map unRelativePath (deletePlanPaths response)
|
||||
, "continuation" .= deletePlanContinuation response
|
||||
]
|
||||
|
||||
data DeleteBatchItem = DeleteBatchItem
|
||||
{ deleteBatchPath :: RelativePath
|
||||
, deleteBatchOperationId :: OperationId
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON DeleteBatchItem where
|
||||
parseJSON = withObject "DeleteBatchItem" $ \o ->
|
||||
DeleteBatchItem
|
||||
<$> o .: "path"
|
||||
<*> o .: "operation_id"
|
||||
|
||||
data DeleteBatchRequest = DeleteBatchRequest
|
||||
{ deleteBatchRoot :: Root
|
||||
, deleteBatchCsrf :: CsrfToken
|
||||
, deleteBatchItems :: [DeleteBatchItem]
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON DeleteBatchRequest where
|
||||
parseJSON = withObject "DeleteBatchRequest" $ \o ->
|
||||
DeleteBatchRequest
|
||||
<$> o .: "root"
|
||||
<*> o .: "csrf"
|
||||
<*> o .: "items"
|
||||
|
||||
data DeleteItemResponse = DeleteItemResponse
|
||||
{ deleteItemPath :: RelativePath
|
||||
, deleteItemOperationId :: OperationId
|
||||
, deleteItemResult :: Maybe MutationResult
|
||||
, deleteItemError :: Maybe Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeleteItemResponse where
|
||||
toJSON response = object
|
||||
[ "path" .= unRelativePath (deleteItemPath response)
|
||||
, "operation_id" .= deleteItemOperationId response
|
||||
, "result" .= fmap mutationResultText (deleteItemResult response)
|
||||
, "error" .= deleteItemError response
|
||||
]
|
||||
|
||||
newtype DeleteBatchResponse = DeleteBatchResponse
|
||||
{ deleteBatchResults :: [DeleteItemResponse]
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeleteBatchResponse where
|
||||
toJSON response = object ["results" .= deleteBatchResults response]
|
||||
|
||||
errorValue :: Text -> Text -> Maybe Value -> Value
|
||||
errorValue code message details = object
|
||||
[ "error" .= code
|
||||
|
|
@ -377,6 +465,19 @@ type ReadyEndpoint =
|
|||
type BrowserScriptEndpoint =
|
||||
"nuthatch.js" :> Get '[JavaScript] BrowserScript
|
||||
|
||||
type AppEndpoint =
|
||||
"app"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Get '[HTML]
|
||||
(Headers '[Header "Content-Security-Policy" Text] HtmlPage)
|
||||
|
||||
type StaticAssetsEndpoint =
|
||||
"assets"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Raw
|
||||
|
||||
type LoginStart =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
|
|
@ -437,6 +538,7 @@ type DownloadSuccess =
|
|||
Headers
|
||||
'[ Header "Content-Disposition" Text
|
||||
, Header "X-Content-Type-Options" Text
|
||||
, Header "Content-Security-Policy" Text
|
||||
, Header "Content-Length" Integer
|
||||
]
|
||||
(SourceIO BS.ByteString)
|
||||
|
|
@ -448,6 +550,7 @@ type DownloadEndpoint =
|
|||
:> Throws DownloadError
|
||||
:> QueryParam' '[Required, Strict] "root" Root
|
||||
:> QueryParam' '[Required, Strict] "path" RelativePath
|
||||
:> Header "Range" Text
|
||||
:> StreamGet NoFraming OctetStream DownloadSuccess
|
||||
|
||||
type UploadEndpoint =
|
||||
|
|
@ -480,10 +583,69 @@ type DeletePrefixEndpoint =
|
|||
:> ReqBody '[JSON] DeletePrefixRequest
|
||||
:> Post '[JSON] DeletePrefixResponse
|
||||
|
||||
type ProductApi =
|
||||
"api" :>
|
||||
( "session"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Get '[JSON] SessionResponse
|
||||
:<|> "browse"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws BrowseError
|
||||
:> QueryParam "root" Root
|
||||
:> QueryParam "prefix" BrowsePrefix
|
||||
:> QueryParam "q" SearchQuery
|
||||
:> QueryParam "continuation" PaginationToken
|
||||
:> Get '[JSON] BrowseView
|
||||
:<|> "download"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DownloadError
|
||||
:> QueryParam' '[Required, Strict] "root" Root
|
||||
:> QueryParam' '[Required, Strict] "path" RelativePath
|
||||
:> Header "Range" Text
|
||||
:> StreamGet NoFraming OctetStream DownloadSuccess
|
||||
:<|> "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
|
||||
:<|> "delete"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DeleteError
|
||||
:> ReqBody '[JSON] DeleteRequest
|
||||
:> Post '[JSON] DeleteResponse
|
||||
:<|> "delete-plan"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DeletePrefixError
|
||||
:> QueryParam' '[Required, Strict] "root" Root
|
||||
:> QueryParam' '[Required, Strict] "path" RelativePath
|
||||
:> QueryParam "continuation" PaginationToken
|
||||
:> Get '[JSON] DeletePlanResponse
|
||||
:<|> "delete-batch"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DeletePrefixError
|
||||
:> ReqBody '[JSON] DeleteBatchRequest
|
||||
:> Post '[JSON] DeleteBatchResponse
|
||||
)
|
||||
|
||||
type Api =
|
||||
HealthEndpoint
|
||||
:<|> ReadyEndpoint
|
||||
:<|> BrowserScriptEndpoint
|
||||
:<|> AppEndpoint
|
||||
:<|> StaticAssetsEndpoint
|
||||
:<|> LoginEndpoint
|
||||
:<|> OidcCallbackEndpoint
|
||||
:<|> LogoutEndpoint
|
||||
|
|
@ -492,6 +654,7 @@ type Api =
|
|||
:<|> UploadEndpoint
|
||||
:<|> DeleteEndpoint
|
||||
:<|> DeletePrefixEndpoint
|
||||
:<|> ProductApi
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -48,7 +48,10 @@ data Config = Config
|
|||
, cfgThrottleBytesPerSec :: Integer
|
||||
, cfgThrottleBurstBytes :: Integer
|
||||
, cfgListCacheTtlSec :: Integer
|
||||
, cfgBrowsePageSize :: Int
|
||||
, cfgSearchMaxKeys :: Int
|
||||
, cfgSearchTimeoutMs :: Integer
|
||||
, cfgDeletePageSize :: Int
|
||||
, cfgRecoveryGraceSec :: Integer
|
||||
, cfgIdempotencyWindowSec :: Integer
|
||||
, cfgObjectRequestTimeoutSec :: Integer
|
||||
|
|
@ -112,7 +115,10 @@ loadConfig = do
|
|||
when (throttleBurst <= 0 || throttleBurst > luaExactIntegerMax) $
|
||||
fail "NUTHATCH_THROTTLE_BURST_BYTES exceeds the exact throttle range"
|
||||
listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
|
||||
browsePageSize <- fromInteger <$> envInteger "NUTHATCH_BROWSE_PAGE_SIZE" 200
|
||||
searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
|
||||
searchTimeoutMs <- envInteger "NUTHATCH_SEARCH_TIMEOUT_MS" 2000
|
||||
deletePageSize <- fromInteger <$> envInteger "NUTHATCH_DELETE_PAGE_SIZE" 100
|
||||
recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
|
||||
idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
|
||||
objectRequestTimeout <- envInteger "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC" 300
|
||||
|
|
@ -122,6 +128,14 @@ loadConfig = do
|
|||
fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
|
||||
when (objectRequestTimeout <= 0) $
|
||||
fail "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC must be positive"
|
||||
when (browsePageSize <= 0 || browsePageSize > 1000) $
|
||||
fail "NUTHATCH_BROWSE_PAGE_SIZE must be between 1 and 1000"
|
||||
when (searchMax <= 0 || searchMax > 100000) $
|
||||
fail "NUTHATCH_SEARCH_MAX_KEYS must be between 1 and 100000"
|
||||
when (searchTimeoutMs <= 0 || searchTimeoutMs > 60000) $
|
||||
fail "NUTHATCH_SEARCH_TIMEOUT_MS must be between 1 and 60000"
|
||||
when (deletePageSize <= 0 || deletePageSize > 1000) $
|
||||
fail "NUTHATCH_DELETE_PAGE_SIZE must be between 1 and 1000"
|
||||
pure Config
|
||||
{ cfgListenHost = host
|
||||
, cfgListenPort = port
|
||||
|
|
@ -156,7 +170,10 @@ loadConfig = do
|
|||
, cfgThrottleBytesPerSec = throttleRate
|
||||
, cfgThrottleBurstBytes = throttleBurst
|
||||
, cfgListCacheTtlSec = listTtl
|
||||
, cfgBrowsePageSize = browsePageSize
|
||||
, cfgSearchMaxKeys = searchMax
|
||||
, cfgSearchTimeoutMs = searchTimeoutMs
|
||||
, cfgDeletePageSize = deletePageSize
|
||||
, cfgRecoveryGraceSec = recoveryGrace
|
||||
, cfgIdempotencyWindowSec = idempotencyWindow
|
||||
, cfgObjectRequestTimeoutSec = objectRequestTimeout
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module Nuthatch.Ui
|
||||
( browserScript
|
||||
, browsePage
|
||||
, productPage
|
||||
, htmlResponse
|
||||
, escapeHtml
|
||||
) where
|
||||
|
|
@ -29,194 +29,27 @@ escapeHtml =
|
|||
'\'' -> "'"
|
||||
c -> T.singleton c
|
||||
|
||||
browsePage
|
||||
:: SessionUser
|
||||
-> Root
|
||||
-> Text
|
||||
-> Text
|
||||
-> Text
|
||||
-> [Text]
|
||||
-> [ListEntry]
|
||||
-> Maybe Text
|
||||
-> Text
|
||||
-> Text
|
||||
browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
|
||||
page "Nuthatch" $ T.unlines $
|
||||
[ "<header>"
|
||||
, " <h1>Nuthatch</h1>"
|
||||
, " <div class=\"meta\">"
|
||||
, " Signed in as <strong>"
|
||||
<> escapeHtml (maybe (unUserId (suUserId user)) id (suDisplay user))
|
||||
<> "</strong>"
|
||||
, " · <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>"
|
||||
, maybe "" (\e -> "<p class=\"err\">" <> escapeHtml e <> "</p>") mError
|
||||
, "<nav class=\"roots\">"
|
||||
, rootLink Personal root prefix
|
||||
, rootLink Shared root prefix
|
||||
, "</nav>"
|
||||
, "<p class=\"path\">/" <> escapeHtml (rootLabel root)
|
||||
<> if T.null prefix then "" else "/" <> escapeHtml prefix
|
||||
<> "</p>"
|
||||
, breadcrumbs root prefix
|
||||
, "<section>"
|
||||
, " <h2>Upload</h2>"
|
||||
, " <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) <> "\">"
|
||||
, " <input type=\"hidden\" name=\"prefix\" value=\"" <> escapeHtml prefix <> "\">"
|
||||
, " <input type=\"file\" name=\"file\" required>"
|
||||
, " <button type=\"submit\">Upload</button>"
|
||||
, " </form>"
|
||||
, "</section>"
|
||||
, "<section>"
|
||||
, " <h2>Search</h2>"
|
||||
, " <form method=\"get\" action=\"/\">"
|
||||
, " <input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
|
||||
, " <input type=\"hidden\" name=\"prefix\" value=\"" <> escapeHtml prefix <> "\">"
|
||||
, " <input name=\"q\" placeholder=\"substring in key\">"
|
||||
, " <button type=\"submit\">Search</button>"
|
||||
, " </form>"
|
||||
, "</section>"
|
||||
, "<section>"
|
||||
, " <h2>Contents</h2>"
|
||||
, " <table><thead><tr><th>Name</th><th>Size</th><th></th></tr></thead><tbody>"
|
||||
]
|
||||
<> zipWith (renderEntry root csrf) deleteOps entries
|
||||
<>
|
||||
[ " </tbody></table>"
|
||||
, if null entries then "<p><em>Empty</em></p>" else ""
|
||||
, "</section>"
|
||||
]
|
||||
|
||||
rootLink :: Root -> Root -> Text -> Text
|
||||
rootLink target current prefix =
|
||||
let label = if target == Shared then "Shared" else "Personal"
|
||||
cls = if target == current then "active" else ""
|
||||
in "<a class=\"" <> cls <> "\" href=\"/?root=" <> rootLabel target
|
||||
<> if target == current && not (T.null prefix)
|
||||
then "&prefix=" <> prefix
|
||||
else ""
|
||||
<> "\">" <> label <> "</a>"
|
||||
|
||||
breadcrumbs :: Root -> Text -> Text
|
||||
breadcrumbs root prefix
|
||||
| T.null prefix = ""
|
||||
| otherwise =
|
||||
let segs = T.splitOn "/" prefix
|
||||
steps = zip segs (scanl1 (\a b -> a <> "/" <> b) segs)
|
||||
links =
|
||||
("<a href=\"/?root=" <> rootLabel root <> "\">root</a>")
|
||||
: [ "<a href=\"/?root=" <> rootLabel root <> "&prefix=" <> path <> "\">"
|
||||
<> escapeHtml name <> "</a>"
|
||||
| (name, path) <- steps
|
||||
]
|
||||
in "<p class=\"crumbs\">" <> T.intercalate " / " links <> "</p>"
|
||||
|
||||
renderEntry :: Root -> Text -> Text -> ListEntry -> Text
|
||||
renderEntry root csrf opId entry =
|
||||
if leIsPrefix entry
|
||||
then
|
||||
let next = leRelativePath entry
|
||||
in "<tr><td colspan=\"2\"><a href=\"/?root=" <> rootLabel root
|
||||
<> "&prefix=" <> next <> "\">" <> escapeHtml (leName entry) <> "/</a></td>"
|
||||
<> "<td>"
|
||||
<> deleteForm root next csrf opId True
|
||||
<> "</td></tr>"
|
||||
else
|
||||
"<tr><td><a href=\"/download?root=" <> rootLabel root
|
||||
<> "&path=" <> leRelativePath entry <> "\">"
|
||||
<> escapeHtml (leName entry) <> "</a></td><td>"
|
||||
<> maybe "-" (T.pack . show) (leSize entry)
|
||||
<> "</td><td>"
|
||||
<> deleteForm root (leRelativePath entry) csrf opId False
|
||||
<> "</td></tr>"
|
||||
|
||||
deleteForm :: Root -> Text -> Text -> Text -> Bool -> Text
|
||||
deleteForm root path csrf opId isPrefix =
|
||||
"<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 <> "\">"
|
||||
<> "<input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
|
||||
<> "<input type=\"hidden\" name=\"path\" value=\"" <> escapeHtml path <> "\">"
|
||||
<> "<input type=\"hidden\" name=\"prefix_delete\" value=\""
|
||||
<> (if isPrefix then "1" else "0") <> "\">"
|
||||
<> "<button type=\"submit\">Delete</button></form>"
|
||||
|
||||
page :: Text -> Text -> Text
|
||||
page title body =
|
||||
productPage :: [ListEntry] -> Text
|
||||
productPage entries =
|
||||
T.unlines
|
||||
[ "<!DOCTYPE html>"
|
||||
[ "<!doctype html>"
|
||||
, "<html lang=\"en\"><head>"
|
||||
, "<meta charset=\"utf-8\">"
|
||||
, "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">"
|
||||
, "<title>" <> escapeHtml title <> "</title>"
|
||||
, "<style>"
|
||||
, "body{font-family:system-ui,sans-serif;margin:2rem auto;max-width:900px;line-height:1.4;color:#122}"
|
||||
, "header{display:flex;justify-content:space-between;align-items:baseline;gap:1rem}"
|
||||
, "a{color:#0b57d0;text-decoration:none}a:hover{text-decoration:underline}"
|
||||
, "nav.roots a{margin-right:1rem;padding:.2rem .5rem;border-radius:4px}"
|
||||
, "nav.roots a.active{background:#e8eefc;font-weight:600}"
|
||||
, "table{width:100%;border-collapse:collapse;margin-top:.5rem}"
|
||||
, "th,td{text-align:left;padding:.4rem .3rem;border-bottom:1px solid #ddd}"
|
||||
, "form.inline{display:inline}"
|
||||
, ".err{color:#a40000;background:#fde8e8;padding:.5rem .75rem;border-radius:4px}"
|
||||
, ".ok{color:#0d5a0d;background:#e7f6e7;padding:.5rem .75rem;border-radius:4px}"
|
||||
, "section{margin:1.5rem 0}"
|
||||
, "input,button{font:inherit;margin:.25rem .25rem .25rem 0}"
|
||||
, "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>"
|
||||
, "<meta name=\"viewport\" content=\"width=device-width,initial-scale=1\">"
|
||||
, "<meta http-equiv=\"Content-Security-Policy\" content=\"default-src 'self'; object-src 'none'; base-uri 'none'\">"
|
||||
, "<title>Nuthatch</title>"
|
||||
, "</head><body><main>"
|
||||
, "<h1>Nuthatch</h1>"
|
||||
, "<p>The browser application has moved to <a href=\"/app\">/app</a>.</p>"
|
||||
, "<ul>"
|
||||
, T.concat
|
||||
[ "<li>" <> escapeHtml (leRelativePath entry) <> "</li>"
|
||||
| entry <- entries
|
||||
]
|
||||
, "</ul>"
|
||||
, "</main></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);"
|
||||
, " }"
|
||||
, "});"
|
||||
]
|
||||
browserScript =
|
||||
"const nuthatchApp = '/app'; if (window.location.pathname === '/') window.location.assign(nuthatchApp);"
|
||||
|
|
|
|||
Loading…
Reference in a new issue