HaskellNet 0.2.5 → 0.3
raw patch · 32 files changed
+2249/−2886 lines, 32 filesdep −containersdep −old-localedep −parsecnew-uploader
Dependencies removed: containers, old-locale, parsec, time
Files
- CHANGELOG +41/−0
- Data/Record.hs +0/−56
- HaskellNet.cabal +48/−22
- Network/HaskellNet/Auth.hs +0/−75
- Network/HaskellNet/BSStream.hs +0/−62
- Network/HaskellNet/IMAP.hs +0/−475
- Network/HaskellNet/POP3.hs +0/−296
- Network/HaskellNet/SMTP.hs +0/−287
- README.md +7/−4
- Text/IMAPParsers.hs +0/−492
- Text/Mime.hs +0/−343
- Text/Packrat/Parse.hs +0/−351
- Text/Packrat/Pos.hs +0/−33
- Text/URI.hsc +0/−230
- example/DebugStream.hs +0/−92
- example/TLSStream.hs +0/−4
- example/imap.hs +3/−5
- example/pop3.hs +3/−3
- example/smtpMimeMail.hs +0/−56
- src/Network/HaskellNet/Auth.hs +62/−0
- src/Network/HaskellNet/BSStream.hs +41/−0
- src/Network/HaskellNet/Debug.hs +81/−0
- src/Network/HaskellNet/IMAP.hs +444/−0
- src/Network/HaskellNet/IMAP/Connection.hs +102/−0
- src/Network/HaskellNet/IMAP/Parsers.hs +379/−0
- src/Network/HaskellNet/IMAP/Types.hs +117/−0
- src/Network/HaskellNet/POP3.hs +239/−0
- src/Network/HaskellNet/POP3/Connection.hs +26/−0
- src/Network/HaskellNet/POP3/Types.hs +24/−0
- src/Network/HaskellNet/SMTP.hs +249/−0
- src/Text/Packrat/Parse.hs +348/−0
- src/Text/Packrat/Pos.hs +35/−0
+ CHANGELOG view
@@ -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)
− Data/Record.hs
@@ -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-
HaskellNet.cabal view
@@ -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 <wrwills@gmail.com>+Maintainer: Jonathan Daugherty <drcygnus@gmail.com> 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
− Network/HaskellNet/Auth.hs
@@ -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
− Network/HaskellNet/BSStream.hs
@@ -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
− Network/HaskellNet/IMAP.hs
@@ -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
− Network/HaskellNet/POP3.hs
@@ -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
− Network/HaskellNet/SMTP.hs
@@ -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-
README.md view
@@ -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
− Text/IMAPParsers.hs
@@ -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"
− Text/Mime.hs
@@ -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 "<input>" 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 "<input>" 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 "<input>" 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"-
− Text/Packrat/Parse.hs
@@ -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)-
− Text/Packrat/Pos.hs
@@ -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')
− Text/URI.hsc
@@ -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 "<uri>" 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 "<uri>" 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)
− example/DebugStream.hs
@@ -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
example/TLSStream.hs view
@@ -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) =
example/imap.hs view
@@ -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)-
example/pop3.hs view
@@ -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
− example/smtpMimeMail.hs
@@ -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 "<html><body>低頭思故鄉</body></html>" )- [((T.pack "application/pdf"),"/tmp/cv.pdf")]- con- HN.closeSMTP con--- [("application/pdf","/tmp/cv.pdf"), ("image/jpeg", "/tmp/img.jpg")]
+ src/Network/HaskellNet/Auth.hs view
@@ -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
+ src/Network/HaskellNet/BSStream.hs view
@@ -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
+ src/Network/HaskellNet/Debug.hs view
@@ -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
+ src/Network/HaskellNet/IMAP.hs view
@@ -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
+ src/Network/HaskellNet/IMAP/Connection.hs view
@@ -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
+ src/Network/HaskellNet/IMAP/Parsers.hs view
@@ -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
+ src/Network/HaskellNet/IMAP/Types.hs view
@@ -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
+ src/Network/HaskellNet/POP3.hs view
@@ -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
+ src/Network/HaskellNet/POP3/Connection.hs view
@@ -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
+ src/Network/HaskellNet/POP3/Types.hs view
@@ -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)
+ src/Network/HaskellNet/SMTP.hs view
@@ -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+
+ src/Text/Packrat/Parse.hs view
@@ -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)+
+ src/Text/Packrat/Pos.hs view
@@ -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')