|
@@ -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
|