{-# LANGUAGE StrictData #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Wire.API.Password
  ( Password (..),
    PasswordReqBody (..),

    -- * Misc
    genPassword,

    -- * Only for testing
    parsePassword,
  )
where

import Cassandra hiding (params)
import Data.Aeson qualified as A
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Misc
import Data.OpenApi qualified as S
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Imports
import OpenSSL.Random (randBytes)
import Wire.API.Password.Argon2id
import Wire.API.Password.Scrypt
import Wire.API.PostgresMarshall

-- | A derived, stretched password that can be safely stored.
data Password
  = Argon2Password Argon2HashedPassword
  | ScryptPassword ScryptHashedPassword

instance Show Password where
  show _ = "<Password>"

-------------------------------------------------------------------------------
-- PSQL

instance PostgresMarshall ByteString Password where
  postgresMarshall =
    Text.encodeUtf8 . \case
      Argon2Password p -> encodeArgon2HashedPassword p
      ScryptPassword p -> encodeScryptPassword p

instance PostgresUnmarshall ByteString Password where
  postgresUnmarshall =
    mapLeft Text.pack . parsePassword . Text.decodeUtf8

-------------------------------------------------------------------------------
-- CQL

instance Cql Password where
  ctype = Tagged BlobColumn

  fromCql (CqlBlob lbs) = parsePassword . Text.decodeUtf8 . toStrict $ lbs
  fromCql _ = Left "password: expected blob"

  toCql = CqlBlob . fromStrict . Text.encodeUtf8 . postgresMarshall

instance PostgresMarshall Text Password where
  postgresMarshall = \case
    Argon2Password argon2pw -> encodeArgon2HashedPassword argon2pw
    ScryptPassword scryptpw -> encodeScryptPassword scryptpw

instance PostgresUnmarshall Text Password where
  postgresUnmarshall = mapLeft Text.pack . parsePassword

-------------------------------------------------------------------------------

parsePassword :: Text -> Either String Password
parsePassword expected =
  case parseArgon2idPasswordHashOptions expected of
    Right hashedPassword -> Right $ Argon2Password hashedPassword
    Left argon2ParseError ->
      case parseScryptPasswordHashParams $ Text.encodeUtf8 expected of
        Right hashedPassword -> Right $ ScryptPassword hashedPassword
        Left scryptParseError ->
          Left $
            "Failed to parse Argon2 or Scrypt. Argon2 parse error: "
              <> argon2ParseError
              <> ", Scrypt parse error: "
              <> scryptParseError

--------------------------------------------------------------------------------
-- Type that can be used to pass a plaintext password as a request body

newtype PasswordReqBody = PasswordReqBody
  {fromPasswordReqBody :: Maybe PlainTextPassword6}
  deriving stock (Eq, Show)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via Schema PasswordReqBody

instance ToSchema PasswordReqBody where
  schema =
    object $
      PasswordReqBody
        <$> fromPasswordReqBody .= maybe_ (optField "password" schema)

--------------------------------------------------------------------------------

-- | Generate a strong, random plaintext password of length 16
-- containing only alphanumeric characters, '+' and '/'.
genPassword :: (MonadIO m) => m PlainTextPassword8
genPassword =
  liftIO . fmap (plainTextPassword8Unsafe . Text.decodeUtf8 . B64.encode) $
    randBytes 12
