{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- 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 Data.Misc
  ( -- * IpAddr / Port
    IpAddr (..),
    Port (..),
    IpAddrRange (..),
    addrMatchesRange,

    -- * Location
    Latitude (..),
    Longitude (..),

    -- * Time
    Milliseconds (..),
    msToInt64,
    int64ToMs,
    Duration (..),
    DurationLiteral,
    durationLiteralText,
    durationLiteralValue,
    diffTimeParser,
    parseDuration,
    unsafeParseDuration,
    mkDurationLiteral,
    unsafeDurationLiteral,
    durationToMicros,
    durationToCeilingSeconds,

    -- * HttpsUrl
    HttpsUrl (..),
    mkHttpsUrl,
    ensureHttpsUrl,
    httpsUrlToText,
    httpsUrlFromText,

    -- * Url
    Url (..),
    urlToText,
    urlFromText,

    -- * Fingerprint
    Fingerprint (..),
    Rsa,

    -- * PlainTextPassword6
    PlainTextPassword' (..),
    PlainTextPassword6,
    PlainTextPassword8,
    plainTextPassword6,
    fromPlainTextPassword,
    plainTextPassword8Unsafe,
    plainTextPassword6Unsafe,

    -- * Typesafe FUTUREWORKS
    FutureWork (..),
    from64,
    readT,
    showT,
  )
where

import Cassandra
import Control.Lens ((.~), (?~), (^.))
import Data.Aeson (FromJSON (..), ToJSON (..), withText)
import Data.Aeson qualified as A
import Data.Aeson.Types qualified as A
import Data.Attoparsec.ByteString.Char8 qualified as Chars
import Data.Attoparsec.Text (Parser)
import Data.Attoparsec.Text qualified as Atto
import Data.Bifunctor (Bifunctor (first))
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Builder
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Conversion
import Data.ByteString.Lazy (toStrict)
import Data.Hashable
import Data.IP
import Data.OpenApi qualified as S
import Data.Range
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Data.Time
import GHC.TypeLits (Nat)
import GHC.TypeNats (KnownNat)
import Imports
import Polysemy.Time
import Polysemy.Time.Data.TimeUnit
import Servant (FromHttpApiData (..))
import Test.QuickCheck (Arbitrary (arbitrary), chooseInteger)
import Test.QuickCheck qualified as QC
import Text.Read (Read (..))
import URI.ByteString hiding (Port, portNumber)
import URI.ByteString.QQ qualified as URI.QQ

--------------------------------------------------------------------------------
-- Orphans

deriving anyclass instance Hashable IP

deriving anyclass instance Hashable IPv4

deriving anyclass instance Hashable IPv6

--------------------------------------------------------------------------------
-- IpAddr / Port

newtype IpAddr = IpAddr {ipAddr :: IP}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (Hashable)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema IpAddr)

instance S.ToParamSchema IpAddr where
  toParamSchema _ = mempty & S.type_ ?~ S.OpenApiString

instance FromHttpApiData IpAddr where
  parseQueryParam p = first Text.pack (runParser parser (encodeUtf8 p))

instance FromByteString IpAddr where
  parser = do
    s <- Chars.takeWhile1 (not . isSpace)
    case readMaybe (unpack s) of
      Nothing -> fail "Failed parsing bytestring as IpAddr."
      Just ip -> pure (IpAddr ip)

instance ToByteString IpAddr where
  builder = string8 . show . ipAddr

instance Read IpAddr where
  readPrec = IpAddr <$> readPrec

instance NFData IpAddr where rnf (IpAddr a) = seq a ()

instance Arbitrary IpAddr where
  arbitrary = IpAddr <$> QC.oneof [IPv4 <$> genIPv4, IPv6 <$> genIPv6]
    where
      genIPv4 = toIPv4 <$> replicateM 4 genByte
      genIPv6 = toIPv6b <$> replicateM 16 genByte
      genByte = QC.chooseInt (0, 255)

newtype Port = Port
  {portNumber :: Word16}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (Real, Enum, Num, Integral, NFData, Arbitrary)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Port)

instance Read Port where
  readsPrec n = map (first Port) . readsPrec n

instance ToSchema IpAddr where
  schema = toText .= parsedText "IpAddr" fromText
    where
      toText :: IpAddr -> Text
      toText = decodeUtf8With lenientDecode . toStrict . toByteString

      fromText :: Text -> Either String IpAddr
      fromText =
        maybe (Left "Failed parsing IP address.") Right
          . fromByteString
          . encodeUtf8

instance ToSchema Port where
  schema = Port <$> portNumber .= schema

newtype IpAddrRange = IpAddrRange {ipAddrRange :: IPRange}
  deriving stock (Eq, Ord, Show, Generic)
  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema IpAddrRange)

