nuthatch/src/Nuthatch/Http/Server.hs

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)