nuthatch/src/Nuthatch/Api.hs

module Nuthatch.Api
  ( Api
  , HealthEndpoint
  , ReadyEndpoint
  , AppEndpoint
  , StaticAssetsEndpoint
  , ProductApi
  , LoginEndpoint
  , LoginStart
  , OidcCallbackEndpoint
  , LoginSuccess
  , LogoutEndpoint
  , LogoutSuccess
  , DownloadSuccess
  , api
  , HTML
  , HtmlPage (..)
  , SessionContext (..)
  , SessionAuth
  , BrowsePrefix (..)
  , PaginationToken (..)
  , SearchQuery (..)
  , DeclaredSize (..)
  , HealthResponse (..)
  , ReadyResponse (..)
  , BrowseResponse (..)
  , DeleteRequest (..)
  , SessionResponse (..)
  , DeletePlanResponse (..)
  , DeleteBatchItem (..)
  , DeleteBatchRequest (..)
  , DeleteItemResponse (..)
  , DeleteBatchResponse (..)
  , 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)

data HTML
instance Accept HTML where
  contentType _ = "text" // "html" /: ("charset", "utf-8")

newtype HtmlPage = HtmlPage { unHtmlPage :: Text }
  deriving stock (Eq, Show)

instance MimeRender HTML HtmlPage where
  mimeRender _ = BL.fromStrict . TE.encodeUtf8 . unHtmlPage

data SessionContext = SessionContext
  { sessionUser :: SessionUser
  , sessionCsrf :: Maybe CsrfToken
  }
  deriving stock (Eq)

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 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 DeleteRequest = DeleteRequest
  { deleteRoot        :: Root
  , deletePath        :: RelativePath
  , deleteOperationId :: OperationId
  , deleteCsrf        :: CsrfToken
  }
  deriving stock (Eq)

instance FromJSON DeleteRequest where
  parseJSON = withObject "DeleteRequest" $ \o ->
    DeleteRequest
      <$> o .: "root"
      <*> o .: "path"
      <*> o .: "operation_id"
      <*> o .: "csrf"

data UploadResponse = UploadResponse
  { uploadResponseOperationId :: OperationId
  , uploadResponseResult      :: MutationResult
  , uploadResponseIdempotencyWindowSeconds :: Integer
  }
  deriving stock (Eq, Show)

instance ToJSON UploadResponse where
  toJSON response = object
    [ "operation_id" .= uploadResponseOperationId response
    , "result" .= mutationResultText (uploadResponseResult response)
    , "idempotency_window_seconds"
        .= uploadResponseIdempotencyWindowSeconds response
    ]

data DeleteResponse = DeleteResponse
  { deleteResponseOperationId :: OperationId
  , deleteResponseResult      :: MutationResult
  , deleteResponseIdempotencyWindowSeconds :: Integer
  }
  deriving stock (Eq, Show)

instance ToJSON DeleteResponse where
  toJSON response = object
    [ "operation_id" .= deleteResponseOperationId response
    , "result" .= mutationResultText (deleteResponseResult response)
    , "idempotency_window_seconds"
        .= deleteResponseIdempotencyWindowSeconds 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
  = OidcAuthorizationFailed
  | OidcCallbackRejected
  | SessionCreationFailed Text
  deriving stock (Eq, Show)

instance ToJSON LoginError where
  toJSON OidcAuthorizationFailed =
    errorValue "oidc_authorization_failed" "OIDC authorization could not start" Nothing
  toJSON OidcCallbackRejected =
    errorValue "oidc_callback_rejected" "OIDC callback validation failed" 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
  | DownloadRangeUnsupported
  | 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 DownloadRangeUnsupported =
    errorValue "range_not_supported" "Range downloads are not supported" 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

data SessionResponse = SessionResponse
  { sessionResponseUserId  :: UserId
  , sessionResponseDisplay :: Maybe Text
  , sessionResponseCsrf    :: CsrfToken
  }
  deriving stock (Eq)

instance ToJSON SessionResponse where
  toJSON response = object
    [ "user_id" .= sessionResponseUserId response
    , "display" .= sessionResponseDisplay response
    , "csrf" .= sessionResponseCsrf response
    ]

data DeletePlanResponse = DeletePlanResponse
  { deletePlanPaths        :: [RelativePath]
  , deletePlanContinuation :: Maybe PaginationToken
  }
  deriving stock (Eq, Show)

instance ToJSON DeletePlanResponse where
  toJSON response = object
    [ "paths" .= map unRelativePath (deletePlanPaths response)
    , "continuation" .= deletePlanContinuation response
    ]

data DeleteBatchItem = DeleteBatchItem
  { deleteBatchPath        :: RelativePath
  , deleteBatchOperationId :: OperationId
  }
  deriving stock (Eq, Show)

instance FromJSON DeleteBatchItem where
  parseJSON = withObject "DeleteBatchItem" $ \o ->
    DeleteBatchItem
      <$> o .: "path"
      <*> o .: "operation_id"

data DeleteBatchRequest = DeleteBatchRequest
  { deleteBatchRoot  :: Root
  , deleteBatchCsrf  :: CsrfToken
  , deleteBatchItems :: [DeleteBatchItem]
  }
  deriving stock (Eq)

instance FromJSON DeleteBatchRequest where
  parseJSON = withObject "DeleteBatchRequest" $ \o ->
    DeleteBatchRequest
      <$> o .: "root"
      <*> o .: "csrf"
      <*> o .: "items"

data DeleteItemResponse = DeleteItemResponse
  { deleteItemPath        :: RelativePath
  , deleteItemOperationId :: OperationId
  , deleteItemResult      :: Maybe MutationResult
  , deleteItemError       :: Maybe Text
  }
  deriving stock (Eq, Show)

instance ToJSON DeleteItemResponse where
  toJSON response = object
    [ "path" .= unRelativePath (deleteItemPath response)
    , "operation_id" .= deleteItemOperationId response
    , "result" .= fmap mutationResultText (deleteItemResult response)
    , "error" .= deleteItemError response
    ]

newtype DeleteBatchResponse = DeleteBatchResponse
  { deleteBatchResults :: [DeleteItemResponse]
  }
  deriving stock (Eq, Show)

instance ToJSON DeleteBatchResponse where
  toJSON response = object ["results" .= deleteBatchResults response]

errorValue :: Text -> Text -> Maybe Value -> Value
errorValue code message details = object
  [ "error" .= code
  , "message" .= message
  , "details" .= details
  ]

type HealthEndpoint =
  "healthz" :> Get '[JSON] HealthResponse

type ReadyEndpoint =
  "readyz" :> Throws ReadyError :> Get '[JSON] ReadyResponse

type AppEndpoint =
  "app"
    :> AuthProtect SessionAuth
    :> Throws AuthenticationError
    :> Get '[HTML]
      (Headers '[Header "Content-Security-Policy" Text] HtmlPage)

type StaticAssetsEndpoint =
  "assets"
    :> AuthProtect SessionAuth
    :> Throws AuthenticationError
    :> Raw

type LoginStart =
  Headers
    '[ Header "Set-Cookie" Text
     , Header "Location" Text
     ]
    NoContent

type LoginEndpoint =
  "login"
    :> Throws LoginError
    :> Verb 'GET 303 '[JSON] LoginStart

type LoginSuccess =
  Headers
    '[ Header "Set-Cookie" Text
     , Header "Set-Cookie" Text
     , Header "Set-Cookie" Text
     , Header "Location" Text
     ]
    NoContent

