CP: Functionality for capability verification

src/Data/SMTP/Crypto/Algos/CP.hs

@@ -6,8 +6,8 @@ module Data.SMTP.Crypto.Algos.CP (
   initCp,
   update,
   update',
-  checkSeal,
-  toSeal
+  checkSeal
+--  toSeal
   ) where
 
 import Data.ByteString (ByteString)
@@ -21,33 +21,33 @@ import qualified Data.ByteString as BS
 import Crypto.Error
 import Data.SMTP.Crypto.Types.CP
 
-data Algo = Sha512Ed25519 deriving (Eq, Ord, Bounded, Enum)
+data State = Sha3_512Ed25519s (Hash.Context Hashs.SHA512)
 
-instance Show Algo where
-  show Sha512Ed25519 = "SHA512-ED25519"
-
-data State = Sha512Ed25519s (Hash.Context Hashs.SHA512)
-             
 initCp :: Algo -> State
-initCp Sha512Ed25519 = Sha512Ed25519s Hash.hashInit
+initCp Sha3_512Ed25519 = Sha3_512Ed25519s Hash.hashInit
+
 update ::  State -> ByteString -> State
-update (Sha512Ed25519s s) dt = Sha512Ed25519s $ Hash.hashUpdate s dt
+update (Sha3_512Ed25519s s) dt = Sha3_512Ed25519s $ Hash.hashUpdate s dt
+
 update' :: State -> LBS.ByteString -> State
-update' (Sha512Ed25519s s) dt = Sha512Ed25519s $ Hash.hashUpdates s $ LBS.toChunks dt
-checkSeal :: State -> Seal.Seal -> CP -> Bool
-checkSeal (Sha512Ed25519s s) (Seal.Seal _ seal _) (Sha512Ed25519Cp _ pk _) = let
+update' (Sha3_512Ed25519s s) dt = Sha3_512Ed25519s $ Hash.hashUpdates s $ LBS.toChunks dt
+
+checkSeal :: State -> Seal.Seal -> SCP -> Bool
+checkSeal _ _ SAll = True
+checkSeal (Sha3_512Ed25519s s) (Seal.Seal _ seal _) (SCPSha3_512Ed25519 _ pk) = let
   dg = Hash.hashFinalize s
   sig' = Ed25519.signature seal
   in case sig' of
     CryptoFailed _ -> False
     CryptoPassed sig -> Ed25519.verify pk dg sig
-toSeal :: State -> CP -> Maybe Seal.Seal
-toSeal (Sha512Ed25519s s) (Sha512Ed25519Cp cpid pk (Just sk)) = let
-  dg = Hash.hashFinalize s
-  sig = ba2bs $ Ed25519.sign sk pk dg
-  in Just $ Seal.Seal cpid sig Nothing
-toSeal (Sha512Ed25519s _) _ = Nothing
+
+-- toSeal :: State -> SCP -> Maybe Seal.Seal
+-- toSeal (Sha3_512Ed25519s s) (SCPSha3_512Ed25519 cpid pk (Just sk)) = let
+--   dg = Hash.hashFinalize s
+--   sig = ba2bs $ Ed25519.sign sk pk dg
+--   in Just $ Seal.Seal cpid sig Nothing
+-- toSeal (Sha3_512Ed25519s _) _ = Nothing
 
 
-ba2bs :: BA.ByteArrayAccess a => a -> ByteString
-ba2bs = BS.pack . BA.unpack
+-- ba2bs :: BA.ByteArrayAccess a => a -> ByteString
+-- ba2bs = BS.pack . BA.unpack

src/Data/SMTP/Crypto/Types/CP.hs

@@ -5,6 +5,56 @@ 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 CP = Sha512Ed25519Cp ByteString Ed25519.PublicKey (Maybe Ed25519.SecretKey)
+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
 

src/Data/SMTP/ResponseCode.hs

@@ -29,6 +29,7 @@ data ResponseCode =
   | NoConversion -- ^ This conversion of email encoding is not supported
   | TempUndefined -- ^ Generic undefined temporary error
   | InvalidCP -- ^ Capability has an invalid format
+  | BadSeal -- ^ Seal data is invalid
     deriving (Eq, Ord, Read, Show)
 
 errorMessage :: ResponseCode -> ByteString
