diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,41 @@ + +0.2.5 -> 0.3 +------------ + +Package changes: + * Constrained dependency on mime-mail to avoid API-breaking changes + in 0.4 + * Removed unused dependencies on parsec, time, containers, and + old-locale + * Removed unused modules: + - Data.Record + - Text.URI + - Text.MIME + - Atom test module + - Moved stream debugging module from test/ to + Network.HaskellNet.Debug + * Moved modules into src/ + +Other changes: + * Got rid of stale module portability / maintainer / stability + annotations in source; moved copyright annotation into Cabal file + * Removed some stale compiler pragmas + * Resolved compiler warnings in all modules + * Moved to using <$> more + * Removed a lot of stale commented-out code + * Shortened a lot of long lines + +API changes: + * Split up IMAP module into + Network.HaskellNet.IMAP (core functionality) + Network.HaskellNet.Types (data types) + Network.HaskellNet.Connection (IMAP connection functions) + * Moved Text.IMAPParsers to Network.HaskellNet.Parsers + * Renamed IMAP 'Mailbox' type to 'MailboxName' + * Split up POP3 module into + Network.HaskellNet.POP3 (core functionality) + Network.HaskellNet.Types (data types) + Network.HaskellNet.Connection (POP connection functions) + * IMAP.Parsers: + - removed unused Either handling functions + - constraind exports (originally exported everything) diff --git a/Data/Record.hs b/Data/Record.hs deleted file mode 100644 --- a/Data/Record.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ----------------------------------------------------------------------- --- | --- Module : Data.Record --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : GHC only --- --- Polymorphic record definitions --- --- To see the usage of this module, you refer Text.Atom --- - - - -module Data.Record - (Attr(..), get, set, update, has, add, howMany, set', get', delete) -where - -import Control.Applicative -import Data.Foldable -import Data.Monoid -import Prelude hiding (foldr1) - -data Attr r v = Attr { getter :: r -> v - , setter :: r -> v -> r - } - -get :: Attr r v -> r -> v -get = getter -set :: Attr r v -> v -> r -> r -set a v r = setter a r v -update :: Attr r v -> (v -> v) -> r -> r -update a f r = set a (f $ get a r) r - -has :: (Foldable t) => Attr r (t v) -> r -> Bool -has a r = howMany a r > 0 - -add :: (Alternative t) => Attr r (t v) -> v -> r -> r -add a v r = update a (pure v <|>) r - -howMany :: (Foldable t, Integral n) => Attr r (t v) -> r -> n -howMany a r = getSum $ foldMap (const (Sum 1)) $ get a r - -set' :: (Applicative t, Foldable t) => Attr r (t v) -> v -> r -> r -set' a v r | has a r = r - | otherwise = set a (pure v) r -get' :: (Foldable t) => Attr r (t v) -> r -> v -get' a r = foldr1 const $ get a r - -delete :: (Alternative t) => Attr r (t v) -> r -> r -delete a r = set a empty r - diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -1,34 +1,60 @@ Name: HaskellNet -Version: 0.2.5 +Synopsis: Client support for POP3, SMTP, and IMAP +Description: This package provides client support for the POP3, + SMTP, and IMAP protocols. NOTE: this package will be + split into smaller, protocol-specific packages in the + future. +Version: 0.3 +Copyright: (c) 2006 Jun Mukai Author: Jun Mukai -Maintainer: Robert Wills +Maintainer: Jonathan Daugherty License: BSD3 License-file: LICENSE Category: Network -Homepage: https://patch-tag.com/r/wrwills/HaskellNet -Description: Originally written for Google SOC, provides network related libraries such as POP3, SMTP, IMAP. - All I have done is get the project to compile using cabal, check that these libraries basically - work, and add some examples -Synopsis: network related libraries such as POP3, SMTP, IMAP +Homepage: https://github.com/jtdaugherty/HaskellNet Cabal-version: >=1.6 Build-type: Simple -Extra-Source-Files: README.md, example/*.hs +Extra-Source-Files: + CHANGELOG + README.md + example/*.hs +Source-Repository head + type: git + location: git://github.com/jtdaugherty/HaskellNet.git + Library + Hs-Source-Dirs: src + GHC-Options: -Wall -fno-warn-unused-do-bind + Exposed-modules: - Text.IMAPParsers, - Text.Mime, - Text.URI, --- Text.Bencode, - Network.HaskellNet.IMAP, - Network.HaskellNet.SMTP, - Network.HaskellNet.POP3, - Network.HaskellNet.BSStream, - Network.HaskellNet.Auth - Other-modules: Data.Record, Text.Packrat.Pos, Text.Packrat.Parse - Build-Depends: base >= 4 && < 5, haskell98, network, mtl, parsec, time, bytestring, pretty, array, Crypto > 4.2.1, base64-string, containers, old-locale, old-time, mime-mail >= 0.3.0, text + Network.HaskellNet.IMAP + Network.HaskellNet.IMAP.Connection + Network.HaskellNet.IMAP.Types + Network.HaskellNet.IMAP.Parsers + Network.HaskellNet.SMTP + Network.HaskellNet.POP3 + Network.HaskellNet.POP3.Connection + Network.HaskellNet.POP3.Types + Network.HaskellNet.BSStream + Network.HaskellNet.Auth + Network.HaskellNet.Debug -source-repository head - type: darcs - location: https://patch-tag.com/r/wrwills/HaskellNet + Other-modules: + Text.Packrat.Pos + Text.Packrat.Parse + + Build-Depends: + base >= 4 && < 5, + haskell98, + network, + mtl, + bytestring, + pretty, + array, + Crypto > 4.2.1, + base64-string, + old-time, + mime-mail >= 0.3.0 && < 0.4, + text diff --git a/Network/HaskellNet/Auth.hs b/Network/HaskellNet/Auth.hs deleted file mode 100644 --- a/Network/HaskellNet/Auth.hs +++ /dev/null @@ -1,75 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Network.HaskellNet.Auth --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- Authentication related APIs --- - -module Network.HaskellNet.Auth -where - -import Data.Digest.MD5 -import Codec.Utils -import qualified Codec.Binary.Base64.String as B64 (encode, decode) - -import Data.List -import Data.Bits -import Data.Array - -type UserName = String -type Password = String - -data AuthType = PLAIN - | LOGIN - | CRAM_MD5 - deriving Eq - -instance Show AuthType where - showsPrec d at = showParen (d>app_prec) $ showString $ showMain at - where app_prec = 10 - showMain PLAIN = "PLAIN" - showMain LOGIN = "LOGIN" - showMain CRAM_MD5 = "CRAM-MD5" - -b64Encode :: String -> String -b64Encode = map (toEnum.fromEnum) . B64.encode . map (toEnum.fromEnum) - -b64Decode :: String -> String -b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum) - -showOctet :: [Octet] -> String -showOctet = concat . map hexChars - where hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)] - arr = listArray (0, 15) "0123456789abcdef" - -hmacMD5 :: String -> String -> [Octet] -hmacMD5 text key = hash $ okey ++ hash (ikey ++ map (toEnum.fromEnum) text) - where koc = map (toEnum.fromEnum) key - key' = if length koc > 64 - then hash koc ++ replicate 48 0 - else koc ++ replicate (64-length koc) 0 - ipad = replicate 64 0x36 - opad = replicate 64 0x5c - ikey = zipWith xor key' ipad - okey = zipWith xor key' opad - -plain :: UserName -> Password -> String -plain user pass = b64Encode $ concat $ intersperse "\0" [user, user, pass] - -login :: UserName -> Password -> (String, String) -login user pass = (b64Encode user, b64Encode pass) - -cramMD5 :: String -> UserName -> Password -> String -cramMD5 challenge user pass = - b64Encode (user ++ " " ++ showOctet (hmacMD5 challenge pass)) - -auth :: AuthType -> String -> UserName -> Password -> String -auth PLAIN _ u p = plain u p -auth LOGIN _ u p = let (u', p') = login u p in unwords [u', p'] -auth CRAM_MD5 c u p = cramMD5 c u p diff --git a/Network/HaskellNet/BSStream.hs b/Network/HaskellNet/BSStream.hs deleted file mode 100644 --- a/Network/HaskellNet/BSStream.hs +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HaskellNet.Stream --- Copyright : (c) Jun Mukai 2006 --- License : BSD --- --- Maintainer : mukai@jmuk.org --- Stability : experimental --- Portability : portable --- --- A library for abstracting sockets suitable to Streams. --- --- ------------------------------------------------------------------------------ - -module Network.HaskellNet.BSStream - ( BSStream(..) - ) -where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Control.Monad.Trans -import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) -import Network - - - -class BSStream h where - bsGetLine :: h -> IO ByteString - bsGet :: h -> Int -> IO ByteString - bsPut :: h -> ByteString -> IO () - bsPuts :: h -> [ByteString] -> IO () - bsPutStrLn :: h -> ByteString -> IO () - bsPutCrLf :: h -> ByteString -> IO () - bsPutNoFlush :: h -> ByteString -> IO () - bsFlush :: h -> IO () - bsClose :: h -> IO () - bsIsOpen :: h -> IO Bool - - bsPuts h strs = mapM_ (bsPut h) strs - bsPutCrLf h s = bsPut h s >> bsPut h crlf - bsPutStrLn h s = bsPut h s >> bsPut h lf - -lf = BS.singleton '\n' -crlf = BS.pack "\r\n" - -blocklen = 4096 -waiting = 500 -- miliseconds - -instance BSStream Handle where - bsGetLine = BS.hGetLine - bsGet = BS.hGet - bsPut h s = BS.hPut h s >> bsFlush h - bsPutStrLn h s = BS.hPutStrLn h s >> bsFlush h - bsPutNoFlush = BS.hPut - bsFlush = hFlush - bsClose h = do - op <- hIsOpen h - if op then (hClose h) else return () - bsIsOpen = hIsOpen diff --git a/Network/HaskellNet/IMAP.hs b/Network/HaskellNet/IMAP.hs deleted file mode 100644 --- a/Network/HaskellNet/IMAP.hs +++ /dev/null @@ -1,475 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Network.HaskellNet.IMAP --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- IMAP client implementation --- - -module Network.HaskellNet.IMAP - ( -- * connection type and corresponding actions - IMAPConnection - , mailbox, exists, recent - , flags, permanentFlags, isWritable, isFlagWritable - , uidNext, uidValidity - , stream - , connectIMAP, connectIMAPPort, connectStream - -- * IMAP commands - -- ** any state commands - , noop, capability, logout - -- ** not authenticated state commands - , login, authenticate - -- ** autenticated state commands - , select, examine, create, delete, rename - , subscribe, unsubscribe - , list, lsub, status, append - -- ** selected state commands - , check, close, expunge - , search, store, copy - -- * fetch commands - , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot - , fetchFlags, fetchR, fetchByString, fetchByStringR - -- * other types - , Flag(..), Attribute(..), MailboxStatus(..) - , SearchQuery(..), FlagsQuery(..) - ) -where - -import Network -import Network.HaskellNet.BSStream -import Network.HaskellNet.Auth hiding (auth, login) -import qualified Network.HaskellNet.Auth as A - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS - -import Data.Digest.MD5 -import Control.Monad -import Control.Monad.Writer - -import System.IO -import System.Time - -import Data.IORef -import Data.Maybe -import Data.Word -import Data.List hiding (delete) -import Data.Char - -import Text.IMAPParsers hiding (exists, recent) -import Text.Packrat.Parse (Result) - - ----------------------------------------------------------------------- --- connection type and corresponding functions -data BSStream s => IMAPConnection s = - IMAPC s (IORef MailboxInfo) (IORef Int) - -mailbox :: BSStream s => IMAPConnection s -> IO Mailbox -mailbox (IMAPC _ mbox _) = fmap _mailbox $ readIORef mbox -exists, recent :: BSStream s => IMAPConnection s -> IO Integer -exists (IMAPC _ mbox _) = fmap _exists $ readIORef mbox -recent (IMAPC _ mbox _) = fmap _recent $ readIORef mbox - -flags, permanentFlags :: BSStream s => IMAPConnection s -> IO [Flag] -flags (IMAPC _ mbox _) = fmap _flags $ readIORef mbox -permanentFlags (IMAPC _ mbox _) = fmap _permanentFlags $ readIORef mbox - -isWritable, isFlagWritable :: BSStream s => IMAPConnection s -> IO Bool -isWritable (IMAPC _ mbox _) = fmap _isWritable $ readIORef mbox -isFlagWritable (IMAPC _ mbox _) = fmap _isFlagWritable $ readIORef mbox - -uidNext, uidValidity :: BSStream s => IMAPConnection s -> IO UID -uidNext (IMAPC _ mbox _) = fmap _uidNext $ readIORef mbox -uidValidity (IMAPC _ mbox _) = fmap _uidValidity $ readIORef mbox - -stream :: BSStream s => IMAPConnection s -> s -stream (IMAPC s _ _) = s - - - - --- suffixed by `s' -data SearchQuery = ALLs - | FLAG Flag - | UNFLAG Flag - | BCCs String - | BEFOREs CalendarTime - | BODYs String - | CCs String - | FROMs String - | HEADERs String String - | LARGERs Integer - | NEWs - | NOTs SearchQuery - | OLDs - | ONs CalendarTime - | ORs SearchQuery SearchQuery - | SENTBEFOREs CalendarTime - | SENTONs CalendarTime - | SENTSINCEs CalendarTime - | SINCEs CalendarTime - | SMALLERs Integer - | SUBJECTs String - | TEXTs String - | TOs String - | UIDs [UID] - - -instance Show SearchQuery where - showsPrec d q = showParen (d>app_prec) $ showString $ showQuery q - where app_prec = 10 - showQuery ALLs = "ALL" - showQuery (FLAG f) = showFlag f - showQuery (UNFLAG f) = "UN" ++ showFlag f - showQuery (BCCs addr) = "BCC " ++ addr - showQuery (BEFOREs t) = "BEFORE " ++ dateToStringIMAP t - showQuery (BODYs s) = "BODY " ++ s - showQuery (CCs addr) = "CC " ++ addr - showQuery (FROMs addr) = "FROM " ++ addr - showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ v - showQuery (LARGERs siz) = "LARGER {" ++ show siz ++ "}" - showQuery NEWs = "NEW" - showQuery (NOTs q) = "NOT " ++ show q - showQuery OLDs = "OLD" - showQuery (ONs t) = "ON " ++ dateToStringIMAP t - showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 - showQuery (SENTBEFOREs t) = "SENTBEFORE " ++ dateToStringIMAP t - showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t - showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t - showQuery (SINCEs t) = "SINCE " ++ dateToStringIMAP t - showQuery (SMALLERs siz) = "SMALLER {" ++ show siz ++ "}" - showQuery (SUBJECTs s) = "SUBJECT " ++ s - showQuery (TEXTs s) = "TEXT " ++ s - showQuery (TOs addr) = "TO " ++ addr - showQuery (UIDs uids) = concat $ intersperse "," $ map show uids - showFlag Seen = "SEEN" - showFlag Answered = "ANSWERED" - showFlag Flagged = "FLAGGED" - showFlag Deleted = "DELETED" - showFlag Draft = "DRAFT" - showFlag Recent = "RECENT" - showFlag (Keyword s) = "KEYWORD " ++ s - - -data FlagsQuery = ReplaceFlags [Flag] - | PlusFlags [Flag] - | MinusFlags [Flag] - - - ----------------------------------------------------------------------- --- establish connection - -connectIMAPPort :: String -> PortNumber -> IO (IMAPConnection Handle) -connectIMAPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream - -connectIMAP :: String -> IO (IMAPConnection Handle) -connectIMAP hostname = connectIMAPPort hostname 143 - -connectStream :: BSStream s => s -> IO (IMAPConnection s) -connectStream s = - do msg <- bsGetLine s - unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ fail "cannot connect to the server" - mbox <- newIORef emptyMboxInfo - c <- newIORef 0 - return $ IMAPC s mbox c - -emptyMboxInfo = MboxInfo "" 0 0 [] [] False False 0 0 - ----------------------------------------------------------------------- --- normal send commands -sendCommand' :: BSStream s => IMAPConnection s -> String -> IO ByteString -sendCommand' (IMAPC s mbox nr) cmdstr = - do num <- readIORef nr - bsPutCrLf s $ BS.pack $ show6 num ++ " " ++ cmdstr - modifyIORef nr (+1) - getResponse s - -show6 n | n > 100000 = show n - | n > 10000 = '0' : show n - | n > 1000 = "00" ++ show n - | n > 100 = "000" ++ show n - | n > 10 = "0000" ++ show n - | otherwise = "00000" ++ show n - -sendCommand :: BSStream s => IMAPConnection s -> String -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) -> IO v -sendCommand imapc@(IMAPC _ mbox nr) cmdstr pFunc = - do num <- readIORef nr - buf <- sendCommand' imapc cmdstr - let (resp, mboxUp, value) = eval pFunc (show6 num) buf - case resp of - OK _ _ -> do mboxUpdate mbox $ mboxUp - return value - NO _ msg -> fail ("NO: " ++ msg) - BAD _ msg -> fail ("BAD: " ++ msg) - PREAUTH _ msg -> fail ("preauth: " ++ msg) - -getResponse :: BSStream s => s -> IO ByteString -getResponse s = fmap unlinesCRLF getLs - where unlinesCRLF = BS.concat . concatMap (:[crlf]) - getLs = - do l <- fmap strip $ bsGetLine s - case () of - _ | isLiteral l -> do l' <- getLiteral l (getLitLen l) - ls <- getLs - return (l' : ls) - | isTagged l -> fmap (l:) getLs - | otherwise -> return [l] - getLiteral l len = - do lit <- bsGet s len - l2 <- fmap strip $ bsGetLine s - let l' = BS.concat [l, crlf, lit, l2] - if isLiteral l2 - then getLiteral l' (getLitLen l2) - else return l' - crlf = BS.pack "\r\n" - isLiteral l = BS.last l == '}' && BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{' - getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init - isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' ' - -mboxUpdate :: IORef MailboxInfo -> MboxUpdate -> IO () -mboxUpdate mbox (MboxUpdate exists recent) = - do when (isJust exists) $ do mb <- readIORef mbox - writeIORef mbox (mb { _exists = e }) - when (isJust recent) $ do mb <- readIORef mbox - writeIORef mbox (mb { _recent = r }) - where e = fromJust exists - r = fromJust recent - ----------------------------------------------------------------------- --- IMAP commands --- - -noop :: BSStream s => IMAPConnection s -> IO () -noop conn@(IMAPC s mbox _) = sendCommand conn "NOOP" pNone - -capability :: BSStream s => IMAPConnection s -> IO [String] -capability conn = sendCommand conn "CAPABILITY" pCapability - -logout :: BSStream s => IMAPConnection s -> IO () -logout conn@(IMAPC s _ _) = do bsPutCrLf s $ BS.pack "a0001 LOGOUT" - bsClose s - -login :: BSStream s => IMAPConnection s -> UserName -> Password -> IO () -login conn user pass = sendCommand conn ("LOGIN " ++ user ++ " " ++ pass) pNone - -select, examine, create, delete :: BSStream s => - IMAPConnection s -> Mailbox -> IO () -_select cmd conn@(IMAPC s mbox _) mboxName = - do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect - writeIORef mbox (mbox' { _mailbox = mboxName }) - -authenticate :: BSStream s => IMAPConnection s -> AuthType -> UserName -> Password -> IO () -authenticate conn@(IMAPC s mbox nr) LOGIN user pass = - do num <- readIORef nr - sendCommand' conn "AUTHENTICATE LOGIN" - bsPutCrLf s $ BS.pack userB64 - bsGetLine s - bsPutCrLf s $ BS.pack passB64 - buf <- getResponse s - let (resp, mboxUp, value) = eval pNone (show6 num) buf - case resp of - OK _ _ -> do mboxUpdate mbox $ mboxUp - return value - NO _ msg -> fail ("NO: " ++ msg) - BAD _ msg -> fail ("BAD: " ++ msg) - PREAUTH _ msg -> fail ("preauth: " ++ msg) - where (userB64, passB64) = A.login user pass -authenticate conn@(IMAPC s mbox nr) at user pass = - do num <- readIORef nr - c <- sendCommand' conn $ "AUTHENTICATE " ++ show at - let challenge = - if BS.take 2 c == BS.pack "+ " - then b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c - else "" - bsPutCrLf s $ BS.pack $ A.auth at challenge user pass - buf <- getResponse s - let (resp, mboxUp, value) = eval pNone (show6 num) buf - case resp of - OK _ _ -> do mboxUpdate mbox $ mboxUp - return value - NO _ msg -> fail ("NO: " ++ msg) - BAD _ msg -> fail ("BAD: " ++ msg) - PREAUTH _ msg -> fail ("preauth: " ++ msg) - -select = _select "SELECT " -examine = _select "EXAMINE " -create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone -delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone - -rename :: BSStream s => IMAPConnection s -> Mailbox -> Mailbox -> IO () -rename conn mboxorg mboxnew = - sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone - -subscribe, unsubscribe :: BSStream s => IMAPConnection s -> Mailbox -> IO () -subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone -unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone - -list, lsub :: BSStream s => IMAPConnection s -> IO [([Attribute], Mailbox)] -list conn = fmap (map (\(a, _, m) -> (a, m))) $ listFull conn "\"\"" "*" -lsub conn = fmap (map (\(a, _, m) -> (a, m))) $ lsubFull conn "\"\"" "*" - -listPat, lsubPat :: BSStream s => IMAPConnection s -> String -> IO [([Attribute], String, Mailbox)] -listPat conn pat = listFull conn "\"\"" pat -lsubPat conn pat = lsubFull conn "\"\"" pat - -listFull, lsubFull :: BSStream s => IMAPConnection s -> String -> String -> IO [([Attribute], String, Mailbox)] -listFull conn ref pat = sendCommand conn (unwords ["LIST", ref, pat]) pList -lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub - -status :: BSStream s => IMAPConnection s -> Mailbox -> [MailboxStatus] -> IO [(MailboxStatus, Integer)] -status conn mbox stats = - sendCommand conn ("STATUS " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")") pStatus - -append :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> IO () -append conn mbox mailData = appendFull conn mbox mailData [] Nothing - -appendFull :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> [Flag] -> Maybe CalendarTime -> IO () -appendFull conn@(IMAPC s mbInfo nr) mbox mailData flags time = - do num <- readIORef nr - buf <- sendCommand' conn - (unwords ["APPEND", mbox - , fstr, tstr, "{" ++ show len ++ "}"]) - unless (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response" - mapM_ (bsPutCrLf s) mailLines - buf <- getResponse s - let (resp, mboxUp, ()) = eval pNone (show6 num) buf - case resp of - OK _ _ -> mboxUpdate mbInfo mboxUp - NO _ msg -> fail ("NO: "++msg) - BAD _ msg -> fail ("BAD: "++msg) - PREAUTH _ msg -> fail ("PREAUTH: "++msg) - where mailLines = BS.lines mailData - len = sum $ map ((2+) . BS.length) mailLines - tstr = maybe "" show time - fstr = unwords $ map show flags - -check :: BSStream s => IMAPConnection s -> IO () -check conn = sendCommand conn "CHECK" pNone - -close :: BSStream s => IMAPConnection s -> IO () -close conn@(IMAPC s mbox _) = - do sendCommand conn "CLOSE" pNone - writeIORef mbox emptyMboxInfo - -expunge :: BSStream s => IMAPConnection s -> IO [Integer] -expunge conn = sendCommand conn "EXPUNGE" pExpunge - -search :: BSStream s => IMAPConnection s -> [SearchQuery] -> IO [UID] -search conn queries = searchCharset conn "" queries - -searchCharset :: BSStream s => IMAPConnection s -> Charset -> [SearchQuery] -> IO [UID] -searchCharset conn charset queries = - sendCommand conn ("UID SEARCH " - ++ (if not . null $ charset - then charset ++ " " - else "") - ++ unwords (map show queries)) pSearch - -fetch, fetchHeader :: BSStream s => IMAPConnection s -> UID -> IO ByteString -fetch conn uid = - do lst <- fetchByString conn uid "BODY[]" - return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst -fetchHeader conn uid = - do lst <- fetchByString conn uid "BODY[HEADER]" - return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst -fetchSize :: BSStream s => IMAPConnection s -> UID -> IO Int -fetchSize conn uid = - do lst <- fetchByString conn uid "RFC822.SIZE" - return $ maybe 0 read $ lookup "RFC822.SIZE" lst -fetchHeaderFields, fetchHeaderFieldsNot :: BSStream s => IMAPConnection s -> UID -> [String] -> IO ByteString -fetchHeaderFields conn uid hs = - do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]") - return $ maybe BS.empty BS.pack $ - lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst -fetchHeaderFieldsNot conn uid hs = - do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]") - return $ maybe BS.empty BS.pack $ lookup ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]") lst -fetchFlags :: BSStream s => IMAPConnection s -> UID -> IO [Flag] -fetchFlags conn uid = - do lst <- fetchByString conn uid "FLAGS" - return $ getFlags $ lookup "FLAGS" lst - where getFlags Nothing = [] - getFlags (Just s) = eval' dvFlags "" s - -fetchR :: BSStream s => IMAPConnection s -> (UID, UID) -> IO [(UID, ByteString)] -fetchR conn r = - do lst <- fetchByStringR conn r "BODY[]" - return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ lookup "BODY[]" vs)) lst -fetchByString :: BSStream s => IMAPConnection s -> UID -> String -> IO [(String, String)] -fetchByString conn uid command = - do lst <- fetchCommand conn ("UID FETCH "++show uid++" "++command) id - return $ snd $ head lst -fetchByStringR :: BSStream s => IMAPConnection s -> (UID, UID) -> String -> IO [(UID, [(String, String)])] -fetchByStringR conn (s, e) command = - fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc - where proc (n, ps) = - (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps) - -fetchCommand conn command proc = - fmap (map proc) $ sendCommand conn command pFetch - -storeFull :: BSStream s => IMAPConnection s -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])] -storeFull conn uidstr query isSilent = - fetchCommand conn ("UID STORE " ++ uidstr ++ flags query) procStore - where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" - toFStr s fstrs = - s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs - flags (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs - flags (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs - flags (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs - procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read - (lookup "UID" ps) - ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps)) - - -store :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO () -storeR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO () -store conn i q = storeFull conn (show i) q True >> return () -storeR conn (s, e) q = storeFull conn (show s++":"++show e) q True >> return () --- storeResults is used without .SILENT, so that its response contains its result flags -storeResults :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO [Flag] -storeResultsR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO [(UID, [Flag])] -storeResults conn i q = - storeFull conn (show i) q False >>= return . snd . head -storeResultsR conn (s, e) q = storeFull conn (show s++":"++show e) q False - -copy :: BSStream s => IMAPConnection s -> UID -> Mailbox -> IO () -copyR :: BSStream s => IMAPConnection s -> (UID, UID) -> Mailbox -> IO () -copyFull conn uidStr mbox = - sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ mbox) pNone - -copy conn uid mbox = copyFull conn (show uid) mbox -copyR conn (s, e) mbox = copyFull conn (show s++":"++show e) mbox - - ----------------------------------------------------------------------- --- auxialiary functions - -dateToStringIMAP :: CalendarTime -> String -dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date - , showMonth $ ctMonth date - , show $ ctYear date] - where show2 n | n < 10 = '0' : show n - | otherwise = show n - showMonth January = "Jan" - showMonth February = "Feb" - showMonth March = "Mar" - showMonth April = "Apr" - showMonth May = "May" - showMonth June = "Jun" - showMonth July = "Jul" - showMonth August = "Aug" - showMonth September = "Sep" - showMonth October = "Oct" - showMonth November = "Nov" - showMonth December = "Dec" - -strip :: ByteString -> ByteString -strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace diff --git a/Network/HaskellNet/POP3.hs b/Network/HaskellNet/POP3.hs deleted file mode 100644 --- a/Network/HaskellNet/POP3.hs +++ /dev/null @@ -1,296 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Network.HaskellNet.POP3 --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- POP3 client implementation --- - -module Network.HaskellNet.POP3 - ( -- * Types - Command(..) - , POP3Connection(..) - , Response(..) - -- * Establishing Connection - , connectPop3Port - , connectPop3 - , connectStream - -- * Send Command - , sendCommand - -- * More Specific Operations - , closePop3 - , user - , pass - , userPass - , apop - , auth - , stat - , dele - , retr - , top - , rset - , allList - , list - , allUIDLs - , uidl - -- * Other Useful Operations - , doPop3Port - , doPop3 - , doPop3Stream - ) - where - -import Network.HaskellNet.BSStream -import Network -import Network.HaskellNet.Auth hiding (auth, login) -import qualified Network.HaskellNet.Auth as A - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Digest.MD5 -import Numeric (showHex) - -import Control.Exception -import Control.Monad (when, unless) - -import Data.List -import Data.Char (isSpace, isControl) - -import System.IO - -import qualified Data.ByteString.Char8 as BSC - -import Prelude hiding (catch) - -data BSStream s => POP3Connection s = POP3C !s !String -- ^ APOP key - -data Command = USER UserName - | PASS Password - | APOP UserName Password - | AUTH AuthType UserName Password - | NOOP - | QUIT - | STAT - | LIST (Maybe Int) - | DELE Int - | RETR Int - | RSET - | TOP Int Int - | UIDL (Maybe Int) - -data Response = Ok | Err - deriving (Eq, Show) - - -hexDigest = concatMap (flip showHex "") . hash . map (toEnum.fromEnum) - -strip :: ByteString -> ByteString -strip = trimR . trimR - where - trimR s = let rs = BS.reverse s in - BS.dropWhile blank rs - -blank :: Char -> Bool -blank a = isSpace a || isControl a ---strip s = head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.dropWhile isSpace s - - --- | --- connecting to the pop3 server specified by the hostname and port number -connectPop3Port :: String -> PortNumber -> IO (POP3Connection Handle) -connectPop3Port hostname port = connectTo hostname (PortNumber port) >>= connectStream - --- | --- connecting to the pop3 server specified by the hostname. 110 is used for the port number. -connectPop3 :: String -> IO (POP3Connection Handle) -connectPop3 = flip connectPop3Port 110 - --- | --- connecting to the pop3 server via a stream -connectStream :: BSStream s => s -> IO (POP3Connection s) -connectStream st = - do (resp, msg) <- response st - when (resp == Err) $ fail "cannot connect" - let code = last $ BS.words msg - if BS.head code == '<' && BS.last code == '>' - then return $ POP3C st (BS.unpack code) - else return $ POP3C st "" - - -response :: BSStream s => s -> IO (Response, ByteString) -response st = - do reply <- fmap strip $ bsGetLine st - if (BS.pack "+OK") `BS.isPrefixOf` reply - then return (Ok, BS.drop 4 reply) - else return (Err, BS.drop 5 reply) - --- | parse mutiline of response -responseML :: BSStream s => s -> IO (Response, ByteString) -responseML st = - do reply <- fmap strip $ bsGetLine st - if (BS.pack "+OK") `BS.isPrefixOf` reply - then do rest <- getRest - return (Ok, BS.unlines (BS.drop 4 reply : rest)) - else return (Err, BS.drop 5 reply) - where getRest = do l <- fmap strip $ bsGetLine st - if l == BS.singleton '.' - then return [] - else fmap (l:) getRest - -{- -response :: BSStream s => s -> IO (Response, ByteString) -response st = - do reply <- bsGetLine st --- reply <- fmap strip $ bsGetLine st - if (BS.pack "+OK") `BS.isPrefixOf` reply - then return (Ok, BS.drop 4 reply) - else return (Err, BS.drop 5 reply) - --- | parse mutiline of response - --- do reply <- fmap strip $ bsGetLine st -responseML :: BSStream s => s -> IO (Response, ByteString) -responseML st = - do reply <- bsGetLine st - if (BS.pack "+OK") `BS.isPrefixOf` reply - then do rest <- getRest - return (Ok, BS.unlines (BS.drop 4 reply : rest)) - else return (Err, BS.drop 5 reply) --- where getRest = do l <- fmap strip $ bsGetLine st --- if l == BS.singleton '.' - where getRest = do l <- bsGetLine st - if BS.null l - then return [] - else fmap (l:) getRest --} - --- | sendCommand sends a pop3 command via a pop3 connection. This --- action is too generic. Use more specific actions -sendCommand :: BSStream s => POP3Connection s -> Command -> IO (Response, ByteString) -sendCommand (POP3C conn _) (LIST Nothing) = - bsPutCrLf conn (BS.pack "LIST") >> responseML conn -sendCommand (POP3C conn _) (UIDL Nothing) = - bsPutCrLf conn (BS.pack "UIDL") >> responseML conn -sendCommand (POP3C conn _) (RETR msg) = - bsPutCrLf conn (BS.pack $ "RETR " ++ show msg) >> responseML conn -sendCommand (POP3C conn _) (TOP msg n) = - bsPutCrLf conn (BS.pack $ "TOP " ++ show msg ++ " " ++ show n) >> responseML conn -sendCommand (POP3C conn _) (AUTH LOGIN user pass) = - do bsPutCrLf conn $ BS.pack "AUTH LOGIN" - bsGetLine conn - bsPutCrLf conn $ BS.pack userB64 - bsGetLine conn - bsPutCrLf conn $ BS.pack passB64 - response conn - where (userB64, passB64) = A.login user pass -sendCommand (POP3C conn _) (AUTH at user pass) = - do bsPutCrLf conn $ BS.pack $ unwords ["AUTH", show at] - c <- bsGetLine conn - let challenge = - if BS.take 2 c == BS.pack "+ " - then b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c - else "" - bsPutCrLf conn $ BS.pack $ A.auth at challenge user pass - response conn -sendCommand (POP3C conn msg_id) command = - bsPutCrLf conn (BS.pack commandStr) >> response conn - where commandStr = case command of - (USER name) -> "USER " ++ name - (PASS pass) -> "PASS " ++ pass - NOOP -> "NOOP" - QUIT -> "QUIT" - STAT -> "STAT" - (DELE msg) -> "DELE " ++ show msg - RSET -> "RSET" - (LIST msg) -> "LIST " ++ maybe "" show msg - (UIDL msg) -> "UIDL " ++ maybe "" show msg - (APOP user pass) -> "APOP " ++ user ++ " " ++ hexDigest (msg_id ++ pass) - -user :: BSStream s => POP3Connection s -> String -> IO () -user conn name = do (resp, _) <- sendCommand conn (USER name) - when (resp == Err) $ fail "cannot send user name" - -pass :: BSStream s => POP3Connection s -> String -> IO () -pass conn pwd = do (resp, _) <- sendCommand conn (PASS pwd) - when (resp == Err) $ fail "cannot send password" - -userPass :: BSStream s => POP3Connection s -> UserName -> Password -> IO () -userPass conn name pwd = user conn name >> pass conn pwd - -auth :: BSStream s => POP3Connection s -> AuthType -> UserName -> Password -> IO () -auth conn at user pass = - do (resp, msg) <- sendCommand conn (AUTH at user pass) - unless (resp == Ok) $ fail $ "authentication failed: " ++ BS.unpack msg - - -apop :: BSStream s => POP3Connection s -> String -> String -> IO () -apop conn name pwd = - do (resp, msg) <- sendCommand conn (APOP name pwd) - when (resp == Err) $ fail $ "authentication failed: " ++ BS.unpack msg - -stat :: BSStream s => POP3Connection s -> IO (Int, Int) -stat conn = do (resp, msg) <- sendCommand conn STAT - when (resp == Err) $ fail "cannot get stat info" - let (nn, mm) = BS.span (/=' ') msg - return (read $ BS.unpack nn, read $ BS.unpack $ BS.tail mm) - -dele :: BSStream s => POP3Connection s -> Int -> IO () -dele conn n = do (resp, _) <- sendCommand conn (DELE n) - when (resp == Err) $ fail "cannot delete" - -retr :: BSStream s => POP3Connection s -> Int -> IO ByteString -retr conn n = do (resp, msg) <- sendCommand conn (RETR n) - when (resp == Err) $ fail "cannot retrieve" - return $ BS.tail $ BS.dropWhile (/='\n') msg - -top :: BSStream s => POP3Connection s -> Int -> Int -> IO ByteString -top conn n m = do (resp, msg) <- sendCommand conn (TOP n m) - when (resp == Err) $ fail "cannot retrieve" - return $ BS.tail $ BS.dropWhile (/='\n') msg - -rset :: BSStream s => POP3Connection s -> IO () -rset conn = do (resp, _) <- sendCommand conn RSET - when (resp == Err) $ fail "cannot reset" - -allList :: BSStream s => POP3Connection s -> IO [(Int, Int)] -allList conn = do (resp, lst) <- sendCommand conn (LIST Nothing) - when (resp == Err) $ fail "cannot retrieve the list" - return $ map f $ tail $ BS.lines lst - where f s = let (n1, n2) = BS.span (/=' ') s - in (read $ BS.unpack n1, read $ BS.unpack $ BS.tail n2) - -list :: BSStream s => POP3Connection s -> Int -> IO Int -list conn n = do (resp, lst) <- sendCommand conn (LIST (Just n)) - when (resp == Err) $ fail "cannot retrieve the list" - let (_, n2) = BS.span (/=' ') lst - return $ read $ BS.unpack $ BS.tail n2 - -allUIDLs :: BSStream s => POP3Connection s -> IO [(Int, ByteString)] -allUIDLs conn = do (resp, lst) <- sendCommand conn (UIDL Nothing) - when (resp == Err) $ fail "cannot retrieve the uidl list" - return $ map f $ tail $ BS.lines lst - where f s = let (n1, n2) = BS.span (/=' ') s in (read $ BS.unpack n1, n2) - -uidl :: BSStream s => POP3Connection s -> Int -> IO ByteString -uidl conn n = do (resp, msg) <- sendCommand conn (UIDL (Just n)) - when (resp == Err) $ fail "cannot retrieve the uidl data" - return $ BS.tail $ BS.dropWhile (/=' ') msg - -closePop3 :: BSStream s => POP3Connection s -> IO () -closePop3 c@(POP3C conn _) = do sendCommand c QUIT - bsClose conn - -doPop3Port :: String -> PortNumber -> (POP3Connection Handle -> IO a) -> IO a -doPop3Port host port execution = - bracket (connectPop3Port host port) closePop3 execution - -doPop3 :: String -> (POP3Connection Handle -> IO a) -> IO a -doPop3 host execution = doPop3Port host 110 execution - -doPop3Stream :: BSStream s => s -> (POP3Connection s -> IO b) -> IO b -doPop3Stream conn execution = bracket (connectStream conn) closePop3 execution diff --git a/Network/HaskellNet/SMTP.hs b/Network/HaskellNet/SMTP.hs deleted file mode 100644 --- a/Network/HaskellNet/SMTP.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------- --- | --- Module : Network.HaskellNet.SMTP --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- SMTP client implementation --- - -module Network.HaskellNet.SMTP - ( -- * Types - Command(..) - , Response(..) - , SMTPConnection - -- * Establishing Connection - , connectSMTPPort - , connectSMTP - , connectStream - -- * Operation to a Connection - , sendCommand - , closeSMTP - -- * Other Useful Operations - , sendMail - , doSMTPPort - , doSMTP - , doSMTPStream - , sendMimeMail - ) - where - -import Network.HaskellNet.BSStream -import Data.ByteString (ByteString, append) -import qualified Data.ByteString.Char8 as BS -import Network.BSD (getHostName) -import Network - -import Control.Exception -import Control.Monad (unless) - -import Data.List (intersperse) -import Data.Char (chr, ord, isSpace, isDigit) - -import Network.HaskellNet.Auth - -import System.IO - -import Network.Mail.Mime -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString as S - -import Data.Text (Text) -import qualified Data.Text.Lazy as LT -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -import Prelude hiding (catch) - -data (BSStream s) => SMTPConnection s = SMTPC !s ![ByteString] - -data Command = HELO String - | EHLO String - | MAIL String - | RCPT String - | DATA ByteString - | EXPN String - | VRFY String - | HELP String - | AUTH AuthType UserName Password - | NOOP - | RSET - | QUIT - deriving (Show, Eq) - -type ReplyCode = Int - -data Response = Ok - | SystemStatus - | HelpMessage - | ServiceReady - | ServiceClosing - | UserNotLocal - | CannotVerify - | StartMailInput - | ServiceNotAvailable - | MailboxUnavailable - | ErrorInProcessing - | InsufficientSystemStorage - | SyntaxError - | ParameterError - | CommandNotImplemented - | BadSequence - | ParameterNotImplemented - | MailboxUnavailableError - | UserNotLocalError - | ExceededStorage - | MailboxNotAllowed - | TransactionFailed - deriving (Show, Eq) - -codeToResponse :: Num a => a -> Response -codeToResponse 211 = SystemStatus -codeToResponse 214 = HelpMessage -codeToResponse 220 = ServiceReady -codeToResponse 221 = ServiceClosing -codeToResponse 250 = Ok -codeToResponse 251 = UserNotLocal -codeToResponse 252 = CannotVerify -codeToResponse 354 = StartMailInput -codeToResponse 421 = ServiceNotAvailable -codeToResponse 450 = MailboxUnavailable -codeToResponse 451 = ErrorInProcessing -codeToResponse 452 = InsufficientSystemStorage -codeToResponse 500 = SyntaxError -codeToResponse 501 = ParameterError -codeToResponse 502 = CommandNotImplemented -codeToResponse 503 = BadSequence -codeToResponse 504 = ParameterNotImplemented -codeToResponse 550 = MailboxUnavailableError -codeToResponse 551 = UserNotLocalError -codeToResponse 552 = ExceededStorage -codeToResponse 553 = MailboxNotAllowed -codeToResponse 554 = TransactionFailed - -crlf = BS.pack "\r\n" - -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight _ = False - --- | connecting SMTP server with the specified name and port number. -connectSMTPPort :: String -- ^ name of the server - -> PortNumber -- ^ port number - -> IO (SMTPConnection Handle) -connectSMTPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream - --- | connecting SMTP server with the specified name and port 25. -connectSMTP :: String -- ^ name of the server - -> IO (SMTPConnection Handle) -connectSMTP = flip connectSMTPPort 25 - --- | create SMTPConnection from already connected Stream -connectStream :: BSStream s => s -> IO (SMTPConnection s) -connectStream st = - do (code, msg) <- parseResponse st - unless (code == 220) $ - do bsClose st - fail "cannot connect to the server" - senderHost <- getHostName - (code, msg) <- sendCommand (SMTPC st []) (EHLO senderHost) - unless (code == 250) $ - do (code, msg) <- sendCommand (SMTPC st []) (HELO senderHost) - unless (code == 250) $ - do bsClose st - fail "cannot connect to the server" - return (SMTPC st (tail $ BS.lines msg)) - -parseResponse :: BSStream s => s -> IO (ReplyCode, ByteString) -parseResponse st = - do (code, bdy) <- readLines - return (read $ BS.unpack code, BS.unlines bdy) - where readLines = - do l <- bsGetLine st - let (c, bdy) = BS.span isDigit l - if not (BS.null bdy) && BS.head bdy == '-' - then do (c, ls) <- readLines - return (c, (BS.tail bdy:ls)) - else return (c, [BS.tail bdy]) - - --- | send a method to a server -sendCommand :: BSStream s => SMTPConnection s -> Command -> IO (ReplyCode, ByteString) -sendCommand (SMTPC conn _) (DATA dat) = - do bsPutCrLf conn $ BS.pack "DATA" - (code, msg) <- parseResponse conn - unless (code == 354) $ fail "this server cannot accept any data." - mapM_ sendLine $ BS.lines dat ++ [BS.pack "."] - parseResponse conn - where sendLine l = bsPutCrLf conn l -sendCommand (SMTPC conn _) (AUTH LOGIN username password) = - do bsPutCrLf conn command - (code, msg) <- parseResponse conn - bsPutCrLf conn $ BS.pack userB64 - (code, msg) <- parseResponse conn - bsPutCrLf conn $ BS.pack passB64 - parseResponse conn - where command = BS.pack $ "AUTH LOGIN" - (userB64, passB64) = login username password -sendCommand (SMTPC conn _) (AUTH at username password) = - do bsPutCrLf conn command - (code, msg) <- parseResponse conn - unless (code == 334) $ fail "authentication failed." - bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password - parseResponse conn - where command = BS.pack $ unwords ["AUTH", show at] -sendCommand (SMTPC conn _) meth = - do bsPutCrLf conn $ BS.pack command - parseResponse conn - where command = case meth of - (HELO param) -> "HELO " ++ param - (EHLO param) -> "EHLO " ++ param - (MAIL param) -> "MAIL FROM:<" ++ param ++ ">" - (RCPT param) -> "RCPT TO:<" ++ param ++ ">" - (EXPN param) -> "EXPN " ++ param - (VRFY param) -> "VRFY " ++ param - (HELP msg) -> if null msg - then "HELP\r\n" - else "HELP " ++ msg - NOOP -> "NOOP" - RSET -> "RSET" - QUIT -> "QUIT" - --- | --- close the connection. This function send the QUIT method, so you --- do not have to QUIT method explicitly. -closeSMTP :: BSStream s => SMTPConnection s -> IO () -closeSMTP c@(SMTPC conn _) = do bsClose conn - -{- -I must be being stupid here -I can't seem to be able to catch the exception arising from the connection already being closed -this would be the correct way to do it but instead we're being naughty above by just closes the -connection without first sending QUIT -closeSMTP c@(SMTPC conn _) = do sendCommand c QUIT - bsClose conn `catch` \(_ :: IOException) -> return () --} - --- | --- sending a mail to a server. This is achieved by sendMessage. If --- something is wrong, it raises an IOexception. -sendMail :: BSStream s => - String -- ^ sender mail - -> [String] -- ^ receivers - -> ByteString -- ^ data - -> SMTPConnection s - -> IO () -sendMail sender receivers dat conn = - catcher `handle` mainProc - where mainProc = do (250, _) <- sendCommand conn (MAIL sender) - vals <- mapM (sendCommand conn . RCPT) receivers - unless (all ((==250) . fst) vals) $ fail "sendMail error" - (250, _) <- sendCommand conn (DATA dat) - return () - catcher e@(PatternMatchFail _) = throwIO e --- catcher e@(PatternMatchFail _) = fail "sendMail error" --- catcher e = throwIO e - --- | --- doSMTPPort open a connection, and do an IO action with the --- connection, and then close it. -doSMTPPort :: String -> PortNumber -> (SMTPConnection Handle -> IO a) -> IO a -doSMTPPort host port execution = - bracket (connectSMTPPort host port) closeSMTP execution - --- | --- doSMTP is similar to doSMTPPort, except that it does not --- require port number but connects to the server with port 25. -doSMTP :: String -> (SMTPConnection Handle -> IO a) -> IO a -doSMTP host execution = doSMTPPort host 25 execution - --- | --- doSMTPStream is similar to doSMTPPort, except that its argument is --- a Stream data instead of hostname and port number. -doSMTPStream :: BSStream s => s -> (SMTPConnection s -> IO a) -> IO a -doSMTPStream s execution = bracket (connectStream s) closeSMTP execution - ---sendMimeMail :: BSStream s => String -> String -> String -> LT.Text -> LT.Text -> [(String, FilePath)] -> SMTPConnection s -> IO () ---sendMimeMail to from subject plainBody htmlBody attachments con = --- sendMimeMail (LT.pack to) (LT.pack from) (LT.pack subject) plainBody htmlBody (map (\x -> ((LT.pack . fst) x, (snd x))) attachments) con - - -sendMimeMail :: BSStream s => String -> String -> String -> LT.Text -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection s -> IO () ---sendMimeMail :: BSStream s => T.Text -> T.Text -> T.Text -> LT.Text -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection s -> IO () -sendMimeMail to from subject plainBody htmlBody attachments con = do - myMail <- simpleMail (T.pack to) (T.pack from) (T.pack subject) plainBody htmlBody attachments - renderedMail <- renderMail' myMail - sendMail from [to] (lazyToStrict renderedMail) con - closeSMTP con - --- haskellNet uses strict bytestrings --- TODO: look at making haskellnet lazy -lazyToStrict = S.concat . B.toChunks - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,13 @@ HaskellNet ========== -Some examples of how to use the library are contained in -the example directory. You should be able to run them -by adjusting the file for your mail server settings and -then loading the file in ghci and type 'main'. eg. +This package provides client support for the E-mail protocols POP3, +SMTP, and IMAP. + +Some examples of how to use the library are contained in the example/ +directory. You should be able to run them by adjusting the file for +your mail server settings and then loading the file in ghci and type +'main'. eg. ghci -hide-package monads-fd example/smtpMimeMail.hs main diff --git a/Text/IMAPParsers.hs b/Text/IMAPParsers.hs deleted file mode 100644 --- a/Text/IMAPParsers.hs +++ /dev/null @@ -1,492 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Text.IMAPParsers --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- Parsers for IMAP server responses --- - -module Text.IMAPParsers where - -import Text.Packrat.Parse hiding (space, spaces) -import Text.Packrat.Pos - -import Data.Maybe -import Data.Word - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS - -type Mailbox = String -type UID = Word64 -type Charset = String - - -data MailboxInfo = MboxInfo { _mailbox :: Mailbox - , _exists :: Integer - , _recent :: Integer - , _flags :: [Flag] - , _permanentFlags :: [Flag] - , _isWritable :: Bool - , _isFlagWritable :: Bool - , _uidNext :: UID - , _uidValidity :: UID - } - deriving (Show, Eq) - - -data Flag = Seen - | Answered - | Flagged - | Deleted - | Draft - | Recent - | Keyword String - deriving Eq - -instance Show Flag where - showsPrec d f = showParen (d > app_prec) $ showString $ showFlag f - where app_prec = 10 - showFlag Seen = "\\Seen" - showFlag Answered = "\\Answered" - showFlag Flagged = "\\Flagged" - showFlag Deleted = "\\Deleted" - showFlag Draft = "\\Draft" - showFlag Recent = "\\Recent" - showFlag (Keyword s) = "\\" ++ s - -data Attribute = Noinferiors - | Noselect - | Marked - | Unmarked - | OtherAttr String - deriving (Show, Eq) - -data MboxUpdate = MboxUpdate { exists :: Maybe Integer - , recent :: Maybe Integer } - deriving (Show, Eq) - -data StatusCode = ALERT - | BADCHARSET [Charset] - | CAPABILITY_sc [String] - | PARSE - | PERMANENTFLAGS [Flag] - | READ_ONLY - | READ_WRITE - | TRYCREATE - | UIDNEXT_sc UID - | UIDVALIDITY_sc UID - | UNSEEN_sc Integer - deriving (Eq, Show) - -data ServerResponse = OK (Maybe StatusCode) String - | NO (Maybe StatusCode) String - | BAD (Maybe StatusCode) String - | PREAUTH (Maybe StatusCode) String - deriving (Eq, Show) - - --- | the query data type for the status command -data MailboxStatus = MESSAGES -- ^ the number of messages in the mailbox - | RECENT -- ^ the number of messages with the \Recent flag set - | UIDNEXT -- ^ the next unique identifier value of the mailbox - | UIDVALIDITY -- ^ the unique identifier validity value of the mailbox - deriving (Show, Read, Eq) - - - - -data RespDerivs = - RespDerivs { dvFlags :: Result RespDerivs [Flag] - , advTag :: Result RespDerivs String - , advChar :: Result RespDerivs Char - , advPos :: Pos - } - -instance Derivs RespDerivs where - dvChar = advChar - dvPos = advPos - - -eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r -eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of - Parsed v d' e' -> v - NoParse e -> error (show e) - - -parse :: String -> Pos -> ByteString -> RespDerivs -parse tagstr pos s = d - where d = RespDerivs flag tag chr pos - flag = pParenFlags d - tag = Parsed tagstr d (nullError d) - chr = if BS.null s - then NoParse (eofError d) - else let (c, s') = (BS.head s, BS.tail s) - in Parsed c (parse tagstr (nextPos pos c) s') - (nullError d) - -eval' :: (RespDerivs -> Result RespDerivs r) -> String -> String -> r -eval' pMain tag s = case pMain (parse' tag (Pos tag 1 1) s) of - Parsed v d' e' -> v - NoParse e -> error (show e) - -parse' :: String -> Pos -> String -> RespDerivs -parse' tagstr pos s = d - where d = RespDerivs flag tag chr pos - flag = pParenFlags d - tag = Parsed tagstr d (nullError d) - chr = case s of - (c:s') -> Parsed c (parse' tagstr (nextPos pos c) s') - (nullError d) - _ -> NoParse (eofError d) - -mkMboxUpdate untagged = (MboxUpdate exists recent, others) - where exists = lookup "EXISTS" $ catLefts untagged - recent = lookup "RECENT" $ catLefts untagged - others = catRights untagged - -pNone :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, ()) -Parser pNone = - do untagged <- many pOtherLine - resp <- Parser pDone - let (mboxUp, _) = mkMboxUpdate untagged - return (resp, mboxUp, ()) - -pCapability :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [String]) -Parser pCapability = - do untagged <- many (pCapabilityLine <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, caps) = mkMboxUpdate untagged - return (resp, mboxUp, concat caps) - - -pList :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)]) -Parser pList = - do untagged <- many (pListLine "LIST" <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, listRes) = mkMboxUpdate untagged - return (resp, mboxUp, listRes) - -pLsub :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)]) -Parser pLsub = - do untagged <- many (pListLine "LSUB" <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, listRes) = mkMboxUpdate untagged - return (resp, mboxUp, listRes) - -pStatus :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(MailboxStatus, Integer)]) -Parser pStatus = - do untagged <- many (pStatusLine <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, statRes) = mkMboxUpdate untagged - return (resp, mboxUp, concat statRes) - -pExpunge :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [Integer]) -Parser pExpunge = - do untagged <- many ((do string "* " - n <- pExpungeLine - return $ Right ("EXPUNGE", n)) - <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, expunges) = mkMboxUpdate untagged - return (resp, mboxUp, lookups "EXPUNGE" expunges) - -pSearch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [UID]) -Parser pSearch = - do untagged <- many (pSearchLine <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, searchRes) = mkMboxUpdate untagged - return (resp, mboxUp, concat searchRes) - - -pSelect :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, MailboxInfo) -Parser pSelect = - do untagged <- many (pSelectLine - <|> (do string "* " - anyChar `manyTill` crlfP - return id)) - resp <- Parser pDone - let box = case resp of - OK writable _ -> - emptyBox { _isWritable = isJust writable && fromJust writable == READ_WRITE } - _ -> emptyBox - return (resp, MboxUpdate Nothing Nothing, foldl (flip ($)) box untagged) - where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0 - -pFetch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(Integer, [(String, String)])]) -Parser pFetch = - do untagged <- many (pFetchLine <|> pOtherLine) - resp <- Parser pDone - let (mboxUp, fetchRes) = mkMboxUpdate untagged - return (resp, mboxUp, fetchRes) - - -pDone :: RespDerivs -> Result RespDerivs ServerResponse -Parser pDone = do tag <- Parser advTag - string tag >> space - respCode <- parseCode - space - stat <- optional (do s <- parseStatusCode - space >> return s) - body <- anyChar `manyTill` crlfP - return $ respCode stat body - where parseCode = choice $ [ string "OK" >> return OK - , string "NO" >> return NO - , string "BAD" >> return BAD - , string "PREAUTH" >> return PREAUTH - ] - parseStatusCode = - between (char '[') (char ']') $ - choice [ string "ALERT" >> return ALERT - , do { string "BADCHARSET" - ; ws <- optional parenWords - ; return $ BADCHARSET $ fromMaybe [] ws } - , do { string "CAPABILITY" - ; space - ; ws <- (many1 $ noneOf " ]") `sepBy1` space - ; return $ CAPABILITY_sc ws } - , string "PARSE" >> return PARSE - , do { string "PERMANENTFLAGS" >> space >> char '(' - ; fs <- pFlag `sepBy1` spaces1 - ; char ')' - ; return $ PERMANENTFLAGS fs } - , string "READ-ONLY" >> return READ_ONLY - , string "READ-WRITE" >> return READ_WRITE - , string "TRYCREATE" >> return TRYCREATE - , do { string "UNSEEN" >> space - ; num <- many1 digit - ; return $ UNSEEN_sc $ read num } - , do { string "UIDNEXT" >> space - ; num <- many1 digit - ; return $ UIDNEXT_sc $ read num } - , do { string "UIDVALIDITY" >> space - ; num <- many1 digit - ; return $ UIDVALIDITY_sc $ read num } - ] - parenWords = between (space >> char '(') (char ')') - (many1 (noneOf " )") `sepBy1` space) - - - -pFlag :: Parser RespDerivs Flag -pFlag = do char '\\' - choice [ string "Seen" >> return Seen - , string "Answered" >> return Answered - , string "Flagged" >> return Flagged - , string "Deleted" >> return Deleted - , string "Draft" >> return Draft - , string "Recent" >> return Recent - , char '*' >> return (Keyword "*") - , many1 atomChar >>= return . Keyword ] - <|> (many1 atomChar >>= return . Keyword) - -pParenFlags :: RespDerivs -> Result RespDerivs [Flag] -Parser pParenFlags = do char '(' - fs <- pFlag `sepBy` space - char ')' - return fs - -atomChar :: Derivs d => Parser d Char -atomChar = noneOf " (){%*\"\\]" - - -pNumberedLine :: String -> Parser RespDerivs Integer -pNumberedLine str = do num <- many1 digit - space - string str - crlfP - return $ read num - -pExistsLine, pRecentLine, pExpungeLine :: Parser RespDerivs Integer -pExistsLine = pNumberedLine "EXISTS" -pRecentLine = pNumberedLine "RECENT" -pExpungeLine = pNumberedLine "EXPUNGE" - - -pOtherLine :: Parser RespDerivs (Either (String, Integer) b) -pOtherLine = do string "* " - choice [ pExistsLine >>= \n -> return (Left ("EXISTS", n)) - , pRecentLine >>= \n -> return (Left ("RECENT", n)) - , blankLine >> return (Left ("", 0))] - where blankLine = anyChar `manyTill` crlfP - - -pCapabilityLine :: Parser RespDerivs (Either a [String]) -pCapabilityLine = do string "* CAPABILITY " - ws <- many1 (noneOf " \r") `sepBy` space - crlfP - return $ Right ws - - -pListLine :: String - -> Parser RespDerivs (Either a ([Attribute], String, Mailbox)) -pListLine list = - do string "* " >> string list >> space - attrs <- parseAttrs - sep <- parseSep - mbox <- parseMailbox - return $ Right (attrs, sep, mbox) - where parseAttr = - do char '\\' - choice [ string "Noinferior" >> return Noinferiors - , string "Noselect" >> return Noselect - , string "Marked" >> return Marked - , string "Unmarked" >> return Unmarked - , many atomChar >>= return . OtherAttr - ] - parseAttrs = do char '(' - attrs <- parseAttr `sepBy` space - char ')' - return attrs - parseSep = space >> char '"' >> anyChar `manyTill` char '"' - parseMailbox = space >> anyChar `manyTill` crlfP - - -pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) -pStatusLine = - do string "* STATUS " - mbox <- anyChar `manyTill` space - stats <- between (char '(') (char ')') (parseStat `sepBy1` space) - crlfP - return $ Right stats - where parseStat = - do cons <- choice [ string "MESSAGES" >>= return . read - , string "RECENT" >>= return . read - , string "UIDNEXT" >>= return . read - , string "UIDVALIDITY" >>= return . read - ] - space - num <- many1 digit >>= return . read - return (cons, num) - - -pSearchLine :: Parser RespDerivs (Either a [UID]) -pSearchLine = do string "* SEARCH " - nums <- (many1 digit) `sepBy` space - crlfP - return $ Right $ map read nums - - -pSelectLine :: Parser RespDerivs (MailboxInfo -> MailboxInfo) -pSelectLine = - do string "* " - choice [ pExistsLine >>= \n -> return (\mbox -> mbox { _exists = n }) - , pRecentLine >>= \n -> return (\mbox -> mbox { _recent = n }) - , pFlags >>= \fs -> return (\mbox -> mbox { _flags = fs }) - , string "OK " >> okResps ] - where pFlags = do string "FLAGS " - char '(' - fs <- pFlag `sepBy` space - char ')' >> crlfP - return fs - okResps = - do char '[' - v <- choice [ do { string "UNSEEN " - ; n <- many1 digit - ; return $ id } - , do { string "PERMANENTFLAGS (" - ; fs <- pFlag `sepBy` space - ; char ')' - ; return $ \mbox -> - mbox { _isFlagWritable = - Keyword "*" `elem` fs - , _permanentFlags = - filter (/= Keyword "*") fs } } - , do { string "UIDNEXT " - ; n <- many1 digit - ; return $ \mbox -> - mbox { _uidNext = read n } } - , do { string "UIDVALIDITY " - ; n <- many1 digit - ; return $ \mbox -> - mbox { _uidValidity = read n } } - ] - char ']' - anyChar `manyTill` crlfP - return v - - -pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)])) -pFetchLine = - do string "* " - num <- many1 digit - string " FETCH" >> spaces - char '(' - pairs <- pPair `sepBy` space - char ')' - crlfP - return $ Right $ (read num, pairs) - where pPair = do key <- anyChar `manyTill` space - value <- (do char '(' - v <- pParen `sepBy` space - char ')' - return ("("++unwords v++")")) - <|> (do char '{' - num <- many1 digit >>= return . read - char '}' >> crlfP - sequence $ replicate num anyChar) - <|> (do char '"' - v <- noneOf "\"" `manyTill` char '"' - return ("\""++v++"\"")) - <|> many1 atomChar - return (key, value) - pParen = (do char '"' - v <- noneOf "\"" `manyTill` char '"' - return ("\""++v++"\"")) - <|> (do char '(' - v <- pParen `sepBy` space - char ')' - return ("("++unwords v++")")) - <|> (do char '\\' - v <- many1 atomChar - return ('\\':v)) - <|> many1 atomChar - - - - ----------------------------------------------------------------------- --- auxiliary parsers -space = char ' ' -spaces = many space -spaces1 = many1 space - -crlf :: String -crlf = "\r\n" - -crlfP :: Derivs d => Parser d String -crlfP = string crlf - -lookups :: Eq a => a -> [(a, b)] -> [b] -lookups _ [] = [] -lookups k ((k', v):tl) | k == k' = v : lookups k tl - | otherwise = lookups k tl - ----- Either handling -catRights :: [Either a b] -> [b] -catRights [] = [] -catRights (Right r:tl) = r : catRights tl -catRights (_:tl) = catRights tl - -catLefts :: [Either a b] -> [a] -catLefts [] = [] -catLefts (Left r:tl) = r : catLefts tl -catLefts (_:tl) = catLefts tl - -isLeft, isRight :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False -isRight (Right _) = True -isRight _ = False - -getLeft :: Either a b -> a -getLeft (Left l) = l -getLeft _ = error "not left" -getRight :: Either a b -> b -getRight (Right r) = r -getRight _ = error "not right" diff --git a/Text/Mime.hs b/Text/Mime.hs deleted file mode 100644 --- a/Text/Mime.hs +++ /dev/null @@ -1,343 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Text.Mime --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : experimental --- Portability : portable --- --- Mime Parser --- - -module Text.Mime where - -import Text.Packrat.Parse hiding (space, spaces, Message) -import Text.Packrat.Pos - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS - -import qualified Codec.Binary.Base64.String as B64 (encode, decode) -import Data.Digest.MD5 (hash) - -import Data.Maybe -import Data.Char -import Data.List -import Data.Bits -import Data.Array - -import qualified Text.PrettyPrint.HughesPJ as PP - -data Mime = SinglePart [Header] ByteString - | MultiPart [Header] [Mime] - deriving (Eq, Show) - -type Message = ([Header], ByteString) - -type Header = (FieldName, FieldValue) -type FieldName = String -type FieldValue = String - -data MimeDerivs = - MimeDerivs { dvMessage :: Result MimeDerivs Message - , dvMime :: Result MimeDerivs Mime - , dvHeader :: Result MimeDerivs Header - , dvRest :: Result MimeDerivs ByteString - , advChar :: Result MimeDerivs Char - , advPos :: Pos - } - - -instance Derivs MimeDerivs where - dvChar = advChar - dvPos = advPos - - -mime :: ByteString -> Mime -mime = eval dvMime - -message :: ByteString -> Message -message = eval dvMessage - - -mime' :: String -> Mime -mime' = eval' dvMime - -message' :: String -> Message -message' = eval' dvMessage - - - -eval :: (MimeDerivs -> Result MimeDerivs r) -> ByteString -> r -eval pMain s = case pMain (parse (Pos "" 1 1) s) of - Parsed v d' e' -> v - NoParse e -> error (show e) - -parse :: Pos -> ByteString -> MimeDerivs -parse pos s = d - where d = MimeDerivs message mime header rest chr pos - message = pMessage d - mime = pMime d - header = pHeader d - rest = if BS.null s - then NoParse (eofError d) - else Parsed s (parse (BS.foldl nextPos pos s) BS.empty) - (nullError d) - chr = if BS.null s - then NoParse (eofError d) - else let (c, s') = (BS.head s, BS.tail s) - in Parsed c (parse (nextPos pos c) s') (nullError d) - -eval' :: (MimeDerivs -> Result MimeDerivs r) -> String -> r -eval' pMain s = case pMain (parse' (Pos "" 1 1) s) of - Parsed v d' e' -> v - NoParse e -> error (show e) - -parse' :: Pos -> String -> MimeDerivs -parse' pos s = d - where d = MimeDerivs message mime header rest chr pos - message = pMessage d - mime = pMime d - header = pHeader d - rest = case s of - "" -> NoParse (eofError d) - _ -> Parsed (BS.pack s) (parse' (foldl nextPos pos s) "") - (nullError d) - chr = case s of - (c:s') -> Parsed c (parse' (nextPos pos c) s') (nullError d) - _ -> NoParse (eofError d) - - ----------------------------------------------------------------------- - -lineBreak :: Derivs d => Parser d String -lineBreak = string "\r\n" <|> string "\n" - -pHeader :: MimeDerivs -> Result MimeDerivs (String, String) -Parser pHeader = - do field <- noneOf "\r\n" `manyTill` char ':' - many (oneOf " \t") - value <- noneOf "\r\n" `manyTill` lineBreak - cont <- many (many1 (oneOf " \t") >> (anyChar `manyTill` lineBreak)) - return (capital field, unwords (value:cont)) - -pMessage :: MimeDerivs -> Result MimeDerivs Message -Parser pMessage = do headers <- many (Parser dvHeader) - lineBreak - body <- Parser dvRest - return (headers, body) - -pMime :: MimeDerivs -> Result MimeDerivs Mime -Parser pMime = - do headers <- many (Parser dvHeader) - lineBreak - if isMultipart headers - then let b = boundary headers - in do string ("--"++b) - lineBreak - mimeBodies <- many $ mimeInner $ string ("--"++b) - mimeLast <- mimeInner $ string ("--"++b++"--") - return $ MultiPart headers (mimeBodies++[mimeLast]) - else do body <- Parser dvRest - return $ SinglePart headers body - where isMultipart headers = - case lookup "Content-Type" headers of - Nothing -> False - Just s -> "multipart/" == (take 10 s) - boundary headers = - case lookup "Content-Type" headers of - Nothing -> fail "" - Just s -> let s' = drop 9 $ head $ - dropWhile ((/="boundary=") . (take 9)) - (tails s) - in if head s' == '"' - then takeWhile (/='"') $ tail s' - else takeWhile isAlphaNum s' - mimeInner b = - do headers <- many (Parser dvHeader) - lineBreak - if isMultipart headers - then let b' = boundary headers - in do string ("--"++b') - lineBreak - mimeBodies <- many $ mimeInner $ - string ("--"++b') - mimeLast <- mimeInner $ string ("--"++b'++"--") - b >> lineBreak - return $ MultiPart headers - (mimeBodies++[mimeLast]) - else do body <- (anyChar `manyTill` lineBreak) `manyTill` - (b >> lineBreak) - return $ SinglePart headers - (BS.pack $ unlines body) - ----------------------------------------------------------------------- --- RFC 2047 Mime Header Extentions Parser --- - -type CharSet = String -data RFC2047Derivs = - RFC2047Derivs { dvHeaderExts :: Result RFC2047Derivs [(CharSet, String)] - , hdvChar :: Result RFC2047Derivs Char - , hdvPos :: Pos - } - -instance Derivs RFC2047Derivs where - dvChar = hdvChar - dvPos = hdvPos - -headerExts :: ByteString -> [(CharSet, String)] -headerExts s = case dvHeaderExts (p (Pos "" 1 1) s) of - Parsed v d' e' -> v - NoParse e -> error (show e) - where p pos s = d - where d = RFC2047Derivs mstr chr pos - mstr = pHeaderExts d - chr = if BS.null s - then NoParse (eofError d) - else let (c, s') = (BS.head s, BS.tail s) - in Parsed c (p (nextPos pos c) s') - (nullError d) - -headerExts' :: String -> [(CharSet, String)] -headerExts' = headerExts . BS.pack - - -pHeaderExts :: RFC2047Derivs -> Result RFC2047Derivs [(CharSet, String)] -Parser pHeaderExts = (getRFC2047 <|> normalStr) `sepBy` (many $ oneOf " \t") - where getRFC2047 = - do string "=?" - charset <- anyChar `manyTill` char '?' - mechanism <- choice [char 'B', char 'b', char 'Q', char 'q'] - char '?' - body <- if mechanism `elem` "bB" - then decodeB64 - else decodeQuoted - return (charset, body) - normalStr :: Derivs d => Parser d (String, String) - normalStr = - do body <- many1 $ noneOf " \t" - return ("", body) - -decodeQuoted :: Derivs d => Parser d String -decodeQuoted = do cs <- many (quotedChar <|> noneOf "?") - string "?=" - return cs - where quotedChar = do char '=' - n1 <- hexChar - n2 <- hexChar - return $ chr $ n1 * 16 + n2 - hexChar = choice [ do { c <- oneOf ['0'..'9'] - ; return $ ord c - ord '0' } - , do { c <- oneOf (['A'..'F']++['a'..'f']) - ; return $ ord (toLower c) - ord 'a' + 10 } - ] - - -decodeB64 :: Derivs d => Parser d String -decodeB64 = do bodies <- many pQuartet - string "?=" - return $ concat bodies - where pQuartet = do a <- b64Chars - b <- b64Chars - c <- b64Chars - d <- b64Chars - return $ decodeChars (a,b,c,d) - <|> do a <- b64Chars - b <- b64Chars - c <- b64Chars - char '=' - return $ init $ decodeChars (a, b, c, 0) - <|> do a <- b64Chars - b <- b64Chars - string "==" - return [head $ decodeChars (a, b, 0, 0)] - b64Chars = - do many $ noneOf (['a'..'z']++['A'..'Z']++['0'..'9']++"+/?=") - choice [ do { c <- oneOf ['a'..'z'] - ; return $ ord c - ord 'a' + 26 } - , do { c <- oneOf ['A'..'Z'] - ; return $ ord c - ord 'A' } - , do { c <- oneOf ['0'..'9'] - ; return $ ord c - ord '0' + 52 } - , char '+' >> return 62 - , char '/' >> return 63 - ] - decodeChars (a, b, c, d) = - map chr [ n `shiftR` 16 .&. 0xff - , n `shiftR` 8 .&. 0xff - , n .&. 0xff] - where n = a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d - - ----------------------------------------------------------------------- --- Mime Documents Pretty printer --- - -showHeader' :: Header -> PP.Doc -showHeader' (field, value) = - (PP.text (capital field) PP.<> PP.char ':') PP.<+> - PP.fsep (map PP.text (words value)) - -showHeader :: CharSet -> Header -> PP.Doc -showHeader charset (field, value) = - (PP.text (capital field) PP.<> PP.char ':') PP.<+> - (PP.fsep $ map (PP.text . prepB64) $ separate value) - where separate s | length s < 76 - length field = [s] - | isJust (find isSpace s) = - concatMap separate $ words s - | length s < 998 - length field = [s] - | otherwise = - let (s', s'') = splitAt (998 - length field) s - in s' : separate s'' - prepB64 s | isJust $ find (not.isPrint) s = - "=?" ++ charset ++ "?b?" ++ b64Encode s ++ "?=" - | otherwise = s - -capital :: String -> String -capital "" = "" -capital (c:cs) | isAlpha c = toUpper c : inner cs - | otherwise = c : capital cs - where inner "" = "" - inner (c:cs) | isAlpha c = toLower c : inner cs - | otherwise = c : capital cs - -b64Encode :: String -> String -b64Encode = B64.encode . map (toEnum.ord) - -showMessage :: CharSet -> Message -> PP.Doc -showMessage charset (hdrs, body) = - PP.vcat ((map (showHeader charset) hdrs) ++ - [ PP.empty, PP.text (BS.unpack body)]) - -showMime :: CharSet -> Mime -> PP.Doc -showMime charset (SinglePart hdrs body) = - PP.vcat ((map (showHeader charset) hdrs) ++ - [ PP.empty, PP.text (BS.unpack body)]) -showMime charset (MultiPart hdrs bodies) - | isJust $ lookup "Content-Type" hdrs = - PP.vcat $ map (showHeader charset) hdrs ++ - (PP.empty : mixture boundary (map (showMime charset) bodies)) - | otherwise = - PP.vcat $ map (showHeader charset) (hdrs++[newHeader]) ++ - (PP.empty : mixture newBoundary - (map (showMime charset) bodies)) - where boundary = let s = fromJust $ lookup "Content-Type" hdrs - s' = drop 9 $ head $ - dropWhile ((/="boundary=") . (take 9)) - (tails s) - in if head s' == '"' - then takeWhile (/='"') $ tail s' - else takeWhile isAlphaNum s' - newBoundary = md5Hash $ concatMap snd hdrs - newHeader = ("Content-Type", "multipart/mixed; boundary=\"" ++ newBoundary ++ "\"") - mixture b [] = [PP.text ("--"++b++"--")] - mixture b (body:bodies) = PP.text ("--"++b) : body : mixture b bodies - -md5Hash = showOctet . hash . map (toEnum.ord) - where showOctet = concat . map hexChars - hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)] - arr = listArray (0, 15) "0123456789abcdef" - diff --git a/Text/Packrat/Parse.hs b/Text/Packrat/Parse.hs deleted file mode 100644 --- a/Text/Packrat/Parse.hs +++ /dev/null @@ -1,351 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Text.Packrat.Parse --- Copyright : (c) Bryan Ford --- License : PublicDomain --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- Packrat parsing: Simple, Powerful, Lazy, Linear time by Bryan Ford. --- This module achieves monadic parsing library similar to Parsec. --- - - - -module Text.Packrat.Parse where - -import Char -import List - -import Text.Packrat.Pos - -import Control.Monad - --- Data types - -data Message = Expected String - | Message String - -data ParseError = ParseError { errorPos :: Pos - , errorMessages :: [Message] } - -data Result d v = Parsed v d ParseError - | NoParse ParseError - -newtype Parser d v = Parser (d -> Result d v) - - -class Derivs d where - dvPos :: d -> Pos - dvChar :: d -> Result d Char - - --- Basic Combinators - -infixl 2 <|> -infixl 1 -infixl 1 - -instance Derivs d => Monad (Parser d) where - (Parser p1) >>= f = Parser parse - where parse dvs = first (p1 dvs) - first (Parsed val rem err) = - let Parser p2 = f val - in second err (p2 rem) - first (NoParse err) = NoParse err - second err1 (Parsed val rem err) = - Parsed val rem (joinErrors err1 err) - second err1 (NoParse err) = - NoParse (joinErrors err1 err) - return x = Parser (\dvs -> Parsed x dvs (nullError dvs)) - fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg)) - -instance Derivs d => MonadPlus (Parser d) where - mzero = Parser (\dvs -> NoParse $ nullError dvs) - mplus = (<|>) - -(<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v -(Parser p1) <|> (Parser p2) = Parser parse - where parse dvs = first dvs (p1 dvs) - first dvs (result @ (Parsed val rem err)) = result - first dvs (NoParse err) = second err (p2 dvs) - second err1 (Parsed val rem err) = - Parsed val rem (joinErrors err1 err) - second err1 (NoParse err) = - NoParse (joinErrors err1 err) - -satisfy :: Derivs d => Parser d v -> (v -> Bool) -> Parser d v -satisfy (Parser p) test = Parser parse - where parse dvs = check dvs (p dvs) - check dvs (result @ (Parsed val rem err)) = - if test val - then result - else NoParse (nullError dvs) - check dvs none = none - -notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d () -notFollowedBy (Parser p) = Parser parse - where parse dvs = case (p dvs) of - Parsed val rem err -> - NoParse (msgError (dvPos dvs) - ("unexpected " ++ show val)) - NoParse err -> Parsed () dvs (nullError dvs) - -optional :: Derivs d => Parser d v -> Parser d (Maybe v) -optional p = (do v <- p; return (Just v)) <|> return Nothing - -option :: Derivs d => v -> Parser d v -> Parser d v -option v p = (do v' <- p; return v') <|> return v - -many :: Derivs d => Parser d v -> Parser d [v] -many p = (do { v <- p; vs <- many p; return (v : vs) } ) - <|> return [] - -many1 :: Derivs d => Parser d v -> Parser d [v] -many1 p = do { v <- p; vs <- many p; return (v : vs) } - -count :: Derivs d => Int -> Parser d v -> Parser d [v] -count n p = sequence $ replicate n p - -sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] -sepBy1 p psep = do v <- p - vs <- many (do { psep; p }) - return (v : vs) - -sepBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] -sepBy p psep = sepBy1 p psep <|> return [] - -endBy :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] -endBy p pend = many (do { v <- p; pend; return v }) - -endBy1 :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] -endBy1 p pend = many1 (do { v <- p; pend; return v }) - -sepEndBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] -sepEndBy1 p psep = do v <- sepBy1 p psep; optional psep; return v - -sepEndBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] -sepEndBy p psep = do v <- sepBy p psep; optional psep; return v - -chainl1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v -chainl1 p psep = let psuffix z = (do f <- psep - v <- p - psuffix (f z v)) - <|> return z - in do v <- p - psuffix v - -chainl :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v -chainl p psep z = chainl1 p psep <|> return z - -chainr1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v -chainr1 p psep = (do v <- p - f <- psep - w <- chainr1 p psep - return (f v w)) - <|> p - -chainr :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v -chainr p psep z = chainr1 p psep <|> return z - -choice :: Derivs d => [Parser d v] -> Parser d v -choice [p] = p -choice (p:ps) = p <|> choice ps - - -manyTill :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] -manyTill p pend = (pend >> return []) - <|> do tok <- p - rest <- manyTill p pend - return (tok:rest) - -between :: Derivs d => Parser d vs -> Parser d ve -> Parser d v -> Parser d v -between s e main = do s - v <- main - e - return v - --- Error handling -instance Eq Message where - Expected e1 == Expected e2 = e1 == e2 - Message m1 == Message m2 = m1 == m2 - _ == _ = False - -failAt :: Derivs d => Pos -> String -> Parser d v -failAt pos msg = Parser (\dvs -> NoParse (msgError pos msg)) - --- Annotate a parser with a description of the construct to be parsed. --- The resulting parser yields an "expected" error message --- if the construct cannot be parsed --- and if no error information is already available --- indicating a position farther right in the source code --- (which would normally be more localized/detailed information). -() :: Derivs d => Parser d v -> String -> Parser d v -(Parser p) desc = Parser (\dvs -> munge dvs (p dvs)) - where munge dvs (Parsed v rem err) = - Parsed v rem (fix dvs err) - munge dvs (NoParse err) = - NoParse (fix dvs err) - fix dvs (err @ (ParseError p ms)) = - if p > dvPos dvs - then err - else expError (dvPos dvs) desc - --- Stronger version of the error annotation operator above, --- which unconditionally overrides any existing error information. -() :: Derivs d => Parser d v -> String -> Parser d v -(Parser p) desc = Parser (\dvs -> munge dvs (p dvs)) - where munge dvs (Parsed v rem err) = - Parsed v rem (fix dvs err) - munge dvs (NoParse err) = - NoParse (fix dvs err) - fix dvs (err @ (ParseError p ms)) = - expError (dvPos dvs) desc - --- Potentially join two sets of ParseErrors, --- but only if the position didn't change from the first to the second. --- If it did, just return the "new" (second) set of errors. -joinErrors (e @ (ParseError p m)) (e' @ (ParseError p' m')) - | p' > p || null m = e' - | p > p' || null m' = e - | otherwise = ParseError p (m `union` m') - -nullError dvs = ParseError (dvPos dvs) [] - -expError pos desc = ParseError pos [Expected desc] - -msgError pos msg = ParseError pos [Message msg] - -eofError dvs = msgError (dvPos dvs) "end of input" - -expected :: Derivs d => String -> Parser d v -expected desc = Parser (\dvs -> NoParse (expError (dvPos dvs) desc)) - -unexpected :: Derivs d => String -> Parser d v -unexpected str = fail ("unexpected " ++ str) - - --- Comparison operators for ParseError just compare relative positions. -instance Eq ParseError where - ParseError p1 m1 == ParseError p2 m2 = p1 == p2 - ParseError p1 m1 /= ParseError p2 m2 = p1 /= p2 - -instance Ord ParseError where - ParseError p1 m1 < ParseError p2 m2 = p1 < p2 - ParseError p1 m1 > ParseError p2 m2 = p1 > p2 - ParseError p1 m1 <= ParseError p2 m2 = p1 <= p2 - ParseError p1 m1 >= ParseError p2 m2 = p1 >= p2 - -- Special behavior: "max" joins two errors - max p1 p2 = joinErrors p1 p2 - min p1 p2 = undefined - -instance Show ParseError where - show (ParseError pos []) = - show pos ++ ": unknown error" - show (ParseError pos msgs) = expectmsg expects ++ messages msgs - where expects = getExpects msgs - getExpects [] = [] - getExpects (Expected exp : rest) = exp : getExpects rest - getExpects (Message msg : rest) = getExpects rest - expectmsg [] = "" - expectmsg [exp] = show pos ++ ": expecting " ++ exp ++ "\n" - expectmsg [e1, e2] = show pos ++ ": expecting either " - ++ e1 ++ " or " ++ e2 ++ "\n" - expectmsg (first : rest) = show pos ++ ": expecting one of: " - ++ first ++ expectlist rest ++ "\n" - expectlist [last] = ", or " ++ last - expectlist (mid : rest) = ", " ++ mid ++ expectlist rest - messages [] = [] - messages (Expected exp : rest) = messages rest - messages (Message msg : rest) = - show pos ++ ": " ++ msg ++ "\n" ++ messages rest - - --- Character-oriented parsers - -anyChar :: Derivs d => Parser d Char -anyChar = Parser dvChar - -char :: Derivs d => Char -> Parser d Char -char ch = satisfy anyChar (\c -> c == ch) show ch - -oneOf :: Derivs d => [Char] -> Parser d Char -oneOf chs = satisfy anyChar (\c -> c `elem` chs) - ("one of the characters " ++ show chs) - -noneOf :: Derivs d => [Char] -> Parser d Char -noneOf chs = satisfy anyChar (\c -> not (c `elem` chs)) - ("any character not in " ++ show chs) - - -charIf :: Derivs d => (Char -> Bool) -> Parser d Char -charIf p = satisfy anyChar p "predicate is not satisfied" - -string :: Derivs d => String -> Parser d String -string str = p str show str - where p [] = return str - p (ch:chs) = do { char ch; p chs } - -stringFrom :: Derivs d => [String] -> Parser d String -stringFrom [str] = string str -stringFrom (str : strs) = string str <|> stringFrom strs - -upper :: Derivs d => Parser d Char -upper = satisfy anyChar isUpper "uppercase letter" - -lower :: Derivs d => Parser d Char -lower = satisfy anyChar isLower "lowercase letter" - -letter :: Derivs d => Parser d Char -letter = satisfy anyChar isAlpha "letter" - -alphaNum :: Derivs d => Parser d Char -alphaNum = satisfy anyChar isAlphaNum "letter or digit" - -digit :: Derivs d => Parser d Char -digit = satisfy anyChar isDigit "digit" - -hexDigit :: Derivs d => Parser d Char -hexDigit = satisfy anyChar isHexDigit "hexadecimal digit (0-9, a-f)" - -octDigit :: Derivs d => Parser d Char -octDigit = satisfy anyChar isOctDigit "octal digit (0-7)" - -newline :: Derivs d => Parser d Char -newline = char '\n' - -tab :: Derivs d => Parser d Char -tab = char '\t' - -space :: Derivs d => Parser d Char -space = satisfy anyChar isSpace "whitespace character" - -spaces :: Derivs d => Parser d [Char] -spaces = many space - -eof :: Derivs d => Parser d () -eof = notFollowedBy anyChar "end of input" - - --- State manipulation - -getDerivs :: Derivs d => Parser d d -getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs)) - -setDerivs :: Derivs d => d -> Parser d () -setDerivs newdvs = Parser (\dvs -> Parsed () newdvs (nullError dvs)) - -getPos :: Derivs d => Parser d Pos -getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs)) - - --- Special function that converts a Derivs "back" into an ordinary String --- by extracting the successive dvChar elements. -dvString :: Derivs d => d -> String -dvString d = - case dvChar d of - NoParse err -> [] - Parsed c rem err -> (c : dvString rem) - diff --git a/Text/Packrat/Pos.hs b/Text/Packrat/Pos.hs deleted file mode 100644 --- a/Text/Packrat/Pos.hs +++ /dev/null @@ -1,33 +0,0 @@ --- Simple data type to keep track of character positions --- within a text file or other text stream. -module Text.Packrat.Pos where - - -data Pos = Pos { posFile :: !String - , posLine :: !Int - , posCol :: !Int - } - -nextPos (Pos file line col) c - | c == '\n' = Pos file (line + 1) 1 - | c == '\t' = Pos file line ((div (col + 8 - 1) 8) * 8 + 1) - | otherwise = Pos file line (col + 1) - -instance Eq Pos where - Pos f1 l1 c1 == Pos f2 l2 c2 = - f1 == f2 && l1 == l2 && c1 == c2 - -instance Ord Pos where - Pos f1 l1 c1 <= Pos f2 l2 c2 = - (l1 < l2) || (l1 == l2 && c1 <= c2) - -instance Show Pos where - show (Pos file line col) = file ++ ":" ++ show line ++ ":" ++ show col - - -showPosRel (Pos file line col) (Pos file' line' col') - | file == file' = - if (line == line') - then "column " ++ show col' - else "line " ++ show line' ++ ", column " ++ show col' - | otherwise = show (Pos file' line' col') diff --git a/Text/URI.hsc b/Text/URI.hsc deleted file mode 100644 --- a/Text/URI.hsc +++ /dev/null @@ -1,230 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} ----------------------------------------------------------------------- --- | --- Module : Text.URI --- Copyright : (c) Jun Mukai 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : mukai@jmuk.org --- Stability : stable --- Portability : portable --- --- URI parser and utilities --- - - -module Text.URI - ( URI(..) - , port' - , uri, uri' - , escape, unescape - , parseURI, parseURI' - , portToName, nameToPort - ) - where - -import Network -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS - -import Text.Packrat.Parse -import Text.Packrat.Pos - -import Data.Array -import Data.Char -import Data.List -import Data.Maybe -import Data.Word (Word8) -import Numeric - -import Network.BSD (getServicePortNumber, getServiceByPort, serviceName, servicePort) -import System.IO.Unsafe - -data URI = URI { scheme :: String - , host :: String - , user :: String - , password :: String - , port :: Maybe PortNumber - , path :: String - , query :: String - , fragment :: String - } -#ifdef DEBUG - deriving (Eq, Show) -#else - deriving (Eq) - -instance Show URI where - showsPrec d uri = showParen (d>app_prec) $ foldl1 (.) $ show' uri - where app_prec = 10 - show' (URI sch host u p port path q f) = - [ showScheme sch - , showUserInfo (escape $ map c2w u) (escape $ map c2w p) - , showString $ escape $ map c2w host - , showPort port - , showString $ escape $ map c2w path - , showQuery $ escape $ map c2w q - , showFragment $ escape $ map c2w f ] - showScheme "" = id - showScheme s = showString s . ("://"++) - showUserInfo "" "" = id - showUserInfo u "" = showString u . ('@':) - showUserInfo u p = showString u . (':':) - . showString p . ('@':) - showPort Nothing = id - showPort (Just p) = (':':) . showInt p - showQuery "" = id - showQuery q = ('?':) . showString q - showFragment "" = id - showFragment f = ('#':) . showFragment f - c2w = toEnum . fromEnum -#endif - --- | Obtain the port number for the URI. If no port number exists, --- port' would like to estimate the port number from the scheme name. --- If both failed, it raises an error. -port' :: URI -> PortNumber -port' (URI { port = Just p }) = p -port' (URI { scheme = s }) = - case nameToPort s of - Just p -> p - Nothing -> error ("no service entries for " ++ s) - - --- | Parse URI string simiar to 'parseURI'. The difference is that it --- raises an error for the case of parse failed, not returns Nothing. -uri' :: ByteString -> URI -uri' u = case dvURI (parse (Pos "" 1 1) u) of - Parsed v d' e' -> v - NoParse e -> error (show e) -uri :: String -> URI -uri = uri' . BS.pack - --- | Parse URI string and returns the result. If the parse is failed, --- it simply returns Nothing. -parseURI :: String -> Maybe URI -parseURI = parseURI' . BS.pack -parseURI' :: ByteString -> Maybe URI -parseURI' u = case dvURI (parse (Pos "" 1 1) u) of - Parsed v d' e' -> Just v - NoParse e -> Nothing - -parse pos s = d - where d = URIDerivs puri psch phost pui pport pabs ppath pq pf pch pos - puri = pURI d - psch = pScheme d - phost = pHost d - pui = pUserInfo d - pport = pPort d - pabs = pPathAbs d - ppath = pPath d - pq = pQuery d - pf = pFragment d - pch | BS.null s = NoParse (eofError d) - | otherwise = - let (c, s') = (BS.head s, BS.tail s) - in Parsed c (parse (nextPos pos c) s') (nullError d) - - - -data URIDerivs = URIDerivs { dvURI :: Result URIDerivs URI - , dvScheme :: Result URIDerivs String - , dvHost :: Result URIDerivs String - , dvUserInfo :: Result URIDerivs [String] - , dvPort :: Result URIDerivs PortNumber - , dvPathAbs :: Result URIDerivs String - , dvPath :: Result URIDerivs String - , dvQuery :: Result URIDerivs String - , dvFragment :: Result URIDerivs String - , advChar :: Result URIDerivs Char - , advPos :: Pos - } - -instance Derivs URIDerivs where - dvChar = advChar - dvPos = advPos - - -unescape :: String -> String -unescape ('%':c1:c2:cs) = chr ((hex c1)*16+(hex c2)) : unescape cs - where arr = array ('0', 'f') $ zip "0123456789abcdef" [0..] - hex = (arr!) . toLower -unescape (c:cs) = c : unescape cs -unescape "" = "" - -escape :: [Word8] -> String -escape [] = "" -escape (c:cs) | c' `elem` validChars = c' : escape cs - | otherwise = escChar c ++ escape cs - where validChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"!$^&*-_=+|/." - escChar c = '%' : map (arr!) [c `div` 16, c `mod` 16] - arr = listArray (0, 15) "0123456789abcdef" - w2c = toEnum . fromEnum - c' = w2c c - -consURI :: String -- ^ scheme - -> String -- ^ host name - -> String -- ^ user - -> String -- ^ password - -> Maybe PortNumber - -> String -- ^ path - -> String -- ^ query - -> String -- ^ fragment - -> URI -consURI s h u p port path q f = - URI (unescape s) (unescape h) (unescape u) (unescape p) port (unescape path) (unescape q) (unescape f) - - -pURI :: URIDerivs -> Result URIDerivs URI -Parser pURI = do sch <- Parser dvScheme - char ':' - uri <- hierPart sch - q <- option "" (Parser dvQuery) - f <- option "" (Parser dvFragment) - eof - return (uri { query = q, fragment = f }) - where hierPart sch = do string "//" - ui <- option [] (Parser dvUserInfo) - host <- Parser dvHost - port <- optional (Parser dvPort) - path <- option "" (Parser dvPathAbs) - let uri = consURI sch host "" "" port path "" "" - case ui of - [u, p] -> return $ uri { user = u, password = p } - [u] -> return $ uri { user = u } - [] -> return uri - <|> do path <- option "" (Parser dvPath) - return $ URI sch "" "" "" Nothing path "" "" - -pScheme, pHost, pPath, pQuery, pFragment :: URIDerivs - -> Result URIDerivs String -Parser pScheme = do c <- oneOf (['a'..'z']++['A'..'Z']) - rest <- many $ oneOf (['a'..'z']++['A'..'Z']++['0'..'9']++"+-.") - return (c:rest) -Parser pHost = many1 (noneOf ":/") -Parser pPathAbs = char '/' >> Parser dvPath >>= return . ('/':) -Parser pPath = many1 (noneOf "#?") -Parser pQuery = char '?' >> many1 (noneOf "#") -Parser pFragment = char '#' >> many1 anyChar - - -pUserInfo :: URIDerivs -> Result URIDerivs [String] -Parser pUserInfo = do ui <- many1 (noneOf ":@") `sepBy1` char ':' - char '@' - return ui - -pPort :: URIDerivs -> Result URIDerivs PortNumber -Parser pPort = char ':' >> many1 digit >>= return . toEnum . read - - -portToName :: PortNumber -> Maybe String -portToName p = unsafePerformIO $ - (do s <- getServiceByPort p "tcp" - return $ Just $ serviceName s) - `catch` - (\_ -> return Nothing) - -nameToPort :: String -> Maybe PortNumber -nameToPort n = unsafePerformIO $ - fmap Just (getServicePortNumber n) - `catch` (\_ -> return Nothing) diff --git a/example/DebugStream.hs b/example/DebugStream.hs deleted file mode 100644 --- a/example/DebugStream.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts -package hsgnutls -package Network.HaskellNet #-} --- examples to connect server by hsgnutls - -module DebugStream - ( connectD - , connectDPort - , DebugStream - , withDebug - , module BS - ) - where - -import Network -import Network.HaskellNet.BSStream - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Base as BSB - -import System.IO - -import Data.IORef -import Control.Monad - -import Foreign.ForeignPtr -import Foreign.Ptr - -newtype (BSStream s) => DebugStream s = DS s - -withDebug :: BSStream s => s -> DebugStream s -withDebug = DS - -connectD :: HostName -> PortNumber -> IO (DebugStream Handle) -connectD host port = connectDPort host (PortNumber port) - -connectDPort :: HostName -> PortID -> IO (DebugStream Handle) -connectDPort host port = - do h <- connectTo host port - hPutStrLn stderr "connected" - return $ DS h - - -instance (BSStream s) => BSStream (DebugStream s) where - bsGetLine (DS h) = - do hPutStr stderr "reading with bsGetLine..." - hFlush stderr - l <- bsGetLine h - BS.hPutStrLn stderr l - return l - bsGet (DS h) len = - do hPutStr stderr $ "reading with bsGet "++show len++"..." - hFlush stderr - chunk <- bsGet h len - BS.hPutStrLn stderr chunk - return chunk - bsPut (DS h) s = - do hPutStr stderr "putting with bsPut (" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPut h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutStrLn (DS h) s = - do hPutStr stderr "putting with bsPutStrLn(" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPutStrLn h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutCrLf (DS h) s = - do hPutStr stderr "putting with bsPutCrLf(" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPutCrLf h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutNoFlush (DS h) s = - do hPutStr stderr "putting with bsPutNoFlush (" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPut h s - hPutStrLn stderr "done" - return () - bsFlush (DS h) = bsFlush h - bsClose (DS h) = bsClose h diff --git a/example/TLSStream.hs b/example/TLSStream.hs --- a/example/TLSStream.hs +++ b/example/TLSStream.hs @@ -46,10 +46,7 @@ handshake s fromSession h s - - bufLen = 4096 -waiting = 500 -- miliseconds extendBuf sess@(TlsSession s _ buf) = do res <- mallocForeignPtrBytes bufLen @@ -60,7 +57,6 @@ doWhile cond execute = do f <- cond when f $ (execute >> doWhile cond execute) - instance BSStream (TlsSession t) where bsGetLine sess@(TlsSession s _ buf) = diff --git a/example/imap.hs b/example/imap.hs --- a/example/imap.hs +++ b/example/imap.hs @@ -1,20 +1,18 @@ import System.IO import Network.HaskellNet.IMAP -import Text.Mime import qualified Data.ByteString.Char8 as BS import Control.Monad imapServer = "imap.mail.org" -user = "" -pass = "" +username = "" +password = "" main = do con <- connectIMAP imapServer - login con user pass + login con username password mboxes <- list con mapM print mboxes select con "INBOX" msgs <- search con [ALLs] mapM_ (\x -> print x) (take 4 msgs) forM_ (take 4msgs) (\x -> fetch con x >>= print) - diff --git a/example/pop3.hs b/example/pop3.hs --- a/example/pop3.hs +++ b/example/pop3.hs @@ -7,13 +7,13 @@ import Data.ByteString (ByteString) popServer = "pop3.mail.org" -user = "" -pass = "" +username = "" +password = "" main = do con <- connectPop3 popServer print "connected" - userPass con user pass + userPass con username password num <- list con 4 print $ "num " ++ (show num) msg <- retr con 1 diff --git a/example/smtpMimeMail.hs b/example/smtpMimeMail.hs deleted file mode 100644 --- a/example/smtpMimeMail.hs +++ /dev/null @@ -1,56 +0,0 @@ ---import qualified Data.ByteString.Lazy.UTF8 as LU -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString as S -import Control.Monad -import qualified Network.HaskellNet.SMTP as HN - -import Data.Text (Text) -import qualified Data.Text.Lazy as LT -import qualified Data.Text as T - ---import qualified Data.Text.Lazy.Encoding as LT - -{- -An example of how to use Network.HaskellNet with the mime-mail package. -Useful if you don't have sendmail installed and want to use -mime-mail. - -nb: you need to cabal install mime-mail to run this example. -(I didn't want to include mime-mail as a dependency of Network.HaskellNet.) - --} - --- substitute your isp's smtp server here -smtpServer = "outmail.f2s.com" --- subtitute your address here -toAddress = "wrwills@gmail.com" -{- -sendMimeMail :: String -> String -> LT.Text -> LT.Text -> [(String, FilePath)] -> IO () -sendMimeMail to from subject plainBody htmlBody attachments = do - myMail <- simpleMail to from subject plainBody htmlBody attachments - con <- HN.connectSMTP smtpServer - renderedMail <- renderMail' myMail - HN.sendMail from [to] (lazyToStrict renderedMail) con - HN.closeSMTP con --} - --- haskellNet uses strict bytestrings --- TODO: look at making haskellnet lazy -lazyToStrict = S.concat . B.toChunks - - -main = do - con <- HN.connectSMTP smtpServer - HN.sendMimeMail toAddress - "haskellnet@test.com" - "Testing " - (LT.pack $ unlines [ - "With some Li Bai to show we can do unicode" - , "舉頭望明月" - , "低頭思故鄉" - ]) - (LT.pack "低頭思故鄉" ) - [((T.pack "application/pdf"),"/tmp/cv.pdf")] - con - HN.closeSMTP con --- [("application/pdf","/tmp/cv.pdf"), ("image/jpeg", "/tmp/img.jpg")] diff --git a/src/Network/HaskellNet/Auth.hs b/src/Network/HaskellNet/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/Auth.hs @@ -0,0 +1,62 @@ +module Network.HaskellNet.Auth +where + +import Data.Digest.MD5 +import Codec.Utils +import qualified Codec.Binary.Base64.String as B64 (encode, decode) + +import Data.List +import Data.Bits +import Data.Array + +type UserName = String +type Password = String + +data AuthType = PLAIN + | LOGIN + | CRAM_MD5 + deriving Eq + +instance Show AuthType where + showsPrec d at = showParen (d>app_prec) $ showString $ showMain at + where app_prec = 10 + showMain PLAIN = "PLAIN" + showMain LOGIN = "LOGIN" + showMain CRAM_MD5 = "CRAM-MD5" + +b64Encode :: String -> String +b64Encode = map (toEnum.fromEnum) . B64.encode . map (toEnum.fromEnum) + +b64Decode :: String -> String +b64Decode = map (toEnum.fromEnum) . B64.decode . map (toEnum.fromEnum) + +showOctet :: [Octet] -> String +showOctet = concat . map hexChars + where hexChars c = [arr ! (c `div` 16), arr ! (c `mod` 16)] + arr = listArray (0, 15) "0123456789abcdef" + +hmacMD5 :: String -> String -> [Octet] +hmacMD5 text key = hash $ okey ++ hash (ikey ++ map (toEnum.fromEnum) text) + where koc = map (toEnum.fromEnum) key + key' = if length koc > 64 + then hash koc ++ replicate 48 0 + else koc ++ replicate (64-length koc) 0 + ipad = replicate 64 0x36 + opad = replicate 64 0x5c + ikey = zipWith xor key' ipad + okey = zipWith xor key' opad + +plain :: UserName -> Password -> String +plain user pass = b64Encode $ concat $ intersperse "\0" [user, user, pass] + +login :: UserName -> Password -> (String, String) +login user pass = (b64Encode user, b64Encode pass) + +cramMD5 :: String -> UserName -> Password -> String +cramMD5 challenge user pass = + b64Encode (user ++ " " ++ showOctet (hmacMD5 challenge pass)) + +auth :: AuthType -> String -> UserName -> Password -> String +auth PLAIN _ u p = plain u p +auth LOGIN _ u p = let (u', p') = login u p in unwords [u', p'] +auth CRAM_MD5 c u p = cramMD5 c u p diff --git a/src/Network/HaskellNet/BSStream.hs b/src/Network/HaskellNet/BSStream.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/BSStream.hs @@ -0,0 +1,41 @@ +-- |A library for abstracting sockets suitable to Streams. +module Network.HaskellNet.BSStream + ( BSStream(..) + ) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import System.IO + +class BSStream h where + bsGetLine :: h -> IO ByteString + bsGet :: h -> Int -> IO ByteString + bsPut :: h -> ByteString -> IO () + bsPuts :: h -> [ByteString] -> IO () + bsPutStrLn :: h -> ByteString -> IO () + bsPutCrLf :: h -> ByteString -> IO () + bsPutNoFlush :: h -> ByteString -> IO () + bsFlush :: h -> IO () + bsClose :: h -> IO () + bsIsOpen :: h -> IO Bool + + bsPuts h strs = mapM_ (bsPut h) strs + bsPutCrLf h s = bsPut h s >> bsPut h crlf + bsPutStrLn h s = bsPut h s >> bsPut h lf + +lf, crlf :: BS.ByteString +lf = BS.singleton '\n' +crlf = BS.pack "\r\n" + +instance BSStream Handle where + bsGetLine = BS.hGetLine + bsGet = BS.hGet + bsPut h s = BS.hPut h s >> bsFlush h + bsPutStrLn h s = BS.hPutStrLn h s >> bsFlush h + bsPutNoFlush = BS.hPut + bsFlush = hFlush + bsClose h = do + op <- hIsOpen h + if op then (hClose h) else return () + bsIsOpen = hIsOpen diff --git a/src/Network/HaskellNet/Debug.hs b/src/Network/HaskellNet/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/Debug.hs @@ -0,0 +1,81 @@ +module Network.HaskellNet.Debug + ( connectD + , connectDPort + , DebugStream + , withDebug + ) + where + +import Network +import Network.HaskellNet.BSStream + +import qualified Data.ByteString.Char8 as BS + +import System.IO + +newtype (BSStream s) => DebugStream s = DS s + +withDebug :: BSStream s => s -> DebugStream s +withDebug = DS + +connectD :: HostName -> PortNumber -> IO (DebugStream Handle) +connectD host port = connectDPort host (PortNumber port) + +connectDPort :: HostName -> PortID -> IO (DebugStream Handle) +connectDPort host port = + do h <- connectTo host port + hPutStrLn stderr "connected" + return $ DS h + + +instance (BSStream s) => BSStream (DebugStream s) where + bsGetLine (DS h) = + do hPutStr stderr "reading with bsGetLine..." + hFlush stderr + l <- bsGetLine h + BS.hPutStrLn stderr l + return l + bsGet (DS h) len = + do hPutStr stderr $ "reading with bsGet "++show len++"..." + hFlush stderr + chunk <- bsGet h len + BS.hPutStrLn stderr chunk + return chunk + bsPut (DS h) s = + do hPutStr stderr "putting with bsPut (" + BS.hPutStrLn stderr s + hPutStr stderr (")...") + hFlush stderr + bsPut h s + bsFlush h + hPutStrLn stderr "done" + return () + bsPutStrLn (DS h) s = + do hPutStr stderr "putting with bsPutStrLn(" + BS.hPutStrLn stderr s + hPutStr stderr (")...") + hFlush stderr + bsPutStrLn h s + bsFlush h + hPutStrLn stderr "done" + return () + bsPutCrLf (DS h) s = + do hPutStr stderr "putting with bsPutCrLf(" + BS.hPutStrLn stderr s + hPutStr stderr (")...") + hFlush stderr + bsPutCrLf h s + bsFlush h + hPutStrLn stderr "done" + return () + bsPutNoFlush (DS h) s = + do hPutStr stderr "putting with bsPutNoFlush (" + BS.hPutStrLn stderr s + hPutStr stderr (")...") + hFlush stderr + bsPut h s + hPutStrLn stderr "done" + return () + bsFlush (DS h) = bsFlush h + bsClose (DS h) = bsClose h + bsIsOpen (DS h) = bsIsOpen h diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/IMAP.hs @@ -0,0 +1,444 @@ +module Network.HaskellNet.IMAP + ( connectIMAP, connectIMAPPort, connectStream + -- * IMAP commands + -- ** any state commands + , noop, capability, logout + -- ** not authenticated state commands + , login, authenticate + -- ** autenticated state commands + , select, examine, create, delete, rename + , subscribe, unsubscribe + , list, lsub, status, append + -- ** selected state commands + , check, close, expunge + , search, store, copy + -- * fetch commands + , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot + , fetchFlags, fetchR, fetchByString, fetchByStringR + -- * other types + , Flag(..), Attribute(..), MailboxStatus(..) + , SearchQuery(..), FlagsQuery(..) + ) +where + +import Network +import Network.HaskellNet.BSStream +import Network.HaskellNet.IMAP.Connection +import Network.HaskellNet.IMAP.Types +import Network.HaskellNet.IMAP.Parsers +import qualified Network.HaskellNet.Auth as A + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS + +import Control.Applicative ((<$>)) +import Control.Monad + +import System.IO +import System.Time + +import Data.Maybe +import Data.List hiding (delete) +import Data.Char + +import Text.Packrat.Parse (Result) + +-- suffixed by `s' +data SearchQuery = ALLs + | FLAG Flag + | UNFLAG Flag + | BCCs String + | BEFOREs CalendarTime + | BODYs String + | CCs String + | FROMs String + | HEADERs String String + | LARGERs Integer + | NEWs + | NOTs SearchQuery + | OLDs + | ONs CalendarTime + | ORs SearchQuery SearchQuery + | SENTBEFOREs CalendarTime + | SENTONs CalendarTime + | SENTSINCEs CalendarTime + | SINCEs CalendarTime + | SMALLERs Integer + | SUBJECTs String + | TEXTs String + | TOs String + | UIDs [UID] + + +instance Show SearchQuery where + showsPrec d q = showParen (d>app_prec) $ showString $ showQuery q + where app_prec = 10 + showQuery ALLs = "ALL" + showQuery (FLAG f) = showFlag f + showQuery (UNFLAG f) = "UN" ++ showFlag f + showQuery (BCCs addr) = "BCC " ++ addr + showQuery (BEFOREs t) = "BEFORE " ++ dateToStringIMAP t + showQuery (BODYs s) = "BODY " ++ s + showQuery (CCs addr) = "CC " ++ addr + showQuery (FROMs addr) = "FROM " ++ addr + showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ v + showQuery (LARGERs siz) = "LARGER {" ++ show siz ++ "}" + showQuery NEWs = "NEW" + showQuery (NOTs qry) = "NOT " ++ show qry + showQuery OLDs = "OLD" + showQuery (ONs t) = "ON " ++ dateToStringIMAP t + showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 + showQuery (SENTBEFOREs t) = "SENTBEFORE " ++ dateToStringIMAP t + showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t + showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t + showQuery (SINCEs t) = "SINCE " ++ dateToStringIMAP t + showQuery (SMALLERs siz) = "SMALLER {" ++ show siz ++ "}" + showQuery (SUBJECTs s) = "SUBJECT " ++ s + showQuery (TEXTs s) = "TEXT " ++ s + showQuery (TOs addr) = "TO " ++ addr + showQuery (UIDs uids) = concat $ intersperse "," $ + map show uids + showFlag Seen = "SEEN" + showFlag Answered = "ANSWERED" + showFlag Flagged = "FLAGGED" + showFlag Deleted = "DELETED" + showFlag Draft = "DRAFT" + showFlag Recent = "RECENT" + showFlag (Keyword s) = "KEYWORD " ++ s + +data FlagsQuery = ReplaceFlags [Flag] + | PlusFlags [Flag] + | MinusFlags [Flag] + +---------------------------------------------------------------------- +-- establish connection + +connectIMAPPort :: String -> PortNumber -> IO (IMAPConnection Handle) +connectIMAPPort hostname port = + connectTo hostname (PortNumber port) >>= connectStream + +connectIMAP :: String -> IO (IMAPConnection Handle) +connectIMAP hostname = connectIMAPPort hostname 143 + +connectStream :: BSStream s => s -> IO (IMAPConnection s) +connectStream s = + do msg <- bsGetLine s + unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ + fail "cannot connect to the server" + newConnection s + +---------------------------------------------------------------------- +-- normal send commands +sendCommand' :: (BSStream s) => IMAPConnection s -> String -> IO (ByteString, Int) +sendCommand' c cmdstr = do + (_, num) <- withNextCommandNum c $ \num -> bsPutCrLf c $ BS.pack $ show6 num ++ " " ++ cmdstr + resp <- getResponse c + return (resp, num) + +show6 :: (Ord a, Num a) => a -> String +show6 n | n > 100000 = show n + | n > 10000 = '0' : show n + | n > 1000 = "00" ++ show n + | n > 100 = "000" ++ show n + | n > 10 = "0000" ++ show n + | otherwise = "00000" ++ show n + +sendCommand :: BSStream s => IMAPConnection s -> String + -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) + -> IO v +sendCommand imapc cmdstr pFunc = + do (buf, num) <- sendCommand' imapc cmdstr + let (resp, mboxUp, value) = eval pFunc (show6 num) buf + case resp of + OK _ _ -> do mboxUpdate imapc mboxUp + return value + NO _ msg -> fail ("NO: " ++ msg) + BAD _ msg -> fail ("BAD: " ++ msg) + PREAUTH _ msg -> fail ("preauth: " ++ msg) + +getResponse :: BSStream s => s -> IO ByteString +getResponse s = unlinesCRLF <$> getLs + where unlinesCRLF = BS.concat . concatMap (:[crlfStr]) + getLs = + do l <- strip <$> bsGetLine s + case () of + _ | isLiteral l -> do l' <- getLiteral l (getLitLen l) + ls <- getLs + return (l' : ls) + | isTagged l -> (l:) <$> getLs + | otherwise -> return [l] + getLiteral l len = + do lit <- bsGet s len + l2 <- strip <$> bsGetLine s + let l' = BS.concat [l, crlfStr, lit, l2] + if isLiteral l2 + then getLiteral l' (getLitLen l2) + else return l' + crlfStr = BS.pack "\r\n" + isLiteral l = BS.last l == '}' && + BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{' + getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init + isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' ' + +mboxUpdate :: (BSStream s) => IMAPConnection s -> MboxUpdate -> IO () +mboxUpdate conn (MboxUpdate exists' recent') = do + when (isJust exists') $ + modifyMailboxInfo conn $ \mbox -> mbox { _exists = fromJust exists' } + + when (isJust recent') $ + modifyMailboxInfo conn $ \mbox -> mbox { _recent = fromJust recent' } + +---------------------------------------------------------------------- +-- IMAP commands +-- + +noop :: BSStream s => IMAPConnection s -> IO () +noop conn = sendCommand conn "NOOP" pNone + +capability :: BSStream s => IMAPConnection s -> IO [String] +capability conn = sendCommand conn "CAPABILITY" pCapability + +logout :: (BSStream s) => IMAPConnection s -> IO () +logout c = do bsPutCrLf c $ BS.pack "a0001 LOGOUT" + bsClose c + +login :: BSStream s => IMAPConnection s -> A.UserName -> A.Password -> IO () +login conn username password = sendCommand conn ("LOGIN " ++ username ++ " " ++ password) + pNone + +authenticate :: (BSStream s) => IMAPConnection s -> A.AuthType + -> A.UserName -> A.Password -> IO () +authenticate conn A.LOGIN username password = + do (_, num) <- sendCommand' conn "AUTHENTICATE LOGIN" + bsPutCrLf conn $ BS.pack userB64 + bsGetLine conn + bsPutCrLf conn $ BS.pack passB64 + buf <- getResponse conn + let (resp, mboxUp, value) = eval pNone (show6 num) buf + case resp of + OK _ _ -> do mboxUpdate conn $ mboxUp + return value + NO _ msg -> fail ("NO: " ++ msg) + BAD _ msg -> fail ("BAD: " ++ msg) + PREAUTH _ msg -> fail ("preauth: " ++ msg) + where (userB64, passB64) = A.login username password +authenticate conn at username password = + do (c, num) <- sendCommand' conn $ "AUTHENTICATE " ++ show at + let challenge = + if BS.take 2 c == BS.pack "+ " + then A.b64Decode $ BS.unpack $ head $ + dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c + else "" + bsPutCrLf conn $ BS.pack $ A.auth at challenge username password + buf <- getResponse conn + let (resp, mboxUp, value) = eval pNone (show6 num) buf + case resp of + OK _ _ -> do mboxUpdate conn $ mboxUp + return value + NO _ msg -> fail ("NO: " ++ msg) + BAD _ msg -> fail ("BAD: " ++ msg) + PREAUTH _ msg -> fail ("preauth: " ++ msg) + +_select :: (BSStream s) => String -> IMAPConnection s -> String -> IO () +_select cmd conn mboxName = + do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect + setMailboxInfo conn $ mbox' { _mailbox = mboxName } + +select :: BSStream s => IMAPConnection s -> MailboxName -> IO () +select = _select "SELECT " + +examine :: BSStream s => IMAPConnection s -> MailboxName -> IO () +examine = _select "EXAMINE " + +create :: BSStream s => IMAPConnection s -> MailboxName -> IO () +create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone + +delete :: BSStream s => IMAPConnection s -> MailboxName -> IO () +delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone + +rename :: BSStream s => IMAPConnection s -> MailboxName -> MailboxName -> IO () +rename conn mboxorg mboxnew = + sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone + +subscribe :: BSStream s => IMAPConnection s -> MailboxName -> IO () +subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone + +unsubscribe :: BSStream s => IMAPConnection s -> MailboxName -> IO () +unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone + +list :: BSStream s => IMAPConnection s -> IO [([Attribute], MailboxName)] +list conn = (map (\(a, _, m) -> (a, m))) <$> listFull conn "\"\"" "*" + +lsub :: BSStream s => IMAPConnection s -> IO [([Attribute], MailboxName)] +lsub conn = (map (\(a, _, m) -> (a, m))) <$> lsubFull conn "\"\"" "*" + +listFull :: BSStream s => IMAPConnection s -> String -> String + -> IO [([Attribute], String, MailboxName)] +listFull conn ref pat = sendCommand conn (unwords ["LIST", ref, pat]) pList + +lsubFull :: BSStream s => IMAPConnection s -> String -> String + -> IO [([Attribute], String, MailboxName)] +lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub + +status :: BSStream s => IMAPConnection s -> MailboxName -> [MailboxStatus] + -> IO [(MailboxStatus, Integer)] +status conn mbox stats = + let cmd = "STATUS " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")" + in sendCommand conn cmd pStatus + +append :: BSStream s => IMAPConnection s -> MailboxName -> ByteString -> IO () +append conn mbox mailData = appendFull conn mbox mailData [] Nothing + +appendFull :: BSStream s => IMAPConnection s -> MailboxName -> ByteString + -> [Flag] -> Maybe CalendarTime -> IO () +appendFull conn mbox mailData flags' time = + do (buf, num) <- sendCommand' conn + (unwords ["APPEND", mbox + , fstr, tstr, "{" ++ show len ++ "}"]) + unless (BS.null buf || (BS.head buf /= '+')) $ + fail "illegal server response" + mapM_ (bsPutCrLf conn) mailLines + buf2 <- getResponse conn + let (resp, mboxUp, ()) = eval pNone (show6 num) buf2 + case resp of + OK _ _ -> mboxUpdate conn mboxUp + NO _ msg -> fail ("NO: "++msg) + BAD _ msg -> fail ("BAD: "++msg) + PREAUTH _ msg -> fail ("PREAUTH: "++msg) + where mailLines = BS.lines mailData + len = sum $ map ((2+) . BS.length) mailLines + tstr = maybe "" show time + fstr = unwords $ map show flags' + +check :: BSStream s => IMAPConnection s -> IO () +check conn = sendCommand conn "CHECK" pNone + +close :: BSStream s => IMAPConnection s -> IO () +close conn = + do sendCommand conn "CLOSE" pNone + setMailboxInfo conn emptyMboxInfo + +expunge :: BSStream s => IMAPConnection s -> IO [Integer] +expunge conn = sendCommand conn "EXPUNGE" pExpunge + +search :: BSStream s => IMAPConnection s -> [SearchQuery] -> IO [UID] +search conn queries = searchCharset conn "" queries + +searchCharset :: BSStream s => IMAPConnection s -> Charset -> [SearchQuery] + -> IO [UID] +searchCharset conn charset queries = + sendCommand conn ("UID SEARCH " + ++ (if not . null $ charset + then charset ++ " " + else "") + ++ unwords (map show queries)) pSearch + +fetch :: BSStream s => IMAPConnection s -> UID -> IO ByteString +fetch conn uid = + do lst <- fetchByString conn uid "BODY[]" + return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst + +fetchHeader :: BSStream s => IMAPConnection s -> UID -> IO ByteString +fetchHeader conn uid = + do lst <- fetchByString conn uid "BODY[HEADER]" + return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst + +fetchSize :: BSStream s => IMAPConnection s -> UID -> IO Int +fetchSize conn uid = + do lst <- fetchByString conn uid "RFC822.SIZE" + return $ maybe 0 read $ lookup "RFC822.SIZE" lst + +fetchHeaderFields :: BSStream s => IMAPConnection s + -> UID -> [String] -> IO ByteString +fetchHeaderFields conn uid hs = + do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]") + return $ maybe BS.empty BS.pack $ + lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst + +fetchHeaderFieldsNot :: BSStream s => IMAPConnection s + -> UID -> [String] -> IO ByteString +fetchHeaderFieldsNot conn uid hs = + do let fetchCmd = "BODY[HEADER.FIELDS.NOT "++unwords hs++"]" + lst <- fetchByString conn uid fetchCmd + return $ maybe BS.empty BS.pack $ lookup fetchCmd lst + +fetchFlags :: BSStream s => IMAPConnection s -> UID -> IO [Flag] +fetchFlags conn uid = + do lst <- fetchByString conn uid "FLAGS" + return $ getFlags $ lookup "FLAGS" lst + where getFlags Nothing = [] + getFlags (Just s) = eval' dvFlags "" s + +fetchR :: BSStream s => IMAPConnection s -> (UID, UID) + -> IO [(UID, ByteString)] +fetchR conn r = + do lst <- fetchByStringR conn r "BODY[]" + return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ + lookup "BODY[]" vs)) lst +fetchByString :: BSStream s => IMAPConnection s -> UID -> String + -> IO [(String, String)] +fetchByString conn uid command = + do lst <- fetchCommand conn ("UID FETCH "++show uid++" "++command) id + return $ snd $ head lst + +fetchByStringR :: BSStream s => IMAPConnection s -> (UID, UID) -> String + -> IO [(UID, [(String, String)])] +fetchByStringR conn (s, e) command = + fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc + where proc (n, ps) = + (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps) + +fetchCommand :: (BSStream s) => IMAPConnection s -> String + -> ((Integer, [(String, String)]) -> b) -> IO [b] +fetchCommand conn command proc = + (map proc) <$> sendCommand conn command pFetch + +storeFull :: BSStream s => IMAPConnection s -> String -> FlagsQuery -> Bool + -> IO [(UID, [Flag])] +storeFull conn uidstr query isSilent = + fetchCommand conn ("UID STORE " ++ uidstr ++ flgs query) procStore + where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" + toFStr s fstrs' = + s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs' + flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs + flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs + flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs + procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read + (lookup "UID" ps) + ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps)) + + +store :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO () +store conn i q = storeFull conn (show i) q True >> return () + +copyFull :: (BSStream s) => IMAPConnection s -> String -> String -> IO () +copyFull conn uidStr mbox = + sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ mbox) pNone + +copy :: BSStream s => IMAPConnection s -> UID -> MailboxName -> IO () +copy conn uid mbox = copyFull conn (show uid) mbox + +---------------------------------------------------------------------- +-- auxialiary functions + +dateToStringIMAP :: CalendarTime -> String +dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date + , showMonth $ ctMonth date + , show $ ctYear date] + where show2 n | n < 10 = '0' : show n + | otherwise = show n + showMonth January = "Jan" + showMonth February = "Feb" + showMonth March = "Mar" + showMonth April = "Apr" + showMonth May = "May" + showMonth June = "Jun" + showMonth July = "Jul" + showMonth August = "Aug" + showMonth September = "Sep" + showMonth October = "Oct" + showMonth November = "Nov" + showMonth December = "Dec" + +strip :: ByteString -> ByteString +strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace diff --git a/src/Network/HaskellNet/IMAP/Connection.hs b/src/Network/HaskellNet/IMAP/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/IMAP/Connection.hs @@ -0,0 +1,102 @@ +module Network.HaskellNet.IMAP.Connection + ( IMAPConnection + , withNextCommandNum + , setMailboxInfo + , modifyMailboxInfo + , newConnection + , mailbox + , exists + , recent + , flags + , permanentFlags + , isWritable + , isFlagWritable + , uidNext + , uidValidity + , stream + ) +where + +import Data.IORef + ( IORef + , newIORef + , readIORef + , writeIORef + , modifyIORef + ) +import Control.Applicative + ( (<$>) + , (<*>) + ) + +import Network.HaskellNet.BSStream +import Network.HaskellNet.IMAP.Types + ( MailboxInfo(..) + , emptyMboxInfo + , MailboxName + , Flag + , UID + ) + +data BSStream s => IMAPConnection s = + IMAPC { stream :: s + , mboxInfo :: IORef MailboxInfo + , nextCommandNum :: IORef Int + } + +instance BSStream s => BSStream (IMAPConnection s) where + bsGetLine = bsGetLine . stream + bsGet = bsGet . stream + bsPut h s = bsPut (stream h) s + bsPutStrLn h s = bsPutStrLn (stream h) s + bsPutNoFlush = bsPutNoFlush . stream + bsFlush = bsFlush . stream + bsClose = bsClose . stream + bsIsOpen = bsIsOpen . stream + +newConnection :: (BSStream s) => s -> IO (IMAPConnection s) +newConnection s = IMAPC s <$> (newIORef emptyMboxInfo) <*> (newIORef 0) + +getMailboxInfo :: (BSStream s) => IMAPConnection s -> IO MailboxInfo +getMailboxInfo c = readIORef $ mboxInfo c + +mailbox :: (BSStream s) => IMAPConnection s -> IO MailboxName +mailbox c = _mailbox <$> getMailboxInfo c + +exists :: (BSStream s) => IMAPConnection s -> IO Integer +exists c = _exists <$> getMailboxInfo c + +recent :: (BSStream s) => IMAPConnection s -> IO Integer +recent c = _recent <$> getMailboxInfo c + +flags :: (BSStream s) => IMAPConnection s -> IO [Flag] +flags c = _flags <$> getMailboxInfo c + +permanentFlags :: (BSStream s) => IMAPConnection s -> IO [Flag] +permanentFlags c = _permanentFlags <$> getMailboxInfo c + +isWritable :: (BSStream s) => IMAPConnection s -> IO Bool +isWritable c = _isWritable <$> getMailboxInfo c + +isFlagWritable :: (BSStream s) => IMAPConnection s -> IO Bool +isFlagWritable c = _isFlagWritable <$> getMailboxInfo c + +uidNext :: (BSStream s) => IMAPConnection s -> IO UID +uidNext c = _uidNext <$> getMailboxInfo c + +uidValidity :: (BSStream s) => IMAPConnection s -> IO UID +uidValidity c = _uidValidity <$> getMailboxInfo c + +withNextCommandNum :: (BSStream s) => IMAPConnection s -> (Int -> IO a) -> IO (a, Int) +withNextCommandNum c act = do + let ref = nextCommandNum c + num <- readIORef ref + result <- act num + modifyIORef ref (+1) + return (result, num) + +setMailboxInfo :: (BSStream s) => IMAPConnection s -> MailboxInfo -> IO () +setMailboxInfo c = writeIORef (mboxInfo c) + +modifyMailboxInfo :: (BSStream s) => IMAPConnection s -> (MailboxInfo -> MailboxInfo) -> IO () +modifyMailboxInfo c f = modifyIORef (mboxInfo c) f diff --git a/src/Network/HaskellNet/IMAP/Parsers.hs b/src/Network/HaskellNet/IMAP/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/IMAP/Parsers.hs @@ -0,0 +1,379 @@ +-- | Parsers for IMAP server responses +module Network.HaskellNet.IMAP.Parsers + ( eval + , eval' + , pNone + , pCapability + , pSelect + , pList + , pLsub + , pStatus + , pExpunge + , pSearch + , pFetch + ) +where + +import Text.Packrat.Parse hiding (space, spaces) +import Text.Packrat.Pos + +import Data.Maybe + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS + +import Network.HaskellNet.IMAP.Types + +eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r +eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of + Parsed v _ _ -> v + NoParse e -> error (show e) + +parse :: String -> Pos -> ByteString -> RespDerivs +parse tagstr pos s = d + where d = RespDerivs flag tag chr pos + flag = pParenFlags d + tag = Parsed tagstr d (nullError d) + chr = if BS.null s + then NoParse (eofError d) + else let (c, s') = (BS.head s, BS.tail s) + in Parsed c (parse tagstr (nextPos pos c) s') + (nullError d) + +eval' :: (RespDerivs -> Result RespDerivs r) -> String -> String -> r +eval' pMain tag s = case pMain (parse' tag (Pos tag 1 1) s) of + Parsed v _ _ -> v + NoParse e -> error (show e) + +parse' :: String -> Pos -> String -> RespDerivs +parse' tagstr pos s = d + where d = RespDerivs flag tag chr pos + flag = pParenFlags d + tag = Parsed tagstr d (nullError d) + chr = case s of + (c:s') -> Parsed c (parse' tagstr (nextPos pos c) s') + (nullError d) + _ -> NoParse (eofError d) + +mkMboxUpdate :: [Either (String, Integer) b] -> (MboxUpdate, [b]) +mkMboxUpdate untagged = (MboxUpdate exists' recent', others) + where exists' = lookup "EXISTS" $ catLefts untagged + recent' = lookup "RECENT" $ catLefts untagged + others = catRights untagged + +pNone :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, ()) +Parser pNone = + do untagged <- many pOtherLine + resp <- Parser pDone + let (mboxUp, _) = mkMboxUpdate untagged + return (resp, mboxUp, ()) + +pCapability :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [String]) +Parser pCapability = + do untagged <- many (pCapabilityLine <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, caps) = mkMboxUpdate untagged + return (resp, mboxUp, concat caps) + +pList :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, MailboxName)]) +Parser pList = + do untagged <- many (pListLine "LIST" <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, listRes) = mkMboxUpdate untagged + return (resp, mboxUp, listRes) + +pLsub :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, MailboxName)]) +Parser pLsub = + do untagged <- many (pListLine "LSUB" <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, listRes) = mkMboxUpdate untagged + return (resp, mboxUp, listRes) + +pStatus :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(MailboxStatus, Integer)]) +Parser pStatus = + do untagged <- many (pStatusLine <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, statRes) = mkMboxUpdate untagged + return (resp, mboxUp, concat statRes) + +pExpunge :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [Integer]) +Parser pExpunge = + do untagged <- many ((do string "* " + n <- pExpungeLine + return $ Right ("EXPUNGE", n)) + <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, expunges) = mkMboxUpdate untagged + return (resp, mboxUp, lookups "EXPUNGE" expunges) + +pSearch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [UID]) +Parser pSearch = + do untagged <- many (pSearchLine <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, searchRes) = mkMboxUpdate untagged + return (resp, mboxUp, concat searchRes) + + +pSelect :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, MailboxInfo) +Parser pSelect = + do untagged <- many (pSelectLine + <|> (do string "* " + anyChar `manyTill` crlfP + return id)) + resp <- Parser pDone + let box = case resp of + OK writable _ -> + emptyBox { _isWritable = isJust writable && fromJust writable == READ_WRITE } + _ -> emptyBox + return (resp, MboxUpdate Nothing Nothing, foldl (flip ($)) box untagged) + where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0 + +pFetch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(Integer, [(String, String)])]) +Parser pFetch = + do untagged <- many (pFetchLine <|> pOtherLine) + resp <- Parser pDone + let (mboxUp, fetchRes) = mkMboxUpdate untagged + return (resp, mboxUp, fetchRes) + +pDone :: RespDerivs -> Result RespDerivs ServerResponse +Parser pDone = do tag <- Parser advTag + string tag >> space + respCode <- parseCode + space + stat <- optional (do s <- parseStatusCode + space >> return s) + body <- anyChar `manyTill` crlfP + return $ respCode stat body + where parseCode = choice $ [ string "OK" >> return OK + , string "NO" >> return NO + , string "BAD" >> return BAD + , string "PREAUTH" >> return PREAUTH + ] + parseStatusCode = + between (char '[') (char ']') $ + choice [ string "ALERT" >> return ALERT + , do { string "BADCHARSET" + ; ws <- optional parenWords + ; return $ BADCHARSET $ fromMaybe [] ws } + , do { string "CAPABILITY" + ; space + ; ws <- (many1 $ noneOf " ]") `sepBy1` space + ; return $ CAPABILITY_sc ws } + , string "PARSE" >> return PARSE + , do { string "PERMANENTFLAGS" >> space >> char '(' + ; fs <- pFlag `sepBy1` spaces1 + ; char ')' + ; return $ PERMANENTFLAGS fs } + , string "READ-ONLY" >> return READ_ONLY + , string "READ-WRITE" >> return READ_WRITE + , string "TRYCREATE" >> return TRYCREATE + , do { string "UNSEEN" >> space + ; num <- many1 digit + ; return $ UNSEEN_sc $ read num } + , do { string "UIDNEXT" >> space + ; num <- many1 digit + ; return $ UIDNEXT_sc $ read num } + , do { string "UIDVALIDITY" >> space + ; num <- many1 digit + ; return $ UIDVALIDITY_sc $ read num } + ] + parenWords = between (space >> char '(') (char ')') + (many1 (noneOf " )") `sepBy1` space) + +pFlag :: Parser RespDerivs Flag +pFlag = do char '\\' + choice [ string "Seen" >> return Seen + , string "Answered" >> return Answered + , string "Flagged" >> return Flagged + , string "Deleted" >> return Deleted + , string "Draft" >> return Draft + , string "Recent" >> return Recent + , char '*' >> return (Keyword "*") + , many1 atomChar >>= return . Keyword ] + <|> (many1 atomChar >>= return . Keyword) + +pParenFlags :: RespDerivs -> Result RespDerivs [Flag] +Parser pParenFlags = do char '(' + fs <- pFlag `sepBy` space + char ')' + return fs + +atomChar :: Derivs d => Parser d Char +atomChar = noneOf " (){%*\"\\]" + +pNumberedLine :: String -> Parser RespDerivs Integer +pNumberedLine str = do num <- many1 digit + space + string str + crlfP + return $ read num + +pExistsLine, pRecentLine, pExpungeLine :: Parser RespDerivs Integer +pExistsLine = pNumberedLine "EXISTS" +pRecentLine = pNumberedLine "RECENT" +pExpungeLine = pNumberedLine "EXPUNGE" + +pOtherLine :: Parser RespDerivs (Either (String, Integer) b) +pOtherLine = do string "* " + choice [ pExistsLine >>= \n -> return (Left ("EXISTS", n)) + , pRecentLine >>= \n -> return (Left ("RECENT", n)) + , blankLine >> return (Left ("", 0))] + where blankLine = anyChar `manyTill` crlfP + + +pCapabilityLine :: Parser RespDerivs (Either a [String]) +pCapabilityLine = do string "* CAPABILITY " + ws <- many1 (noneOf " \r") `sepBy` space + crlfP + return $ Right ws + +pListLine :: String + -> Parser RespDerivs (Either a ([Attribute], String, MailboxName)) +pListLine list = + do string "* " >> string list >> space + attrs <- parseAttrs + sep <- parseSep + mbox <- parseMailbox + return $ Right (attrs, sep, mbox) + where parseAttr = + do char '\\' + choice [ string "Noinferior" >> return Noinferiors + , string "Noselect" >> return Noselect + , string "Marked" >> return Marked + , string "Unmarked" >> return Unmarked + , many atomChar >>= return . OtherAttr + ] + parseAttrs = do char '(' + attrs <- parseAttr `sepBy` space + char ')' + return attrs + parseSep = space >> char '"' >> anyChar `manyTill` char '"' + parseMailbox = space >> anyChar `manyTill` crlfP + +pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) +pStatusLine = + do string "* STATUS " + _ <- anyChar `manyTill` space + stats <- between (char '(') (char ')') (parseStat `sepBy1` space) + crlfP + return $ Right stats + where parseStat = + do cons <- choice [ string "MESSAGES" >>= return . read + , string "RECENT" >>= return . read + , string "UIDNEXT" >>= return . read + , string "UIDVALIDITY" >>= return . read + ] + space + num <- many1 digit >>= return . read + return (cons, num) + +pSearchLine :: Parser RespDerivs (Either a [UID]) +pSearchLine = do string "* SEARCH " + nums <- (many1 digit) `sepBy` space + crlfP + return $ Right $ map read nums + +pSelectLine :: Parser RespDerivs (MailboxInfo -> MailboxInfo) +pSelectLine = + do string "* " + choice [ pExistsLine >>= \n -> return (\mbox -> mbox { _exists = n }) + , pRecentLine >>= \n -> return (\mbox -> mbox { _recent = n }) + , pFlags >>= \fs -> return (\mbox -> mbox { _flags = fs }) + , string "OK " >> okResps ] + where pFlags = do string "FLAGS " + char '(' + fs <- pFlag `sepBy` space + char ')' >> crlfP + return fs + okResps = + do char '[' + v <- choice [ do { string "UNSEEN " + ; many1 digit + ; return id } + , do { string "PERMANENTFLAGS (" + ; fs <- pFlag `sepBy` space + ; char ')' + ; return $ \mbox -> + mbox { _isFlagWritable = + Keyword "*" `elem` fs + , _permanentFlags = + filter (/= Keyword "*") fs } } + , do { string "UIDNEXT " + ; n <- many1 digit + ; return $ \mbox -> + mbox { _uidNext = read n } } + , do { string "UIDVALIDITY " + ; n <- many1 digit + ; return $ \mbox -> + mbox { _uidValidity = read n } } + ] + char ']' + anyChar `manyTill` crlfP + return v + +pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)])) +pFetchLine = + do string "* " + num <- many1 digit + string " FETCH" >> spaces + char '(' + pairs <- pPair `sepBy` space + char ')' + crlfP + return $ Right $ (read num, pairs) + where pPair = do key <- anyChar `manyTill` space + value <- (do char '(' + v <- pParen `sepBy` space + char ')' + return ("("++unwords v++")")) + <|> (do char '{' + num <- many1 digit >>= return . read + char '}' >> crlfP + sequence $ replicate num anyChar) + <|> (do char '"' + v <- noneOf "\"" `manyTill` char '"' + return ("\""++v++"\"")) + <|> many1 atomChar + return (key, value) + pParen = (do char '"' + v <- noneOf "\"" `manyTill` char '"' + return ("\""++v++"\"")) + <|> (do char '(' + v <- pParen `sepBy` space + char ')' + return ("("++unwords v++")")) + <|> (do char '\\' + v <- many1 atomChar + return ('\\':v)) + <|> many1 atomChar + +---------------------------------------------------------------------- +-- auxiliary parsers +space :: Parser RespDerivs Char +space = char ' ' + +spaces, spaces1 :: Parser RespDerivs String +spaces = many space +spaces1 = many1 space + +crlf :: String +crlf = "\r\n" + +crlfP :: Derivs d => Parser d String +crlfP = string crlf + +lookups :: Eq a => a -> [(a, b)] -> [b] +lookups _ [] = [] +lookups k ((k', v):tl) | k == k' = v : lookups k tl + | otherwise = lookups k tl + +---- Either handling +catRights :: [Either a b] -> [b] +catRights [] = [] +catRights (Right r:tl) = r : catRights tl +catRights (_:tl) = catRights tl + +catLefts :: [Either a b] -> [a] +catLefts [] = [] +catLefts (Left r:tl) = r : catLefts tl +catLefts (_:tl) = catLefts tl diff --git a/src/Network/HaskellNet/IMAP/Types.hs b/src/Network/HaskellNet/IMAP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/IMAP/Types.hs @@ -0,0 +1,117 @@ +module Network.HaskellNet.IMAP.Types + ( MailboxName + , UID + , Charset + , MailboxInfo(..) + , Flag(..) + , Attribute(..) + , MboxUpdate(..) + , StatusCode(..) + , ServerResponse(..) + , MailboxStatus(..) + , RespDerivs(..) + , emptyMboxInfo + ) +where + +import Data.Word + ( Word64 + ) +import Text.Packrat.Parse + ( Result + , Derivs(..) + ) +import Text.Packrat.Pos + ( Pos + ) + +type MailboxName = String +type UID = Word64 +type Charset = String + +data MailboxInfo = MboxInfo { _mailbox :: MailboxName + , _exists :: Integer + , _recent :: Integer + , _flags :: [Flag] + , _permanentFlags :: [Flag] + , _isWritable :: Bool + , _isFlagWritable :: Bool + , _uidNext :: UID + , _uidValidity :: UID + } + deriving (Show, Eq) + +data Flag = Seen + | Answered + | Flagged + | Deleted + | Draft + | Recent + | Keyword String + deriving Eq + +instance Show Flag where + showsPrec d f = showParen (d > app_prec) $ showString $ showFlag f + where app_prec = 10 + showFlag Seen = "\\Seen" + showFlag Answered = "\\Answered" + showFlag Flagged = "\\Flagged" + showFlag Deleted = "\\Deleted" + showFlag Draft = "\\Draft" + showFlag Recent = "\\Recent" + showFlag (Keyword s) = "\\" ++ s + +data Attribute = Noinferiors + | Noselect + | Marked + | Unmarked + | OtherAttr String + deriving (Show, Eq) + +data MboxUpdate = MboxUpdate { exists :: Maybe Integer + , recent :: Maybe Integer } + deriving (Show, Eq) + +data StatusCode = ALERT + | BADCHARSET [Charset] + | CAPABILITY_sc [String] + | PARSE + | PERMANENTFLAGS [Flag] + | READ_ONLY + | READ_WRITE + | TRYCREATE + | UIDNEXT_sc UID + | UIDVALIDITY_sc UID + | UNSEEN_sc Integer + deriving (Eq, Show) + +data ServerResponse = OK (Maybe StatusCode) String + | NO (Maybe StatusCode) String + | BAD (Maybe StatusCode) String + | PREAUTH (Maybe StatusCode) String + deriving (Eq, Show) + + +-- | the query data type for the status command +data MailboxStatus = MESSAGES -- ^ the number of messages in the mailbox + | RECENT -- ^ the number of messages with the \Recent flag set + | UIDNEXT -- ^ the next unique identifier value of the mailbox + | UIDVALIDITY -- ^ the unique identifier validity value of the mailbox + deriving (Show, Read, Eq) + + + + +data RespDerivs = + RespDerivs { dvFlags :: Result RespDerivs [Flag] + , advTag :: Result RespDerivs String + , advChar :: Result RespDerivs Char + , advPos :: Pos + } + +instance Derivs RespDerivs where + dvChar = advChar + dvPos = advPos + +emptyMboxInfo :: MailboxInfo +emptyMboxInfo = MboxInfo "" 0 0 [] [] False False 0 0 diff --git a/src/Network/HaskellNet/POP3.hs b/src/Network/HaskellNet/POP3.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/POP3.hs @@ -0,0 +1,239 @@ +module Network.HaskellNet.POP3 + ( -- * Establishing Connection + connectPop3Port + , connectPop3 + , connectStream + -- * Send Command + , sendCommand + -- * More Specific Operations + , closePop3 + , user + , pass + , userPass + , apop + , auth + , stat + , dele + , retr + , top + , rset + , allList + , list + , allUIDLs + , uidl + -- * Other Useful Operations + , doPop3Port + , doPop3 + , doPop3Stream + ) + where + +import Network.HaskellNet.BSStream +import Network +import Network.HaskellNet.Auth hiding (auth, login) +import qualified Network.HaskellNet.Auth as A + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Digest.MD5 +import Numeric (showHex) + +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad (when, unless) + +import Data.List +import Data.Char (isSpace, isControl) + +import System.IO + +import Prelude hiding (catch) + +import Network.HaskellNet.POP3.Types +import Network.HaskellNet.POP3.Connection + +hexDigest :: [Char] -> [Char] +hexDigest = concatMap (flip showHex "") . hash . map (toEnum.fromEnum) + +strip :: ByteString -> ByteString +strip = trimR . trimR + where + trimR s = let rs = BS.reverse s in + BS.dropWhile blank rs + +blank :: Char -> Bool +blank a = isSpace a || isControl a + +-- | connecting to the pop3 server specified by the hostname and port +-- number +connectPop3Port :: String -> PortNumber -> IO (POP3Connection Handle) +connectPop3Port hostname port = + connectTo hostname (PortNumber port) >>= connectStream + +-- | connecting to the pop3 server specified by the hostname. 110 is +-- used for the port number. +connectPop3 :: String -> IO (POP3Connection Handle) +connectPop3 = flip connectPop3Port 110 + +-- | connecting to the pop3 server via a stream +connectStream :: BSStream s => s -> IO (POP3Connection s) +connectStream st = + do (resp, msg) <- response st + when (resp == Err) $ fail "cannot connect" + let code = last $ BS.words msg + if BS.head code == '<' && BS.last code == '>' + then return $ newConnection st (BS.unpack code) + else return $ newConnection st "" + +response :: BSStream s => s -> IO (Response, ByteString) +response st = + do reply <- strip <$> bsGetLine st + if (BS.pack "+OK") `BS.isPrefixOf` reply + then return (Ok, BS.drop 4 reply) + else return (Err, BS.drop 5 reply) + +-- | parse mutiline of response +responseML :: BSStream s => s -> IO (Response, ByteString) +responseML st = + do reply <- strip <$> bsGetLine st + if (BS.pack "+OK") `BS.isPrefixOf` reply + then do rest <- getRest + return (Ok, BS.unlines (BS.drop 4 reply : rest)) + else return (Err, BS.drop 5 reply) + where getRest = do l <- strip <$> bsGetLine st + if l == BS.singleton '.' + then return [] + else (l:) <$> getRest + +-- | sendCommand sends a pop3 command via a pop3 connection. This +-- action is too generic. Use more specific actions +sendCommand :: BSStream s => POP3Connection s -> Command + -> IO (Response, ByteString) +sendCommand conn (LIST Nothing) = + bsPutCrLf conn (BS.pack "LIST") >> responseML conn +sendCommand conn (UIDL Nothing) = + bsPutCrLf conn (BS.pack "UIDL") >> responseML conn +sendCommand conn (RETR msg) = + bsPutCrLf conn (BS.pack $ "RETR " ++ show msg) >> responseML conn +sendCommand conn (TOP msg n) = + bsPutCrLf conn (BS.pack $ "TOP " ++ show msg ++ " " ++ show n) >> + responseML conn +sendCommand conn (AUTH LOGIN username password) = + do bsPutCrLf conn $ BS.pack "AUTH LOGIN" + bsGetLine conn + bsPutCrLf conn $ BS.pack userB64 + bsGetLine conn + bsPutCrLf conn $ BS.pack passB64 + response conn + where (userB64, passB64) = A.login username password +sendCommand conn (AUTH at username password) = + do bsPutCrLf conn $ BS.pack $ unwords ["AUTH", show at] + c <- bsGetLine conn + let challenge = + if BS.take 2 c == BS.pack "+ " + then b64Decode $ BS.unpack $ head $ + dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c + else "" + bsPutCrLf conn $ BS.pack $ A.auth at challenge username password + response conn +sendCommand conn command = + bsPutCrLf conn (BS.pack commandStr) >> response conn + where commandStr = case command of + (USER name) -> "USER " ++ name + (PASS passw) -> "PASS " ++ passw + NOOP -> "NOOP" + QUIT -> "QUIT" + STAT -> "STAT" + (DELE msg) -> "DELE " ++ show msg + RSET -> "RSET" + (LIST msg) -> "LIST " ++ maybe "" show msg + (UIDL msg) -> "UIDL " ++ maybe "" show msg + (APOP usern passw) -> "APOP " ++ usern ++ " " ++ + hexDigest (apopKey conn ++ passw) + (AUTH _ _ _) -> error "BUG: AUTH should not get matched here" + (RETR _) -> error "BUG: RETR should not get matched here" + (TOP _ _) -> error "BUG: TOP should not get matched here" + +user :: BSStream s => POP3Connection s -> String -> IO () +user conn name = do (resp, _) <- sendCommand conn (USER name) + when (resp == Err) $ fail "cannot send user name" + +pass :: BSStream s => POP3Connection s -> String -> IO () +pass conn pwd = do (resp, _) <- sendCommand conn (PASS pwd) + when (resp == Err) $ fail "cannot send password" + +userPass :: BSStream s => POP3Connection s -> UserName -> Password -> IO () +userPass conn name pwd = user conn name >> pass conn pwd + +auth :: BSStream s => POP3Connection s -> AuthType -> UserName -> Password + -> IO () +auth conn at username password = + do (resp, msg) <- sendCommand conn (AUTH at username password) + unless (resp == Ok) $ fail $ "authentication failed: " ++ BS.unpack msg + +apop :: BSStream s => POP3Connection s -> String -> String -> IO () +apop conn name pwd = + do (resp, msg) <- sendCommand conn (APOP name pwd) + when (resp == Err) $ fail $ "authentication failed: " ++ BS.unpack msg + +stat :: BSStream s => POP3Connection s -> IO (Int, Int) +stat conn = do (resp, msg) <- sendCommand conn STAT + when (resp == Err) $ fail "cannot get stat info" + let (nn, mm) = BS.span (/=' ') msg + return (read $ BS.unpack nn, read $ BS.unpack $ BS.tail mm) + +dele :: BSStream s => POP3Connection s -> Int -> IO () +dele conn n = do (resp, _) <- sendCommand conn (DELE n) + when (resp == Err) $ fail "cannot delete" + +retr :: BSStream s => POP3Connection s -> Int -> IO ByteString +retr conn n = do (resp, msg) <- sendCommand conn (RETR n) + when (resp == Err) $ fail "cannot retrieve" + return $ BS.tail $ BS.dropWhile (/='\n') msg + +top :: BSStream s => POP3Connection s -> Int -> Int -> IO ByteString +top conn n m = do (resp, msg) <- sendCommand conn (TOP n m) + when (resp == Err) $ fail "cannot retrieve" + return $ BS.tail $ BS.dropWhile (/='\n') msg + +rset :: BSStream s => POP3Connection s -> IO () +rset conn = do (resp, _) <- sendCommand conn RSET + when (resp == Err) $ fail "cannot reset" + +allList :: BSStream s => POP3Connection s -> IO [(Int, Int)] +allList conn = do (resp, lst) <- sendCommand conn (LIST Nothing) + when (resp == Err) $ fail "cannot retrieve the list" + return $ map f $ tail $ BS.lines lst + where f s = let (n1, n2) = BS.span (/=' ') s + in (read $ BS.unpack n1, read $ BS.unpack $ BS.tail n2) + +list :: BSStream s => POP3Connection s -> Int -> IO Int +list conn n = do (resp, lst) <- sendCommand conn (LIST (Just n)) + when (resp == Err) $ fail "cannot retrieve the list" + let (_, n2) = BS.span (/=' ') lst + return $ read $ BS.unpack $ BS.tail n2 + +allUIDLs :: BSStream s => POP3Connection s -> IO [(Int, ByteString)] +allUIDLs conn = do (resp, lst) <- sendCommand conn (UIDL Nothing) + when (resp == Err) $ fail "cannot retrieve the uidl list" + return $ map f $ tail $ BS.lines lst + where f s = let (n1, n2) = BS.span (/=' ') s in (read $ BS.unpack n1, n2) + +uidl :: BSStream s => POP3Connection s -> Int -> IO ByteString +uidl conn n = do (resp, msg) <- sendCommand conn (UIDL (Just n)) + when (resp == Err) $ fail "cannot retrieve the uidl data" + return $ BS.tail $ BS.dropWhile (/=' ') msg + +closePop3 :: BSStream s => POP3Connection s -> IO () +closePop3 c = do sendCommand c QUIT + bsClose c + +doPop3Port :: String -> PortNumber -> (POP3Connection Handle -> IO a) -> IO a +doPop3Port host port execution = + bracket (connectPop3Port host port) closePop3 execution + +doPop3 :: String -> (POP3Connection Handle -> IO a) -> IO a +doPop3 host execution = doPop3Port host 110 execution + +doPop3Stream :: BSStream s => s -> (POP3Connection s -> IO b) -> IO b +doPop3Stream conn execution = bracket (connectStream conn) closePop3 execution diff --git a/src/Network/HaskellNet/POP3/Connection.hs b/src/Network/HaskellNet/POP3/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/POP3/Connection.hs @@ -0,0 +1,26 @@ +module Network.HaskellNet.POP3.Connection + ( POP3Connection + , newConnection + , apopKey + ) +where + +import Network.HaskellNet.BSStream + +data BSStream s => POP3Connection s = + POP3C { stream :: !s + , apopKey :: !String -- ^ APOP key + } + +newConnection :: BSStream s => s -> String -> POP3Connection s +newConnection = POP3C + +instance BSStream s => BSStream (POP3Connection s) where + bsGetLine = bsGetLine . stream + bsGet = bsGet . stream + bsPut h s = bsPut (stream h) s + bsPutStrLn h s = bsPutStrLn (stream h) s + bsPutNoFlush = bsPutNoFlush . stream + bsFlush = bsFlush . stream + bsClose = bsClose . stream + bsIsOpen = bsIsOpen . stream diff --git a/src/Network/HaskellNet/POP3/Types.hs b/src/Network/HaskellNet/POP3/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/POP3/Types.hs @@ -0,0 +1,24 @@ +module Network.HaskellNet.POP3.Types + ( Command(..) + , Response(..) + ) +where + +import Network.HaskellNet.Auth + +data Command = USER UserName + | PASS Password + | APOP UserName Password + | AUTH AuthType UserName Password + | NOOP + | QUIT + | STAT + | LIST (Maybe Int) + | DELE Int + | RETR Int + | RSET + | TOP Int Int + | UIDL (Maybe Int) + +data Response = Ok | Err + deriving (Eq, Show) diff --git a/src/Network/HaskellNet/SMTP.hs b/src/Network/HaskellNet/SMTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/HaskellNet/SMTP.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Network.HaskellNet.SMTP + ( -- * Types + Command(..) + , Response(..) + , SMTPConnection + -- * Establishing Connection + , connectSMTPPort + , connectSMTP + , connectStream + -- * Operation to a Connection + , sendCommand + , closeSMTP + -- * Other Useful Operations + , sendMail + , doSMTPPort + , doSMTP + , doSMTPStream + , sendMimeMail + ) + where + +import Network.HaskellNet.BSStream +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Network.BSD (getHostName) +import Network + +import Control.Exception +import Control.Monad (unless) + +import Data.Char (isDigit) + +import Network.HaskellNet.Auth + +import System.IO + +import Network.Mail.Mime +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as S + +import qualified Data.Text.Lazy as LT +import qualified Data.Text as T + +import Prelude hiding (catch) + +data (BSStream s) => SMTPConnection s = SMTPC !s ![ByteString] + +data Command = HELO String + | EHLO String + | MAIL String + | RCPT String + | DATA ByteString + | EXPN String + | VRFY String + | HELP String + | AUTH AuthType UserName Password + | NOOP + | RSET + | QUIT + deriving (Show, Eq) + +type ReplyCode = Int + +data Response = Ok + | SystemStatus + | HelpMessage + | ServiceReady + | ServiceClosing + | UserNotLocal + | CannotVerify + | StartMailInput + | ServiceNotAvailable + | MailboxUnavailable + | ErrorInProcessing + | InsufficientSystemStorage + | SyntaxError + | ParameterError + | CommandNotImplemented + | BadSequence + | ParameterNotImplemented + | MailboxUnavailableError + | UserNotLocalError + | ExceededStorage + | MailboxNotAllowed + | TransactionFailed + deriving (Show, Eq) + +-- | connecting SMTP server with the specified name and port number. +connectSMTPPort :: String -- ^ name of the server + -> PortNumber -- ^ port number + -> IO (SMTPConnection Handle) +connectSMTPPort hostname port = + connectTo hostname (PortNumber port) >>= connectStream + +-- | connecting SMTP server with the specified name and port 25. +connectSMTP :: String -- ^ name of the server + -> IO (SMTPConnection Handle) +connectSMTP = flip connectSMTPPort 25 + +tryCommand :: BSStream s => s -> Command -> Int -> ReplyCode + -> IO ByteString +tryCommand st cmd tries expectedReply | tries <= 0 = do + bsClose st + fail $ "cannot execute command " ++ show cmd ++ + ", expected reply code " ++ show expectedReply +tryCommand st cmd tries expectedReply = do + (code, msg) <- sendCommand (SMTPC st []) cmd + if code == expectedReply then + return msg else + tryCommand st cmd (tries - 1) expectedReply + +-- | create SMTPConnection from already connected Stream +connectStream :: BSStream s => s -> IO (SMTPConnection s) +connectStream st = + do (code1, _) <- parseResponse st + unless (code1 == 220) $ + do bsClose st + fail "cannot connect to the server" + senderHost <- getHostName + msg <- tryCommand st (EHLO senderHost) 3 250 + return (SMTPC st (tail $ BS.lines msg)) + +parseResponse :: BSStream s => s -> IO (ReplyCode, ByteString) +parseResponse st = + do (code, bdy) <- readLines + return (read $ BS.unpack code, BS.unlines bdy) + where readLines = + do l <- bsGetLine st + let (c, bdy) = BS.span isDigit l + if not (BS.null bdy) && BS.head bdy == '-' + then do (c2, ls) <- readLines + return (c2, (BS.tail bdy:ls)) + else return (c, [BS.tail bdy]) + + +-- | send a method to a server +sendCommand :: BSStream s => SMTPConnection s -> Command + -> IO (ReplyCode, ByteString) +sendCommand (SMTPC conn _) (DATA dat) = + do bsPutCrLf conn $ BS.pack "DATA" + (code, _) <- parseResponse conn + unless (code == 354) $ fail "this server cannot accept any data." + mapM_ sendLine $ BS.lines dat ++ [BS.pack "."] + parseResponse conn + where sendLine l = bsPutCrLf conn l +sendCommand (SMTPC conn _) (AUTH LOGIN username password) = + do bsPutCrLf conn command + (_, _) <- parseResponse conn + bsPutCrLf conn $ BS.pack userB64 + (_, _) <- parseResponse conn + bsPutCrLf conn $ BS.pack passB64 + parseResponse conn + where command = BS.pack $ "AUTH LOGIN" + (userB64, passB64) = login username password +sendCommand (SMTPC conn _) (AUTH at username password) = + do bsPutCrLf conn command + (code, msg) <- parseResponse conn + unless (code == 334) $ fail "authentication failed." + bsPutCrLf conn $ BS.pack $ auth at (BS.unpack msg) username password + parseResponse conn + where command = BS.pack $ unwords ["AUTH", show at] +sendCommand (SMTPC conn _) meth = + do bsPutCrLf conn $ BS.pack command + parseResponse conn + where command = case meth of + (HELO param) -> "HELO " ++ param + (EHLO param) -> "EHLO " ++ param + (MAIL param) -> "MAIL FROM:<" ++ param ++ ">" + (RCPT param) -> "RCPT TO:<" ++ param ++ ">" + (EXPN param) -> "EXPN " ++ param + (VRFY param) -> "VRFY " ++ param + (HELP msg) -> if null msg + then "HELP\r\n" + else "HELP " ++ msg + NOOP -> "NOOP" + RSET -> "RSET" + QUIT -> "QUIT" + (DATA _) -> + error "BUG: DATA pattern should be matched by sendCommand patterns" + (AUTH _ _ _) -> + error "BUG: AUTH pattern should be matched by sendCommand patterns" + +-- | close the connection. This function send the QUIT method, so you +-- do not have to QUIT method explicitly. +closeSMTP :: BSStream s => SMTPConnection s -> IO () +closeSMTP (SMTPC conn _) = bsClose conn + +{- +I must be being stupid here + +I can't seem to be able to catch the exception arising from the +connection already being closed this would be the correct way to do it +but instead we're being naughty above by just closes the connection +without first sending QUIT + +closeSMTP c@(SMTPC conn _) = + do sendCommand c QUIT + bsClose conn `catch` \(_ :: IOException) -> return () +-} + +-- | sending a mail to a server. This is achieved by sendMessage. If +-- something is wrong, it raises an IOexception. +sendMail :: BSStream s => + String -- ^ sender mail + -> [String] -- ^ receivers + -> ByteString -- ^ data + -> SMTPConnection s + -> IO () +sendMail sender receivers dat conn = + catcher `handle` mainProc + where mainProc = + do (250, _) <- sendCommand conn (MAIL sender) + vals <- mapM (sendCommand conn . RCPT) receivers + unless (all ((==250) . fst) vals) $ fail "sendMail error" + (250, _) <- sendCommand conn (DATA dat) + return () + catcher e@(PatternMatchFail _) = throwIO e + +-- | doSMTPPort open a connection, and do an IO action with the +-- connection, and then close it. +doSMTPPort :: String -> PortNumber -> (SMTPConnection Handle -> IO a) -> IO a +doSMTPPort host port execution = + bracket (connectSMTPPort host port) closeSMTP execution + +-- | doSMTP is similar to doSMTPPort, except that it does not require +-- port number but connects to the server with port 25. +doSMTP :: String -> (SMTPConnection Handle -> IO a) -> IO a +doSMTP host execution = doSMTPPort host 25 execution + +-- | doSMTPStream is similar to doSMTPPort, except that its argument +-- is a Stream data instead of hostname and port number. +doSMTPStream :: BSStream s => s -> (SMTPConnection s -> IO a) -> IO a +doSMTPStream s execution = bracket (connectStream s) closeSMTP execution + +sendMimeMail :: BSStream s => String -> String -> String -> LT.Text + -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection s -> IO () +sendMimeMail to from subject plainBody htmlBody attachments con = do + myMail <- simpleMail (T.pack to) (T.pack from) (T.pack subject) + plainBody htmlBody attachments + renderedMail <- renderMail' myMail + sendMail from [to] (lazyToStrict renderedMail) con + closeSMTP con + +-- haskellNet uses strict bytestrings +-- TODO: look at making haskellnet lazy +lazyToStrict :: B.ByteString -> S.ByteString +lazyToStrict = S.concat . B.toChunks + diff --git a/src/Text/Packrat/Parse.hs b/src/Text/Packrat/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/Packrat/Parse.hs @@ -0,0 +1,348 @@ +-- | Packrat parsing: Simple, Powerful, Lazy, Linear time by Bryan +-- Ford. This module achieves monadic parsing library similar to +-- Parsec. +module Text.Packrat.Parse where + +import Prelude hiding (exp, rem) + +import Char +import List + +import Text.Packrat.Pos + +import Control.Monad + +-- Data types + +data Message = Expected String + | Message String + +data ParseError = ParseError { errorPos :: Pos + , errorMessages :: [Message] } + +data Result d v = Parsed v d ParseError + | NoParse ParseError + +newtype Parser d v = Parser (d -> Result d v) + + +class Derivs d where + dvPos :: d -> Pos + dvChar :: d -> Result d Char + + +-- Basic Combinators + +infixl 2 <|> +infixl 1 +infixl 1 + +instance Derivs d => Monad (Parser d) where + (Parser p1) >>= f = Parser parse + where parse dvs = first (p1 dvs) + first (Parsed val rem err) = + let Parser p2 = f val + in second err (p2 rem) + first (NoParse err) = NoParse err + second err1 (Parsed val rem err) = + Parsed val rem (joinErrors err1 err) + second err1 (NoParse err) = + NoParse (joinErrors err1 err) + return x = Parser (\dvs -> Parsed x dvs (nullError dvs)) + fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg)) + +instance Derivs d => MonadPlus (Parser d) where + mzero = Parser (\dvs -> NoParse $ nullError dvs) + mplus = (<|>) + +(<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v +(Parser p1) <|> (Parser p2) = Parser parse + where parse dvs = first dvs (p1 dvs) + first _ (result @ (Parsed _ _ _)) = result + first dvs (NoParse err) = second err (p2 dvs) + second err1 (Parsed val rem err) = + Parsed val rem (joinErrors err1 err) + second err1 (NoParse err) = + NoParse (joinErrors err1 err) + +satisfy :: Derivs d => Parser d v -> (v -> Bool) -> Parser d v +satisfy (Parser p) test = Parser parse + where parse dvs = check dvs (p dvs) + check dvs (result @ (Parsed val _ _)) = + if test val + then result + else NoParse (nullError dvs) + check _ none = none + +notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d () +notFollowedBy (Parser p) = Parser parse + where parse dvs = case (p dvs) of + Parsed val _ _ -> + NoParse (msgError (dvPos dvs) + ("unexpected " ++ show val)) + NoParse _ -> Parsed () dvs (nullError dvs) + +optional :: Derivs d => Parser d v -> Parser d (Maybe v) +optional p = (do v <- p; return (Just v)) <|> return Nothing + +option :: Derivs d => v -> Parser d v -> Parser d v +option v p = (do v' <- p; return v') <|> return v + +many :: Derivs d => Parser d v -> Parser d [v] +many p = (do { v <- p; vs <- many p; return (v : vs) } ) + <|> return [] + +many1 :: Derivs d => Parser d v -> Parser d [v] +many1 p = do { v <- p; vs <- many p; return (v : vs) } + +count :: Derivs d => Int -> Parser d v -> Parser d [v] +count n p = sequence $ replicate n p + +sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] +sepBy1 p psep = do v <- p + vs <- many (do { psep; p }) + return (v : vs) + +sepBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] +sepBy p psep = sepBy1 p psep <|> return [] + +endBy :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] +endBy p pend = many (do { v <- p; pend; return v }) + +endBy1 :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] +endBy1 p pend = many1 (do { v <- p; pend; return v }) + +sepEndBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] +sepEndBy1 p psep = do v <- sepBy1 p psep; optional psep; return v + +sepEndBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] +sepEndBy p psep = do v <- sepBy p psep; optional psep; return v + +chainl1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v +chainl1 p psep = let psuffix z = (do f <- psep + v <- p + psuffix (f z v)) + <|> return z + in do v <- p + psuffix v + +chainl :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v +chainl p psep z = chainl1 p psep <|> return z + +chainr1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v +chainr1 p psep = (do v <- p + f <- psep + w <- chainr1 p psep + return (f v w)) + <|> p + +chainr :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v +chainr p psep z = chainr1 p psep <|> return z + +choice :: Derivs d => [Parser d v] -> Parser d v +choice [] = error "choice requires non-empty list" +choice [p] = p +choice (p:ps) = p <|> choice ps + + +manyTill :: Derivs d => Parser d v -> Parser d vend -> Parser d [v] +manyTill p pend = (pend >> return []) + <|> do tok <- p + rest <- manyTill p pend + return (tok:rest) + +between :: Derivs d => Parser d vs -> Parser d ve -> Parser d v -> Parser d v +between s e main = do s + v <- main + e + return v + +-- Error handling +instance Eq Message where + Expected e1 == Expected e2 = e1 == e2 + Message m1 == Message m2 = m1 == m2 + _ == _ = False + +failAt :: Derivs d => Pos -> String -> Parser d v +failAt pos msg = Parser (const $ NoParse (msgError pos msg)) + +-- Annotate a parser with a description of the construct to be parsed. +-- The resulting parser yields an "expected" error message +-- if the construct cannot be parsed +-- and if no error information is already available +-- indicating a position farther right in the source code +-- (which would normally be more localized/detailed information). +() :: Derivs d => Parser d v -> String -> Parser d v +(Parser p) desc = Parser (\dvs -> munge dvs (p dvs)) + where munge dvs (Parsed v rem err) = + Parsed v rem (fix dvs err) + munge dvs (NoParse err) = + NoParse (fix dvs err) + fix dvs (err @ (ParseError ep _)) = + if ep > dvPos dvs + then err + else expError (dvPos dvs) desc + +-- Stronger version of the error annotation operator above, +-- which unconditionally overrides any existing error information. +() :: Derivs d => Parser d v -> String -> Parser d v +(Parser p) desc = Parser (\dvs -> munge dvs (p dvs)) + where munge dvs (Parsed v rem err) = + Parsed v rem (fix dvs err) + munge dvs (NoParse err) = + NoParse (fix dvs err) + fix dvs (ParseError _ _) = + expError (dvPos dvs) desc + +-- Potentially join two sets of ParseErrors, +-- but only if the position didn't change from the first to the second. +-- If it did, just return the "new" (second) set of errors. +joinErrors :: ParseError -> ParseError -> ParseError +joinErrors (e @ (ParseError p m)) (e' @ (ParseError p' m')) + | p' > p || null m = e' + | p > p' || null m' = e + | otherwise = ParseError p (m `union` m') + +nullError :: Derivs d => d -> ParseError +nullError dvs = ParseError (dvPos dvs) [] + +expError :: Pos -> String -> ParseError +expError pos desc = ParseError pos [Expected desc] + +msgError :: Pos -> String -> ParseError +msgError pos msg = ParseError pos [Message msg] + +eofError :: Derivs d => d -> ParseError +eofError dvs = msgError (dvPos dvs) "end of input" + +expected :: Derivs d => String -> Parser d v +expected desc = Parser (\dvs -> NoParse (expError (dvPos dvs) desc)) + +unexpected :: Derivs d => String -> Parser d v +unexpected str = fail ("unexpected " ++ str) + + +-- Comparison operators for ParseError just compare relative positions. +instance Eq ParseError where + ParseError p1 _ == ParseError p2 _ = p1 == p2 + ParseError p1 _ /= ParseError p2 _ = p1 /= p2 + +instance Ord ParseError where + ParseError p1 _ < ParseError p2 _ = p1 < p2 + ParseError p1 _ > ParseError p2 _ = p1 > p2 + ParseError p1 _ <= ParseError p2 _ = p1 <= p2 + ParseError p1 _ >= ParseError p2 _ = p1 >= p2 + -- Special behavior: "max" joins two errors + max p1 p2 = joinErrors p1 p2 + min _ _ = undefined + +instance Show ParseError where + show (ParseError pos []) = + show pos ++ ": unknown error" + show (ParseError pos msgs) = expectmsg expects ++ messages msgs + where expects = getExpects msgs + getExpects [] = [] + getExpects (Expected exp : rest) = exp : getExpects rest + getExpects (Message _ : rest) = getExpects rest + expectmsg [] = "" + expectmsg [exp] = show pos ++ ": expecting " ++ exp ++ "\n" + expectmsg [e1, e2] = show pos ++ ": expecting either " + ++ e1 ++ " or " ++ e2 ++ "\n" + expectmsg (first : rest) = show pos ++ ": expecting one of: " + ++ first ++ expectlist rest ++ "\n" + expectlist [] = "" + expectlist [lst] = ", or " ++ lst + expectlist (mid : rest) = ", " ++ mid ++ expectlist rest + messages [] = [] + messages (Expected _ : rest) = messages rest + messages (Message msg : rest) = + show pos ++ ": " ++ msg ++ "\n" ++ messages rest + + +-- Character-oriented parsers + +anyChar :: Derivs d => Parser d Char +anyChar = Parser dvChar + +char :: Derivs d => Char -> Parser d Char +char ch = satisfy anyChar (\c -> c == ch) show ch + +oneOf :: Derivs d => [Char] -> Parser d Char +oneOf chs = satisfy anyChar (\c -> c `elem` chs) + ("one of the characters " ++ show chs) + +noneOf :: Derivs d => [Char] -> Parser d Char +noneOf chs = satisfy anyChar (\c -> not (c `elem` chs)) + ("any character not in " ++ show chs) + + +charIf :: Derivs d => (Char -> Bool) -> Parser d Char +charIf p = satisfy anyChar p "predicate is not satisfied" + +string :: Derivs d => String -> Parser d String +string str = p str show str + where p [] = return str + p (ch:chs) = do { char ch; p chs } + +stringFrom :: Derivs d => [String] -> Parser d String +stringFrom [] = error "stringFrom requires non-empty list" +stringFrom [str] = string str +stringFrom (str : strs) = string str <|> stringFrom strs + +upper :: Derivs d => Parser d Char +upper = satisfy anyChar isUpper "uppercase letter" + +lower :: Derivs d => Parser d Char +lower = satisfy anyChar isLower "lowercase letter" + +letter :: Derivs d => Parser d Char +letter = satisfy anyChar isAlpha "letter" + +alphaNum :: Derivs d => Parser d Char +alphaNum = satisfy anyChar isAlphaNum "letter or digit" + +digit :: Derivs d => Parser d Char +digit = satisfy anyChar isDigit "digit" + +hexDigit :: Derivs d => Parser d Char +hexDigit = satisfy anyChar isHexDigit "hexadecimal digit (0-9, a-f)" + +octDigit :: Derivs d => Parser d Char +octDigit = satisfy anyChar isOctDigit "octal digit (0-7)" + +newline :: Derivs d => Parser d Char +newline = char '\n' + +tab :: Derivs d => Parser d Char +tab = char '\t' + +space :: Derivs d => Parser d Char +space = satisfy anyChar isSpace "whitespace character" + +spaces :: Derivs d => Parser d [Char] +spaces = many space + +eof :: Derivs d => Parser d () +eof = notFollowedBy anyChar "end of input" + + +-- State manipulation + +getDerivs :: Derivs d => Parser d d +getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs)) + +setDerivs :: Derivs d => d -> Parser d () +setDerivs newdvs = Parser (\dvs -> Parsed () newdvs (nullError dvs)) + +getPos :: Derivs d => Parser d Pos +getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs)) + + +-- Special function that converts a Derivs "back" into an ordinary String +-- by extracting the successive dvChar elements. +dvString :: Derivs d => d -> String +dvString d = + case dvChar d of + NoParse _ -> [] + Parsed c rem _ -> (c : dvString rem) + diff --git a/src/Text/Packrat/Pos.hs b/src/Text/Packrat/Pos.hs new file mode 100644 --- /dev/null +++ b/src/Text/Packrat/Pos.hs @@ -0,0 +1,35 @@ +-- Simple data type to keep track of character positions +-- within a text file or other text stream. +module Text.Packrat.Pos where + + +data Pos = Pos { posFile :: !String + , posLine :: !Int + , posCol :: !Int + } + +nextPos :: Pos -> Char -> Pos +nextPos (Pos file line col) c + | c == '\n' = Pos file (line + 1) 1 + | c == '\t' = Pos file line ((div (col + 8 - 1) 8) * 8 + 1) + | otherwise = Pos file line (col + 1) + +instance Eq Pos where + Pos f1 l1 c1 == Pos f2 l2 c2 = + f1 == f2 && l1 == l2 && c1 == c2 + +instance Ord Pos where + Pos _ l1 c1 <= Pos _ l2 c2 = + (l1 < l2) || (l1 == l2 && c1 <= c2) + +instance Show Pos where + show (Pos file line col) = file ++ ":" ++ show line ++ ":" ++ show col + + +showPosRel :: Pos -> Pos -> String +showPosRel (Pos file line _) (Pos file' line' col') + | file == file' = + if (line == line') + then "column " ++ show col' + else "line " ++ show line' ++ ", column " ++ show col' + | otherwise = show (Pos file' line' col')