type OidcCallbackEndpoint =
  "oidc"
    :> "callback"
    :> Throws LoginError
    :> QueryParam' '[Required, Strict] "code" Text
    :> QueryParam' '[Required, Strict] "state" Text
    :> Header' '[Required, Strict] "Cookie" Text
    :> Verb 'GET 303 '[JSON] LoginSuccess

type LogoutSuccess =
  Headers
    '[ Header "Set-Cookie" Text
     , 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 DownloadSuccess =
  Headers
    '[ Header "Content-Disposition" Text
     , Header "X-Content-Type-Options" Text
     , Header "Content-Security-Policy" Text
     , Header "Content-Length" Integer
     ]
    (SourceIO BS.ByteString)

type ProductApi =
  "api" :>
    (    "session"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Get '[JSON] SessionResponse
    :<|> "browse"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws BrowseError
           :> QueryParam "root" Root
           :> QueryParam "prefix" BrowsePrefix
           :> QueryParam "q" SearchQuery
           :> QueryParam "continuation" PaginationToken
           :> Get '[JSON] BrowseResponse
    :<|> "download"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws DownloadError
           :> QueryParam' '[Required, Strict] "root" Root
           :> QueryParam' '[Required, Strict] "path" RelativePath
           :> Header "Range" Text
           :> StreamGet NoFraming OctetStream DownloadSuccess
    :<|> "upload"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws UploadError
           :> QueryParam' '[Required, Strict] "root" Root
           :> QueryParam' '[Required, Strict] "path" RelativePath
           :> QueryParam' '[Required, Strict] "operation_id" OperationId
           :> Header' '[Required, Strict] "X-Declared-Size" DeclaredSize
           :> Header' '[Required, Strict] "X-Content-SHA256" ContentSha256
           :> Header' '[Required, Strict] "X-CSRF-Token" CsrfToken
           :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString)
           :> Post '[JSON] UploadResponse
    :<|> "delete"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws DeleteError
           :> ReqBody '[JSON] DeleteRequest
           :> Post '[JSON] DeleteResponse
    :<|> "delete-plan"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws DeletePrefixError
           :> QueryParam' '[Required, Strict] "root" Root
           :> QueryParam' '[Required, Strict] "path" RelativePath
           :> QueryParam "continuation" PaginationToken
           :> Get '[JSON] DeletePlanResponse
    :<|> "delete-batch"
           :> AuthProtect SessionAuth
           :> Throws AuthenticationError
           :> Throws DeletePrefixError
           :> ReqBody '[JSON] DeleteBatchRequest
           :> Post '[JSON] DeleteBatchResponse
    )

type Api =
       HealthEndpoint
  :<|> ReadyEndpoint
  :<|> AppEndpoint
  :<|> StaticAssetsEndpoint
  :<|> LoginEndpoint
  :<|> OidcCallbackEndpoint
  :<|> LogoutEndpoint
  :<|> ProductApi

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)

mutationResultText :: MutationResult -> Text
mutationResultText MutationPending   = "pending"
mutationResultText MutationSucceeded = "succeeded"
mutationResultText MutationFailed    = "failed"
mutationResultText MutationRejected  = "rejected"
mutationResultText MutationConflict  = "conflict"