HaskellNet 0.2.3 → 0.2.4

raw patch · 27 files changed

+1330/−2789 lines, 27 filesdep +mime-maildep +textdep −HaXmldep ~Cryptodep ~basedep ~haskell98PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mime-mail, text

Dependencies removed: HaXml

Dependency ranges changed: Crypto, base, haskell98, network

API changes (from Hackage documentation)

Files

• HaskellNet.cabal +22/−17
• HaskellNet/Auth.hs +0/−75
• HaskellNet/BSStream.hs +0/−58
• HaskellNet/IMAP.hs +0/−471
• HaskellNet/POP3.hs +0/−296
• HaskellNet/SMTP.hs +0/−249
• INSTALL +0/−7
• LICENSE +24/−22
• Network/HaskellNet/Auth.hs +75/−0
• Network/HaskellNet/BSStream.hs +62/−0
• Network/HaskellNet/IMAP.hs +475/−0
• Network/HaskellNet/POP3.hs +296/−0
• Network/HaskellNet/SMTP.hs +277/−0
• README.md +16/−0
• Text/Atom.hs +0/−643
• Text/Bencode.hs +0/−152
• Text/RSS.hs +0/−239
• Text/URI.hs +0/−233
• example/DebugStream.hs +2/−2
• example/TLSStream.hs +4/−4
• example/imap.hs +1/−1
• example/pop3.hs +1/−1
• example/smtp.hs +21/−4
• example/smtpMimeMail.hs +54/−0
• test/AtomTest.hs +0/−81
• test/IMAPParsersTest.hs +0/−174
• test/RSSTest.hs +0/−60

@@ -1,29 +1,34 @@ Name:           HaskellNet-Version:        0.2.3+Version:        0.2.4 Author:         Jun Mukai Maintainer:	Robert Wills <wrwills@gmail.com> License:        BSD3+License-file:	LICENSE Category:       Network-Homepage:       https://patch-tag.com/r/wrwills/HaskellNet/home+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 and check that these libraries basically -		work.  -Build-Depends:  base >= 2 && < 4, haskell98, network, mtl, parsec, time, bytestring, pretty, array, Crypto, base64-string, containers, HaXml<1.19, old-locale, old-time+		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-cabal-version:  >=1.2-build-type:	Simple+Cabal-version:  >=1.6+Build-type:	Simple +Extra-Source-Files: README.md, example/*.hs -exposed-modules:+Library+  Exposed-modules:    Text.IMAPParsers,    Text.Mime,    Text.URI,-   Text.Bencode,-   Text.RSS,-   Text.Atom,-   HaskellNet.IMAP,-   HaskellNet.SMTP,-   HaskellNet.POP3,-   HaskellNet.BSStream,-   HaskellNet.Auth-other-modules: Data.Record, Text.Packrat.Pos, Text.Packrat.Parse+--   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, text++source-repository head+  type:     darcs+  location: https://patch-tag.com/r/wrwills/HaskellNet

@@ -1,75 +0,0 @@-------------------------------------------------------------------------- |--- Module      :  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 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

@@ -1,58 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  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 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 ()--    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 = hClose

@@ -1,471 +0,0 @@-------------------------------------------------------------------------- |--- Module      :  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 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 HaskellNet.BSStream-import HaskellNet.Auth hiding (auth, login)-import qualified 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 " ++ charset ++ " " ++ 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

@@ -1,296 +0,0 @@-------------------------------------------------------------------------- |--- Module      :  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 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 HaskellNet.BSStream-import Network-import HaskellNet.Auth hiding (auth, login)-import qualified 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

@@ -1,249 +0,0 @@-------------------------------------------------------------------------- |--- Module      :  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 HaskellNet.SMTP-    ( -- * Types-      Command(..)-    , Response(..)-    , SMTPConnection-      -- * Establishing Connection-    , connectSMTPPort-    , connectSMTP-    , connectStream-      -- * Operation to a Connection-    , sendCommand-    , closeSMTP-      -- * Other Useful Operations -    , sendMail-    , doSMTPPort-    , doSMTP-    , doSMTPStream-    )-    where--import 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 HaskellNet.Auth--import System.IO--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 sendCommand c QUIT-                                bsClose conn---- | --- 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 _) = 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

@@ -1,7 +0,0 @@--cabal configure-cabal build-cabal install--You can run imap, smtp, and pop3 examples using ghci.-NB: you might need to add "-hide-package transformers" to the ghci command

@@ -1,28 +1,30 @@-Copyright (c) 2006, Jun Mukai +Copyright (c)2010, Jun Mukai, Rob Wills+ All rights reserved.  Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-  1. Redistributions of source code must retain the above copyright-     notice, this list of conditions and the following disclaimer.-  2. Redistributions in binary form must reproduce the above copyright-     notice, this list of conditions and the following disclaimer in the-     documentation and/or other materials provided with the distribution.-  3. Neither the name of the author nor the names of its contributors-     may be used to endorse or promote products derived from this software-     without specific prior written permission.+modification, are permitted provided that the following conditions are met: +    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer. -THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. AND CONTRIBUTORS-``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED-TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS-BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution. +    * Neither the name of Jun Mukai, Rob Wills nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,75 @@+----------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,475 @@+----------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,296 @@+----------------------------------------------------------------------+-- |+-- 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

