CryptoCipherTypes.hs

-- CryptoCipherTypes.hs: shim for crypto-cipher-types stuff (current nettle)
-- Copyright © 2016-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes
    ( HOWrappedOldCCT (..)
    ) where

import Control.Error.Util (note)
import Data.Bifunctor (bimap)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT
import qualified "crypton" Crypto.Cipher.Types as CCT

import Codec.Encryption.OpenPGP.Internal.HOBlockCipher
import Codec.Encryption.OpenPGP.Types.Internal.Errors
    ( CipherError (..)
    )

newtype HOWrappedOldCCT a
    = HWOCCT a

instance
    OldCCT.BlockCipher cipher
    => HOBlockCipher (HOWrappedOldCCT cipher)
    where
    cipherInit key =
        let keyBS = BA.convert key :: B.ByteString
         in bimap
                (const (CipherOldInitFailed "nettle invalid key"))
                (HWOCCT . OldCCT.cipherInit)
                (OldCCT.makeKey keyBS)
    cipherName (HWOCCT c) = OldCCT.cipherName c
    cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c
    blockSize (HWOCCT c) = OldCCT.blockSize c
    ecbEncrypt (HWOCCT c) bs = Right (OldCCT.ecbEncrypt c bs)
    ecbDecrypt (HWOCCT c) bs = Right (OldCCT.ecbDecrypt c bs)
    cfbEncrypt (HWOCCT c) iv bs =
        hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)
    cfbDecrypt (HWOCCT c) iv bs =
        hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)
    paddedCfbEncrypt _ _ _ =
        Left CipherPaddingUnsupported
    paddedCfbDecrypt (HWOCCT cipher) iv ciphertext =
        hammerIV iv >>= \i ->
            return
                (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))
      where
        padded =
            ciphertext
                `B.append` B.pack
                    ( replicate
                        ( OldCCT.blockSize cipher
                            - (B.length ciphertext `mod` OldCCT.blockSize cipher)
                        )
                        0
                    )
    aeadInit mode (HWOCCT c) iv =
        case OldCCT.aeadInit (convertMode mode) c iv of
            Nothing -> Left CipherAEADModeUnsupported
            Just (OldCCT.AEAD _ (OldCCT.AEADState st)) ->
                Right (CCT.AEAD (bridgeImpl c) st)
    aeadSimpleEncrypt aead aad pt plen =
        CCT.aeadSimpleEncrypt aead aad pt plen
    aeadSimpleDecrypt aead aad ct tag =
        CCT.aeadSimpleDecrypt aead aad ct tag

convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier
convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b
convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as
convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a

convertMode :: CCT.AEADMode -> OldCCT.AEADMode
convertMode CCT.AEAD_GCM = OldCCT.AEAD_GCM
convertMode (CCT.AEAD_CCM 0 CCT.CCM_M16 CCT.CCM_L2) = OldCCT.AEAD_CCM
convertMode _ = OldCCT.AEAD_GCM

bridgeImpl
    :: OldCCT.AEADModeImpl cipher st => cipher -> CCT.AEADModeImpl st
bridgeImpl c =
    CCT.AEADModeImpl
        { CCT.aeadImplAppendHeader = \st' ba -> OldCCT.aeadStateAppendHeader c st' (BA.convert ba)
        , CCT.aeadImplEncrypt = \st' ba ->
            let (ct, st'') = OldCCT.aeadStateEncrypt c st' (BA.convert ba)
             in (BA.convert ct, st'')
        , CCT.aeadImplDecrypt = \st' ba ->
            let (pt, st'') = OldCCT.aeadStateDecrypt c st' (BA.convert ba)
             in (BA.convert pt, st'')
        , CCT.aeadImplFinalize = \st' plen ->
            let OldCCT.AuthTag bs = OldCCT.aeadStateFinalize c st' plen
             in CCT.AuthTag (BA.convert bs)
        }

hammerIV
    :: OldCCT.BlockCipher cipher
    => B.ByteString -> Either CipherError (OldCCT.IV cipher)
hammerIV = note (CipherBadIV "nettle") . OldCCT.makeIV