emailparse (empty) → 0.2.0.6
raw patch · 15 files changed
+1027/−0 lines, 15 filesdep +HUnitdep +MissingHdep +QuickChecksetup-changed
Dependencies added: HUnit, MissingH, QuickCheck, attoparsec, base, bytestring, either, either-unwrap, mime, mtl, strptime, tasty, tasty-hunit, tasty-quickcheck, text, text-icu, time, word8
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- csrc/codec.c +162/−0
- emailparse.cabal +95/−0
- src/Network/Mail/Parse.hs +15/−0
- src/Network/Mail/Parse/Decoders/BodyDecoder.hs +66/−0
- src/Network/Mail/Parse/Decoders/FormatDecoders.hs +91/−0
- src/Network/Mail/Parse/Parsers/Header.hs +36/−0
- src/Network/Mail/Parse/Parsers/HeaderFields.hs +207/−0
- src/Network/Mail/Parse/Parsers/Message.hs +107/−0
- src/Network/Mail/Parse/Parsers/Multipart.hs +31/−0
- src/Network/Mail/Parse/Parsers/Utils.hs +36/−0
- src/Network/Mail/Parse/Types.hs +84/−0
- src/Network/Mail/Parse/Utils.hs +56/−0
- test/main.hs +9/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Michal Kawalec++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Michal Kawalec nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ csrc/codec.c view
@@ -0,0 +1,162 @@+// Copyright: (c) Magnus Therning, 2012+// License: BSD3, found in the LICENSE file++#include <assert.h>+#include <string.h>++#include "codec.h"++static uint8_t const qp_decmap[] = {+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+};++int qp_dec_c(uint8_t const *src, size_t srclen,+ uint8_t *dst, size_t *dstlen,+ uint8_t const **rem, size_t *remlen)+{+ assert(src || srclen == 0);+ assert(dst);+ assert(dstlen);+ assert(rem);+ assert(remlen);++ size_t od = *dstlen, i;+ int res = 0;++ for(i = 0, *dstlen = 0; i < srclen && *dstlen < od; i++, (*dstlen)++) {+ if((9 == src[i]) || (10 == src[i]) || (13 == src[i]) ||+ (32 <= src[i] && src[i] <= 60) ||+ (62 <= src[i] && src[i] <= 126)) {+ dst[*dstlen] = src[i];+ } else if('=' == src[i]) {+ if(i + 2 >= srclen) { res = 0; goto exit; }++ // We want to append nothing if we see '=\r\n'+ if (src[i + 1] == '\r' && src[i + 2] == '\n') {+ (*dstlen)--;+ } else {+ uint8_t o0 = qp_decmap[src[i + 1]], o1 = qp_decmap[src[i + 2]];+ if((o0 | o1) & 0xf0) { res = 1; break; }+ dst[*dstlen] = o0 << 4 | o1;+ }++ i += 2;+ } else { res = 1; goto exit; }+ }++exit:+ *rem = src + i;+ *remlen = srclen -i;++ return(res);+}++// decode map, 0x80 = not allowed, 0x40 = end char+static uint8_t const b64_decmap[] = {+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x3e, 0x80, 0x80, 0x80, 0x3f,+ 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x80, 0x80, 0x80, 0x40, 0x80, 0x80,+ 0x80, 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e,+ 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28,+ 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80,+ 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80 };+++int b64_dec_part_c(uint8_t const *src, size_t srclen,+ uint8_t *dst, size_t *dstlen,+ uint8_t const **rem, size_t *remlen)+{+ assert(src || 0 == srclen);+ assert(dst);+ assert(dstlen);+ assert(rem);+ assert(remlen);++ size_t od = *dstlen, i;+ int res = 0;++ for(i = 0, *dstlen = 0; i + 4 <= srclen && *dstlen + 3 <= od; i += 4, *dstlen += 3) {+ uint8_t o0, o1, o2, o3;++ if (src[i] == '\r' && src[i+1] == '\n') {+ i -= 2;+ *dstlen -= 3;+ continue;+ }++ o0 = b64_decmap[src[i]];+ o1 = b64_decmap[src[i+1]];+ o2 = b64_decmap[src[i+2]];+ o3 = b64_decmap[src[i+3]];+ if(!(0xc0 & (o0 | o1 | o2 | o3))) { // no illegal chars, and no '='+ *dst++ = (o0 << 2) | (o1 >> 4);+ *dst++ = (o1 << 4) | (o2 >> 2);+ *dst++ = (o2 << 6) | o3;+ } else if((!(0xc0 & (o0 | o1)) && (0x40 & o2 & o3)) // two legal chars, two '='+ || (!(0xc0 & (o0 | o1 | o2)) && (0x40 & o3))) { // three legal chars, one '='+ res = 0;+ break;+ } else {+ res = 1;+ break;+ }+ }++ *rem = src + i;+ *remlen = srclen - i;+ return(res);+}++int b64_dec_final_c(uint8_t const *src, size_t srclen,+ uint8_t *dst, size_t *dstlen)+{+ assert(src || 0 == srclen);+ assert(dst);+ assert(dstlen);++ uint8_t o0, o1, o2, o3;++ if(0 == srclen || (src[0] == '\r' && src[1] == '\n')) {+ *dstlen = 0;+ return(0);+ }+ o0 = b64_decmap[src[0]];+ o1 = b64_decmap[src[1]];+ o2 = b64_decmap[src[2]];+ o3 = b64_decmap[src[3]];+ if(!(0xc0 & (o0 | o1)) && (0x40 & o2 & o3)) { // two legal chars, two '='+ *dst++ = (o0 << 2) | (o1 >> 4);+ *dstlen = 1;+ } else if(!(0xc0 & (o0 | o1 | o2)) && (0x40 & o3)) { // three legal chars, one '='+ *dst++ = (o0 << 2) | (o1 >> 4);+ *dst++ = (o1 << 4) | (o2 >> 2);+ *dstlen = 2;+ } else+ return(1);++ return(0);+}
+ emailparse.cabal view
@@ -0,0 +1,95 @@+-- Initial emailparse.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: emailparse+version: 0.2.0.6+synopsis: An email parser that will parse everything+-- description:+license: BSD3+license-file: LICENSE+author: Michal Kawalec+maintainer: michal@monad.cat+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Network.Mail.Parse+ Network.Mail.Parse.Types+ Network.Mail.Parse.Utils+ Network.Mail.Parse.Decoders.BodyDecoder+ Network.Mail.Parse.Decoders.FormatDecoders+ Network.Mail.Parse.Parsers.Header+ Network.Mail.Parse.Parsers.HeaderFields+ Network.Mail.Parse.Parsers.Message+ Network.Mail.Parse.Parsers.Multipart+ Network.Mail.Parse.Parsers.Utils+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.8 && <4.9,+ bytestring == 0.10.*,+ attoparsec == 0.13.*,+ word8 == 0.1.*,+ text == 1.2.*,+ mime == 0.4.*,+ MissingH == 1.3.*,+ either == 4.4.*,+ text-icu == 0.7.*,+ time == 1.5.*,+ strptime == 1.0.*,+ either-unwrap == 1.1.*+ hs-source-dirs: src+ c-sources: csrc/codec.c+ include-dirs: csrc+ cc-options: -fPIC -Wall -Wextra -O2+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind+ default-extensions: OverloadedStrings,+ GeneralizedNewtypeDeriving,+ BangPatterns,+ ScopedTypeVariables,+ TypeSynonymInstances,+ DeriveFunctor,+ DeriveGeneric,+ FlexibleInstances,+ TemplateHaskell,+ LambdaCase++Test-Suite emailparse-test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test, src+ build-depends: base >=4.8 && <4.9,+ bytestring == 0.10.*,+ attoparsec == 0.13.*,+ word8 == 0.1.*,+ text == 1.2.*,+ mime == 0.4.*,+ MissingH == 1.3.*,+ either == 4.4.*,+ text-icu == 0.7.*,+ time == 1.5.*,+ strptime == 1.0.*,+ either-unwrap == 1.1.*,++ tasty == 0.11.*,+ HUnit == 1.3.*,+ QuickCheck == 2.8.*,+ tasty-hunit == 0.9.*,+ tasty-quickcheck == 0.8.*,+ mtl == 2.2.*+ c-sources: csrc/codec.c+ include-dirs: csrc+ cc-options: -fPIC -Wall -Wextra -O2+ default-language: Haskell2010+ default-extensions: OverloadedStrings,+ GeneralizedNewtypeDeriving,+ BangPatterns,+ ScopedTypeVariables,+ TypeSynonymInstances,+ DeriveFunctor,+ FlexibleInstances,+ TemplateHaskell,+ LambdaCase
+ src/Network/Mail/Parse.hs view
@@ -0,0 +1,15 @@+module Network.Mail.Parse (parseMessage) where++import Network.Mail.Parse.Types+import Network.Mail.Parse.Parsers.Message (messageParser)++import qualified Data.ByteString.Char8 as BSC+import Data.Attoparsec.ByteString+import Control.Monad (join)+import qualified Data.Text as T+import Data.Either.Combinators (mapLeft)++-- |Parses a single message of any mimetype+parseMessage :: BSC.ByteString -> Either ErrorMessage EmailMessage+parseMessage message =+ join . mapLeft T.pack $ parseOnly (messageParser Nothing Nothing) message
+ src/Network/Mail/Parse/Decoders/BodyDecoder.hs view
@@ -0,0 +1,66 @@+module Network.Mail.Parse.Decoders.BodyDecoder where++import qualified Data.ByteString.Char8 as BSC++import Codec.MIME.Parse (parseMIMEType)+import Codec.MIME.Type++import Data.Either.Combinators (mapLeft, fromRight')+import Data.Either.Utils (maybeToEither)+import Data.Either (isRight, rights)++import Data.List (find)++import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.ICU.Convert as ICU+import System.IO.Unsafe (unsafePerformIO)++import Network.Mail.Parse.Types+import Network.Mail.Parse.Decoders.FormatDecoders (qpDec, decodeB64)+import Network.Mail.Parse.Utils (findHeader)+++-- |Remove transfer encoding from a string of bytes+transferDecode :: BSC.ByteString -> Text -> Either (BSC.ByteString, BSC.ByteString) BSC.ByteString+transferDecode body encoding = case T.toLower encoding of+ "quoted-printable" -> qpDec body+ "q" -> qpDec body+ "base64" -> decodeB64 body+ "b" -> decodeB64 body+ _ -> Right body++-- |Transform a string of bytes with a given encoding+-- into a UTF-8 string of bytes+encodingToUtf :: BSC.ByteString -> Text -> Text+encodingToUtf body encoding = case T.toLower encoding of+ "utf-8" -> decodeUtf8 body+ _ -> ICU.toUnicode converter body+ where converter = unsafePerformIO $ ICU.open (T.unpack encoding) (Just True)++-- |Reverse content transfer encoding applied to the body.+decodeBody :: [Header] -> BSC.ByteString -> BSC.ByteString+decodeBody headers body =+ if isRight decodedBody+ then fromRight' decodedBody+ else body+ where decodedBody = findHeader "Content-Transfer-Encoding" headers >>=+ return . headerContents >>=+ \h -> mapLeft (const "Decoding error") (transferDecode body h)++-- |Given a set of headers it tries to figure out+-- the transfer encoding and charset and normalizes+-- the contents into an UTF-8 encoded Text.+--+-- It will recover from errors, wherever possible+decodeTextBody :: [Header] -> BSC.ByteString -> Text+decodeTextBody headers body =+ if isRight charset+ then encodingToUtf decodedBody $ fromRight' charset+ else decodeUtf8 decodedBody+ where decodedBody = decodeBody headers body+ charset = findHeader "Content-Type" headers >>=+ \h -> maybeToEither "" (parseMIMEType $ headerContents h) >>=+ \m -> maybeToEither "" $ find (\x -> paramName x == "charset") (mimeParams m) >>=+ return . paramValue
+ src/Network/Mail/Parse/Decoders/FormatDecoders.hs view
@@ -0,0 +1,91 @@+module Network.Mail.Parse.Decoders.FormatDecoders (qpDec, decodeB64) where++-- Copyright: (c) Magnus Therning, 2012+-- License: BSD3, found in the LICENSE file+-- Copied from the Sandi library++import Foreign+import Foreign.C.Types+import System.IO.Unsafe as U+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU+import Data.ByteString.Unsafe++foreign import ccall "static qp.h qp_dec_c"+ c_qp_dec :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt++foreign import ccall "static b64.h b64_dec_part_c"+ c_b64_dec_part :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt++foreign import ccall "static b64.h b64_dec_final_c"+ c_b64_dec_final :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt++castEnum :: (Enum a, Enum b) => a -> b+castEnum = toEnum . fromEnum++qpDec' :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)+qpDec' bs = U.unsafePerformIO $ BSU.unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do+ outBuf <- mallocBytes inLen+ alloca $ \ pOutLen ->+ alloca $ \ pRemBuf ->+ alloca $ \ pRemLen -> do+ poke pOutLen (castEnum inLen)+ r <- c_qp_dec (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf pRemLen+ outLen <- peek pOutLen+ newOutBuf <- reallocBytes outBuf (castEnum outLen)+ remBuf <- peek pRemBuf+ remLen <- peek pRemLen+ remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)+ outBs <- BSU.unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)+ if r == 0+ then return $ Right (outBs, remBs)+ else return $ Left (outBs, remBs)++qpDec :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString+qpDec bs = case qpDec' bs of+ Right a@(d, r) -> if BS.null r+ then Right d+ else Left a+ Left a -> Left a++b64DecodePart :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)+b64DecodePart bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do+ let maxOutLen = inLen `div` 4 * 3+ outBuf <- mallocBytes maxOutLen+ alloca $ \ pOutLen ->+ alloca $ \ pRemBuf ->+ alloca $ \ pRemLen -> do+ poke pOutLen (castEnum maxOutLen)+ r <- c_b64_dec_part (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf pRemLen+ outLen <- peek pOutLen+ newOutBuf <- reallocBytes outBuf (castEnum outLen)+ remBuf <- peek pRemBuf+ remLen <- peek pRemLen+ remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)+ outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)+ if r == 0+ then return $ Right (outBs, remBs)+ else return $ Left (outBs, remBs)++b64DecodeFinal :: BS.ByteString -> Maybe BS.ByteString+b64DecodeFinal bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do+ outBuf <- mallocBytes 3+ alloca $ \ pOutLen -> do+ r <- c_b64_dec_final (castPtr inBuf) (castEnum inLen) outBuf pOutLen+ if r == 0+ then do+ outLen <- peek pOutLen+ newOutBuf <- reallocBytes outBuf (castEnum outLen)+ outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)+ return $ Just outBs+ else free outBuf >> return Nothing++decodeB64 :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString+decodeB64 bs = either+ Left+ (\ (first, rest) ->+ maybe+ (Left (first, rest))+ (\ fin -> Right (first `BS.append` fin))+ (b64DecodeFinal rest))+ (b64DecodePart bs)
+ src/Network/Mail/Parse/Parsers/Header.hs view
@@ -0,0 +1,36 @@+module Network.Mail.Parse.Parsers.Header where++import Network.Mail.Parse.Types+import Network.Mail.Parse.Utils+import Network.Mail.Parse.Parsers.HeaderFields (parseText)++import Data.Word8+import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString as AP+import Data.Text.Encoding (decodeUtf8)+import Data.Either.Unwrap (fromRight)+import Data.Either (isRight)++import qualified Data.ByteString.Char8 as BSC++-- |Parses a header+headerParser :: Parser Header+headerParser = do+ headerName <- AP.takeWhile (/= _colon)+ word8 _colon+ AP.takeWhile isWhitespace++ headerLine <- consumeTillEndLine+ moreLines <- many' isConsequentHeaderLine++ let headerBody = decodeUtf8 . cleanupLines $ headerLine:moreLines+ let parsedBody = parseText headerBody+ let body = if isRight parsedBody then fromRight parsedBody else headerBody++ return $ Header (decodeUtf8 headerName) body++-- |Concatenate lines insterting whitespace between them.+-- The whitespace needs to be inserted as these lines+-- come from parser that eats up the whitespace+cleanupLines :: [BSC.ByteString] -> BSC.ByteString+cleanupLines ls = BSC.intercalate " " $ map BSC.init ls
+ src/Network/Mail/Parse/Parsers/HeaderFields.hs view
@@ -0,0 +1,207 @@+module Network.Mail.Parse.Parsers.HeaderFields (+ emailAddressParser,+ emailAddressListParser,+ parseTime,+ parseEmailAddress,+ parseEmailAddressList,+ parseText,+ parseTextList,+ parseMessageId+) where++import Network.Mail.Parse.Types+import Network.Mail.Parse.Decoders.BodyDecoder (transferDecode, encodingToUtf)++import Data.Attoparsec.Text+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import qualified Data.Attoparsec.Text as AP+import Data.Text.Encoding (encodeUtf8)+import Control.Applicative+import Data.Maybe+import qualified Data.Char as C+import Data.Either (isRight)+import Data.Either.Combinators (mapLeft, mapBoth)++import Data.Either.Unwrap (fromRight)++import Data.Time.Parse (strptime)+import Data.Time.LocalTime+import Control.Monad (join, liftM)++-- |Parses a name-addr formatted email+nameAddrParser :: Parser EmailAddress+nameAddrParser = do+ label <- AP.takeWhile (/= '<')+ _ <- char '<'++ address <- AP.takeWhile1 (/= '>')+ _ <- char '>'+ return $ EmailAddress address (Just . T.strip $ label)++-- |Parses an addr-spec formatted email+addrSpecParser :: Parser EmailAddress+addrSpecParser = do+ address <- AP.takeWhile1 (\c -> c /= '\r' && c /= ',' && c /= ' ')+ if isJust $ T.find (== '@') address+ then return $ EmailAddress address Nothing+ else fail "no @ in the address"++-- |Parses an email in any format+emailAddressParser :: Parser EmailAddress+emailAddressParser = nameAddrParser <|> addrSpecParser++-- |Eats unneeded whitespace+eatWhitespace :: Parser T.Text+eatWhitespace = AP.takeWhile (\c -> c == ',' || c == ' ')++-- |Parses a list of email addresses+emailAddressListParser :: Parser [EmailAddress]+emailAddressListParser =+ (eatWhitespace *> emailAddressParser) `sepBy'` char ','++messageIdParser :: Parser MessageId+messageIdParser = parseWrappedMsgId <|> takeText++parseWrappedMsgId :: Parser MessageId+parseWrappedMsgId = do+ _ <- char '<'+ msgId <- AP.takeWhile1 (/= '>')+ _ <- char '>'+ return msgId++minutesAndHoursToTZ :: Int -> Either T.Text (Int, T.Text) ->+ (Int, T.Text) -> Either T.Text TimeZone+minutesAndHoursToTZ direction minutes hours =+ Right $ minutesToTimeZone timezoneMins+ where knownMinutes = if isRight minutes+ then fst . fromRight $ minutes+ else 0+ h = fst hours+ timezoneMins = direction * (h * 60 + knownMinutes)++zoneToOffset :: T.Text -> Either ErrorMessage TimeZone+zoneToOffset offset = if offsetH == '+' || offsetH == '-'+ then hours >>= (minutesAndHoursToTZ direction minutes)+ else Right $ minutesToTimeZone . (*60) $ case offset of+ "UT" -> 0+ "GMT" -> 0+ "EST" -> -5+ "EDT" -> -4+ "CST" -> -6+ "CDT" -> -5+ "MST" -> -7+ "MDT" -> -6+ "PST" -> -8+ "PDT" -> -7+ _ -> 0+ where offsetH = T.head offset+ direction = if offsetH == '+' then 1 else -1+ splitOffset = T.splitAt 2 $ T.tail offset+ hours = mapLeft T.pack $ TR.decimal . fst $ splitOffset+ minutes = mapLeft T.pack $ TR.decimal . snd $ splitOffset++timeToLocalTime :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe LocalTime+timeToLocalTime (day, month, year, timeOfDay@(hours:minutes:_)) =+ liftM fst (strptime "%d %b %Y %T" dateString)+ where dateString = T.intercalate " " [day, month, year, timeString]+ seconds = if length timeOfDay < 3 then "0" else last timeOfDay+ timeString = T.intercalate ":" [hours, minutes, seconds]++timeParser :: Parser (Either ErrorMessage ZonedTime)+timeParser =+ do+ day <- AP.takeWhile1 C.isDigit+ AP.takeWhile (== ' ')++ month <- AP.takeWhile1 C.isLetter+ AP.takeWhile (== ' ')++ year <- AP.takeWhile1 C.isDigit+ AP.takeWhile (== ' ')++ timeOfDay <- (AP.takeWhile (== ':') *> AP.takeWhile1 C.isDigit) `sepBy` char ':'++ AP.takeWhile (== ' ')+ zone <- AP.takeWhile1 (/= ' ')+ let localTime = timeToLocalTime (day, month, year, timeOfDay)+ let timeZone = zoneToOffset zone+ let result = if isJust localTime && isRight timeZone+ then Right $ ZonedTime (fromJust localTime) (fromRight timeZone)+ else mapBoth (const "cannot decode timezone") (const defaultZT) timeZone+ return result++-- |Parse a time from a header containing time+parseTime :: T.Text -> Either ErrorMessage ZonedTime+parseTime dateString = join . mapLeft T.pack $ parseOnly timeParser withoutDoW+ where withoutDoW = T.strip . last $ T.splitOn "," dateString++parseMessageId :: T.Text -> Either ErrorMessage MessageId+parseMessageId = mapLeft T.pack . parseOnly messageIdParser++parseEmailAddress :: T.Text -> Either ErrorMessage EmailAddress+parseEmailAddress = mapLeft T.pack . parseOnly emailAddressParser++parseEmailAddressList :: T.Text -> Either ErrorMessage [EmailAddress]+parseEmailAddressList = mapLeft T.pack . parseOnly emailAddressListParser++untilEndSection :: Char -> Char -> Maybe Char+untilEndSection prev current =+ if prev == '?' && current == '='+ then Nothing+ else Just current++untilStartSection :: Char -> Char -> Maybe Char+untilStartSection prev current =+ if prev == '=' && current == '?'+ then Nothing+ else Just current++parseInlineEncoding :: Parser (Either ErrorMessage T.Text)+parseInlineEncoding = do+ charset <- AP.takeWhile1 (/= '?')+ char '?'++ encoding <- AP.takeWhile1 (/= '?')+ char '?'++ matchedText <- AP.scan ' ' untilEndSection+ char '='++ let text = encodeUtf8 $ T.init matchedText+ let decoded = mapLeft (const "Count not decode encoding") (transferDecode text encoding) >>= return . (`encodingToUtf` charset)++ if T.toLower encoding == "q"+ then return $ liftM (T.replace "_" " ") decoded+ else return decoded++parseTextBlock :: Parser (Either ErrorMessage T.Text)+parseTextBlock = do+ before <- AP.scan ' ' untilStartSection+ endReached <- atEnd+ decoded <- if not endReached+ then char '?' >> parseInlineEncoding+ else return . Right $ T.empty++ let didDecode = isRight decoded && (not . T.null . fromRight $ decoded)+ let normalizedBefore = if didDecode then T.init before else before+ return $ liftM (T.append normalizedBefore) decoded++untilEOF :: Parser (Either ErrorMessage T.Text) -> Parser [Either ErrorMessage T.Text]+untilEOF parser = do+ parsed <- parser+ endReached <- atEnd+ if endReached+ then return [parsed]+ else liftM (parsed:) (untilEOF parser)++parseText' :: Parser (Either ErrorMessage T.Text)+parseText' = do+ blocks <- untilEOF parseTextBlock+ return $ liftM T.concat (mapM id blocks)++parseText :: T.Text -> Either ErrorMessage T.Text+parseText = join . mapLeft T.pack . parseOnly parseText'++parseTextList :: T.Text -> T.Text -> Either ErrorMessage [T.Text]+parseTextList splitChar t = mapM parseText $ T.splitOn splitChar t
+ src/Network/Mail/Parse/Parsers/Message.hs view
@@ -0,0 +1,107 @@+module Network.Mail.Parse.Parsers.Message (messageParser) where++import Data.Attoparsec.ByteString++import Data.List (find)+import Data.Maybe+import Data.Either (isRight)+import Control.Monad (liftM)++import Network.Mail.Parse.Types+import Network.Mail.Parse.Utils++import Network.Mail.Parse.Parsers.Utils (isMIME, discoverAttachment)+import Network.Mail.Parse.Parsers.Multipart (parseMultipart)+import Network.Mail.Parse.Decoders.BodyDecoder (decodeBody, decodeTextBody)+import Network.Mail.Parse.Parsers.Header (headerParser)+import Network.Mail.Parse.Parsers.HeaderFields+import qualified Data.Text as T++import qualified Data.ByteString.Char8 as BSC+import Data.Either.Utils (maybeToEither)++import Data.Text.Encoding (encodeUtf8)+import Data.Either.Combinators (fromRight', fromRight, mapLeft)++import Codec.MIME.Parse (parseMIMEType)+import Codec.MIME.Type++import Control.Monad (join)++parseHeader :: Header -> Header+parseHeader header = fromRight header parsedHeader+ where hname = headerName header+ contents = headerContents header+ references = parseTextList " " contents >>= mapM parseMessageId+ parsedHeader = case T.toLower hname of+ "date" -> Date <$> parseTime contents+ "from" -> From <$> parseEmailAddress contents+ "reply-to" -> ReplyTo <$> parseEmailAddress contents+ "to" -> To <$> parseEmailAddressList contents+ "cc" -> CC <$> parseEmailAddressList contents+ "bcc" -> BCC <$> parseEmailAddressList contents+ "message-id" -> MessageId <$> parseMessageId contents+ "in-reply-to" -> InReplyTo <$> parseMessageId contents+ "references" -> References <$> references+ "subject" -> Right $ Subject contents+ "comments" -> Right $ Comments contents+ "keywords" -> Keywords <$> parseTextList "," contents+ _ -> Right header++-- |Parses a single message+messageParser :: Maybe [Header] -> -- ^ Headers, if they were already parsed+ Maybe [Header] -> -- ^ Context headers, useful is encoding is only+ -- defined in the message above, for instance+ Parser (Either ErrorMessage EmailMessage)+messageParser headersIn helperHeadersIn = do+ headers <- if isJust headersIn+ then return . fromJust $ headersIn+ else manyTill' headerParser $ string "\r\n"+ let helperHeaders = if isJust helperHeadersIn then fromJust helperHeadersIn else []++ body <- takeByteString+ let parsedHeaders = map parseHeader headers++ -- Parse MIME if the message is in a MIME format+ let parsedBody = if isJust $ find isMIME headers+ then parseMIME (headers ++ helperHeaders) body+ else Right [TextBody $ decodeTextBody (headers ++ helperHeaders) body]++ return $! parsedBody >>= return . EmailMessage parsedHeaders+++-- |Parses a MIME message part. Needs headers from the actual message+-- in case the MIME block misses some encoding blocks+mimeParser :: [Header] -> Parser (Either ErrorMessage EmailBody)+mimeParser bodyHeaders = do+ headers <- manyTill' headerParser $ string "\r\n"+ let isAttachment = discoverAttachment headers+ if isJust isAttachment+ then do+ body <- takeByteString+ let filename = fromJust isAttachment+ let decodedBody = decodeBody headers body+ return . Right $ Attachment headers filename (Just decodedBody) Nothing+ else (liftM . liftM) MessageBody $ messageParser (Just headers) (Just bodyHeaders)++-- |Parse a set of parts.+multipartParser :: [Header] -> [BSC.ByteString] -> Either ErrorMessage [EmailBody]+multipartParser bodyHeaders parts = do+ mapM (\p -> join $ mapLeft T.pack $ parseOnly (mimeParser bodyHeaders) p) parts++-- |Parse a mime encoded body.+parseMIME :: [Header] -> BSC.ByteString -> Either ErrorMessage [EmailBody]+parseMIME headers body = if isRight msgType then+ (case mimeType . fromRight' $ msgType of+ Multipart _ -> multiParsed >>= multipartParser headers+ Text _ -> Right decodedBody+ _ -> Left "mimetype not supported")+ else Right decodedBody+ where msgType = findHeader "Content-Type" headers >>=+ Right . parseMIMEType . headerContents >>=+ maybeToEither "Couldn't parse message type"+ multiParsed = msgType >>=+ \x -> maybeToEither "" $ find (\p -> paramName p == "boundary") (mimeParams x) >>=+ return . encodeUtf8 . paramValue >>=+ \b -> eitherToMaybe $ parseOnly (parseMultipart b) body+ decodedBody = [TextBody $ decodeTextBody headers body]
+ src/Network/Mail/Parse/Parsers/Multipart.hs view
@@ -0,0 +1,31 @@+module Network.Mail.Parse.Parsers.Multipart (parseMultipart) where++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString as BS+import Data.Word8+import Data.Attoparsec.ByteString++import Network.Mail.Parse.Utils++isBoundaryMatched :: BSC.ByteString -> Int -> Word8 -> Maybe Int+isBoundaryMatched boundary matchIdx char =+ if char == BS.index boundary matchIdx+ then if matchIdx == boundaryLength - 1+ then Nothing+ else Just $ matchIdx + 1+ else Just 0+ where boundaryLength = BS.length boundary++trimPayload :: BSC.ByteString -> BSC.ByteString -> BSC.ByteString+trimPayload boundary payload = BSC.take trimLength payload+ where payloadLength = BSC.length payload+ boundaryLength = BSC.length boundary+ trimLength = payloadLength - boundaryLength + 1++parseMultipart :: BSC.ByteString -> Parser [BSC.ByteString]+parseMultipart boundary =+ do+ _ <- manyTill' anyWord8 (string completeBoundary) <* consumeTillEndLine+ payloads <- many' (scan 0 (isBoundaryMatched completeBoundary) <* consumeTillEndLine)+ return $ map (trimPayload completeBoundary) payloads+ where completeBoundary = BSC.append "--" boundary
+ src/Network/Mail/Parse/Parsers/Utils.hs view
@@ -0,0 +1,36 @@+module Network.Mail.Parse.Parsers.Utils where++import Network.Mail.Parse.Types+import Network.Mail.Parse.Utils++import qualified Data.Text as T+import Data.List+import Control.Monad (liftM)+++-- |Check if the given headers represent an attachment+discoverAttachment :: [Header] -> Maybe T.Text+discoverAttachment headers = hdr >>= findAttachmentName . headerContents+ where hdr = find (\x -> (T.toLower . headerName $ x) == "content-disposition") headers++-- |When provided with a content-disposition header,+-- checks if it represents an attachment. If it does it returns+-- it's name, otherwise Nothing+findAttachmentName :: T.Text -> Maybe T.Text+findAttachmentName header =+ if dispType == "attachment" || dispType == "inline"+ then if length split == 1+ then Just ""+ else liftM (T.strip . T.dropAround (== '"') . (!! 1)) filenameParam+ else Nothing+ where split = T.splitOn ";" header+ dispType = T.toLower . T.strip . head $ split+ paramSplit = map (T.splitOn "=") (tail split)+ filenameParam = find (\x -> T.strip (head x) == "filename") paramSplit++-- |Decide if the header contains a valid MIME info+isMIME :: Header -> Bool+isMIME header = isNameValid && isVersionValid+ where isNameValid = T.toLower (headerName header) == "mime-version"+ version = commentRemover $ headerContents header+ isVersionValid = version == "1.0"
+ src/Network/Mail/Parse/Types.hs view
@@ -0,0 +1,84 @@+module Network.Mail.Parse.Types where++import Data.Text+import GHC.Generics+import qualified Data.ByteString.Char8 as BS+import Data.Time.Calendar (Day(..))+import Data.Time.LocalTime (ZonedTime(..), minutesToTimeZone, LocalTime(..),+ TimeOfDay(..))++type UID = Integer+type ErrorMessage = Text++data EmailMessage = EmailMessage {+ emailHeaders :: [Header],+ emailBodies :: ![EmailBody]+} deriving (Show, Eq, Generic)++type MessageId = Text+data Header = Date ZonedTime+ | From EmailAddress+ | ReplyTo EmailAddress+ | To [EmailAddress]+ | CC [EmailAddress]+ | BCC [EmailAddress]+ | MessageId MessageId+ | InReplyTo MessageId+ | References [MessageId]+ | Subject Text+ | Comments Text+ | Keywords [Text]+ | Header {+ headerName :: !Text,+ headerContents :: !Text+ }+ deriving (Eq, Show, Generic)++data EmailAddress = EmailAddress {+ emailAddress :: !Text,+ emailLabel :: Maybe Text+} deriving (Show, Generic)++instance Eq EmailAddress where+ x == y = emailAddress x == emailAddress y++-- |An email body contains the contents of an email part+-- up until the boundary marker.+data EmailBody+ -- |Body of a MIME message part. Contains headers+ = MessageBody EmailMessage+ -- = MIMEBody { mimeHeaders :: ![Header], mimeBody :: !Text}+ -- |If the message contained no MIME information, it's probably+ -- just some text. Best guess decoding into UTF-8 is applied+ | TextBody !Text+ -- |Attachment is part of a MIME message, but a rather special+ -- one. It's decoded from whatever the transfer encoding was applied+ -- and left as a raw sollection of bytes for your enjoyment+ | Attachment {+ attachmentHeaders :: ![Header],+ attachmentName :: !Text,+ attachmentBody :: Maybe BS.ByteString,+ -- |Location of the actual filename on disk+ storageFilename :: Maybe Text+ }+ deriving (Eq, Show, Generic)+++instance Eq ZonedTime where+ x == y = (zonedTimeToLocalTime x) == (zonedTimeToLocalTime y) &&+ (zonedTimeZone x) == (zonedTimeZone y)++defaultZT :: ZonedTime+defaultZT = ZonedTime {+ zonedTimeZone = minutesToTimeZone 0,+ zonedTimeToLocalTime = LocalTime {+ localDay = ModifiedJulianDay {+ toModifiedJulianDay = 1+ },+ localTimeOfDay = TimeOfDay {+ todHour = 0,+ todMin = 0,+ todSec = 0+ }+ }+}
+ src/Network/Mail/Parse/Utils.hs view
@@ -0,0 +1,56 @@+module Network.Mail.Parse.Utils where++import Network.Mail.Parse.Types++import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString.Char8 as BS+import Data.Word8+import Data.List++import Data.Text (Text)+import qualified Data.Text as T+import Data.Either.Utils (maybeToEither)++-- |If the previous character was a carriage return and the current+-- is a line feed, stop parsing+hadCRLF :: Word8 -> Word8 -> Maybe Word8+hadCRLF prev current =+ if prev == _cr && current == _lf+ then Nothing+ else Just current++-- |Consumes a line until CRLF is hit+consumeTillEndLine :: Parser BS.ByteString+consumeTillEndLine = scan 0 hadCRLF <* satisfy (== _lf)++-- |Can a given character be regarded as a whitespace?+isWhitespace :: Word8 -> Bool+isWhitespace x = x == 9 || x == 32++-- |If the next line is a part of a previous header, parse it.+-- Fail otherwise+isConsequentHeaderLine :: Parser BS.ByteString+isConsequentHeaderLine = satisfy isWhitespace *>+ AP.takeWhile isWhitespace *>+ consumeTillEndLine++-- |Remove a MIME header comment and return a header without the comment+commentRemover :: Text -> Text+commentRemover contents = T.strip withoutComment+ where splitAtComment = T.split (\c -> c == '(' || c == ')') contents+ withoutComment = if length splitAtComment > 1+ then T.append (head splitAtComment) (last splitAtComment)+ else head splitAtComment++-- |Given a header name, it will try to locate it in+-- a list of headers, fail if it's not there+findHeader :: Text -> [Header] -> Either ErrorMessage Header+findHeader hdr headers = maybeToEither notFound header+ where notFound = T.concat ["Cound not find header '", T.pack . show $ hdr, "'"]+ eigenHeader = T.toLower hdr+ header = find (\x -> T.toLower (headerName x) == eigenHeader) headers++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Right a) = Just a+eitherToMaybe (Left _) = Nothing
+ test/main.hs view
@@ -0,0 +1,9 @@+module Main where++import Test.Tasty (defaultMain, testGroup)+import qualified Network.Mail.Parse.Parsers.Tests.Headers as TH+import qualified Network.Mail.Parse.Parsers.Tests.HeaderFields as THF++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [TH.tests, THF.tests]