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

-- | Capability algorithms
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
  
-- | Public capabilities data
data PCP = PCPSha3_512Ed25519 ByteString Ed25519.PublicKey
         | PAll deriving (Show)

-- | The fCMTP CP revocation header: "CP-Revoked"
revocationHeader :: String
revocationHeader = "CP-Revoked"

-- | The fCMTP header for public access: "CP-Grant-All"
publicHeader :: String
publicHeader = "CP-Grant-All"

-- | The fCMTP CP algorithm header: "CP-Algorithm"
algoHeader :: String
algoHeader = "CP-Algorithm"

-- | The fCMTP CP shared key header: "CP-Shared-Key"
sharedKeyHeader :: String
sharedKeyHeader = "CP-Shared-Key"

-- | The fMCTP CP id header: "CP-Id"
idHeader :: String
idHeader = "CP-Id"

sFromHeaders :: Resc.PlainHeaders -> Maybe PCP
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 PAll
    else do
      algo <- Resc.getReadHeader shh algoHeader
      sh' <- Resc.getBase64urlHeader shh sharedKeyHeader
      sh <- maybeCryptoError . Ed25519.publicKey $ sh'
      cid <- Resc.getBase64urlHeader shh idHeader
      case algo of
        Sha3_512Ed25519 -> pure $ PCPSha3_512Ed25519 cid sh