@@ -0,0 +1,277 @@+{-# 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 qualified Data.Text.Lazy as LT++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 = do+  myMail <-  simpleMail to from 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+

@@ -0,0 +1,16 @@+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.++  ghci -hide-package monads-fd example/smtpMimeMail.hs+  main+  +If you encounter problems and want to debug the ghci +debugger works well:++  :set -fbreak-on-exception+  :trace main

@@ -1,643 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-------------------------------------------------------------------------- |--- Module      :  Text.Atom--- Copyright   :  (c) Jun Mukai 2006--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  mukai@jmuk.org--- Stability   :  experimental--- Portability :  portable--- --- Atom Syndication format Parser/Printer Library using HaXml--- --module Text.Atom-    ( Text(..), EntryContent(..), stringContent, xhtmlContent, binaryContent, srcContent-    , Person, mkPerson-    , Feed, mkFeed, Entry, mkEntry-    , Category, mkCategory, Generator, mkGenerator, defaultGenerator-    , Link, LinkRelation(..), mkLink, selfLink-    , Attr, get, set, update, has, add, howMany, set', get', delete-    , AName(..), AUri(..), AEmail(..), AAuthor(..), ACategory(..)-    , AContributor(..), AGenerator(..), AIcon(..), AId(..), ALink(..)-    , ALogo(..), ARights(..), ASubtitle(..), ATitle(..), AUpdated(..)-    , AEntries(..), AContent(..), APublished(..), ASource(..), ASummary(..)-    , ATerm(..), AScheme(..), ALabel(..), AVersion(..), AHref(..), ARel(..)-    , AMediatype(..), AHreflang(..), ALength(..)-    , PERSON(..), CATEGORY(..), GENERATOR(..), LINK(..), FEED(..), ENTRY(..)-    )-where--import Data.Record-import Data.List (genericLength, nubBy, isPrefixOf)-import Data.Char (isSpace)-import Data.Maybe-import Control.Applicative hiding (many)-import Data.Foldable-import Data.Map (findWithDefault, insert, Map)-import qualified Data.Map as M-import Data.Monoid (Sum(..))-import Data.Time (formatTime)-import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), ZonedTime(..), TimeZone(..), minutesToTimeZone, utc)-import System.Locale (defaultTimeLocale)-import Data.Time.Calendar-import Text.XML.HaXml hiding (version)-import Text.XML.HaXml.Escape (xmlEscape, xmlUnEscape, mkXmlEscaper)-import qualified Text.XML.HaXml.Html.Pretty as P (content)-import Text.XML.HaXml.Xml2Haskell-import Text.PrettyPrint.HughesPJ (hcat)-import qualified Codec.Binary.Base64.String as B64 (encode, decode)--import Prelude hiding (foldr1, foldr, or, any, all, concatMap, concat, elem)--e2e :: (Enum a, Enum b) => a -> b-e2e = toEnum . fromEnum-b64Encode :: String -> String-b64Encode = map e2e . B64.encode . map e2e-b64Decode :: String -> String-b64Decode = map e2e . B64.decode . map e2e--atomEscaper = mkXmlEscaper [('<', "lt"), ('>', "gt"), ('&', "amp"), ('"', "quot")] (`elem` "<>\"")-xEscape :: [Content] -> [Content]-xEscape cs = let Elem _ _ cs' = xmlEscape atomEscaper (Elem "" [] cs) in cs'--xUnEscape :: [Content] -> [Content]-xUnEscape cs = let Elem _ _ cs' = xmlUnEscape atomEscaper (Elem "" [] cs) in cs'--escapeString :: String -> String-escapeString s = fromText' $ xEscape [CString False s]--unEscapeString :: String -> String-unEscapeString s = fromText' $ xUnEscape [CString False s]----------------------------------------------------------------- basic constructs --data Text = Text String-          | HTML String-          | XHtml [Content]-instance Show Text where-    show (Text s) = "Text "++show s-    show (HTML s) = "HTML "++show s-    show (XHtml cont) = "XHtml \""++show (hcat (map P.content cont))++"\""--data EntryContent = TextCont Text-                  | BinaryData String String-                  | OtherSrc String String-                    deriving Show-stringContent = TextCont . Text-xhtmlContent = TextCont . XHtml-binaryContent t d | typeChecker t = error "binary data must not text, html, or xhtml"-                  | otherwise = BinaryData t d-srcContent t url | typeChecker t = error "other src must not text, html, or xhtml"-                 | otherwise = OtherSrc t url-typeChecker t = any (flip isPrefixOf t) ["text", "html", "xhtml"]---data Person = Person { personName :: !Text-                     , personUri :: Maybe String-                     , personEmail :: Maybe String-                     } deriving Show-mkPerson :: String -> Person-mkPerson s = Person (Text s) Nothing Nothing----------------------------------------------------------------- atom types-data Feed = Feed { feedAuthor :: [Person]-                 , feedCategory :: [Category]-                 , feedContributor :: [Person]-                 , feedGenerator :: [Generator]-                 , feedIcon :: Maybe String-                 , feedId :: !String-                 , feedLink :: [Link]-                 , feedLogo :: Maybe String-                 , feedRights :: Maybe Text-                 , feedSubtitle :: Maybe Text-                 , feedTitle :: !Text-                 , feedUpdated :: !ZonedTime-                 , feedEntries :: [Entry]-                 } deriving Show-mkFeed :: Person -- ^ primary author-       -> String -- ^ id-       -> String -- ^ self link-       -> String -- ^ title-       -> ZonedTime -> Feed-mkFeed a id l t ut = Feed [a] [] [] [defaultGenerator] Nothing id [selfLink l] Nothing Nothing Nothing (Text t) ut []--data Entry = Entry { entryAuthor :: [Person]-                   , entryCategory :: [Category]-                   , entryContent :: Maybe EntryContent-                   , entryContributor :: [Person]-                   , entryId :: !String-                   , entryLink :: [Link]-                   , entryPublished :: Maybe ZonedTime-                   , entryRights :: Maybe Text-                   , entrySource :: Maybe Feed-                   , entrySummary :: Maybe String-                   , entryTitle :: !Text-                   , entryUpdated :: !ZonedTime-                   } deriving Show-mkEntry :: String -- ^ id-        -> String -- ^ title-        -> EntryContent -- ^ content-        -> ZonedTime -> Entry-mkEntry id title content updated = Entry [] [] (Just content) [] id [] Nothing Nothing Nothing Nothing (Text title) updated--data Category = Category { categoryTerm :: !String-                         , categoryScheme :: Maybe String-                         , categoryLabel :: Maybe String-                         } deriving Show-mkCategory :: String -> Category-mkCategory s = Category s Nothing Nothing--data Generator = Generator { generatorName :: !String-                           , generatorUri :: Maybe String-                           , generatorVersion :: Maybe String-                           } deriving Show-mkGenerator :: String -> Generator-mkGenerator s = Generator s Nothing Nothing-defaultGenerator :: Generator-defaultGenerator = Generator "HaskellNet" (Just "http://darcs.haskell.org/SoC/haskellnet/") (Just "0.1")--data Link = Link { linkHref :: !String-                 , linkRel :: !LinkRelation-                 , linkMediatype :: Maybe String-                 , linkHreflang :: Maybe String-                 , linkTitle :: Maybe String-                 , linkLength :: Maybe Integer-                 } deriving Show-data LinkRelation = Alternate | Related | Self | Enclosure | Via deriving Eq-instance Show LinkRelation where-    show Alternate = "alternate"-    show Related = "related"-    show Self = "self"-    show Enclosure = "enclosure"-    show Via = "via"-instance Read LinkRelation where-    readsPrec d s = readParen (d > app_prec) (\s -> concatMap (f s) labels) s-        where app_prec = 10-              f s (s', l) | s' `isPrefixOf` s = [(l, drop (length s') s)]-                          | otherwise         = []-              labels = [ ("alternate", Alternate), ("related", Related)-                       , ("self", Self), ("enclosure", Enclosure)-                       , ("via", Via) ]-mkLink :: String -> Link-mkLink s = Link s Alternate Nothing Nothing Nothing Nothing-selfLink :: String -> Link-selfLink s = Link s Self Nothing Nothing Nothing Nothing----------------------------------------------------------------- field class/instance declarations--class AName r v | r -> v where    name :: Attr r v-class AUri r v | r -> v where    uri :: Attr r v-class AEmail r v | r -> v where    email :: Attr r v-class AAuthor r v | r -> v where    author :: Attr r v-class ACategory r v | r -> v where    category :: Attr r v-class AContributor r v | r -> v where    contributor :: Attr r v-class AGenerator r v | r -> v where    generator :: Attr r v-class AIcon r v | r -> v where    icon :: Attr r v-class AId r v | r -> v where    identifier :: Attr r v-class ALink r v | r -> v where    link :: Attr r v-class ALogo r v | r -> v where    logo :: Attr r v-class ARights r v | r -> v where    rights :: Attr r v-class ASubtitle r v | r -> v where    subtitle :: Attr r v-class ATitle r v | r -> v where    title :: Attr r v-class AUpdated r v | r -> v where    updated :: Attr r v-class AEntries r v | r -> v where    entries :: Attr r v-class AContent r v | r -> v where    content :: Attr r v-class APublished r v | r -> v where    published :: Attr r v-class ASource r v | r -> v where    source :: Attr r v-class ASummary r v | r -> v where    summary :: Attr r v-class ATerm r v | r -> v where    term :: Attr r v-class AScheme r v | r -> v where    scheme :: Attr r v-class ALabel r v | r -> v where    label :: Attr r v-class AVersion r v | r -> v where    version :: Attr r v-class AHref r v | r -> v where    href :: Attr r v-class ARel r v | r -> v where    rel :: Attr r v-class AMediatype r v | r -> v where    mediatype :: Attr r v-class AHreflang r v | r -> v where    hreflang :: Attr r v-class ALength r v | r -> v where    len :: Attr r v---instance AName Person Text where-    name = Attr personName setter-        where setter r v = r { personName = v }--instance AUri Person (Maybe String) where-    uri = Attr personUri setter-        where setter r v = r { personUri = v }--instance AEmail Person (Maybe String) where-    email = Attr personEmail setter-        where setter r v = r { personEmail = v }--instance AAuthor Feed [Person] where-    author = Attr feedAuthor setter-        where setter r v | check r v = r { feedAuthor = v }-                         | otherwise = error "Feed must have at least one author"-              check r [] = not $ any (null . get author) $ feedEntries r-              check r vs = True--instance ACategory Feed [Category] where-    category = Attr feedCategory setter-        where setter r v = r { feedCategory = v }--instance AContributor Feed [Person] where-    contributor = Attr feedContributor setter-        where setter r v = r { feedContributor = v }--instance AGenerator Feed [Generator] where-    generator = Attr feedGenerator setter-        where setter r v = r { feedGenerator = v }--instance AIcon Feed (Maybe String) where-    icon = Attr feedIcon setter-        where setter r v = r { feedIcon = v }--instance AId Feed String where-    identifier = Attr feedId setter-        where setter r v = r { feedId = v }--instance ALink Feed [Link] where-    link = Attr feedLink setter-        where setter r v | check v   = r { feedLink = v }-                         | otherwise = error "links do not satisfy the specs of atom"-              check ls = let ls'  = filter ((==Alternate) . get rel) ls-                             ls'' = filter ((==Self) . get rel) ls-                         in length (nubBy f1 ls') == length ls' && -                            not (null ls'')-              f1 a b = get mediatype a == get mediatype b && -                       get hreflang a == get hreflang b-                        -instance ALogo Feed (Maybe String) where-    logo = Attr feedLogo setter-        where setter r v = r { feedLogo = v }--instance ARights Feed (Maybe Text) where-    rights = Attr feedRights setter-        where setter r v = r { feedRights = v }--instance ASubtitle Feed (Maybe Text) where-    subtitle = Attr feedSubtitle setter-        where setter r v = r { feedSubtitle = v }--instance ATitle Feed Text where-    title = Attr feedTitle setter-        where setter r v = r { feedTitle = v }--instance AUpdated Feed ZonedTime where-    updated = Attr feedUpdated setter-        where setter r v = r { feedUpdated = v }--instance AEntries Feed [Entry] where-    entries = Attr feedEntries setter-        where setter r v = r { feedEntries = v }-              --instance AAuthor Entry [Person] where-    author = Attr entryAuthor setter-        where setter r v = r { entryAuthor = v }--instance ACategory Entry [Category] where-    category = Attr entryCategory setter-        where setter r v = r { entryCategory = v }--instance AContent Entry (Maybe EntryContent) where-    content = Attr entryContent setter-        where setter r v = r { entryContent = v }--instance AContributor Entry [Person] where-    contributor = Attr entryContributor setter-        where setter r v = r { entryContributor = v }--instance AId Entry String where-    identifier = Attr entryId setter-        where setter r v = r { entryId = v }--instance ALink Entry [Link] where-    link = Attr entryLink setter-        where setter r v | check r v = r { entryLink = v }-                         | otherwise = error "links do not satisfy the specs of atom"-              check r ls = -                  let ls'  = filter ((==Alternate) . get rel) ls-                  in length (nubBy f1 ls') == length ls' && -                         (isJust (entryContent r) || not (null ls'))-              f1 a b = get mediatype a == get mediatype b && -                       get hreflang a == get hreflang b---instance APublished Entry (Maybe ZonedTime) where-    published = Attr entryPublished setter-        where setter r v = r { entryPublished = v }--instance ARights Entry (Maybe Text) where-    rights = Attr entryRights setter-        where setter r v = r { entryRights = v }--instance ASource Entry (Maybe Feed) where-    source = Attr entrySource setter-        where setter r v = r { entrySource = fmap (delete entries) v }--instance ASummary Entry (Maybe String) where-    summary = Attr entrySummary setter-        where setter r Nothing | check (get content r) = error "summary is required to this entry"-              setter r v = r { entrySummary = v }-              check (Just (BinaryData _ _)) = True-              check (Just (OtherSrc _ _))   = True-              check _ = False--instance ATitle Entry Text where-    title = Attr entryTitle setter-        where setter r v = r { entryTitle = v }--instance AUpdated Entry ZonedTime where-    updated = Attr entryUpdated setter-        where setter r v = r { entryUpdated = v }--instance ATerm Category String where-    term = Attr categoryTerm setter-        where setter r v = r { categoryTerm = v }--instance AScheme Category (Maybe String) where-    scheme = Attr categoryScheme setter-        where setter r v = r { categoryScheme = v }--instance ALabel Category (Maybe String) where-    label = Attr categoryLabel setter-        where setter r v = r { categoryLabel = v }--instance AName Generator String where-    name = Attr generatorName setter-        where setter r v = r { generatorName = v }--instance AUri Generator (Maybe String) where-    uri = Attr generatorUri setter-        where setter r v = r { generatorUri = v }--instance AVersion Generator (Maybe String) where-    version = Attr generatorVersion setter-        where setter r v = r { generatorVersion = v }--instance AHref Link String where-    href = Attr linkHref setter-        where setter r v = r { linkHref = v }--instance ARel Link LinkRelation where-    rel = Attr linkRel setter-        where setter r v = r { linkRel = v }--instance AMediatype Link (Maybe String) where-    mediatype = Attr linkMediatype setter-        where setter r v = r { linkMediatype = v }--instance AHreflang Link (Maybe String) where-    hreflang = Attr linkHreflang setter-        where setter r v = r { linkHreflang = v }--instance ATitle Link (Maybe String) where-    title = Attr linkTitle setter-        where setter r v = r { linkTitle = v }--instance ALength Link (Maybe Integer) where-    len = Attr linkLength setter-        where setter r v = r { linkLength = v }----------------------------------------------------------------- XML <-> ATOM data types interchange--class (AName r Text, AUri r (Maybe String), AEmail r (Maybe String)) -    => PERSON r-instance PERSON Person-class (ATerm r String, AScheme r (Maybe String), ALabel r (Maybe String))-    => CATEGORY r-instance CATEGORY Category-class (AName r String, AUri r (Maybe String), AVersion r (Maybe String))-    => GENERATOR r-instance GENERATOR Generator-class ( AHref r String, ARel r LinkRelation, AMediatype r (Maybe String)-      , AHreflang r (Maybe String), ATitle r (Maybe String)-      , ALength r (Maybe Integer))-    => LINK r-instance LINK Link--class ( AAuthor r [Person], ACategory r [Category], AContributor r [Person]-      , AGenerator r [Generator], AIcon r (Maybe String), AId r String-      , ALink r [Link], ALogo r (Maybe String), ARights r (Maybe Text)-      , ASubtitle r (Maybe Text), ATitle r Text, AUpdated r ZonedTime)-    => FEED r-instance FEED Feed-class ( AAuthor r [Person], ACategory r [Category]-      , AContent r (Maybe EntryContent), AContributor r [Person], AId r String-      , ALink r [Link], APublished r (Maybe ZonedTime), ARights r (Maybe Text)-      , ASource r (Maybe Feed), ASummary r (Maybe String)-      , ATitle r Text, AUpdated r ZonedTime)-    => ENTRY r-instance ENTRY Entry--s2cont :: String -> Content-s2cont s = CString False (escapeString s)--simpleCont :: String -> [Content] -> Content-simpleCont t cs = CElem $ Elem t [] cs--p2cont :: String -> Person -> Content-p2cont t p = simpleCont t (n:(u++m))-    where n = t2cont "name" $ get name p-          u = toList $ fmap (\u -> simpleCont "uri" [s2cont u]) $ get uri p-          m = toList $ fmap (\m -> simpleCont "email" [s2cont m]) $ get email p-cont2p :: Content -> Person-cont2p (CElem (Elem _ _ cs)) = Person n u m-    where n = cont2t $ head $ getTags "name" cs-          u = fmap fromText' $ listToMaybe $ getChildren "uri" cs-          m = fmap fromText' $ listToMaybe $ getChildren "email" cs--t2cont :: String -> Text -> Content-t2cont t (Text s) = CElem $ Elem t [("type", str2attr "text")] [s2cont s]-t2cont t (HTML s) = CElem $ Elem t [("type", str2attr "html")] [s2cont s]-t2cont t (XHtml cont) = CElem $ Elem t [("type", str2attr "xhtml")] [CElem $ Elem "div" [("xmlns", str2attr "http://www.w3.org/1999/xhtml")] cont]--cont2t :: Content -> Text-cont2t (CElem (Elem _ ats cs)) =-       case typ of-         Just t | t == "html" || t == "text/html"   -> HTML contText-                | t == "xhtml" || t == "text/xhtml" -> XHtml cont-         _                                          -> Text contText -    where typ = possibleA fromAttrToStr "type" ats-          contText = fromText' $ xUnEscape cs-          cont = stripSpaces `o` children $ head cs--zt2cont :: String -> ZonedTime -> Content-zt2cont t (ZonedTime d (TimeZone diffs _ _))-    = simpleCont t [s2cont $ formatTime defaultTimeLocale "%FT%T" d ++ zs ]-    where zs = if diffs == 0 then "Z"-               else let (zh,zm) = diffs `divMod` 60-                        (zh',zm') = if diffs < 0 && zm /= 0 -                                    then (zh+1,60-zm) else (zh,zm)-                        sig = if zh' < 0 then '-' else '+'-                    in sig : show2 zh' ++ ":" ++ show2 zm'-          show2 n | abs n < 10 = '0':show (abs n)-                  | otherwise  = show n---breaks :: Char -> String -> [String]-breaks c s = case rest of-               []     -> [s1]-               (_:s') -> s1:breaks c s'-    where (s1, rest) = break (==c) s--s2zt :: String -> ZonedTime-s2zt s = let (d, _:h') = break (=='T') s-             (h, z) = break (`elem` "+-Z") h'-             (year:mon:day:_) = breaks '-' d-             (hour:min:sec:_) = breaks ':' h-             zone = case z of-                      "Z" -> utc-                      zs@(_:_) -> -                          let (zh:zm:_) = map read $ breaks ':' zs-                          in minutesToTimeZone ((abs zh * 60 + zm) * signum zh)-                      _ -> utc-         in ZonedTime (LocalTime (fromGregorian (read year) (read mon) (read day))-                                 (TimeOfDay (read hour) (read min) (fromRational $ toRational (read sec::Double))))-                      zone--fromMany :: (XmlContent a) => [Content] -> [a]-fromMany = fst . many fromElem--fromText' :: [Content] -> String-fromText' = concat . fst . many fromText--getTags :: String -> [Content] -> [Content]-getTags s = concatMap (tag s)--getChildren :: String -> [Content] -> [[Content]]-getChildren s = dropWhile null . map (tag s /> keep)--stripSpaces :: CFilter-stripSpaces = foldXml (ifTxt (\s -> if all isSpace s then none else keep) keep)--instance XmlContent Category where-    fromElem css@(CElem (Elem "category" ats cs):rest) = -        case lookup "term" ats of-          Just v -> (Just (Category (attr2str v) s l), rest)-          Nothing -> (Nothing, css)-        where s = possibleA fromAttrToStr "scheme" ats-              l = possibleA fromAttrToStr "label" ats-    fromElem css = (Nothing, css)-    toElem c = [CElem (Elem "category" (catMaybes [t, s, l]) [])]-        where t = Just ("term", str2attr $ get term c)-              s = get scheme c >>= return . (,) "scheme" . str2attr-              l = get label c >>= return . (,) "label" . str2attr-instance XmlContent Generator where-    fromElem (CElem (Elem "generator" ats cs):rest) = -        (Just (Generator n u v), rest)-        where n = fromText' cs-              u = possibleA fromAttrToStr "uri" ats-              v = possibleA fromAttrToStr "version" ats-    fromElem cs = (Nothing, cs)-    toElem g = [CElem $ Elem "generator" (catMaybes [u, v])-                          [s2cont $ get name g]]-        where u = get uri g >>= Just . (,) "uri" . str2attr-              v = get version g >>= Just . (,) "version" . str2attr-instance XmlContent Link where-    fromElem (CElem (Elem "link" ats cs):rest) =-        (Just (Link hr r t hl ti len), rest)-        where hr = case possibleA fromAttrToStr "href" ats of-                     Nothing -> error "link requires href attribute"-                     Just v -> v-              r = maybe Alternate read $ possibleA fromAttrToStr "rel" ats-              t = possibleA fromAttrToStr "type" ats-              hl = possibleA fromAttrToStr "hreflang" ats-              ti = possibleA fromAttrToStr "title" ats-              len = fmap read $ possibleA fromAttrToStr "length" ats-    fromElem cs = (Nothing, cs)-    toElem l = [CElem $ Elem "link" (hr:r:catMaybes [t,hl,ti,len']) []]-        where hr = ("href", str2attr $ get href l)-              r = ("rel", str2attr $ show $ get rel l)-              t = get mediatype l >>= return . (,) "type" . str2attr-              hl = get hreflang l >>= return . (,) "hreflang" . str2attr-              ti = get title l >>= return . (,) "title" . str2attr-              len' = get len l >>= return . (,) "length" . str2attr . show-instance XmlContent EntryContent where-    fromElem (CElem (Elem "content" ats cs):rest) = -        case possibleA fromAttrToStr "type" ats of-          Just "text" -> (Just $ TextCont $ Text inText, rest)-          Just "html" -> (Just $ TextCont $ HTML inText, rest)-          Just "xhtml" -> (Just $ TextCont $ XHtml inHtml, rest)-          Just "text/html" -> (Just $ TextCont $ HTML inText, rest)-          Just "text/xhtml" -> (Just $ TextCont $ XHtml inHtml, rest)-          Just s | "text" `isPrefixOf` s -> -                     (Just $ TextCont $ Text inText, rest)-                 | otherwise -> case src of-                                  Just d -> (Just $ OtherSrc s d, rest)-                                  Nothing -> (Just $ BinaryData s $ b64Decode inText, rest)-        where inText = fromText' cs-              inHtml = concatMap stripSpaces $ head $ getChildren "div" $ cs-              src = possibleA fromAttrToStr "src" ats-    fromElem cs = (Nothing, cs)-    toElem (TextCont (Text s)) = [CElem $ Elem "content" [("type", str2attr "text")] [s2cont s]]-    toElem (TextCont (HTML s)) = [CElem $ Elem "content" [("type", str2attr "html")] [s2cont s]]-    toElem (TextCont (XHtml cont)) = [CElem $ Elem "content" [("type", str2attr "xhtml")] [CElem $ Elem "div" [("xmlns", str2attr "http://www.w3.org/1999/xhtml")] cont]]-    toElem (BinaryData t d) = [CElem $ Elem "content" [("type", str2attr t)] [CString False (b64Encode d)]]-    toElem (OtherSrc t d) = [CElem $ Elem "content" [ ("type", str2attr t), ("src", str2attr t)] []]-instance XmlContent Entry where-    fromElem (CElem (Elem "entry" _ cs):rest) =-        (Just $ Entry authors cats content conts ident links pubd rts src summ tit upd, rest)-        where authors = map cont2p $ getTags "author" cs-              cats = fromMany $ getTags "category" cs-              content = listToMaybe $ fromMany $ getTags "content" cs-              conts = map cont2p $ getTags "contributor" cs-              ident = fromText' $ head $ getChildren "id" cs-              links = fromMany $ getTags "link" cs-              pubd = fmap (s2zt . fromText') $ listToMaybe $ getChildren "published" cs-              rts = fmap cont2t $ listToMaybe $ getTags "rights" cs-              src = (listToMaybe $ getChildren "source" cs) >>= fst . fromElem-              summ = fmap fromText' $ listToMaybe $ getChildren "summary" cs-              tit = cont2t $ head $ getTags "title" cs-              upd = s2zt $ fromText' $ head $ getChildren "updated" cs-    fromElem rest = (Nothing, rest)-    toElem e = [CElem $ Elem "entry" [] (concat [authors, cats, contents, conts, ident, links, pubd, rts, src, summ, tit, upd])]-        where authors = map (p2cont "author") $ get author e-              cats = toElem $ get category e-              contents = toElem $ get content e-              conts = map (p2cont "contributor") $ get contributor e-              ident = [simpleCont "id" [s2cont $ get identifier e]]-              links = toElem $ get link e-              pubd = toList $ fmap (zt2cont "published") $ get published e-              rts = toList $ fmap (t2cont "rights") $ get rights e-              src = toList $ fmap (\s -> CElem (Elem "source" [] (toElem s))) $ get source e -              summ = toList $ fmap (\s -> simpleCont "summary" [s2cont s]) $ get summary e-              tit = [t2cont "title" $ get title e]-              upd = [zt2cont "updated" $ get updated e]-instance XmlContent Feed where-    fromElem (CElem (Elem "feed" _ cs):rest) = -        (Just $ Feed authors cats conts gens ic ident links lg rts subtit tit upd ents, rest)-        where authors = map cont2p $ getTags "author" cs-              cats = fromMany $ getTags "category" cs-              conts = map cont2p $ getTags "contributor" cs-              gens = fromMany $ getTags "generator" cs-              ic = fmap fromText' $ listToMaybe $ getChildren "icon" cs-              ident = fromText' $ head $ getChildren  "id" cs-              links = fromMany $ getTags "link" cs-              lg = fmap fromText' $ listToMaybe $ getChildren "logo" cs-              rts = fmap cont2t $ listToMaybe $ getTags "rights" cs-              subtit = fmap cont2t $ listToMaybe $ getTags "subtitle" cs-              tit = cont2t $ head $ getTags "title" cs-              upd = s2zt $ fromText' $ head $ getChildren "updated" cs-              ents = fromMany $ getTags "entry" cs-    fromElem rest = (Nothing, rest)-    toElem f = [CElem $ Elem "feed" [("xmlns", str2attr "http://www.w3.org/2005/Atom")] (concat [authors, cats, conts, gens, ic, ident, links, lg, rts, subtit, tit, upd, ents])]-        where authors = map (p2cont "author") $ get author f-              cats = toElem $ get category f-              conts = map (p2cont "contributor") $ get contributor f-              gens = toElem $ get generator f-              ic = toList $ fmap (\i -> simpleCont "icon" [s2cont i]) $ get icon f-              ident = [simpleCont "id" [s2cont $ get identifier f]]-              links = toElem $ get link f-              lg = toList $ fmap (\l -> simpleCont "logo" [s2cont l]) $ get logo f-              rts = toList $ fmap (t2cont "rights") $ get rights f-              subtit = toList $ fmap (t2cont "subtitle") $ get subtitle f-              tit = [t2cont "title" $ get title f]-              upd = [zt2cont "updated" $ get updated f]-              ents = toElem $ feedEntries f