instance ToSchema IpAddrRange where
  schema = toText .= parsedText "IpAddrRange" fromText
    where
      toText :: IpAddrRange -> Text
      toText = Text.pack . show . ipAddrRange

      fromText :: Text -> Either String IpAddrRange
      fromText =
        maybe (Left "Failed to parse IP Address Range") (Right . IpAddrRange)
          . readMaybe
          . Text.unpack

addrMatchesRange :: IpAddr -> IpAddrRange -> Bool
addrMatchesRange (IpAddr unwrappedIp) (IpAddrRange unwrappedRange) =
  go unwrappedIp unwrappedRange
  where
    go (IPv4 ip) (IPv4Range range) = ip `isMatchedTo` range
    go (IPv6 ip) (IPv6Range range) = ip `isMatchedTo` range
    go (IPv6 ipv6) (IPv4Range rangev4) = ipv6 `isMatchedTo` ipv4RangeToIPv6 rangev4
    go (IPv4 ipv4) (IPv6Range rangev6) = ipv4ToIPv6 ipv4 `isMatchedTo` rangev6

--------------------------------------------------------------------------------
-- Location

-- FUTUREWORK: why not use these in 'Location'?
newtype Latitude = Latitude Double
  deriving newtype (NFData)
  deriving stock (Generic)

newtype Longitude = Longitude Double
  deriving newtype (NFData)
  deriving stock (Generic)

instance Cql Latitude where
  ctype = Tagged DoubleColumn

  toCql (Latitude x) = CqlDouble x

  fromCql (CqlDouble x) = pure (Latitude x)
  fromCql _ = Left "Latitude: Expected CqlDouble."

instance Cql Longitude where
  ctype = Tagged DoubleColumn

  toCql (Longitude x) = CqlDouble x

  fromCql (CqlDouble x) = pure (Longitude x)
  fromCql _ = Left "Longitude: Expected CqlDouble."

--------------------------------------------------------------------------------
-- Time

newtype Milliseconds = Ms
  { ms :: Word64
  }
  deriving stock (Eq, Ord, Show, Generic)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema Milliseconds
  deriving newtype (Num)

-- only generate values which can be represented exactly by double
-- precision floating points
instance Arbitrary Milliseconds where
  arbitrary = Ms . fromIntegral <$> chooseInteger (0 :: Integer, 2 ^ (53 :: Int))

-- | Convert milliseconds to 'Int64', with clipping if it doesn't fit.
msToInt64 :: Milliseconds -> Int64
msToInt64 = fromIntegral . min (fromIntegral (maxBound @Int64)) . ms

-- | Convert 'Int64' to milliseconds, rounding negative values to 0.
int64ToMs :: Int64 -> Milliseconds
int64ToMs = Ms . fromIntegral . max 0

instance ToSchema Milliseconds where
  schema = int64ToMs <$> msToInt64 .= schema

instance Cql Milliseconds where
  ctype = Tagged BigIntColumn
  toCql = CqlBigInt . msToInt64
  fromCql = \case
    CqlBigInt i -> pure $ int64ToMs i
    _ -> Left "Milliseconds: expected CqlBigInt"

newtype Duration = Duration {duration :: DiffTime}
  deriving (Eq, Show)

data DurationLiteral = DurationLiteral
  { durationLiteralText :: Text,
    durationLiteralValue :: Duration
  }
  deriving stock (Show, Eq, Generic)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema DurationLiteral

instance TimeUnit Duration where
  nanos = NanoSeconds 1_000_000_000

  toNanos (Duration dt) =
    NanoSeconds . fromInteger $
      diffTimeToPicoseconds dt `div` 1_000

  fromNanos (NanoSeconds ns) =
    Duration $ picosecondsToDiffTime (fromIntegral ns * 1_000)

diffTimeParser :: Parser DiffTime
diffTimeParser = do
  n :: DiffTime <- Atto.rational
  mult <-
    ("us" $> 1e-6)
      <|> ("ms" $> 1e-3)
      <|> ("s" $> 1)
      <|> ("m" $> 60)
      <|> ("h" $> 3600)
      <|> ("d" $> 86400)
      <|> ("w" $> 604800)
  pure $ n * mult

parseDuration :: Text -> Either String Duration
parseDuration = fmap Duration . Atto.parseOnly (diffTimeParser <* Atto.endOfInput)

mkDurationLiteral :: Text -> Either String DurationLiteral
mkDurationLiteral txt = DurationLiteral txt <$> parseDuration txt

