fcmtp-data/src/Data/SMTP/Crypto/Types/CP.hs

{- |
fCMTP capabilities.
-}
module Data.SMTP.Crypto.Types.CP where

import Data.ByteString (ByteString)
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Data.SMTP.Resource as Resc
import Crypto.Error (maybeCryptoError)
import Data.Maybe
import qualified Text.Read as Read

data Algo = Sha3_512Ed25519 deriving (Eq, Ord, Bounded, Enum)
instance Show Algo where
  show Sha3_512Ed25519 = "SHA3_512-ED25519"
instance Read.Read Algo where
  readsPrec _ str = catMaybes $ map (tryRead str) [minBound..maxBound]
    where
      tryRead input test = let
        txt = show test
        firstIn = take (length txt) input
        lastIn = drop (length txt) input
        in if firstIn == txt then Just (test, lastIn) else Nothing
  

data SCP = SCPSha3_512Ed25519 ByteString Ed25519.PublicKey
         | SAll

revocationHeader :: String
revocationHeader = "CP-Revoked"

publicHeader :: String
publicHeader = "CP-Grant-All"

algoHeader :: String
algoHeader = "CP-Algorithm"

sharedKeyHeader :: String
sharedKeyHeader = "CP-Shared-Key"

idHeader :: String
idHeader = "CP-Id"

sFromHeaders :: Resc.PlainHeaders -> Maybe SCP
sFromHeaders hh = let
  shh = Resc.sealed hh
  pbc = fromMaybe False $ Resc.getBooleanHeader shh publicHeader
  revoked = fromMaybe False $ Resc.getBooleanHeader shh revocationHeader
  in
  if revoked then Nothing
  else
    if pbc then Just SAll
    else do
      algo <- Resc.getReadHeader shh algoHeader
      sh' <- Resc.getBase64Header shh sharedKeyHeader
      sh <- maybeCryptoError . Ed25519.publicKey $ sh'
      cid <- Resc.getBase64Header shh idHeader
      case algo of
        Sha3_512Ed25519 -> pure $ SCPSha3_512Ed25519 cid sh