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"