content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PackageImports #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  -- 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.ETag
    ( Digest (..),
      Opaque,
      opaqueMD5,
      opaqueSHA1,
      _OpaqueDigest,
      opaqueDigest,
      ETag,
      _StrictETag,
      _WeakETag,
      strictETag,
      weakETag,
    )
  where
  
  import Control.Applicative (optional)
  import Control.Lens
  -- TODO: These package imports are only needed due to the
  -- use of GHCI. They should be removed by moving everything
  -- from cryptohash (which is deprecated) to cryptonite
  
  import Data.Attoparsec.ByteString.Char8
  import Data.ByteString.Base16 qualified as Hex
  import Data.ByteString.Builder (byteString)
  import Data.ByteString.Conversion
  import Imports hiding (takeWhile)
  import "cryptohash-md5" Crypto.Hash.MD5 qualified as MD5
  import "cryptohash-sha1" Crypto.Hash.SHA1 qualified as SHA1
  
  data Digest = MD5 | SHA1
  
  -- | The \"opaque-tag\" (RFC 7232) portion of an 'ETag' calculated using some
  -- hashing algorithm.
  --
  -- The actual hashing is delayed until the 'ETag' is serialised into a
  -- 'ByteString' (via the 'ToByteString' instance). Useful as a convenience and
  -- to compose values into an 'ETag' via the 'Semigroup' instance.
  --
  -- prop> \x y -> toByteString (opaqueMD5 (x :: Int) <> opaqueMD5 (y :: String)) === toByteString (opaqueMD5 (builder x <> builder y))
  --
  -- Ie. concatenating two 'Opaque d' values is the same as converting two values
  -- of arbitrary types to a 'Builder', concatenating them, and applying the hash
  -- function on the result.
  data Opaque (d :: Digest) where
    Opaque :: (ToByteString a) => a -> Opaque d
  
  instance ToByteString (Opaque 'MD5) where
    builder (Opaque x) =
      byteString . Hex.encode . MD5.hashlazy . toByteString $ x
  
  instance ToByteString (Opaque 'SHA1) where
    builder (Opaque x) =
      byteString . Hex.encode . SHA1.hashlazy . toByteString $ x
  
  instance Semigroup (Opaque d) where
    Opaque a <> Opaque b = Opaque (builder a <> builder b)
  
  opaqueMD5 :: (ToByteString a) => a -> Opaque 'MD5
  opaqueMD5 = Opaque
  {-# INLINE opaqueMD5 #-}
  
  opaqueSHA1 :: (ToByteString a) => a -> Opaque 'SHA1
  opaqueSHA1 = Opaque
  {-# INLINE opaqueSHA1 #-}
  
  -- | Adjust the digest algorithm of an 'Opaque' value, as an 'Iso'
  _OpaqueDigest :: Iso' (Opaque a) (Opaque b)
  _OpaqueDigest = iso opaqueDigest opaqueDigest
  {-# INLINE _OpaqueDigest #-}
  
  -- | Adjust the digest algorithm of an 'Opaque' value
  opaqueDigest :: Opaque a -> Opaque b
  opaqueDigest (Opaque x) = Opaque x
  {-# INLINE opaqueDigest #-}
  
  data ETag a
    = StrictETag !a
    | WeakETag !a
    deriving (Eq, Show)
  
  instance (ToByteString a) => ToByteString (ETag a) where
    builder (StrictETag v) = byteString "\"" <> builder v <> byteString "\""
    builder (WeakETag v) = byteString "W/\"" <> builder v <> byteString "\""
  
  instance (FromByteString a) => FromByteString (ETag a) where
    parser = do
      w <- optional (string "W/")
      v <- char '"' *> takeWhile (/= '"') <* char '"'
      case runParser parser v of
        Left e -> fail e
        Right a -> pure $ maybe (StrictETag a) (const $ WeakETag a) w
  
  instance (Semigroup a) => Semigroup (ETag a) where
    StrictETag a <> StrictETag b = StrictETag (a <> b)
    StrictETag a <> WeakETag b = WeakETag (a <> b)
    WeakETag a <> StrictETag b = WeakETag (a <> b)
    WeakETag a <> WeakETag b = WeakETag (a <> b)
  
  makePrisms ''ETag
  
  strictETag :: a -> ETag a
  strictETag = StrictETag
  {-# INLINE strictETag #-}
  
  weakETag :: a -> ETag a
  weakETag = WeakETag
  {-# INLINEABLE weakETag #-}
  