-- | Build a 'DurationLiteral' without checking that the textual literal parses
-- to the supplied duration. Use only for trusted/generated literals.
unsafeDurationLiteral :: Text -> Duration -> DurationLiteral
unsafeDurationLiteral = DurationLiteral

unsafeParseDuration :: Text -> Duration
unsafeParseDuration txt =
  either
    (\err -> error $ "Malformed duration: " <> show txt <> " " <> err)
    id
    (parseDuration txt)

-- | Useful for threadDelay, timeout, etc.
durationToMicros :: Duration -> Int
durationToMicros =
  fromInteger . flip div 1_000_000 . diffTimeToPicoseconds . duration

-- | Convert a 'Duration' to whole seconds, rounding up and clamping a bounded integral type.
-- Non-positive durations map to zero.
durationToCeilingSeconds :: forall a. (Bounded a, Integral a) => Duration -> a
durationToCeilingSeconds d
  | duration d <= 0 = 0
  | otherwise =
      fromInteger $
        min
          (toInteger (maxBound :: a))
          (ceiling (duration d) :: Integer)

instance FromJSON Duration where
  parseJSON = withText "Duration" $ either fail pure . parseDuration

instance ToSchema DurationLiteral where
  schema = durationLiteralText .= schema @Text `withParser` parseDurationLiteral

instance Arbitrary DurationLiteral where
  arbitrary = do
    n :: Double <-
      QC.frequency
        [ (8, fromInteger <$> chooseInteger (0, 10_000)),
          (2, (/ 10) . fromInteger <$> chooseInteger (0, 1_000))
        ]
    unit <-
      QC.elements
        [ "us",
          "ms",
          "s",
          "m",
          "h",
          "d",
          "w"
        ]
    let textValue = Text.pack (show n) <> unit
    either (error . ("Invalid generated DurationLiteral: " <>)) pure $
      mkDurationLiteral textValue

parseDurationLiteral :: Text -> A.Parser DurationLiteral
parseDurationLiteral = either fail pure . mkDurationLiteral

--------------------------------------------------------------------------------
-- HttpsUrl

newtype HttpsUrl = HttpsUrl
  { httpsUrl :: URIRef Absolute
  }
  deriving stock (Eq, Ord, Generic)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema HttpsUrl

mkHttpsUrl :: URIRef Absolute -> Either String HttpsUrl
mkHttpsUrl uri =
  if uri ^. uriSchemeL . schemeBSL == "https"
    then Right $ HttpsUrl uri
    else Left $ "Non-HTTPS URL: " ++ show uri

ensureHttpsUrl :: URIRef Absolute -> HttpsUrl
ensureHttpsUrl = HttpsUrl . (uriSchemeL . schemeBSL .~ "https")

httpsUrlToText :: HttpsUrl -> Text
httpsUrlToText = decodeUtf8 . toByteString'

httpsUrlFromText :: Text -> Either String HttpsUrl
httpsUrlFromText = runParser parser . encodeUtf8

instance Show HttpsUrl where
  showsPrec i = showsPrec i . httpsUrl

instance ToByteString HttpsUrl where
  builder = serializeURIRef . httpsUrl

instance FromByteString HttpsUrl where
  parser = either fail pure . mkHttpsUrl =<< uriParser strictURIParserOptions

instance ToSchema HttpsUrl where
  schema =
    httpsUrlToText
      .= parsedText "HttpsUrl" httpsUrlFromText
      & doc'
        . S.schema
        . S.example
        ?~ toJSON ("https://example.com" :: Text)

instance Cql HttpsUrl where
  ctype = Tagged BlobColumn
  toCql = CqlBlob . toByteString

  fromCql (CqlBlob t) = runParser parser (toStrict t)
  fromCql _ = Left "HttpsUrl: Expected CqlBlob"

