Replace raw HTTP dispatch with typed Servant API
This commit is contained in:
parent
06d1383456
commit
435d4fea4c
6 changed files with 1625 additions and 445 deletions
572
src/Nuthatch/Api.hs
Normal file
572
src/Nuthatch/Api.hs
Normal file
|
|
@ -0,0 +1,572 @@
|
|||
module Nuthatch.Api
|
||||
( Api
|
||||
, HealthEndpoint
|
||||
, ReadyEndpoint
|
||||
, LoginPageEndpoint
|
||||
, BrowserScriptEndpoint
|
||||
, LoginEndpoint
|
||||
, LoginSuccess
|
||||
, LogoutEndpoint
|
||||
, LogoutSuccess
|
||||
, BrowseEndpoint
|
||||
, DownloadEndpoint
|
||||
, DownloadSuccess
|
||||
, UploadEndpoint
|
||||
, DeleteEndpoint
|
||||
, DeletePrefixEndpoint
|
||||
, api
|
||||
, HTML
|
||||
, JavaScript
|
||||
, HtmlPage (..)
|
||||
, BrowserScript (..)
|
||||
, SessionContext (..)
|
||||
, SessionAuth
|
||||
, BrowsePrefix (..)
|
||||
, PaginationToken (..)
|
||||
, SearchQuery (..)
|
||||
, DeclaredSize (..)
|
||||
, DevUsername (..)
|
||||
, LoginRequest (..)
|
||||
, LoginResponse (..)
|
||||
, LoginView (..)
|
||||
, HealthResponse (..)
|
||||
, ReadyResponse (..)
|
||||
, BrowseResponse (..)
|
||||
, BrowseView (..)
|
||||
, DeleteRequest (..)
|
||||
, DeletePrefixRequest (..)
|
||||
, DeletePrefixResponse (..)
|
||||
, UploadResponse (..)
|
||||
, DeleteResponse (..)
|
||||
, Throws
|
||||
, BoundaryError (..)
|
||||
, AuthenticationError (..)
|
||||
, ReadyError (..)
|
||||
, LoginError (..)
|
||||
, LogoutError (..)
|
||||
, BrowseError (..)
|
||||
, DownloadError (..)
|
||||
, UploadError (..)
|
||||
, DeleteError (..)
|
||||
, DeletePrefixError (..)
|
||||
, validatePaginationToken
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
( FromJSON (..)
|
||||
, ToJSON (..)
|
||||
, Value
|
||||
, object
|
||||
, withObject
|
||||
, (.:)
|
||||
, (.=)
|
||||
)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Char (isControl)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Network.HTTP.Media ((//), (/:))
|
||||
import Nuthatch.Types
|
||||
import Servant.API
|
||||
import Servant.Server (HasServer (..))
|
||||
import Servant.Server.Experimental.Auth (AuthServerData)
|
||||
import Web.FormUrlEncoded (FromForm (..), lookupUnique)
|
||||
|
||||
data HTML
|
||||
data JavaScript
|
||||
|
||||
instance Accept HTML where
|
||||
contentType _ = "text" // "html" /: ("charset", "utf-8")
|
||||
|
||||
instance Accept JavaScript where
|
||||
contentType _ = "text" // "javascript" /: ("charset", "utf-8")
|
||||
|
||||
newtype HtmlPage = HtmlPage { unHtmlPage :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance MimeRender HTML HtmlPage where
|
||||
mimeRender _ = BL.fromStrict . TE.encodeUtf8 . unHtmlPage
|
||||
|
||||
newtype BrowserScript = BrowserScript { unBrowserScript :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance MimeRender JavaScript BrowserScript where
|
||||
mimeRender _ = BL.fromStrict . TE.encodeUtf8 . unBrowserScript
|
||||
|
||||
data SessionContext = SessionContext
|
||||
{ sessionUser :: SessionUser
|
||||
, sessionCsrf :: Maybe CsrfToken
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data SessionAuth
|
||||
|
||||
type instance AuthServerData (AuthProtect SessionAuth) = SessionContext
|
||||
|
||||
newtype BrowsePrefix = BrowsePrefix { unBrowsePrefix :: Maybe RelativePath }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
newtype PaginationToken = PaginationToken { unPaginationToken :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
|
||||
newtype SearchQuery = SearchQuery { unSearchQuery :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
|
||||
newtype DeclaredSize = DeclaredSize { unDeclaredSize :: Integer }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
|
||||
newtype DevUsername = DevUsername { unDevUsername :: Text }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data LoginRequest = LoginRequest
|
||||
{ loginUsername :: DevUsername
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON LoginRequest where
|
||||
parseJSON = withObject "LoginRequest" $ \o -> do
|
||||
raw <- o .: "username"
|
||||
LoginRequest <$> either (fail . T.unpack) pure (validateDevUsername raw)
|
||||
|
||||
instance FromForm LoginRequest where
|
||||
fromForm form = do
|
||||
raw <- lookupUnique "username" form
|
||||
LoginRequest <$> validateDevUsername raw
|
||||
|
||||
data LoginResponse = LoginResponse
|
||||
{ loginUserId :: UserId
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON LoginResponse where
|
||||
toJSON response = object ["user_id" .= loginUserId response]
|
||||
|
||||
data LoginView = LoginView
|
||||
{ loginViewHtml :: HtmlPage
|
||||
, loginViewJson :: LoginResponse
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance MimeRender HTML LoginView where
|
||||
mimeRender proxy = mimeRender proxy . loginViewHtml
|
||||
|
||||
instance ToJSON LoginView where
|
||||
toJSON = toJSON . loginViewJson
|
||||
|
||||
newtype HealthResponse = HealthResponse { healthOk :: Bool }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON HealthResponse where
|
||||
toJSON response = object ["ok" .= healthOk response]
|
||||
|
||||
newtype ReadyResponse = ReadyResponse { ready :: Bool }
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON ReadyResponse where
|
||||
toJSON response = object ["ready" .= ready response]
|
||||
|
||||
data BrowseResponse = BrowseResponse
|
||||
{ browseEntries :: [ListEntry]
|
||||
, browseContinuation :: Maybe PaginationToken
|
||||
, browsePartial :: Bool
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON BrowseResponse where
|
||||
toJSON response = object
|
||||
[ "entries" .= browseEntries response
|
||||
, "continuation" .= browseContinuation response
|
||||
, "partial" .= browsePartial response
|
||||
]
|
||||
|
||||
data BrowseView = BrowseView
|
||||
{ browseViewHtml :: HtmlPage
|
||||
, browseViewJson :: BrowseResponse
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance MimeRender HTML BrowseView where
|
||||
mimeRender proxy = mimeRender proxy . browseViewHtml
|
||||
|
||||
instance ToJSON BrowseView where
|
||||
toJSON = toJSON . browseViewJson
|
||||
|
||||
data DeleteRequest = DeleteRequest
|
||||
{ deleteRoot :: Root
|
||||
, deletePath :: RelativePath
|
||||
, deleteOperationId :: OperationId
|
||||
, deleteCsrf :: CsrfToken
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON DeleteRequest where
|
||||
parseJSON = withObject "DeleteRequest" $ \o ->
|
||||
DeleteRequest
|
||||
<$> o .: "root"
|
||||
<*> o .: "path"
|
||||
<*> o .: "operation_id"
|
||||
<*> o .: "csrf"
|
||||
|
||||
data DeletePrefixRequest = DeletePrefixRequest
|
||||
{ deletePrefixRoot :: Root
|
||||
, deletePrefixPath :: RelativePath
|
||||
, deletePrefixCsrf :: CsrfToken
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance FromJSON DeletePrefixRequest where
|
||||
parseJSON = withObject "DeletePrefixRequest" $ \o ->
|
||||
DeletePrefixRequest
|
||||
<$> o .: "root"
|
||||
<*> o .: "path"
|
||||
<*> o .: "csrf"
|
||||
|
||||
newtype DeletePrefixResponse = DeletePrefixResponse
|
||||
{ deletedObjectCount :: Int
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeletePrefixResponse where
|
||||
toJSON response = object ["deleted" .= deletedObjectCount response]
|
||||
|
||||
data UploadResponse = UploadResponse
|
||||
{ uploadResponseOperationId :: OperationId
|
||||
, uploadResponseResult :: MutationResult
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON UploadResponse where
|
||||
toJSON response = object
|
||||
[ "operation_id" .= uploadResponseOperationId response
|
||||
, "result" .= mutationResultText (uploadResponseResult response)
|
||||
]
|
||||
|
||||
data DeleteResponse = DeleteResponse
|
||||
{ deleteResponseOperationId :: OperationId
|
||||
, deleteResponseResult :: MutationResult
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeleteResponse where
|
||||
toJSON response = object
|
||||
[ "operation_id" .= deleteResponseOperationId response
|
||||
, "result" .= mutationResultText (deleteResponseResult response)
|
||||
]
|
||||
|
||||
data Throws error
|
||||
|
||||
instance HasServer endpoint context =>
|
||||
HasServer (Throws error :> endpoint) context where
|
||||
type ServerT (Throws error :> endpoint) m = ServerT endpoint m
|
||||
route _ = route (Proxy :: Proxy endpoint)
|
||||
hoistServerWithContext _ context transform server =
|
||||
hoistServerWithContext
|
||||
(Proxy :: Proxy endpoint)
|
||||
context
|
||||
transform
|
||||
server
|
||||
|
||||
instance HasLink endpoint => HasLink (Throws error :> endpoint) where
|
||||
type MkLink (Throws error :> endpoint) result = MkLink endpoint result
|
||||
toLink convert _ = toLink convert (Proxy :: Proxy endpoint)
|
||||
|
||||
data BoundaryError = InvalidUtf8
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON BoundaryError where
|
||||
toJSON InvalidUtf8 =
|
||||
errorValue "invalid_utf8" "request paths and query values must be valid UTF-8" Nothing
|
||||
|
||||
data AuthenticationError
|
||||
= AuthenticationRequired
|
||||
| MalformedAuthentication
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON AuthenticationError where
|
||||
toJSON AuthenticationRequired =
|
||||
errorValue "authentication_required" "login required" Nothing
|
||||
toJSON MalformedAuthentication =
|
||||
errorValue "malformed_authentication" "authentication data is malformed" Nothing
|
||||
|
||||
data ReadyError = ReadyDependencyUnavailable
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON ReadyError where
|
||||
toJSON ReadyDependencyUnavailable =
|
||||
errorValue "dependency_unavailable" "PostgreSQL is unavailable" Nothing
|
||||
|
||||
data LoginError
|
||||
= InvalidUsername
|
||||
| SessionCreationFailed Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON LoginError where
|
||||
toJSON InvalidUsername =
|
||||
errorValue "invalid_username" "username must be one token" Nothing
|
||||
toJSON (SessionCreationFailed message) =
|
||||
errorValue "session_error" message Nothing
|
||||
|
||||
data LogoutError = LogoutCsrfRejected
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON LogoutError where
|
||||
toJSON LogoutCsrfRejected =
|
||||
errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
|
||||
|
||||
newtype BrowseError = BrowseObjectStoreFailed Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON BrowseError where
|
||||
toJSON (BrowseObjectStoreFailed message) =
|
||||
errorValue "object_store_error" message Nothing
|
||||
|
||||
data DownloadError
|
||||
= DownloadObjectStoreFailed Text
|
||||
| DownloadNotFound
|
||||
| DownloadThrottleUnavailable
|
||||
| DownloadBandwidthExceeded
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DownloadError where
|
||||
toJSON (DownloadObjectStoreFailed message) =
|
||||
errorValue "object_store_error" message Nothing
|
||||
toJSON DownloadNotFound =
|
||||
errorValue "not_found" "object not found" Nothing
|
||||
toJSON DownloadThrottleUnavailable =
|
||||
errorValue "throttle_unavailable" "bandwidth throttle unavailable" Nothing
|
||||
toJSON DownloadBandwidthExceeded =
|
||||
errorValue "bandwidth_exceeded" "bandwidth limit exceeded" Nothing
|
||||
|
||||
data UploadError
|
||||
= UploadCsrfRejected
|
||||
| UploadInvalidBodyStream Text
|
||||
| UploadSizeMismatch
|
||||
| UploadTooLarge
|
||||
| UploadContentIdentityMismatch
|
||||
| UploadThrottleUnavailable
|
||||
| UploadBandwidthExceeded
|
||||
| UploadMutationRejected Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON UploadError where
|
||||
toJSON UploadCsrfRejected =
|
||||
errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
|
||||
toJSON (UploadInvalidBodyStream message) =
|
||||
errorValue "invalid_body_stream" message Nothing
|
||||
toJSON UploadSizeMismatch =
|
||||
errorValue "size_mismatch" "request body does not match declared size" Nothing
|
||||
toJSON UploadTooLarge =
|
||||
errorValue "object_too_large" "object too large" Nothing
|
||||
toJSON UploadContentIdentityMismatch =
|
||||
errorValue "content_identity_mismatch" "request body digest does not match" Nothing
|
||||
toJSON UploadThrottleUnavailable =
|
||||
errorValue "throttle_unavailable" "bandwidth throttle unavailable" Nothing
|
||||
toJSON UploadBandwidthExceeded =
|
||||
errorValue "bandwidth_exceeded" "bandwidth limit exceeded" Nothing
|
||||
toJSON (UploadMutationRejected message) =
|
||||
errorValue "mutation_rejected" message Nothing
|
||||
|
||||
data DeleteError
|
||||
= DeleteCsrfRejected
|
||||
| DeleteMutationRejected Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeleteError where
|
||||
toJSON DeleteCsrfRejected =
|
||||
errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
|
||||
toJSON (DeleteMutationRejected message) =
|
||||
errorValue "mutation_rejected" message Nothing
|
||||
|
||||
data DeletePrefixError
|
||||
= DeletePrefixCsrfRejected
|
||||
| DeletePrefixMutationRejected Text
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON DeletePrefixError where
|
||||
toJSON DeletePrefixCsrfRejected =
|
||||
errorValue "csrf_validation_failed" "CSRF validation failed" Nothing
|
||||
toJSON (DeletePrefixMutationRejected message) =
|
||||
errorValue "prefix_mutation_rejected" message Nothing
|
||||
|
||||
errorValue :: Text -> Text -> Maybe Value -> Value
|
||||
errorValue code message details = object
|
||||
[ "error" .= code
|
||||
, "message" .= message
|
||||
, "details" .= details
|
||||
]
|
||||
|
||||
type HealthEndpoint =
|
||||
"healthz" :> Get '[JSON] HealthResponse
|
||||
|
||||
type ReadyEndpoint =
|
||||
"readyz" :> Throws ReadyError :> Get '[JSON] ReadyResponse
|
||||
|
||||
type LoginPageEndpoint =
|
||||
"login" :> Get '[HTML] HtmlPage
|
||||
|
||||
type BrowserScriptEndpoint =
|
||||
"nuthatch.js" :> Get '[JavaScript] BrowserScript
|
||||
|
||||
type LoginSuccess =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
, Header "Set-Cookie" Text
|
||||
, Header "X-CSRF-Token" CsrfToken
|
||||
]
|
||||
LoginView
|
||||
|
||||
type LoginEndpoint =
|
||||
"login"
|
||||
:> Throws LoginError
|
||||
:> ReqBody '[JSON, FormUrlEncoded] LoginRequest
|
||||
:> Post '[HTML, JSON] LoginSuccess
|
||||
|
||||
type LogoutSuccess =
|
||||
Headers
|
||||
'[ Header "Set-Cookie" Text
|
||||
, Header "Set-Cookie" Text
|
||||
]
|
||||
NoContent
|
||||
|
||||
type LogoutEndpoint =
|
||||
"logout"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws LogoutError
|
||||
:> Header' '[Required, Strict] "X-CSRF-Token" CsrfToken
|
||||
:> Post '[JSON] LogoutSuccess
|
||||
|
||||
type BrowseEndpoint =
|
||||
AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws BrowseError
|
||||
:> QueryParam "root" Root
|
||||
:> QueryParam "prefix" BrowsePrefix
|
||||
:> QueryParam "q" SearchQuery
|
||||
:> QueryParam "continuation" PaginationToken
|
||||
:> Get '[HTML, JSON] BrowseView
|
||||
|
||||
type DownloadSuccess =
|
||||
Headers
|
||||
'[ Header "Content-Disposition" Text
|
||||
, Header "X-Content-Type-Options" Text
|
||||
]
|
||||
(SourceIO BS.ByteString)
|
||||
|
||||
type DownloadEndpoint =
|
||||
"download"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DownloadError
|
||||
:> QueryParam' '[Required, Strict] "root" Root
|
||||
:> QueryParam' '[Required, Strict] "path" RelativePath
|
||||
:> StreamGet NoFraming OctetStream DownloadSuccess
|
||||
|
||||
type UploadEndpoint =
|
||||
"upload"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws UploadError
|
||||
:> QueryParam' '[Required, Strict] "root" Root
|
||||
:> QueryParam' '[Required, Strict] "path" RelativePath
|
||||
:> QueryParam' '[Required, Strict] "operation_id" OperationId
|
||||
:> Header' '[Required, Strict] "X-Declared-Size" DeclaredSize
|
||||
:> Header' '[Required, Strict] "X-Content-SHA256" ContentSha256
|
||||
:> Header' '[Required, Strict] "X-CSRF-Token" CsrfToken
|
||||
:> StreamBody NoFraming OctetStream (SourceIO BS.ByteString)
|
||||
:> Post '[JSON] UploadResponse
|
||||
|
||||
type DeleteEndpoint =
|
||||
"delete"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DeleteError
|
||||
:> ReqBody '[JSON] DeleteRequest
|
||||
:> Post '[JSON] DeleteResponse
|
||||
|
||||
type DeletePrefixEndpoint =
|
||||
"delete-prefix"
|
||||
:> AuthProtect SessionAuth
|
||||
:> Throws AuthenticationError
|
||||
:> Throws DeletePrefixError
|
||||
:> ReqBody '[JSON] DeletePrefixRequest
|
||||
:> Post '[JSON] DeletePrefixResponse
|
||||
|
||||
type Api =
|
||||
HealthEndpoint
|
||||
:<|> ReadyEndpoint
|
||||
:<|> LoginPageEndpoint
|
||||
:<|> BrowserScriptEndpoint
|
||||
:<|> LoginEndpoint
|
||||
:<|> LogoutEndpoint
|
||||
:<|> BrowseEndpoint
|
||||
:<|> DownloadEndpoint
|
||||
:<|> UploadEndpoint
|
||||
:<|> DeleteEndpoint
|
||||
:<|> DeletePrefixEndpoint
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
instance ToHttpApiData BrowsePrefix where
|
||||
toUrlPiece (BrowsePrefix Nothing) = ""
|
||||
toUrlPiece (BrowsePrefix (Just path)) = unRelativePath path
|
||||
|
||||
instance FromHttpApiData BrowsePrefix where
|
||||
parseUrlPiece "" = Right (BrowsePrefix Nothing)
|
||||
parseUrlPiece raw = BrowsePrefix . Just <$> validateRelativePath raw
|
||||
|
||||
instance ToHttpApiData PaginationToken where
|
||||
toUrlPiece = unPaginationToken
|
||||
|
||||
instance FromHttpApiData PaginationToken where
|
||||
parseUrlPiece = validatePaginationToken
|
||||
|
||||
instance ToHttpApiData SearchQuery where
|
||||
toUrlPiece = unSearchQuery
|
||||
|
||||
instance FromHttpApiData SearchQuery where
|
||||
parseUrlPiece raw
|
||||
| T.null raw = Left "search query must not be empty"
|
||||
| T.length raw > 512 = Left "search query is too long"
|
||||
| T.any isControl raw = Left "search query contains a control character"
|
||||
| otherwise = Right (SearchQuery raw)
|
||||
|
||||
instance ToHttpApiData DeclaredSize where
|
||||
toUrlPiece = T.pack . show . unDeclaredSize
|
||||
|
||||
instance FromHttpApiData DeclaredSize where
|
||||
parseUrlPiece raw =
|
||||
case reads (T.unpack raw) of
|
||||
[(size, "")] | size > 0 -> Right (DeclaredSize size)
|
||||
_ -> Left "declared size must be a positive integer"
|
||||
|
||||
validatePaginationToken :: Text -> Either Text PaginationToken
|
||||
validatePaginationToken raw
|
||||
| T.null raw = Left "pagination token must not be empty"
|
||||
| T.length raw > 2048 = Left "pagination token is too long"
|
||||
| T.any isControl raw = Left "pagination token contains a control character"
|
||||
| otherwise = Right (PaginationToken raw)
|
||||
|
||||
validateDevUsername :: Text -> Either Text DevUsername
|
||||
validateDevUsername raw
|
||||
| T.null raw = Left "username must not be empty"
|
||||
| T.length raw > 128 = Left "username is too long"
|
||||
| T.any invalidCharacter raw = Left "username must be one printable token"
|
||||
| otherwise = Right (DevUsername raw)
|
||||
where
|
||||
invalidCharacter character =
|
||||
isControl character || character `elem` (" \t\r\n" :: String)
|
||||
|
||||
mutationResultText :: MutationResult -> Text
|
||||
mutationResultText MutationPending = "pending"
|
||||
mutationResultText MutationSucceeded = "succeeded"
|
||||
mutationResultText MutationFailed = "failed"
|
||||
mutationResultText MutationRejected = "rejected"
|
||||
mutationResultText MutationConflict = "conflict"
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -10,33 +10,11 @@ import Crypto.Hash (Digest, SHA256, hash)
|
|||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import Data.Char (isControl)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Normalize as TN
|
||||
import Nuthatch.Types
|
||||
|
||||
validateRelativePath :: Text -> Either Text RelativePath
|
||||
validateRelativePath raw = do
|
||||
if T.null raw
|
||||
then Left "path must not be empty"
|
||||
else if T.head raw == '/' || T.last raw == '/'
|
||||
then Left "path must not begin or end with a separator"
|
||||
else if TN.normalize TN.NFC raw /= raw
|
||||
then Left "path must be NFC-normalized"
|
||||
else do
|
||||
let segments = T.splitOn "/" raw
|
||||
mapM_ validateSegment segments
|
||||
pure (RelativePath raw)
|
||||
where
|
||||
validateSegment seg
|
||||
| T.null seg = Left "empty path segment"
|
||||
| seg == "." || seg == ".." = Left "path segment may not be . or .."
|
||||
| T.any (== '\\') seg = Left "backslash is not allowed"
|
||||
| T.any isControl seg = Left "control characters are not allowed"
|
||||
| otherwise = Right ()
|
||||
|
||||
buildObjectKey :: Root -> UserId -> RelativePath -> ObjectKey
|
||||
buildObjectKey root uid (RelativePath path) =
|
||||
ObjectKey $ case root of
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import Nuthatch.Paths (encodeUserId)
|
|||
import Nuthatch.Types
|
||||
import System.Entropy (getEntropy)
|
||||
|
||||
mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text Text)
|
||||
mintSession :: Config -> Text -> Text -> Maybe Text -> IO (Either Text SessionToken)
|
||||
mintSession cfg iss sub display = do
|
||||
now <- floor <$> getPOSIXTime
|
||||
let expAt = now + cfgSessionHours cfg * 3600
|
||||
|
|
@ -43,10 +43,10 @@ mintSession cfg iss sub display = do
|
|||
, "oidc_subject" A..= sub
|
||||
] <> maybe [] (\d -> ["display" A..= d]) display
|
||||
token = signJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) header payload
|
||||
pure (Right token)
|
||||
pure (validateSessionToken token)
|
||||
|
||||
verifySession :: Config -> Text -> IO (Either Text SessionUser)
|
||||
verifySession cfg token = do
|
||||
verifySession :: Config -> SessionToken -> IO (Either Text SessionUser)
|
||||
verifySession cfg (SessionToken token) = do
|
||||
now <- floor <$> getPOSIXTime
|
||||
pure $ do
|
||||
claims <- verifyJwt (TE.encodeUtf8 (cfgJwtSecret cfg)) token
|
||||
|
|
@ -120,13 +120,13 @@ claimInt obj key =
|
|||
_ -> Left ("invalid integer claim " <> key)
|
||||
_ -> Left ("missing claim " <> key)
|
||||
|
||||
newCsrfToken :: IO Text
|
||||
newCsrfToken :: IO CsrfToken
|
||||
newCsrfToken = do
|
||||
bytes <- getEntropy 32
|
||||
pure (TE.decodeUtf8 (B64.encodeUnpadded bytes))
|
||||
pure (CsrfToken (TE.decodeUtf8 (B64.encodeUnpadded bytes)))
|
||||
|
||||
constantTimeEq :: Text -> Text -> Bool
|
||||
constantTimeEq a b =
|
||||
constantTimeEq :: CsrfToken -> CsrfToken -> Bool
|
||||
constantTimeEq (CsrfToken a) (CsrfToken b) =
|
||||
let ba = TE.encodeUtf8 a
|
||||
bb = TE.encodeUtf8 b
|
||||
in BS.length ba == BS.length bb
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ module Nuthatch.Types
|
|||
, ExternalState (..)
|
||||
, UserId (..)
|
||||
, OperationId (..)
|
||||
, SessionToken (..)
|
||||
, CsrfToken (..)
|
||||
, ContentSha256 (..)
|
||||
, ObjectKey (..)
|
||||
, RelativePath (..)
|
||||
|
|
@ -20,13 +22,30 @@ module Nuthatch.Types
|
|||
, parseState
|
||||
, externalLabel
|
||||
, parseExternal
|
||||
, validateRelativePath
|
||||
, validateOperationId
|
||||
, validateContentSha256
|
||||
, validateSessionToken
|
||||
, validateCsrfToken
|
||||
, sharedPool
|
||||
, personalPool
|
||||
) where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))
|
||||
import Data.Aeson
|
||||
( FromJSON (..)
|
||||
, ToJSON (..)
|
||||
, object
|
||||
, withObject
|
||||
, withText
|
||||
, (.:)
|
||||
, (.:?)
|
||||
, (.=)
|
||||
)
|
||||
import Data.Char (isAsciiLower, isAsciiUpper, isControl, isDigit)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Normalize as TN
|
||||
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
|
||||
|
||||
data Root = Personal | Shared
|
||||
deriving stock (Eq, Show)
|
||||
|
|
@ -99,7 +118,22 @@ newtype UserId = UserId { unUserId :: Text }
|
|||
|
||||
newtype OperationId = OperationId { unOperationId :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving newtype (ToJSON)
|
||||
|
||||
instance FromJSON OperationId where
|
||||
parseJSON = withText "OperationId" $
|
||||
either (fail . T.unpack) pure . validateOperationId
|
||||
|
||||
newtype SessionToken = SessionToken { unSessionToken :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
newtype CsrfToken = CsrfToken { unCsrfToken :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (ToJSON)
|
||||
|
||||
instance FromJSON CsrfToken where
|
||||
parseJSON = withText "CsrfToken" $
|
||||
either (fail . T.unpack) pure . validateCsrfToken
|
||||
|
||||
newtype ContentSha256 = ContentSha256 { unContentSha256 :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
|
@ -111,7 +145,11 @@ newtype ObjectKey = ObjectKey { unObjectKey :: Text }
|
|||
|
||||
newtype RelativePath = RelativePath { unRelativePath :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving newtype (ToJSON, FromJSON)
|
||||
deriving newtype (ToJSON)
|
||||
|
||||
instance FromJSON RelativePath where
|
||||
parseJSON = withText "RelativePath" $
|
||||
either (fail . T.unpack) pure . validateRelativePath
|
||||
|
||||
newtype PoolId = PoolId { unPoolId :: Text }
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
|
@ -162,3 +200,118 @@ data MutationResult
|
|||
| MutationRejected
|
||||
| MutationConflict
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance ToJSON Root where
|
||||
toJSON = toJSON . rootLabel
|
||||
|
||||
instance FromJSON Root where
|
||||
parseJSON = withText "Root" $ \raw ->
|
||||
maybe (fail "root must be personal or shared") pure (strictRoot raw)
|
||||
|
||||
instance ToHttpApiData Root where
|
||||
toUrlPiece = rootLabel
|
||||
|
||||
instance FromHttpApiData Root where
|
||||
parseUrlPiece raw =
|
||||
maybe (Left "root must be personal or shared") Right (strictRoot raw)
|
||||
|
||||
instance ToHttpApiData RelativePath where
|
||||
toUrlPiece = unRelativePath
|
||||
|
||||
instance FromHttpApiData RelativePath where
|
||||
parseUrlPiece = validateRelativePath
|
||||
|
||||
instance ToHttpApiData OperationId where
|
||||
toUrlPiece = unOperationId
|
||||
|
||||
instance FromHttpApiData OperationId where
|
||||
parseUrlPiece = validateOperationId
|
||||
|
||||
instance ToHttpApiData CsrfToken where
|
||||
toUrlPiece = unCsrfToken
|
||||
|
||||
instance FromHttpApiData CsrfToken where
|
||||
parseUrlPiece = validateCsrfToken
|
||||
|
||||
instance ToHttpApiData ContentSha256 where
|
||||
toUrlPiece = unContentSha256
|
||||
|
||||
instance FromHttpApiData ContentSha256 where
|
||||
parseUrlPiece = validateContentSha256
|
||||
|
||||
validateRelativePath :: Text -> Either Text RelativePath
|
||||
validateRelativePath raw = do
|
||||
if T.null raw
|
||||
then Left "path must not be empty"
|
||||
else if T.head raw == '/' || T.last raw == '/'
|
||||
then Left "path must not begin or end with a separator"
|
||||
else if TN.normalize TN.NFC raw /= raw
|
||||
then Left "path must be NFC-normalized"
|
||||
else do
|
||||
mapM_ validateSegment (T.splitOn "/" raw)
|
||||
pure (RelativePath raw)
|
||||
where
|
||||
validateSegment segment
|
||||
| T.null segment = Left "empty path segment"
|
||||
| segment == "." || segment == ".." =
|
||||
Left "path segment may not be . or .."
|
||||
| T.any (== '\\') segment = Left "backslash is not allowed"
|
||||
| T.any isControl segment = Left "control characters are not allowed"
|
||||
| otherwise = Right ()
|
||||
|
||||
validateOperationId :: Text -> Either Text OperationId
|
||||
validateOperationId raw
|
||||
| T.null raw = Left "operation id must not be empty"
|
||||
| T.length raw > 128 = Left "operation id is too long"
|
||||
| T.any (not . operationCharacter) raw =
|
||||
Left "operation id must contain only URL-safe ASCII characters"
|
||||
| otherwise = Right (OperationId raw)
|
||||
where
|
||||
operationCharacter character =
|
||||
isAsciiLower character
|
||||
|| isAsciiUpper character
|
||||
|| isDigit character
|
||||
|| character `elem` ("-._~" :: String)
|
||||
|
||||
validateContentSha256 :: Text -> Either Text ContentSha256
|
||||
validateContentSha256 raw
|
||||
| T.length raw /= 64 =
|
||||
Left "content SHA-256 must contain 64 hexadecimal characters"
|
||||
| T.any (not . hexadecimal) raw =
|
||||
Left "content SHA-256 must use lowercase hexadecimal"
|
||||
| otherwise = Right (ContentSha256 raw)
|
||||
where
|
||||
hexadecimal character =
|
||||
isDigit character || character >= 'a' && character <= 'f'
|
||||
|
||||
validateSessionToken :: Text -> Either Text SessionToken
|
||||
validateSessionToken raw
|
||||
| T.length raw > 8192 = Left "session token is too long"
|
||||
| otherwise =
|
||||
case T.splitOn "." raw of
|
||||
[header, payload, signature]
|
||||
| all validSegment [header, payload, signature] ->
|
||||
Right (SessionToken raw)
|
||||
_ -> Left "session token must be compact JOSE"
|
||||
where
|
||||
validSegment segment =
|
||||
not (T.null segment) && T.all base64UrlCharacter segment
|
||||
|
||||
validateCsrfToken :: Text -> Either Text CsrfToken
|
||||
validateCsrfToken raw
|
||||
| T.length raw /= 43 = Left "CSRF token must encode 32 bytes"
|
||||
| T.all base64UrlCharacter raw = Right (CsrfToken raw)
|
||||
| otherwise = Left "CSRF token must use unpadded Base64url"
|
||||
|
||||
base64UrlCharacter :: Char -> Bool
|
||||
base64UrlCharacter character =
|
||||
isAsciiLower character
|
||||
|| isAsciiUpper character
|
||||
|| isDigit character
|
||||
|| character == '-'
|
||||
|| character == '_'
|
||||
|
||||
strictRoot :: Text -> Maybe Root
|
||||
strictRoot "personal" = Just Personal
|
||||
strictRoot "shared" = Just Shared
|
||||
strictRoot _ = Nothing
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
module Nuthatch.Ui
|
||||
( loginPage
|
||||
, browserScript
|
||||
, browsePage
|
||||
, htmlResponse
|
||||
, escapeHtml
|
||||
|
|
@ -61,7 +62,10 @@ browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
|
|||
, " Signed in as <strong>"
|
||||
<> escapeHtml (maybe (unUserId (suUserId user)) id (suDisplay user))
|
||||
<> "</strong>"
|
||||
, " · <a href=\"/logout\">Log out</a>"
|
||||
, " · <form class=\"inline\" data-nuthatch=\"logout\">"
|
||||
, " <input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
|
||||
, " <button type=\"submit\">Log out</button>"
|
||||
, " </form>"
|
||||
, " </div>"
|
||||
, "</header>"
|
||||
, if T.null notice then "" else "<p class=\"ok\">" <> escapeHtml notice <> "</p>"
|
||||
|
|
@ -76,7 +80,7 @@ browsePage user root prefix csrf uploadOp deleteOps entries mError notice =
|
|||
, breadcrumbs root prefix
|
||||
, "<section>"
|
||||
, " <h2>Upload</h2>"
|
||||
, " <form method=\"post\" action=\"/upload\" enctype=\"multipart/form-data\">"
|
||||
, " <form method=\"post\" action=\"/upload\" enctype=\"multipart/form-data\" data-nuthatch=\"upload\">"
|
||||
, " <input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
|
||||
, " <input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml uploadOp <> "\">"
|
||||
, " <input type=\"hidden\" name=\"root\" value=\"" <> escapeHtml (rootLabel root) <> "\">"
|
||||
|
|
@ -150,7 +154,7 @@ renderEntry root csrf opId entry =
|
|||
|
||||
deleteForm :: Root -> Text -> Text -> Text -> Bool -> Text
|
||||
deleteForm root path csrf opId isPrefix =
|
||||
"<form class=\"inline\" method=\"post\" action=\"/delete\" onsubmit=\"return confirm('Delete "
|
||||
"<form class=\"inline\" method=\"post\" action=\"/delete\" data-nuthatch=\"delete\" onsubmit=\"return confirm('Delete "
|
||||
<> escapeHtml path <> "?');\">"
|
||||
<> "<input type=\"hidden\" name=\"csrf\" value=\"" <> escapeHtml csrf <> "\">"
|
||||
<> "<input type=\"hidden\" name=\"operation_id\" value=\"" <> escapeHtml opId <> "\">"
|
||||
|
|
@ -184,7 +188,49 @@ page title body =
|
|||
, "button{cursor:pointer}"
|
||||
, "</style>"
|
||||
, "<meta http-equiv=\"Content-Security-Policy\" content=\"default-src 'self'; style-src 'unsafe-inline'; img-src 'none'; object-src 'none'\">"
|
||||
, "<script src=\"/nuthatch.js\" defer></script>"
|
||||
, "</head><body>"
|
||||
, body
|
||||
, "</body></html>"
|
||||
]
|
||||
|
||||
browserScript :: Text
|
||||
browserScript = T.unlines
|
||||
[ "const hex = bytes => Array.from(new Uint8Array(bytes), byte => byte.toString(16).padStart(2, '0')).join('');"
|
||||
, "const fail = async response => { if (!response.ok) throw new Error((await response.json()).message || response.statusText); };"
|
||||
, "document.addEventListener('submit', async event => {"
|
||||
, " const form = event.target.closest('form[data-nuthatch]');"
|
||||
, " if (!form) return;"
|
||||
, " event.preventDefault();"
|
||||
, " const fields = new FormData(form);"
|
||||
, " try {"
|
||||
, " if (form.dataset.nuthatch === 'logout') {"
|
||||
, " const response = await fetch('/logout', { method: 'POST', headers: { 'X-CSRF-Token': fields.get('csrf') } });"
|
||||
, " await fail(response);"
|
||||
, " location.assign('/login');"
|
||||
, " return;"
|
||||
, " }"
|
||||
, " if (form.dataset.nuthatch === 'upload') {"
|
||||
, " const file = fields.get('file');"
|
||||
, " const prefix = fields.get('prefix');"
|
||||
, " const path = prefix ? `${prefix}/${file.name}` : file.name;"
|
||||
, " const digest = hex(await crypto.subtle.digest('SHA-256', await file.arrayBuffer()));"
|
||||
, " const query = new URLSearchParams({ root: fields.get('root'), path, operation_id: fields.get('operation_id') });"
|
||||
, " const response = await fetch(`/upload?${query}`, { method: 'POST', headers: { 'Content-Type': 'application/octet-stream', 'X-Declared-Size': String(file.size), 'X-Content-SHA256': digest, 'X-CSRF-Token': fields.get('csrf') }, body: file });"
|
||||
, " await fail(response);"
|
||||
, " location.reload();"
|
||||
, " return;"
|
||||
, " }"
|
||||
, " const prefixDelete = fields.get('prefix_delete') === '1';"
|
||||
, " const endpoint = prefixDelete ? '/delete-prefix' : '/delete';"
|
||||
, " const request = prefixDelete"
|
||||
, " ? { root: fields.get('root'), path: fields.get('path'), csrf: fields.get('csrf') }"
|
||||
, " : { root: fields.get('root'), path: fields.get('path'), operation_id: fields.get('operation_id'), csrf: fields.get('csrf') };"
|
||||
, " const response = await fetch(endpoint, { method: 'POST', headers: { 'Content-Type': 'application/json' }, body: JSON.stringify(request) });"
|
||||
, " await fail(response);"
|
||||
, " location.reload();"
|
||||
, " } catch (error) {"
|
||||
, " alert(error.message);"
|
||||
, " }"
|
||||
, "});"
|
||||
]
|
||||
|
|
|
|||
Loading…
Reference in a new issue