256 lines
9.1 KiB
Haskell
256 lines
9.1 KiB
Haskell
module Nuthatch.Http.Server
|
|
( server
|
|
, utf8Boundary
|
|
) where
|
|
|
|
import Control.Exception (SomeException)
|
|
import Control.Monad (forM, when)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import qualified Data.Aeson as A
|
|
import Data.Either (isRight)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Text.IO as TIO
|
|
import Database.PostgreSQL.Simple (Only (..))
|
|
import Network.HTTP.Types
|
|
( hContentType
|
|
, methodGet
|
|
, status200
|
|
, status400
|
|
, status404
|
|
, status405
|
|
, urlDecode
|
|
)
|
|
import Network.Wai (Request (..), responseFile, responseLBS)
|
|
import Nuthatch.Api
|
|
import Nuthatch.App.Env
|
|
import Nuthatch.Audit (audit)
|
|
import Nuthatch.Browse
|
|
import Nuthatch.Config
|
|
import qualified Nuthatch.Db as Db
|
|
import Nuthatch.Http.Auth
|
|
import Nuthatch.Http.Error
|
|
import Nuthatch.Mutation.Effects
|
|
import Nuthatch.Mutation.Service
|
|
import Nuthatch.Recovery (trySynchronous)
|
|
import Nuthatch.Transfer
|
|
import Nuthatch.Types
|
|
import Servant
|
|
import System.Directory (doesFileExist)
|
|
|
|
server :: Env -> Server Api
|
|
server env =
|
|
pure (HealthResponse True)
|
|
:<|> handleReady env
|
|
:<|> handleAppRequest
|
|
:<|> staticAssetsServer
|
|
:<|> handleLoginRequest env
|
|
:<|> handleOidcCallback env
|
|
:<|> handleLogoutRequest env
|
|
:<|>
|
|
( handleSessionRequest
|
|
:<|> handleBrowseRequest env
|
|
:<|> handleDownloadRequest env
|
|
:<|> handleUploadRequest env
|
|
:<|> handleDeleteRequest env
|
|
:<|> handleDeletePlanRequest env
|
|
:<|> handleDeleteBatchRequest env
|
|
)
|
|
|
|
utf8Boundary :: Application -> Application
|
|
utf8Boundary downstream request sendResponse
|
|
| requestUtf8Valid request = downstream request sendResponse
|
|
| otherwise =
|
|
sendResponse $
|
|
responseLBS status400
|
|
[(hContentType, "application/json")]
|
|
(A.encode InvalidUtf8)
|
|
|
|
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'
|
|
|
|
handleReady :: Env -> Handler ReadyResponse
|
|
handleReady env = do
|
|
pg <- liftIO $
|
|
trySynchronous (Db.query_ (envDb env) "SELECT 1")
|
|
:: Handler (Either SomeException [Only Int])
|
|
case pg of
|
|
Right _ -> pure (ReadyResponse True)
|
|
Left _ -> throwOperationError err503 ReadyDependencyUnavailable
|
|
|
|
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"
|
|
|
|
handleDeleteRequest
|
|
:: Env
|
|
-> SessionContext
|
|
-> DeleteRequest
|
|
-> Handler DeleteResponse
|
|
handleDeleteRequest env session request = do
|
|
requireCsrf "delete" DeleteCsrfRejected session (deleteCsrf request)
|
|
let user = sessionUser session
|
|
operation = deleteOperationId request
|
|
root = deleteRoot request
|
|
deleteAttempt <- liftIO $
|
|
tryRecoveryDependency
|
|
(runDelete env user root (deletePath request) operation)
|
|
outcome <- case deleteAttempt of
|
|
Left _ -> do
|
|
liftIO $ audit "delete" "failed"
|
|
(Just (unUserId (suUserId user)))
|
|
([ ("root", A.toJSON (rootLabel root))
|
|
, ("operation_id", A.toJSON (unOperationId operation))
|
|
, ("reason", A.String "database_unavailable")
|
|
] <> objectKeyAudit (cfgProduct (envConfig env)) (deletePath request))
|
|
throwOperationError err503
|
|
(DeleteMutationRejected "database unavailable")
|
|
Right value -> pure value
|
|
result <- case outcome of
|
|
Left reason -> do
|
|
liftIO $ audit "delete" "failed"
|
|
(Just (unUserId (suUserId user)))
|
|
([ ("root", A.toJSON (rootLabel root))
|
|
, ("operation_id", A.toJSON (unOperationId operation))
|
|
, ("reason", A.String "object_store_unavailable")
|
|
] <> objectKeyAudit (cfgProduct (envConfig env)) (deletePath request))
|
|
throwOperationError err409 (DeleteMutationRejected reason)
|
|
Right value -> pure value
|
|
liftIO $ audit "delete" (mutationAuditResult result)
|
|
(Just (unUserId (suUserId user)))
|
|
([ ("root", A.toJSON (rootLabel root))
|
|
, ("operation_id", A.toJSON (unOperationId operation))
|
|
] <> mutationReasonFields result
|
|
<> objectKeyAudit (cfgProduct (envConfig env)) (deletePath request))
|
|
pure DeleteResponse
|
|
{ deleteResponseOperationId = operation
|
|
, deleteResponseResult = result
|
|
, deleteResponseIdempotencyWindowSeconds =
|
|
cfgIdempotencyWindowSec (cfgProduct (envConfig env))
|
|
}
|
|
|
|
handleDeleteBatchRequest
|
|
:: Env
|
|
-> SessionContext
|
|
-> DeleteBatchRequest
|
|
-> Handler DeleteBatchResponse
|
|
handleDeleteBatchRequest env session request = do
|
|
requireCsrf
|
|
"delete_batch"
|
|
DeletePrefixCsrfRejected
|
|
session
|
|
(deleteBatchCsrf request)
|
|
let items = deleteBatchItems request
|
|
when (null items || length items > cfgDeletePageSize (cfgProduct (envConfig env))) $ do
|
|
liftIO $ audit "delete_batch" "rejected"
|
|
(Just (unUserId (suUserId (sessionUser session))))
|
|
[ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
|
|
, ("reason", A.String "invalid_batch_size")
|
|
]
|
|
throwOperationError err409
|
|
(DeletePrefixMutationRejected "delete batch size is invalid")
|
|
results <- forM items $ \item -> do
|
|
deleteAttempt <- liftIO $ tryRecoveryDependency $
|
|
runDelete
|
|
env
|
|
(sessionUser session)
|
|
(deleteBatchRoot request)
|
|
(deleteBatchPath item)
|
|
(deleteBatchOperationId item)
|
|
let outcome = case deleteAttempt of
|
|
Left _ -> Left "database unavailable"
|
|
Right value -> value
|
|
failureReason = case deleteAttempt of
|
|
Left _ -> "database_unavailable"
|
|
Right (Left _) -> "object_store_unavailable"
|
|
Right (Right _) -> ""
|
|
liftIO $ audit "delete" (either (const "failed") mutationAuditResult outcome)
|
|
(Just (unUserId (suUserId (sessionUser session))))
|
|
([ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
|
|
, ("operation_id", A.toJSON
|
|
(unOperationId (deleteBatchOperationId item)))
|
|
] <> either
|
|
(const [("reason", A.String failureReason)])
|
|
mutationReasonFields
|
|
outcome
|
|
<> objectKeyAudit (cfgProduct (envConfig env)) (deleteBatchPath 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)
|