Split application orchestration by responsibility
This commit is contained in:
parent
f28810ea33
commit
37a7a55bfe
1 changed files with 1545 additions and 1265 deletions
256
src/Nuthatch/Http/Server.hs
Normal file
256
src/Nuthatch/Http/Server.hs
Normal file
|
|
@ -0,0 +1,256 @@
|
|||
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 (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 (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 (envConfig env) (deletePath request))
|
||||
pure DeleteResponse
|
||||
{ deleteResponseOperationId = operation
|
||||
, deleteResponseResult = result
|
||||
, deleteResponseIdempotencyWindowSeconds =
|
||||
cfgIdempotencyWindowSec (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 (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 (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)
|
||||
Loading…
Reference in a new issue