@@ -1,152 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-incoherent-instances #-}-------------------------------------------------------------------------- |--- Module      :  Text.Bencode--- Copyright   :  (c) Jun Mukai 2006--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  mukai@jmuk.org--- Stability   :  experimental--- Portability :  GHC-only--- --- Bencode Parser and Serializer and type classes, for BitTorrent.--- --module Text.Bencode-    ( -- * Basic Type and Type Class-      Bencodable(..), BencodeNode(..)-    , parse, parses, encode-    )-where--import Data.Char (isDigit)-import Data.Map (Map, toList, fromList)-import qualified Data.Map as M (empty, insert, map, mapKeys, singleton)-import Data.Word-import Data.ByteString.Char8 (ByteString, pack, unpack)-import qualified Data.ByteString.Char8 as BS-import Control.Monad.Writer--class Bencodable a where-    fromBencode :: BencodeNode -> a-    toBencode :: a -> BencodeNode-    bRead :: String -> a-    bShow :: a -> String-    bRead = fromBencode . parse . pack-    bShow = unpack . encode . toBencode--instance Bencodable BencodeNode where-    fromBencode = id-    toBencode = id--instance Bencodable String where-    fromBencode (String s) = unpack s-    fromBencode _          = error "type mismatch"-    toBencode = String . pack--instance Bencodable ByteString where-    fromBencode (String s) = s-    fromBencode _          = error "type mismatch"-    toBencode = String--instance Bencodable Integer where-    fromBencode (Number n) = n-    fromBencode _          = error "type mismatch"-    toBencode = Number--instance Bencodable Int where-    fromBencode (Number n) = fromInteger n-    fromBencode _          = error "type mismatch"-    toBencode = Number . toInteger--instance (Bencodable a) => Bencodable (Map ByteString a) where-    fromBencode (Dictionary m) = M.map fromBencode m-    fromBencode _              = error "type mismatch"-    toBencode = Dictionary . M.map toBencode--instance (Bencodable a) => Bencodable [(ByteString, a)] where-    fromBencode (Dictionary m) = toList $ M.map fromBencode m-    fromBencode _              = error "type mismatch"-    toBencode = Dictionary . M.map toBencode . fromList--instance (Bencodable a) => Bencodable (Map String a) where-    fromBencode (Dictionary m) = M.mapKeys unpack $ M.map fromBencode m-    fromBencode _              = error "type mismatch"-    toBencode = Dictionary . M.map toBencode . M.mapKeys pack--instance (Bencodable a) => Bencodable [(String, a)] where-    fromBencode (Dictionary m) = toList $ M.mapKeys unpack $ M.map fromBencode m-    fromBencode _              = error "type mismatch"-    toBencode = Dictionary . M.mapKeys pack . M.map toBencode . fromList--instance (Bencodable a) => Bencodable [a] where-    fromBencode (List l) = map fromBencode l-    fromBencode _        = error "type mismatch"-    toBencode = List . map toBencode---data BencodeNode = String !ByteString -                 | Number !Integer-                 | Dictionary !(Map ByteString BencodeNode)-                 | List [BencodeNode]-                   deriving (Eq, Show)--stringP :: ByteString -> Writer [BencodeNode] ByteString-stringP s = if BS.head rest == ':' -            then Writer (s', [String v]) else error "parse error for stringP"-    where (lenStr, rest) = BS.span isDigit s-          len = read $ unpack lenStr-          rest' = BS.tail rest-          (v, s') = BS.splitAt len rest'--numberP :: ByteString -> Writer [BencodeNode] ByteString-numberP s = Writer (BS.tail rest, [Number $ read $ unpack v])-    where (v, rest) = BS.break (=='e') s-          t = BS.head rest--headIsE = (=='e') . BS.head-untilM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a-untilM c p s = if c s then return s else p s >>= untilM c p--listP :: ByteString -> Writer [BencodeNode] ByteString-listP s = fmap BS.tail $ censor f $ listP' s-    where listP' s = untilM headIsE bencodeP s-          f l = [List l]--censor' :: (Monoid w, Monoid w') => (w -> w') -> Writer w a -> Writer w' a-censor' f (Writer (a, w)) = Writer (a, f w)--dictP :: ByteString -> Writer [BencodeNode] ByteString-dictP s = fmap BS.tail $ censor' f $ dictP' s-    where dictP' s = -              untilM headIsE (\s -> censor' l2n (stringP s >>= bencodeP)) s-          l2n [String k,v] = M.singleton k v-          f m = [Dictionary m]--bencodeP :: ByteString -> Writer [BencodeNode] ByteString-bencodeP s | isDigit h = stringP s-           | h == 'i'  = numberP s'-           | h == 'l'  = listP s'-           | h == 'd'  = dictP s'-           | otherwise = error ("unidentified type specifier '"++[h]++"'")-    where s' = BS.tail s-          h = BS.head s--parse :: ByteString -> BencodeNode-parse = head . execWriter . bencodeP--parses :: ByteString -> [BencodeNode]-parses s = execWriter (parse' s)-    where parse' s = untilM BS.null bencodeP s--encode :: BencodeNode -> ByteString-encode (String s) = BS.concat [pack $ show $ BS.length s, colon, s]-encode (Number n) = BS.concat [i, pack $ show n, e]-encode (List lst) =  BS.concat (l : (map encode lst) ++ [e])-encode (Dictionary dic) =  BS.concat (d : concatMap f (toList dic) ++ [e])-    where f (k, v) = [encode $ String k, encode v]-colon = BS.singleton ':'-i = BS.singleton 'i'-l = BS.singleton 'l'-d = BS.singleton 'd'-e = BS.singleton 'e'

