Seal as URI query data

fcmtp-data.cabal

@@ -28,6 +28,7 @@ library
         cond,
         network-uri,
         split,
+        text,
         cryptonite >= 0.9
     exposed-modules:
         Data.SMTP.Response

src/Data/SMTP/Parser/Seal.hs

@@ -1,28 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Data.SMTP.Parser.Seal (
-  --parseRcptSeal, parseRcptSealParam, SealAttribute,
-  headersToSeal) where
+  parseURISeal
+  ) where
 
 import Data.SMTP.Types.Seal
-import Data.SMTP.Types.Resource
+-- import Data.SMTP.Types.Resource
+import qualified Data.Attoparsec.Text as A
 import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as C8
 import Data.ByteString (ByteString)
+import Text.StringConvert
+
+parseURISeal :: A.Parser Seal
+parseURISeal = do
+  mycp <- base64
+  A.string ":"
+  mycode <- base64
+  A.choice [
+    do
+      A.string ":"
+      mynonce <- base64
+      return . Seal mycp mycode $ Just mynonce,
+    return $ Seal mycp mycode Nothing
+    ]
 
-headersToSeal :: [Header] -> Maybe Seal
-headersToSeal hh = let
-  mycp = decode2maybe =<< getH hh cpHeaderName
-  mynonce = decode2maybe =<< getH hh nonceHeaderName
-  mycode = decode2maybe =<< getH hh sealHeaderName
-  in do
-    cp' <- mycp
-    code' <- mycode
-    Just $ Seal cp' code' mynonce
+base64 :: A.Parser ByteString
+base64 = do
+  e <- A.takeWhile isBase64Char
+  case B64.decode . s . map replaceSlash . s $ e of
+    Left r -> fail r
+    Right r -> return r
   where
-    getH :: [Header] -> String -> Maybe ByteString
-    getH hh' h = C8.pack <$> getHeaderValue hh' h
-    either2maybef :: (a -> Either b c) -> a -> Maybe c
-    either2maybef f v = either2maybe $ f v
-    either2maybe :: Either a b -> Maybe b
-    either2maybe (Left _) = Nothing
-    either2maybe (Right v) = Just v
-    decode2maybe = either2maybef B64.decode
+    replaceSlash '-' = '/'
+    replaceSlash c = c
+--      | c == W8._hyphen = W8._slash
+--      | otherwise = c
+    isBase64Char c
+      | c >= '0' && c <= '9' = True
+      | c >= 'a' && c <= 'z' = True
+      | c >= 'A' && c <= 'Z' = True
+      | c == '+' || c == '-' || c == '=' = True
+      | otherwise = False
+
+-- headersToSeal :: [Header] -> Maybe Seal
+-- headersToSeal hh = let
+--   mycp = decode2maybe =<< getH hh cpHeaderName
+--   mynonce = decode2maybe =<< getH hh nonceHeaderName
+--   mycode = decode2maybe =<< getH hh sealHeaderName
+--   in do
+--     cp' <- mycp
+--     code' <- mycode
+--     Just $ Seal cp' code' mynonce
+--   where
+--     getH :: [Header] -> String -> Maybe ByteString
+--     getH hh' h = C8.pack <$> getHeaderValue hh' h
+--     either2maybef :: (a -> Either b c) -> a -> Maybe c
+--     either2maybef f v = either2maybe $ f v
+--     either2maybe :: Either a b -> Maybe b
+--     either2maybe (Left _) = Nothing
+--     either2maybe (Right v) = Just v
+--     decode2maybe = either2maybef B64.decode

src/Data/SMTP/Seal.hs

@@ -1,4 +1,7 @@
-module Data.SMTP.Seal (module Data.SMTP.Types.Seal, module Data.SMTP.Parser.Seal) where
+module Data.SMTP.Seal (
+  module Data.SMTP.Types.Seal,
+  module Data.SMTP.Parser.Seal
+  ) where
 
 import Data.SMTP.Types.Seal
 import Data.SMTP.Parser.Seal

src/Data/SMTP/Types/URI.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Data.SMTP.Types.URI where
 
 import qualified Network.URI as N
 import Data.SMTP.Account
 import Data.List
+import qualified Data.Text as T
+import qualified Data.SMTP.Seal as Seal
+import qualified Data.Attoparsec.Text as A
 
 import Text.StringConvert
 
@@ -32,7 +33,23 @@ fullURI u@(URI{account=a, revision=r, parameters=pp}) =
   where
     formatParameter (Parameter nm vl) = concat [uriEncode nm, "=", uriEncode vl]
 
+uriEncode :: String -> String
 uriEncode = N.escapeURIString N.isUnescapedInURIComponent
     
 instance Show URI where
   show = fullURI
+
+getParameter :: String -> URI -> Maybe String
+getParameter p u = case map (\(Parameter _ vl) -> vl) .
+                        filter (\(Parameter nm _) -> nm == p) $
+                        parameters u of
+                     [] -> Nothing
+                     (v:_) -> Just v
+
+getSeal :: URI -> Maybe Seal.Seal
+getSeal u = do
+  se <- getParameter "seal" u
+  eitherToMaybe . A.parseOnly Seal.parseURISeal . T.pack $ se
+  where
+    eitherToMaybe (Left _) = Nothing
+    eitherToMaybe (Right v) = Just v