instance Arbitrary HttpsUrl where
  arbitrary = pure $ HttpsUrl [URI.QQ.uri|https://example.com|]

--------------------------------------------------------------------------------
-- Url

-- | An absolute URL
newtype Url = Url
  { unUrl :: URIRef Absolute
  }
  deriving stock (Eq, Ord, Generic)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema Url

instance ToSchema Url where
  schema =
    urlToText
      .= parsedText "Url" urlFromText
      & doc'
        . S.schema
        . S.example
        ?~ toJSON ("http://example.com" :: Text)

urlToText :: Url -> Text
urlToText = decodeUtf8 . toByteString'

urlFromText :: Text -> Either String Url
urlFromText = runParser parser . encodeUtf8

instance FromByteString Url where
  parser = Url <$> uriParser strictURIParserOptions

instance ToByteString Url where
  builder = serializeURIRef . unUrl

--------------------------------------------------------------------------------
-- Fingerprint

-- Tag for Rsa encoded fingerprints
data Rsa

newtype Fingerprint a = Fingerprint
  { fingerprintBytes :: ByteString
  }
  deriving stock (Eq, Show, Generic, Typeable)
  deriving newtype (FromByteString, ToByteString, NFData)

deriving via
  (Schema (Fingerprint a))
  instance
    (ToSchema (Fingerprint a)) =>
    ToJSON (Fingerprint a)

deriving via
  (Schema (Fingerprint a))
  instance
    (ToSchema (Fingerprint a)) =>
    FromJSON (Fingerprint a)

deriving via
  (Schema (Fingerprint a))
  instance
    (Typeable (Fingerprint a), ToSchema (Fingerprint a)) =>
    S.ToSchema (Fingerprint a)

instance ToSchema (Fingerprint Rsa) where
  schema =
    (decodeUtf8 . B64.encode . fingerprintBytes)
      .= parsedText "Fingerprint" (runParser p . encodeUtf8)
      & doc'
        . S.schema
        . S.example
        ?~ toJSON ("ioy3GeIjgQRsobf2EKGO3O8mq/FofFxHRqy0T4ERIZ8=" :: Text)
    where
      p :: Chars.Parser (Fingerprint Rsa)
      p = do
        bs <- parser
        either fail (pure . Fingerprint) (B64.decode bs)

instance Cql (Fingerprint a) where
  ctype = Tagged BlobColumn
  toCql = CqlBlob . toByteString

  fromCql (CqlBlob b) = pure (Fingerprint (toStrict b))
  fromCql _ = Left "Fingerprint: Expected CqlBlob"

instance Arbitrary (Fingerprint Rsa) where
  arbitrary =
    pure $
      Fingerprint
        "\138\140\183\EM\226#\129\EOTl\161\183\246\DLE\161\142\220\239&\171\241h|\\GF\172\180O\129\DC1!\159"

--------------------------------------------------------------------------------
-- Password

type PlainTextPassword6 = PlainTextPassword' (6 :: Nat)

type PlainTextPassword8 = PlainTextPassword' (8 :: Nat)

plainTextPassword6 :: Text -> Maybe PlainTextPassword6
plainTextPassword6 = fmap PlainTextPassword' . checked

plainTextPassword6Unsafe :: Text -> PlainTextPassword6
plainTextPassword6Unsafe = PlainTextPassword' . unsafeRange

plainTextPassword8Unsafe :: Text -> PlainTextPassword8
plainTextPassword8Unsafe = PlainTextPassword' . unsafeRange

fromPlainTextPassword :: PlainTextPassword' t -> Text
fromPlainTextPassword = fromRange . fromPlainTextPassword'

newtype PlainTextPassword' (minLen :: Nat) = PlainTextPassword'
  {fromPlainTextPassword' :: Range minLen (1024 :: Nat) Text}
  deriving stock (Eq, Generic)

deriving via (Schema (PlainTextPassword' tag)) instance (ToSchema (PlainTextPassword' tag)) => FromJSON (PlainTextPassword' tag)

deriving via (Schema (PlainTextPassword' tag)) instance (ToSchema (PlainTextPassword' tag)) => ToJSON (PlainTextPassword' tag)

deriving via (Schema (PlainTextPassword' tag)) instance (KnownNat tag, ToSchema (PlainTextPassword' tag)) => S.ToSchema (PlainTextPassword' tag)

instance Show (PlainTextPassword' minLen) where
  show _ = "PlainTextPassword' <hidden>"

instance (KnownNat (n :: Nat), Within Text n 1024) => ToSchema (PlainTextPassword' n) where
  schema = PlainTextPassword' <$> fromPlainTextPassword' .= schema

instance (KnownNat (n :: Nat), Within Text n 1024) => Arbitrary (PlainTextPassword' n) where
  arbitrary = PlainTextPassword' <$> arbitrary

-- | Usage:
-- 1. Use this type in patterns to mark FUTUREWORKS.
-- 2. Remove the label constructor -> all futureworks become compiler errors
--
-- Example:
-- >>> let (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteUsers, localUsers)
-- >>>      = partitionQualified domain qualifiedUids
newtype FutureWork label payload = FutureWork payload

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

-- | Same as 'read' but works on 'Text'
readT :: (Read a) => Text -> Maybe a
readT = readMaybe . Text.unpack
{-# INLINE readT #-}

-- | Same as 'show' but works on 'Text'
showT :: (Show a) => a -> Text
showT = Text.pack . show
{-# INLINE showT #-}

-- | Decodes a base64 'Text' to a regular 'ByteString' (if possible)
from64 :: Text -> Either String ByteString
from64 = B64.decode . encodeUtf8
{-# INLINE from64 #-}