@@ -59,3 +60,4 @@ toResponse BadConnection = Response TransientError [] 421 (Just (4, 4, 2)) "Conn
 toResponse NoConversion = Response PermanentError [] 554 (Just (5, 6, 1)) "Conversion is not supported."
 toResponse TempUndefined = Response TransientError [] 451 (Just (4, 2, 0)) "Undefined mailsystem error."
 toResponse InvalidCP = Response PermanentError [] 500 (Just (5, 7, 7)) "Capability corrupted or invalid."
+toResponse BadSeal = Response PermanentError [] 535 (Just (5, 7, 8)) "Seal data is invalid."

src/Data/SMTP/Types/Resource.hs

@@ -9,7 +9,9 @@ import qualified Data.Attoparsec.ByteString as BA
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
+import Data.ByteString.Base64 as Base64
 import qualified Text.StringConvert as SC
+import Text.Read (readMaybe)
 
 import Data.Maybe
 import Data.Default.Class
@@ -51,6 +53,24 @@ getHeader hh k = case getMultiple hh k of
 getHeaderValue :: [Header] -> String -> Maybe String
 getHeaderValue hh k = value <$> getHeader hh k
 
+{- |
+Retrieves the value of a boolean header,
+accepting the common true strings:
+true, t, yes, y, 1
+-}
+getBooleanHeader :: [Header] -> String -> Maybe Bool
+getBooleanHeader hh s = (\k -> map C.toLower k `elem` ["true", "t", "yes", "y", "1"]) <$> getHeaderValue hh s
+
+-- | Retrieves the binary value of a base64 encoded header
+getBase64Header :: [Header] -> String -> Maybe BS.ByteString
+getBase64Header hh s = getHeaderValue hh s >>= (rightToJust . Base64.decode . SC.s)
+  where
+    rightToJust = either (\_ -> Nothing) Just
+
+-- | Gets the reader value, and converts it with readMaybe
+getReadHeader :: Read a => [Header] -> String -> Maybe a
+getReadHeader hh s = getHeaderValue hh s >>= readMaybe
+
 -- | Retrieves all headers that match the key
 getMultiple :: [Header] -> String -> [Header]
 getMultiple hh k = filter (hasKey k) hh

src/Data/SMTP/Types/Seal.hs

@@ -15,3 +15,6 @@ nonceHeaderName :: String
 nonceHeaderName = "FCMTP-SEAL-NONCE"
 sealHeaderName :: String
 sealHeaderName = "FCMTP-SEAL"
+
+sealURIParam :: String
+sealURIParam = "seal"

src/Data/SMTP/Types/URI.hs

@@ -2,9 +2,11 @@ module Data.SMTP.Types.URI where
 
 import qualified Network.URI as N
 import Data.SMTP.Account
+import qualified Data.SMTP.Seal as Seal
 import Data.List
 
-import Text.StringConvert
+import qualified Text.StringConvert as SC
+import qualified Data.Attoparsec.Text as A
 
 newtype Path = Path [String] deriving (Eq, Ord, Read, Show)
 data Revision = NoRevision | Revision String deriving (Eq, Ord, Read, Show)
@@ -28,7 +30,7 @@ relativePath URI{path=Path p} = intercalate "/" . map uriEncode $ drop 1 p
 -- | Entire textual representation of the URI
 fullURI :: URI -> String
 fullURI u@(URI{account=a, revision=r, parameters=pp}) =
-  concat $ ["FCMTP://", s . fullAccount $ a, fullPath u] ++ (
+  concat $ ["FCMTP://", SC.s . fullAccount $ a, fullPath u] ++ (
     case r of
       NoRevision -> []
       Revision r' -> [":", r']
@@ -54,6 +56,11 @@ getParameter p u = case map (\(Parameter _ vl) -> vl) .
                      [] -> Nothing
                      (v:_) -> Just v
 
+getSeal :: URI -> Maybe Seal.Seal
+getSeal u = do
+  bare <- getParameter Seal.sealURIParam u
+  A.maybeResult . A.parse Seal.parseURISeal $ SC.s bare
+
 -- | Return revision string or a default value
 fromRevision :: String -> Revision -> String
 fromRevision d NoRevision = d