@@ -1,239 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-------------------------------------------------------------------------- |--- Module      :  Text.RSS--- Copyright   :  (c) Jun Mukai 2006--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  mukai@jmuk.org--- Stability   :  experimental--- Portability :  portable--- --- RSS 1.0 Printer Library (printing such like Text.HTML)--- --module Text.RSS-    ( RSSItem(..), RSSChannel(..), RSSImage(..), DublinCore(..)-    , ATitle(..), ALink(..), ADescription(..), AContent(..), ADC(..)-    , AImage(..), AItems(..), AUri(..)-    , RSSITEM(..), RSSCHANNEL(..), RSSIMAGE(..)-    , rss2Elem, rss2ElemWithAttrs, defaultAttrs, elem2rss-    , Attr, get, set, update, has, add, howMany, set', get', delete-    )-where--import Data.Char (ord)-import Data.Record-import Data.List (isPrefixOf)-import Data.Maybe-import Data.Time.Calendar (fromGregorian)-import Data.Time (formatTime)-import Data.Time.LocalTime-import System.Locale (defaultTimeLocale)-import Text.XML.HaXml-import Text.XML.HaXml.Xml2Haskell--data RSSItem = RSSItem { itemTitle :: String -                       , itemLink :: String-                       , itemDescription :: Maybe String-                       , itemContent :: Maybe String-                       , itemDC :: [DublinCore]-                       }--data RSSChannel = RSSChannel { chTitle :: String-                             , chURI :: String-                             , chLink :: String-                             , chDescription :: String-                             , chDC ::  [DublinCore]-                             , chImage :: Maybe RSSImage-                             , chItems :: [RSSItem]-                             }-data RSSImage = RSSImage { imURI :: String-                         , imTitle :: String-                         , imLink :: String-                         } --data DublinCore = DCCreator String -                | DCDate ZonedTime-                | DCSubject String--class ATitle r v | r -> v where title :: Attr r v-class ALink r v | r -> v where link :: Attr r v-class ADescription r v | r -> v where description :: Attr r v-class AContent r v | r -> v where content :: Attr r v-class ADC r v | r -> v where dc :: Attr r v-class AImage r v | r -> v where image :: Attr r v-class AItems r v | r -> v where items :: Attr r v-class AUri r v | r -> v where uri :: Attr r v--class ( ATitle r String, ALink r String, ADescription r (Maybe String)-      , AContent r (Maybe String), ADC r [DublinCore]) -    => RSSITEM r-class ( ATitle r String, AUri r String, ALink r String, ADescription r String-      , ADC r [DublinCore], AImage r (Maybe RSSImage), AItems r [RSSItem])-    => RSSCHANNEL r-class (AUri r String, ATitle r String, ALink r String) => RSSIMAGE r--instance ATitle RSSItem String where-    title = Attr itemTitle setter-        where setter r v = r { itemTitle = v }-instance ALink RSSItem String where-    link = Attr itemLink setter-        where setter r v = r { itemLink = v }-instance ADescription RSSItem (Maybe String) where-    description = Attr itemDescription setter-        where setter r v = r { itemDescription = v }-instance AContent RSSItem (Maybe String) where-    content = Attr itemContent setter-        where setter r v = r { itemContent = v }-instance ADC RSSItem [DublinCore] where-    dc = Attr itemDC setter-        where setter r v = r { itemDC = v }-instance RSSITEM RSSItem--instance ATitle RSSChannel String where-    title = Attr chTitle setter-        where setter r v = r { chTitle = v }-instance AUri RSSChannel String where-    uri = Attr chTitle setter-        where setter r v = r { chURI = v }-instance ALink RSSChannel String where-    link = Attr chLink setter-        where setter r v = r { chLink = v }-instance ADescription RSSChannel String where-    description = Attr chDescription setter-        where setter r v = r { chDescription = v }-instance ADC RSSChannel [DublinCore] where-    dc = Attr chDC setter-        where setter r v = r { chDC = v }-instance AImage RSSChannel (Maybe RSSImage) where-    image = Attr chImage setter-        where setter r v = r { chImage = v }-instance AItems RSSChannel [RSSItem] where-    items = Attr chItems setter-        where setter r v = r { chItems = v }-instance RSSCHANNEL RSSChannel--instance AUri RSSImage String where-    uri = Attr imURI setter-        where setter r v = r { imURI = v }-instance ATitle RSSImage String where-    title = Attr imTitle setter-        where setter r v = r { imTitle = v }-instance ALink RSSImage String where-    link = Attr imLink setter-        where setter r v = r { imLink = v }--fromText' :: String -> [Content] -> [String]-fromText' t = map (concat . fst . many fromText) . dropWhile null . map (tag t /> keep)-toText' :: String -> String -> Content-toText' tag cont = CElem $ Elem tag [] [CString False cont]-toText'' tag cont = CElem $ Elem tag [] [CString True cont]--instance XmlContent RSSImage where-    fromElem (CElem (Elem "image" ats cs) : rest) =-        (Just $ RSSImage u' t l, rest)-        where t = concat $ fromText' "title" cs-              l = concat $ fromText' "link" cs-              u' = concat $ fromText' "url" cs-    fromElem rest = (Nothing, rest)-    toElem (RSSImage u t l) = [CElem $ escape $ Elem "image" [about] $ zipWith toText' ["title", "link", "url"] [u, t, l]]-        where about = ("rdf:resource", str2attr u)--instance XmlContent DublinCore where-    fromElem (CElem (Elem "dc:creator" _ cs) : rest) =-        (Just $ DCCreator (concat $ fst $ many fromText cs), rest)-    fromElem (CElem (Elem "dc:subject" _ cs) : rest) =-        (Just $ DCSubject (concat $ fst $ many fromText cs), rest)-    fromElem (CElem (Elem "dc:date" _ cs) : rest) =-        (Just $ DCDate $ ZonedTime (LocalTime (fromGregorian (read year) (read mon) (read day)) (TimeOfDay (read hour) (read min) (fromRational $ toRational (read sec::Double)))) zone, rest)-        where s = concat $ fst $ many fromText cs-              (d, _:h') = break (=='T') s-              (h, z) = break (`elem` "+-Z") h'-              (year:mon:day:_) = breaks '-' d-              (hour:min:sec:_) = breaks ':' h-              zone = case z of-                       "Z" -> utc-                       zs@(_:_) -> -                           let (zh:zm:_) = map read $ breaks ':' zs-                           in minutesToTimeZone ((abs zh * 60 + zm) * signum zh)-                       _ -> utc-              breaks c d = case break (==c) d of-                             (s, "")   -> [s]-                             (s, rest) -> s : breaks c rest-    fromElem rest = (Nothing, rest)-    toElem (DCCreator c) = [toText' "dc:creator" c]-    toElem (DCSubject s) = [toText' "dc:subject" s]-    toElem (DCDate (ZonedTime d (TimeZone diffs _ _))) = [toText' "dc:date" dateStr]-      where dateStr = formatTime defaultTimeLocale "%FT%T" d ++ zs-            zs = if diffs == 0 then "Z"-                 else let (zh,zm) = diffs `divMod` 60-                          (zh',zm') = if diffs < 0 && zm /= 0 -                                      then (zh+1,60-zm) else (zh,zm)-                          sig = if zh' < 0 then '-' else '+'-                      in sig : show2 zh' ++ ":" ++ show2 zm'-            show2 n | abs n < 10 = '0':show (abs n)-                    | otherwise  = show n--instance XmlContent RSSItem where-    fromElem (CElem (Elem "item" ats cs) : rest) =-        (Just $ RSSItem t l d c dcs, rest)-        where t = concat $ fromText' "title" cs-              l = concat $ fromText' "link" cs-              d = listToMaybe $ fromText' "description" cs-              c = listToMaybe $ fromText' "content:encoded" cs-              dcs = fst $ many fromElem $ concatMap (tagWith (isPrefixOf "dc:")) cs-    fromElem rest = (Nothing, rest)-    toElem (RSSItem t l d c dcs) = [CElem $ escape $ Elem "item" [("rdf:about", str2attr l)] ([tt, lt] ++ catMaybes [dt, ct] ++ dct)]-        where tt = toText' "title" t-              lt = toText' "link" l-              dt = d >>= return . toText' "description"-              ct = c >>= return . toText'' "content:encoded"-              dct = concatMap toElem dcs--instance XmlContent RSSChannel where-    fromElem (CElem (Elem "channel" ats cs) : rest) =-        (Just $ RSSChannel t u l d dcs Nothing [], rest)-        where t = concat $ fromText' "title" cs-              u = definiteA fromAttrToStr "about" "" ats-              l = concat $ fromText' "link" cs-              d = concat $ fromText' "description" cs-              dcs = fst $ many fromElem $ concatMap (tagWith (isPrefixOf "dc:")) cs-    fromElem rest = (Nothing, rest)-    toElem (RSSChannel t u l d dcs im is) = [CElem $ escape $ Elem "channel" [("rdf:about", str2attr u)] ([tt, lt, dt, ist]++imt++dct)]-        where tt = toText' "title" t-              lt = toText' "link" l-              dt = toText' "description" d-              imt = map (\im' -> CElem $ Elem "image" [("rdf:resource", str2attr $ get link im')] []) $ maybeToList im-              ist = CElem $ Elem "items" [] -                    [CElem $ Elem "rdf:Seq" [] (map (l2li . get link) is)]-              dct = concatMap toElem dcs-              l2li l = CElem $ escape $ Elem "rdf:li" [("rdf:resource", str2attr l)] []---rss2Elem :: RSSChannel -> Element-rss2Elem = rss2ElemWithAttrs defaultAttrs-rss2ElemWithAttrs :: [(String, String)] -> RSSChannel -> Element-rss2ElemWithAttrs attrs ch = -    escape $ Elem "rdf:RDF" attrs' (toElem ch++toElem img++concatMap toElem es++toElem img)-    where img = get image ch-          es  = get items ch-          attrs' = map (\(f, v) -> (f, str2attr v)) attrs--elem2rss :: Element -> RSSChannel-elem2rss (Elem "rdf:RDF" _ cs) = ch { chItems = is, chImage = img }-    where (Just ch, cs') = fromElem cs-          is = fst $ many fromElem $ concatMap (tag "item") cs'-          img = fst $ fromElem $ concatMap (tag "image") cs'--defaultAttrs = [ ("xmlns", "http://purl.org/rss/1.0/")-               , ("xmlns:rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")-               , ("xmlns:dc", "http://purl.org/dc/elements/1.1/")-               , ("xmlns:content", "http://purl.org/rss/1.0/modules/content/")-               ] --escape = xmlEscape rssXmlEscaper--rssXmlEscaper = mkXmlEscaper [('<', "lt"),('>',"gt"),('&',"amp"),('\'',"apos"),('"',"quot")] f-    where f ch = i < 32 || i > 255 || (ch `elem` "\"&<>")-                 where i = ord ch

@@ -1,233 +0,0 @@-{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}-{-# LINE 1 "Text/URI.hsc" #-}-{-# OPTIONS -fglasgow-exts #-}-{-# LINE 2 "Text/URI.hsc" #-}-------------------------------------------------------------------------- |--- 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-               }--{-# LINE 55 "Text/URI.hsc" #-}-         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--{-# LINE 82 "Text/URI.hsc" #-}---- | 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)

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -package hsgnutls -package HaskellNet #-}+{-# OPTIONS_GHC -cpp -fglasgow-exts -package hsgnutls -package Network.HaskellNet #-} -- examples to connect server by hsgnutls  module DebugStream@@ -11,7 +11,7 @@     where  import Network-import HaskellNet.BSStream+import Network.HaskellNet.BSStream  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS

@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -cpp -fglasgow-exts -package hsgnutls -package HaskellNet #-}+-- {-# OPTIONS_GHC -cpp -fglasgow-exts -package hsgnutls -package Network.HaskellNet #-} -- examples to connect server by hsgnutls  module TLSStream@@ -11,11 +11,11 @@  import Network.GnuTLS import Network-import HaskellNet.BSStream+import Network.HaskellNet.BSStream  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Base as BSB+import qualified Data.ByteString.Internal as BSB  import System.IO @@ -54,7 +54,7 @@ extendBuf sess@(TlsSession s _ buf) =     do res <- mallocForeignPtrBytes bufLen        len <- withForeignPtr res (\p -> tlsRecv s p bufLen)-       modifyIORef buf (flip BS.append $ BSB.fromForeignPtr res len)+       modifyIORef buf (flip BS.append $ BSB.fromForeignPtr res 0 len)        return len  doWhile cond execute =

@@ -1,5 +1,5 @@ import System.IO-import HaskellNet.IMAP+import Network.HaskellNet.IMAP import Text.Mime import qualified Data.ByteString.Char8 as BS import Control.Monad

@@ -1,5 +1,5 @@ import System.IO-import HaskellNet.POP3+import Network.HaskellNet.POP3  import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Char8 as BS

@@ -1,15 +1,32 @@ import System.IO-import HaskellNet.SMTP+import Network.HaskellNet.SMTP import Text.Mime import qualified Data.ByteString.Char8 as BS+import Codec.Binary.Base64.String -smtpServer = "mysmtpserver"++smtpServer = "outmail.f2s.com" sendFrom = "test@test.org" sendTo = ["wrwills@gmail.com"] + main = do   con <- connectSMTP smtpServer-  let msg = ([("From", "HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")], BS.pack "\r\nhello from haskellnet")-  sendMail sendFrom sendTo (BS.pack $ show $ showMessage "utf-8" msg) con+  message <- BS.readFile "example/message.txt"+  messageHtml <- BS.readFile "example/message.html"+  let textP = SinglePart [("Content-Type", "text/plain; charset=utf-8")] message+  let htmlP = SinglePart [("Content-Type", "text/html; charset=utf-8")] messageHtml+  let msg = MultiPart [("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")] [htmlP, textP]+  sendMail sendFrom sendTo (BS.pack $ show $ showMime "utf-8" msg) con   closeSMTP con          +++  --let msg = ([("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")], MultiPart [] [textP, htmlP])+  --sendMail sendFrom sendTo (BS.pack $ show $ showMessage "utf-8" msg) con+--  let msg = ([("From", "Network.HaskellNet <" ++ sendFrom ++ ">"),("Subject","Test")], BS.pack "\r\nhello 算法是指完成一个任from haskellnet")++--htmlP = SinglePart [("Content-Type", "text/html; charset=utf-8", "Content-Transfer-Encoding", ""] BS.pack $ encode $  +++

@@ -0,0 +1,54 @@+--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 qualified Data.Text.Lazy as LT++--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>"  )+             [("application/pdf","/tmp/cv.pdf")]+             con+  HN.closeSMTP con+--             [("application/pdf","/tmp/cv.pdf"), ("image/jpeg", "/tmp/img.jpg")]

@@ -1,81 +0,0 @@-module Main(main) where--import Data.Maybe-import Text.Atom-import Text.XML.HaXml.Xml2Haskell-import Test.HUnit--sample1 = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n\-          \<feed xmlns=\"http://www.w3.org/2005/Atom\">\n\-          \\n\-          \  <title>Example Feed</title>\n\-          \  <link href=\"http://example.org/\"/>\n\-          \  <updated>2003-12-13T18:30:02Z</updated>\n\-          \  <author>\n\-          \    <name>John Doe</name>\n\-          \  </author>\n\-          \  <id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>\n\-          \\n\-          \  <entry>\n\-          \    <title>Atom-Powered Robots Run Amok</title>\n\-          \    <link href=\"http://example.org/2003/12/13/atom03\"/>\n\-          \    <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>\n\-          \    <updated>2003-12-13T18:30:02Z</updated>\n\-          \    <summary>Some text.</summary>\n\-          \  </entry>\n\-          \ \n\-          \</feed>\n"--sample2 = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n\-          \<feed xmlns=\"http://www.w3.org/2005/Atom\">\n\-          \  <title type=\"text\">dive into mark</title>\n\-          \  <subtitle type=\"html\">\n\-          \    A &lt;em&gt;lot&lt;/em&gt; of effort\n\-          \    went into making this effortless\n\-          \  </subtitle>\n\-          \  <updated>2005-07-31T12:29:29Z</updated>\n\-          \  <id>tag:example.org,2003:3</id>\n\-          \  <link rel=\"alternate\" type=\"text/html\"\n\-          \    hreflang=\"en\" href=\"http://example.org/\"/>\n\-          \  <link rel=\"self\" type=\"application/atom+xml\"\n\-          \    href=\"http://example.org/feed.atom\"/>\n\-          \  <rights>Copyright (c) 2003, Mark Pilgrim</rights>\n\-          \  <generator uri=\"http://www.example.com/\" version=\"1.0\">\n\-          \    Example Toolkit\n\-          \  </generator>\n\-          \  <entry>\n\-          \    <title>Atom draft-07 snapshot</title>\n\-          \    <link rel=\"alternate\" type=\"text/html\"\n\-          \      href=\"http://example.org/2005/04/02/atom\"/>\n\-          \    <link rel=\"enclosure\" type=\"audio/mpeg\" length=\"1337\"\n\-          \      href=\"http://example.org/audio/ph34r_my_podcast.mp3\"/>\n\-          \    <id>tag:example.org,2003:3.2397</id>\n\-          \    <updated>2005-07-31T12:29:29Z</updated>\n\-          \    <published>2003-12-13T08:29:29-04:00</published>\n\-          \    <author>\n\-          \      <name>Mark Pilgrim</name>\n\-          \      <uri>http://example.org/</uri>\n\-          \      <email>f8dy@example.com</email>\n\-          \    </author>\n\-          \    <contributor>\n\-          \      <name>Sam Ruby</name>\n\-          \    </contributor>\n\-          \    <contributor>\n\-          \      <name>Joe Gregorio</name>\n\-          \    </contributor>\n\-          \    <content type=\"xhtml\" xml:lang=\"en\"\n\-          \      xml:base=\"http://diveintomark.org/\">\n\-          \      <div xmlns=\"http://www.w3.org/1999/xhtml\">\n\-          \        <p><i>[Update: The Atom draft is finished.]</i></p>\n\-          \      </div>\n\-          \    </content>\n\-          \  </entry>\n\-          \</feed>\n"--feed1, feed2 :: Feed-feed1 = fromJust $ readXml sample1-feed2 = fromJust $ readXml sample2--main = runTestTT $ test [ showXml feed1 ~=? (showXml (readXml (showXml feed1) :: Maybe Feed))-                        , showXml feed2 ~=? (showXml (readXml (showXml feed2) :: Maybe Feed))-                        ]

@@ -1,174 +0,0 @@-module Main (main) where--import Text.IMAPParsers--import Test.HUnit--baseTest =-    [(OK Nothing "LOGIN Completed", MboxUpdate Nothing Nothing, ())-     ~=? eval' pNone "A001"-             "* OK [ALERT] System shutdown in 10 minutes\r\n\-             \A001 OK LOGIN Completed\r\n"-    ,(NO Nothing "COPY failed: disk is full", MboxUpdate Nothing Nothing, ())-     ~=?  eval' pNone "A223"-              "* NO Disk is 98% full, please delete unnecessary data\r\n\-              \* NO Disk is 99% full, please delete unnecessary data\r\n\-              \A223 NO COPY failed: disk is full\r\n"-    ,(OK Nothing "LOGOUT completed", MboxUpdate Nothing Nothing, ())-     ~=? eval' pNone "a006"-             "* BYE Courier-IMAP server shutting down\r\n\-             \a006 OK LOGOUT completed\r\n"-    ]--capabilityTest =-    (OK Nothing "CAPABILITY completed"-    , MboxUpdate Nothing Nothing-    , ["IMAP4rev1", "STARTTLS", "AUTH=GSSAPI", "LOGINDISABLED"])-    ~=? eval' pCapability "abcd"-            "* CAPABILITY IMAP4rev1 STARTTLS AUTH=GSSAPI LOGINDISABLED\r\n\-            \abcd OK CAPABILITY completed\r\n"--noopTest =-    ( OK Nothing "NOOP completed", MboxUpdate (Just 23) (Just 3), ())-    ~=?  eval' pNone "a047"-             "* 22 EXPUNGE\r\n\-             \* 23 EXISTS\r\n\-             \* 3 RECENT\r\n\-             \* 14 FETCH (FLAGS (\\Seen \\Deleted))\r\n\-             \a047 OK NOOP completed\r\n"--selectTest =-    [ ( OK (Just READ_WRITE) "SELECT completed"-      , MboxUpdate Nothing Nothing-      , MboxInfo "" 172 1 [Answered, Flagged, Deleted, Seen, Draft]-                     [Deleted, Seen] True True 4392 3857529045 )-      ~=? eval' pSelect "A142"-              "* 172 EXISTS\r\n\-              \* 1 RECENT\r\n\-              \* OK [UNSEEN 12] Message 12 is first unseen\r\n\-              \* OK [UIDVALIDITY 3857529045] UIDs valid\r\n\-              \* OK [UIDNEXT 4392] Predicted next UID\r\n\-              \* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n\-              \* OK [PERMANENTFLAGS (\\Deleted \\Seen \\*)] Limited\r\n\-              \A142 OK [READ-WRITE] SELECT completed\r\n"-    , (OK (Just READ_ONLY) "EXAMINE completed"-      , MboxUpdate Nothing Nothing-      , MboxInfo "" 17 2 [Answered, Flagged, Deleted, Seen, Draft]-                     [] False False 4392 3857529045 )-      ~=? eval' pSelect "A932"-              "* 17 EXISTS\r\n\-              \* 2 RECENT\r\n\-              \* OK [UNSEEN 8] Message 8 is first unseen\r\n\-              \* OK [UIDVALIDITY 3857529045] UIDs valid\r\n\-              \* OK [UIDNEXT 4392] Predicted next UID\r\n\-              \* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n\-              \* OK [PERMANENTFLAGS ()] No permanent flags permitted\r\n\-              \A932 OK [READ-ONLY] EXAMINE completed\r\n"-    ]--listTest =-    [ ( OK Nothing "LIST completed"-      , MboxUpdate Nothing Nothing-      , [([], "/", "blurdybloop")-        ,([Noselect], "/", "foo")-        ,([], "/", "foo/bar")])-      ~=? eval' pList "A682" "* LIST () \"/\" blurdybloop\r\n\-                             \* LIST (\\Noselect) \"/\" foo\r\n\-                             \* LIST () \"/\" foo/bar\r\n\-                             \A682 OK LIST completed\r\n"-    , ( OK Nothing "LSUB completed"-      , MboxUpdate Nothing Nothing-      , [([], ".", "#news.comp.mail.mime")-        ,([], ".", "#news.comp.mail.misc")])-      ~=? eval' pLsub "A002" "* LSUB () \".\" #news.comp.mail.mime\r\n\-                             \* LSUB () \".\" #news.comp.mail.misc\r\n\-                             \A002 OK LSUB completed\r\n"-    ]--statusTest =-    ( OK Nothing "STATUS completed"-                  , MboxUpdate Nothing Nothing-                  , [(MESSAGES, 231), (UIDNEXT, 44292)])-    ~=? eval' pStatus "A042"-            "* STATUS blurdybloop (MESSAGES 231 UIDNEXT 44292)\r\n\-            \A042 OK STATUS completed\r\n"--expungeTest =-    ( OK Nothing "EXPUNGE completed"-    , MboxUpdate Nothing Nothing-    , [3, 3, 5, 8])-    ~=? eval' pExpunge "A202" "* 3 EXPUNGE\r\n\-                              \* 3 EXPUNGE\r\n\-                              \* 5 EXPUNGE\r\n\-                              \* 8 EXPUNGE\r\n\-                              \A202 OK EXPUNGE completed\r\n"--searchTest =-    [ ( OK Nothing "SEARCH completed"-          , MboxUpdate Nothing Nothing-          , [2, 84, 882])-      ~=? eval' pSearch "A282" "* SEARCH 2 84 882\r\n\-                               \A282 OK SEARCH completed\r\n"-    , ( OK Nothing "SEARCH completed"-          , MboxUpdate Nothing Nothing-          , [] )-      ~=? eval' pSearch "A283" "* SEARCH\r\n\-                               \A283 OK SEARCH completed\r\n"-    ]--fetchTest =-    [ ( OK Nothing "FETCH completed"-      , MboxUpdate Nothing Nothing-      , [ (12, [("FLAGS", "(\\Seen)")-               ,("INTERNALDATE", "\"17-Jul-1996 02:44:25 -0700\"")-               ,("RFC822.SIZE", "4286")-               ,("ENVELOPE", "(\"Wed, 17 Jul 1996 02:23:25 -0700 (PDT)\" \"IMAP4rev1 WG mtg summary and minutes\" ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((NIL NIL \"imap\" \"cac.washington.edu\")) ((NIL NIL \"minutes\" \"CNRI.Reston.VA.US\") (\"John Klensin\" NIL \"KLENSIN\" \"MIT.EDU\")) NIL NIL \"<B27397-0100000@cac.washington.edu>\")")-               ,("BODY", "(\"TEXT\" \"PLAIN\" (\"CHARSET\" \"US-ASCII\") NIL NIL \"7BIT\" 3028 92)")-               ])])-      ~=? eval' pFetch "a003" "* 12 FETCH (FLAGS (\\Seen) INTERNALDATE \"17-Jul-1996 02:44:25 -0700\" RFC822.SIZE 4286 ENVELOPE (\"Wed, 17 Jul 1996 02:23:25 -0700 (PDT)\" \"IMAP4rev1 WG mtg summary and minutes\" ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((\"Terry Gray\" NIL \"gray\" \"cac.washington.edu\")) ((NIL NIL \"imap\" \"cac.washington.edu\")) ((NIL NIL \"minutes\" \"CNRI.Reston.VA.US\") (\"John Klensin\" NIL \"KLENSIN\" \"MIT.EDU\")) NIL NIL \"<B27397-0100000@cac.washington.edu>\") BODY (\"TEXT\" \"PLAIN\" (\"CHARSET\" \"US-ASCII\") NIL NIL \"7BIT\" 3028 92))\r\n\-                              \a003 OK FETCH completed\r\n"-    , ( OK Nothing "FETCH completed"-          , MboxUpdate Nothing Nothing-          , [ (12, [( "BODY[HEADER]"-                    , "Date: Wed, 17 Jul 1996 02:23:25 -0700 (PDT)\r\n\-                      \From: Terry Gray <gray@cac.washington.edu>\r\n\-                      \Subject: IMAP4rev1 WG mtg summary and minutes\r\n\-                      \To: imap@cac.washington.edu\r\n\-                      \cc: minutes@CNRI.Reston.VA.US, John Klensin <KLENSIN@MIT.EDU>\r\n\-                      \Message-Id: <B27397-0100000@cac.washington.edu>\r\n\-                      \MIME-Version: 1.0\r\n\-                      \Content-Type: TEXT/PLAIN; CHARSET=US-ASCII\r\n\-                      \\r\n" )])])-      ~=? eval' pFetch "a004"-              "* 12 FETCH (BODY[HEADER] {342}\r\n\-              \Date: Wed, 17 Jul 1996 02:23:25 -0700 (PDT)\r\n\-              \From: Terry Gray <gray@cac.washington.edu>\r\n\-              \Subject: IMAP4rev1 WG mtg summary and minutes\r\n\-              \To: imap@cac.washington.edu\r\n\-              \cc: minutes@CNRI.Reston.VA.US, John Klensin <KLENSIN@MIT.EDU>\r\n\-              \Message-Id: <B27397-0100000@cac.washington.edu>\r\n\-              \MIME-Version: 1.0\r\n\-              \Content-Type: TEXT/PLAIN; CHARSET=US-ASCII\r\n\r\n\-              \)\r\n\-              \a004 OK FETCH completed\r\n"-    , ( OK Nothing "+FLAGS completed"-          , MboxUpdate Nothing Nothing-          , [(12, [("FLAGS", "(\\Seen \\Deleted)")])])-      ~=? eval' pFetch "a005" "* 12 FETCH (FLAGS (\\Seen \\Deleted))\r\n\-                              \a005 OK +FLAGS completed\r\n"-    ]---testData = [ "base" ~: baseTest-           , "capability" ~: capabilityTest-           , "noop" ~: noopTest-           , "select" ~: selectTest-           , "list" ~: listTest-           , "status" ~: statusTest-           , "expunge" ~: expungeTest-           , "search" ~: searchTest-           , "fetch" ~: fetchTest-           ]---main = runTestTT (test testData)

@@ -1,60 +0,0 @@-module Main(main) where--import Text.RSS-import Test.HUnit-import Data.Time.Calendar-import Data.Time.LocalTime--testChannel :: RSSChannel-testChannel = RSSChannel { chTitle = "Example Channel"-                         , chLink = "http://example.com/"-                         , chDescription = "My example channel"-                         , chDC = [], chImage = Nothing }--testItems :: [RSSItem]-testItems = [ RSSItem { title = "News for September the First"-                      , link = "http://example.com/2002/09/01/"-                      , description = Just "other things happend today"-                      , content = Nothing-                      , dc = [DCDate sep1] }-            , RSSItem { title = "News for September the Second"-                      , link = "http://example.com/2002/09/02/"-                      , description = Nothing-                      , content = Nothing-                      , dc = [DCDate sep2] }-            ]-    where sep1 = ZonedTime (LocalTime (fromGregorian 2002 9 1) (TimeOfDay 0 0 0))-                           (minutesToTimeZone 0)-          sep2 = ZonedTime (LocalTime (fromGregorian 2002 9 2) (TimeOfDay 0 0 0))-                           (minutesToTimeZone 0)--testResult = -    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\-    \<rdf:RDF xmlns=\"http://purl.org/rss/1.0/\"\n\-    \         xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n\-    \         xmlns:dc=\"http://purl.org/dc/elements/1.1/\"\n\-    \         xmlns:content=\"http://purl.org/rss/1.0/modules/content/\">\n\-    \  <channel rdf:about=\"http://example.com/\">\n\-    \    <title>Example Channel</title><link>http://example.com/</link>\n\-    \    <description>My example channel</description>\n\-    \    <items>\n\-    \      <rdf:Seq>\n\-    \        <rdf:li rdf:resource=\"http://example.com/2002/09/01/\" />\n\-    \        <rdf:li rdf:resource=\"http://example.com/2002/09/02/\" />\n\-    \      </rdf:Seq>\n\-    \    </items>\n\-    \  </channel>\n\-    \  <item rdf:about=\"http://example.com/2002/09/01/\">\n\-    \    <title>News for September the First</title>\n\-    \    <link>http://example.com/2002/09/01/</link>\n\-    \    <description>other things happend today</description>\n\-    \    <dc:date>2002-09-01T00:00:00+00:00</dc:date>\n\-    \  </item>\n\-    \  <item rdf:about=\"http://example.com/2002/09/02/\">\n\-    \    <title>News for September the Second</title>\n\-    \    <link>http://example.com/2002/09/02/</link>\n\-    \    <dc:date>2002-09-02T00:00:00+00:00</dc:date>\n\-    \  </item>\n\-    \</rdf:RDF>"--main = runTestTT $ test $ renderRSS testChannel testItems ~=? testResult