diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -4,7 +4,7 @@ SMTP, and IMAP protocols. NOTE: this package will be split into smaller, protocol-specific packages in the future. -Version: 0.3 +Version: 0.3.1 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Jonathan Daugherty @@ -24,6 +24,12 @@ type: git location: git://github.com/jtdaugherty/HaskellNet.git +Source-Repository this + type: git + location: git://github.com/shapr/HaskellNet.git + tag: nonmaintainerupload + + Library Hs-Source-Dirs: src GHC-Options: -Wall -fno-warn-unused-do-bind @@ -47,7 +53,6 @@ Build-Depends: base >= 4 && < 5, - haskell98, network, mtl, bytestring, @@ -56,5 +61,5 @@ Crypto > 4.2.1, base64-string, old-time, - mime-mail >= 0.3.0 && < 0.4, + mime-mail >= 0.4, text diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,3 +17,6 @@ :set -fbreak-on-exception :trace main + + +(The source for the 0.3.1 non-maintainer upload can be found at https://github.com/shapr/HaskellNet) diff --git a/src/Network/HaskellNet/BSStream.hs b/src/Network/HaskellNet/BSStream.hs --- a/src/Network/HaskellNet/BSStream.hs +++ b/src/Network/HaskellNet/BSStream.hs @@ -1,6 +1,9 @@ --- |A library for abstracting sockets suitable to Streams. +-- |This module provides a byte string \"stream\" interface. This +-- interface provides some common operations on a value which +-- supports reading and writing byte strings. module Network.HaskellNet.BSStream ( BSStream(..) + , handleToStream ) where @@ -8,34 +11,34 @@ import qualified Data.ByteString.Char8 as BS import System.IO -class BSStream h where - bsGetLine :: h -> IO ByteString - bsGet :: h -> Int -> IO ByteString - bsPut :: h -> ByteString -> IO () - bsPuts :: h -> [ByteString] -> IO () - bsPutStrLn :: h -> ByteString -> IO () - bsPutCrLf :: h -> ByteString -> IO () - bsPutNoFlush :: h -> ByteString -> IO () - bsFlush :: h -> IO () - bsClose :: h -> IO () - bsIsOpen :: h -> IO Bool - - bsPuts h strs = mapM_ (bsPut h) strs - bsPutCrLf h s = bsPut h s >> bsPut h crlf - bsPutStrLn h s = bsPut h s >> bsPut h lf - -lf, crlf :: BS.ByteString -lf = BS.singleton '\n' -crlf = BS.pack "\r\n" +-- |A byte string stream. +data BSStream = + BSStream { bsGetLine :: IO ByteString + -- ^Read a line from the stream. Should return the line + -- which was read, including the newline. + , bsGet :: Int -> IO ByteString + -- ^Read the specified number of bytes from the stream. + -- Should block until the requested bytes can be read. + , bsPut :: ByteString -> IO () + -- ^Write the specified byte string to the stream. + -- Should flush the stream after writing. + , bsFlush :: IO () + -- ^Flush the stream. + , bsClose :: IO () + -- ^Close the stream. + , bsIsOpen :: IO Bool + -- ^Is the stream open? + } -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 +-- |Build a byte string stream which operates on a 'Handle'. +handleToStream :: Handle -> BSStream +handleToStream h = + BSStream { bsGetLine = BS.hGetLine h + , bsGet = BS.hGet h + , bsPut = \s -> BS.hPut h s >> hFlush h + , bsFlush = hFlush h + , bsClose = do + op <- hIsOpen h + if op then (hClose h) else return () + , bsIsOpen = hIsOpen h + } diff --git a/src/Network/HaskellNet/Debug.hs b/src/Network/HaskellNet/Debug.hs --- a/src/Network/HaskellNet/Debug.hs +++ b/src/Network/HaskellNet/Debug.hs @@ -1,81 +1,44 @@ module Network.HaskellNet.Debug - ( connectD - , connectDPort - , DebugStream - , withDebug + ( debugStream ) where -import Network import Network.HaskellNet.BSStream import qualified Data.ByteString.Char8 as BS import System.IO -newtype (BSStream s) => DebugStream s = DS s - -withDebug :: BSStream s => s -> DebugStream s -withDebug = DS - -connectD :: HostName -> PortNumber -> IO (DebugStream Handle) -connectD host port = connectDPort host (PortNumber port) +debugStream :: BSStream -> BSStream +debugStream inner = + inner { bsGetLine = debugBsGetLine inner + , bsGet = debugBsGet inner + , bsPut = debugBsPut inner + } -connectDPort :: HostName -> PortID -> IO (DebugStream Handle) -connectDPort host port = - do h <- connectTo host port - hPutStrLn stderr "connected" - return $ DS h +debugBsGetLine :: BSStream -> IO BS.ByteString +debugBsGetLine s = do + hPutStr stderr "reading with bsGetLine..." + hFlush stderr + l <- bsGetLine s + BS.hPutStrLn stderr l + return l +debugBsGet :: BSStream -> Int -> IO BS.ByteString +debugBsGet s len = do + hPutStr stderr $ "reading with bsGet "++show len++"..." + hFlush stderr + chunk <- bsGet s len + BS.hPutStrLn stderr chunk + return chunk -instance (BSStream s) => BSStream (DebugStream s) where - bsGetLine (DS h) = - do hPutStr stderr "reading with bsGetLine..." - hFlush stderr - l <- bsGetLine h - BS.hPutStrLn stderr l - return l - bsGet (DS h) len = - do hPutStr stderr $ "reading with bsGet "++show len++"..." - hFlush stderr - chunk <- bsGet h len - BS.hPutStrLn stderr chunk - return chunk - bsPut (DS h) s = - do hPutStr stderr "putting with bsPut (" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPut h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutStrLn (DS h) s = - do hPutStr stderr "putting with bsPutStrLn(" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPutStrLn h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutCrLf (DS h) s = - do hPutStr stderr "putting with bsPutCrLf(" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPutCrLf h s - bsFlush h - hPutStrLn stderr "done" - return () - bsPutNoFlush (DS h) s = - do hPutStr stderr "putting with bsPutNoFlush (" - BS.hPutStrLn stderr s - hPutStr stderr (")...") - hFlush stderr - bsPut h s - hPutStrLn stderr "done" - return () - bsFlush (DS h) = bsFlush h - bsClose (DS h) = bsClose h - bsIsOpen (DS h) = bsIsOpen h +debugBsPut :: BSStream -> BS.ByteString -> IO () +debugBsPut s str = do + hPutStr stderr "putting with bsPut (" + BS.hPutStrLn stderr str + hPutStr stderr (")...") + hFlush stderr + bsPut s str + bsFlush s + hPutStrLn stderr "done" + return () diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -34,7 +34,6 @@ import Control.Applicative ((<$>)) import Control.Monad -import System.IO import System.Time import Data.Maybe @@ -113,14 +112,15 @@ ---------------------------------------------------------------------- -- establish connection -connectIMAPPort :: String -> PortNumber -> IO (IMAPConnection Handle) +connectIMAPPort :: String -> PortNumber -> IO IMAPConnection connectIMAPPort hostname port = - connectTo hostname (PortNumber port) >>= connectStream + handleToStream <$> connectTo hostname (PortNumber port) + >>= connectStream -connectIMAP :: String -> IO (IMAPConnection Handle) +connectIMAP :: String -> IO IMAPConnection connectIMAP hostname = connectIMAPPort hostname 143 -connectStream :: BSStream s => s -> IO (IMAPConnection s) +connectStream :: BSStream -> IO IMAPConnection connectStream s = do msg <- bsGetLine s unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ @@ -129,13 +129,14 @@ ---------------------------------------------------------------------- -- normal send commands -sendCommand' :: (BSStream s) => IMAPConnection s -> String -> IO (ByteString, Int) +sendCommand' :: IMAPConnection -> String -> IO (ByteString, Int) sendCommand' c cmdstr = do - (_, num) <- withNextCommandNum c $ \num -> bsPutCrLf c $ BS.pack $ show6 num ++ " " ++ cmdstr - resp <- getResponse c + (_, num) <- withNextCommandNum c $ \num -> bsPutCrLf (stream c) $ + BS.pack $ show6 num ++ " " ++ cmdstr + resp <- getResponse (stream c) return (resp, num) -show6 :: (Ord a, Num a) => a -> String +show6 :: (Ord a, Num a, Show a) => a -> String show6 n | n > 100000 = show n | n > 10000 = '0' : show n | n > 1000 = "00" ++ show n @@ -143,7 +144,7 @@ | n > 10 = "0000" ++ show n | otherwise = "00000" ++ show n -sendCommand :: BSStream s => IMAPConnection s -> String +sendCommand :: IMAPConnection -> String -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) -> IO v sendCommand imapc cmdstr pFunc = @@ -156,7 +157,7 @@ BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) -getResponse :: BSStream s => s -> IO ByteString +getResponse :: BSStream -> IO ByteString getResponse s = unlinesCRLF <$> getLs where unlinesCRLF = BS.concat . concatMap (:[crlfStr]) getLs = @@ -180,7 +181,7 @@ getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' ' -mboxUpdate :: (BSStream s) => IMAPConnection s -> MboxUpdate -> IO () +mboxUpdate :: IMAPConnection -> MboxUpdate -> IO () mboxUpdate conn (MboxUpdate exists' recent') = do when (isJust exists') $ modifyMailboxInfo conn $ \mbox -> mbox { _exists = fromJust exists' } @@ -192,28 +193,28 @@ -- IMAP commands -- -noop :: BSStream s => IMAPConnection s -> IO () +noop :: IMAPConnection -> IO () noop conn = sendCommand conn "NOOP" pNone -capability :: BSStream s => IMAPConnection s -> IO [String] +capability :: IMAPConnection -> IO [String] capability conn = sendCommand conn "CAPABILITY" pCapability -logout :: (BSStream s) => IMAPConnection s -> IO () -logout c = do bsPutCrLf c $ BS.pack "a0001 LOGOUT" - bsClose c +logout :: IMAPConnection -> IO () +logout c = do bsPutCrLf (stream c) $ BS.pack "a0001 LOGOUT" + bsClose (stream c) -login :: BSStream s => IMAPConnection s -> A.UserName -> A.Password -> IO () +login :: IMAPConnection -> A.UserName -> A.Password -> IO () login conn username password = sendCommand conn ("LOGIN " ++ username ++ " " ++ password) pNone -authenticate :: (BSStream s) => IMAPConnection s -> A.AuthType +authenticate :: IMAPConnection -> A.AuthType -> A.UserName -> A.Password -> IO () authenticate conn A.LOGIN username password = do (_, num) <- sendCommand' conn "AUTHENTICATE LOGIN" - bsPutCrLf conn $ BS.pack userB64 - bsGetLine conn - bsPutCrLf conn $ BS.pack passB64 - buf <- getResponse conn + bsPutCrLf (stream conn) $ BS.pack userB64 + bsGetLine (stream conn) + bsPutCrLf (stream conn) $ BS.pack passB64 + buf <- getResponse $ stream conn let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of OK _ _ -> do mboxUpdate conn $ mboxUp @@ -229,8 +230,9 @@ then A.b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c else "" - bsPutCrLf conn $ BS.pack $ A.auth at challenge username password - buf <- getResponse conn + bsPutCrLf (stream conn) $ BS.pack $ + A.auth at challenge username password + buf <- getResponse $ stream conn let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of OK _ _ -> do mboxUpdate conn $ mboxUp @@ -239,57 +241,57 @@ BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) -_select :: (BSStream s) => String -> IMAPConnection s -> String -> IO () +_select :: String -> IMAPConnection -> String -> IO () _select cmd conn mboxName = do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect setMailboxInfo conn $ mbox' { _mailbox = mboxName } -select :: BSStream s => IMAPConnection s -> MailboxName -> IO () +select :: IMAPConnection -> MailboxName -> IO () select = _select "SELECT " -examine :: BSStream s => IMAPConnection s -> MailboxName -> IO () +examine :: IMAPConnection -> MailboxName -> IO () examine = _select "EXAMINE " -create :: BSStream s => IMAPConnection s -> MailboxName -> IO () +create :: IMAPConnection -> MailboxName -> IO () create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone -delete :: BSStream s => IMAPConnection s -> MailboxName -> IO () +delete :: IMAPConnection -> MailboxName -> IO () delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone -rename :: BSStream s => IMAPConnection s -> MailboxName -> MailboxName -> IO () +rename :: IMAPConnection -> MailboxName -> MailboxName -> IO () rename conn mboxorg mboxnew = sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone -subscribe :: BSStream s => IMAPConnection s -> MailboxName -> IO () +subscribe :: IMAPConnection -> MailboxName -> IO () subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone -unsubscribe :: BSStream s => IMAPConnection s -> MailboxName -> IO () +unsubscribe :: IMAPConnection -> MailboxName -> IO () unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone -list :: BSStream s => IMAPConnection s -> IO [([Attribute], MailboxName)] +list :: IMAPConnection -> IO [([Attribute], MailboxName)] list conn = (map (\(a, _, m) -> (a, m))) <$> listFull conn "\"\"" "*" -lsub :: BSStream s => IMAPConnection s -> IO [([Attribute], MailboxName)] +lsub :: IMAPConnection -> IO [([Attribute], MailboxName)] lsub conn = (map (\(a, _, m) -> (a, m))) <$> lsubFull conn "\"\"" "*" -listFull :: BSStream s => IMAPConnection s -> String -> String +listFull :: IMAPConnection -> String -> String -> IO [([Attribute], String, MailboxName)] listFull conn ref pat = sendCommand conn (unwords ["LIST", ref, pat]) pList -lsubFull :: BSStream s => IMAPConnection s -> String -> String +lsubFull :: IMAPConnection -> String -> String -> IO [([Attribute], String, MailboxName)] lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub -status :: BSStream s => IMAPConnection s -> MailboxName -> [MailboxStatus] +status :: IMAPConnection -> MailboxName -> [MailboxStatus] -> IO [(MailboxStatus, Integer)] status conn mbox stats = let cmd = "STATUS " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")" in sendCommand conn cmd pStatus -append :: BSStream s => IMAPConnection s -> MailboxName -> ByteString -> IO () +append :: IMAPConnection -> MailboxName -> ByteString -> IO () append conn mbox mailData = appendFull conn mbox mailData [] Nothing -appendFull :: BSStream s => IMAPConnection s -> MailboxName -> ByteString +appendFull :: IMAPConnection -> MailboxName -> ByteString -> [Flag] -> Maybe CalendarTime -> IO () appendFull conn mbox mailData flags' time = do (buf, num) <- sendCommand' conn @@ -297,8 +299,8 @@ , fstr, tstr, "{" ++ show len ++ "}"]) unless (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response" - mapM_ (bsPutCrLf conn) mailLines - buf2 <- getResponse conn + mapM_ (bsPutCrLf $ stream conn) mailLines + buf2 <- getResponse $ stream conn let (resp, mboxUp, ()) = eval pNone (show6 num) buf2 case resp of OK _ _ -> mboxUpdate conn mboxUp @@ -310,21 +312,21 @@ tstr = maybe "" show time fstr = unwords $ map show flags' -check :: BSStream s => IMAPConnection s -> IO () +check :: IMAPConnection -> IO () check conn = sendCommand conn "CHECK" pNone -close :: BSStream s => IMAPConnection s -> IO () +close :: IMAPConnection -> IO () close conn = do sendCommand conn "CLOSE" pNone setMailboxInfo conn emptyMboxInfo -expunge :: BSStream s => IMAPConnection s -> IO [Integer] +expunge :: IMAPConnection -> IO [Integer] expunge conn = sendCommand conn "EXPUNGE" pExpunge -search :: BSStream s => IMAPConnection s -> [SearchQuery] -> IO [UID] +search :: IMAPConnection -> [SearchQuery] -> IO [UID] search conn queries = searchCharset conn "" queries -searchCharset :: BSStream s => IMAPConnection s -> Charset -> [SearchQuery] +searchCharset :: IMAPConnection -> Charset -> [SearchQuery] -> IO [UID] searchCharset conn charset queries = sendCommand conn ("UID SEARCH " @@ -333,67 +335,67 @@ else "") ++ unwords (map show queries)) pSearch -fetch :: BSStream s => IMAPConnection s -> UID -> IO ByteString +fetch :: IMAPConnection -> UID -> IO ByteString fetch conn uid = do lst <- fetchByString conn uid "BODY[]" return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst -fetchHeader :: BSStream s => IMAPConnection s -> UID -> IO ByteString +fetchHeader :: IMAPConnection -> UID -> IO ByteString fetchHeader conn uid = do lst <- fetchByString conn uid "BODY[HEADER]" return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst -fetchSize :: BSStream s => IMAPConnection s -> UID -> IO Int +fetchSize :: IMAPConnection -> UID -> IO Int fetchSize conn uid = do lst <- fetchByString conn uid "RFC822.SIZE" return $ maybe 0 read $ lookup "RFC822.SIZE" lst -fetchHeaderFields :: BSStream s => IMAPConnection s +fetchHeaderFields :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFields conn uid hs = do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]") return $ maybe BS.empty BS.pack $ lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst -fetchHeaderFieldsNot :: BSStream s => IMAPConnection s +fetchHeaderFieldsNot :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFieldsNot conn uid hs = do let fetchCmd = "BODY[HEADER.FIELDS.NOT "++unwords hs++"]" lst <- fetchByString conn uid fetchCmd return $ maybe BS.empty BS.pack $ lookup fetchCmd lst -fetchFlags :: BSStream s => IMAPConnection s -> UID -> IO [Flag] +fetchFlags :: IMAPConnection -> 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) +fetchR :: IMAPConnection -> (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 +fetchByString :: IMAPConnection -> 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 +fetchByStringR :: IMAPConnection -> (UID, UID) -> String -> IO [(UID, [(String, String)])] fetchByStringR conn (s, e) command = fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc where proc (n, ps) = (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps) -fetchCommand :: (BSStream s) => IMAPConnection s -> String +fetchCommand :: IMAPConnection -> String -> ((Integer, [(String, String)]) -> b) -> IO [b] fetchCommand conn command proc = (map proc) <$> sendCommand conn command pFetch -storeFull :: BSStream s => IMAPConnection s -> String -> FlagsQuery -> Bool +storeFull :: IMAPConnection -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])] storeFull conn uidstr query isSilent = fetchCommand conn ("UID STORE " ++ uidstr ++ flgs query) procStore @@ -408,14 +410,14 @@ ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps)) -store :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO () -store conn i q = storeFull conn (show i) q True >> return () +store :: IMAPConnection -> UID -> FlagsQuery -> IO () +store conn i q = storeFull conn (show i) q True >> return () -copyFull :: (BSStream s) => IMAPConnection s -> String -> String -> IO () +copyFull :: IMAPConnection -> String -> String -> IO () copyFull conn uidStr mbox = sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ mbox) pNone -copy :: BSStream s => IMAPConnection s -> UID -> MailboxName -> IO () +copy :: IMAPConnection -> UID -> MailboxName -> IO () copy conn uid mbox = copyFull conn (show uid) mbox ---------------------------------------------------------------------- @@ -442,3 +444,9 @@ strip :: ByteString -> ByteString strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace + +crlf :: BS.ByteString +crlf = BS.pack "\r\n" + +bsPutCrLf :: BSStream -> ByteString -> IO () +bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h diff --git a/src/Network/HaskellNet/IMAP/Connection.hs b/src/Network/HaskellNet/IMAP/Connection.hs --- a/src/Network/HaskellNet/IMAP/Connection.hs +++ b/src/Network/HaskellNet/IMAP/Connection.hs @@ -38,56 +38,46 @@ , UID ) -data BSStream s => IMAPConnection s = - IMAPC { stream :: s +data IMAPConnection = + IMAPC { stream :: BSStream , mboxInfo :: IORef MailboxInfo , nextCommandNum :: IORef Int } -instance BSStream s => BSStream (IMAPConnection s) where - bsGetLine = bsGetLine . stream - bsGet = bsGet . stream - bsPut h s = bsPut (stream h) s - bsPutStrLn h s = bsPutStrLn (stream h) s - bsPutNoFlush = bsPutNoFlush . stream - bsFlush = bsFlush . stream - bsClose = bsClose . stream - bsIsOpen = bsIsOpen . stream - -newConnection :: (BSStream s) => s -> IO (IMAPConnection s) +newConnection :: BSStream -> IO IMAPConnection newConnection s = IMAPC s <$> (newIORef emptyMboxInfo) <*> (newIORef 0) -getMailboxInfo :: (BSStream s) => IMAPConnection s -> IO MailboxInfo +getMailboxInfo :: IMAPConnection -> IO MailboxInfo getMailboxInfo c = readIORef $ mboxInfo c -mailbox :: (BSStream s) => IMAPConnection s -> IO MailboxName +mailbox :: IMAPConnection -> IO MailboxName mailbox c = _mailbox <$> getMailboxInfo c -exists :: (BSStream s) => IMAPConnection s -> IO Integer +exists :: IMAPConnection -> IO Integer exists c = _exists <$> getMailboxInfo c -recent :: (BSStream s) => IMAPConnection s -> IO Integer +recent :: IMAPConnection -> IO Integer recent c = _recent <$> getMailboxInfo c -flags :: (BSStream s) => IMAPConnection s -> IO [Flag] +flags :: IMAPConnection -> IO [Flag] flags c = _flags <$> getMailboxInfo c -permanentFlags :: (BSStream s) => IMAPConnection s -> IO [Flag] +permanentFlags :: IMAPConnection -> IO [Flag] permanentFlags c = _permanentFlags <$> getMailboxInfo c -isWritable :: (BSStream s) => IMAPConnection s -> IO Bool +isWritable :: IMAPConnection -> IO Bool isWritable c = _isWritable <$> getMailboxInfo c -isFlagWritable :: (BSStream s) => IMAPConnection s -> IO Bool +isFlagWritable :: IMAPConnection -> IO Bool isFlagWritable c = _isFlagWritable <$> getMailboxInfo c -uidNext :: (BSStream s) => IMAPConnection s -> IO UID +uidNext :: IMAPConnection -> IO UID uidNext c = _uidNext <$> getMailboxInfo c -uidValidity :: (BSStream s) => IMAPConnection s -> IO UID +uidValidity :: IMAPConnection -> IO UID uidValidity c = _uidValidity <$> getMailboxInfo c -withNextCommandNum :: (BSStream s) => IMAPConnection s -> (Int -> IO a) -> IO (a, Int) +withNextCommandNum :: IMAPConnection -> (Int -> IO a) -> IO (a, Int) withNextCommandNum c act = do let ref = nextCommandNum c num <- readIORef ref @@ -95,8 +85,8 @@ modifyIORef ref (+1) return (result, num) -setMailboxInfo :: (BSStream s) => IMAPConnection s -> MailboxInfo -> IO () +setMailboxInfo :: IMAPConnection -> MailboxInfo -> IO () setMailboxInfo c = writeIORef (mboxInfo c) -modifyMailboxInfo :: (BSStream s) => IMAPConnection s -> (MailboxInfo -> MailboxInfo) -> IO () +modifyMailboxInfo :: IMAPConnection -> (MailboxInfo -> MailboxInfo) -> IO () modifyMailboxInfo c f = modifyIORef (mboxInfo c) f diff --git a/src/Network/HaskellNet/POP3.hs b/src/Network/HaskellNet/POP3.hs --- a/src/Network/HaskellNet/POP3.hs +++ b/src/Network/HaskellNet/POP3.hs @@ -30,7 +30,6 @@ import Network.HaskellNet.BSStream import Network -import Network.HaskellNet.Auth hiding (auth, login) import qualified Network.HaskellNet.Auth as A import Data.ByteString (ByteString) @@ -66,17 +65,18 @@ -- | connecting to the pop3 server specified by the hostname and port -- number -connectPop3Port :: String -> PortNumber -> IO (POP3Connection Handle) +connectPop3Port :: String -> PortNumber -> IO POP3Connection connectPop3Port hostname port = - connectTo hostname (PortNumber port) >>= connectStream + handleToStream <$> (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 :: String -> IO POP3Connection connectPop3 = flip connectPop3Port 110 -- | connecting to the pop3 server via a stream -connectStream :: BSStream s => s -> IO (POP3Connection s) +connectStream :: BSStream -> IO POP3Connection connectStream st = do (resp, msg) <- response st when (resp == Err) $ fail "cannot connect" @@ -85,7 +85,7 @@ then return $ newConnection st (BS.unpack code) else return $ newConnection st "" -response :: BSStream s => s -> IO (Response, ByteString) +response :: BSStream -> IO (Response, ByteString) response st = do reply <- strip <$> bsGetLine st if (BS.pack "+OK") `BS.isPrefixOf` reply @@ -93,51 +93,51 @@ else return (Err, BS.drop 5 reply) -- | parse mutiline of response -responseML :: BSStream s => s -> IO (Response, ByteString) -responseML st = +responseML :: POP3Connection -> IO (Response, ByteString) +responseML conn = do reply <- strip <$> bsGetLine st if (BS.pack "+OK") `BS.isPrefixOf` reply then do rest <- getRest return (Ok, BS.unlines (BS.drop 4 reply : rest)) else return (Err, BS.drop 5 reply) - where getRest = do l <- strip <$> bsGetLine st + where st = stream conn + getRest = do l <- strip <$> bsGetLine st if l == BS.singleton '.' then return [] else (l:) <$> getRest -- | sendCommand sends a pop3 command via a pop3 connection. This -- action is too generic. Use more specific actions -sendCommand :: BSStream s => POP3Connection s -> Command - -> IO (Response, ByteString) +sendCommand :: POP3Connection -> Command -> IO (Response, ByteString) sendCommand conn (LIST Nothing) = - bsPutCrLf conn (BS.pack "LIST") >> responseML conn + bsPutCrLf (stream conn) (BS.pack "LIST") >> responseML conn sendCommand conn (UIDL Nothing) = - bsPutCrLf conn (BS.pack "UIDL") >> responseML conn + bsPutCrLf (stream conn) (BS.pack "UIDL") >> responseML conn sendCommand conn (RETR msg) = - bsPutCrLf conn (BS.pack $ "RETR " ++ show msg) >> responseML conn + bsPutCrLf (stream conn) (BS.pack $ "RETR " ++ show msg) >> responseML conn sendCommand conn (TOP msg n) = - bsPutCrLf conn (BS.pack $ "TOP " ++ show msg ++ " " ++ show n) >> + bsPutCrLf (stream conn) (BS.pack $ "TOP " ++ show msg ++ " " ++ show n) >> responseML conn -sendCommand conn (AUTH LOGIN username password) = - do bsPutCrLf conn $ BS.pack "AUTH LOGIN" - bsGetLine conn - bsPutCrLf conn $ BS.pack userB64 - bsGetLine conn - bsPutCrLf conn $ BS.pack passB64 - response conn +sendCommand conn (AUTH A.LOGIN username password) = + do bsPutCrLf (stream conn) $ BS.pack "AUTH LOGIN" + bsGetLine (stream conn) + bsPutCrLf (stream conn) $ BS.pack userB64 + bsGetLine (stream conn) + bsPutCrLf (stream conn) $ BS.pack passB64 + response (stream conn) where (userB64, passB64) = A.login username password sendCommand conn (AUTH at username password) = - do bsPutCrLf conn $ BS.pack $ unwords ["AUTH", show at] - c <- bsGetLine conn + do bsPutCrLf (stream conn) $ BS.pack $ unwords ["AUTH", show at] + c <- bsGetLine (stream conn) let challenge = if BS.take 2 c == BS.pack "+ " - then b64Decode $ BS.unpack $ head $ + then A.b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c else "" - bsPutCrLf conn $ BS.pack $ A.auth at challenge username password - response conn + bsPutCrLf (stream conn) $ BS.pack $ A.auth at challenge username password + response (stream conn) sendCommand conn command = - bsPutCrLf conn (BS.pack commandStr) >> response conn + bsPutCrLf (stream conn) (BS.pack commandStr) >> response (stream conn) where commandStr = case command of (USER name) -> "USER " ++ name (PASS passw) -> "PASS " ++ passw @@ -154,86 +154,92 @@ (RETR _) -> error "BUG: RETR should not get matched here" (TOP _ _) -> error "BUG: TOP should not get matched here" -user :: BSStream s => POP3Connection s -> String -> IO () +user :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> A.UserName -> A.Password -> IO () userPass conn name pwd = user conn name >> pass conn pwd -auth :: BSStream s => POP3Connection s -> AuthType -> UserName -> Password +auth :: POP3Connection -> A.AuthType -> A.UserName -> A.Password -> IO () auth conn at username password = do (resp, msg) <- sendCommand conn (AUTH at username password) unless (resp == Ok) $ fail $ "authentication failed: " ++ BS.unpack msg -apop :: BSStream s => POP3Connection s -> String -> String -> IO () +apop :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> IO () rset conn = do (resp, _) <- sendCommand conn RSET when (resp == Err) $ fail "cannot reset" -allList :: BSStream s => POP3Connection s -> IO [(Int, Int)] +allList :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> 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 :: POP3Connection -> IO () closePop3 c = do sendCommand c QUIT - bsClose c + bsClose (stream c) -doPop3Port :: String -> PortNumber -> (POP3Connection Handle -> IO a) -> IO a +doPop3Port :: String -> PortNumber -> (POP3Connection -> IO a) -> IO a doPop3Port host port execution = bracket (connectPop3Port host port) closePop3 execution -doPop3 :: String -> (POP3Connection Handle -> IO a) -> IO a +doPop3 :: String -> (POP3Connection -> IO a) -> IO a doPop3 host execution = doPop3Port host 110 execution -doPop3Stream :: BSStream s => s -> (POP3Connection s -> IO b) -> IO b +doPop3Stream :: BSStream -> (POP3Connection -> IO b) -> IO b doPop3Stream conn execution = bracket (connectStream conn) closePop3 execution + +crlf :: BS.ByteString +crlf = BS.pack "\r\n" + +bsPutCrLf :: BSStream -> ByteString -> IO () +bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h diff --git a/src/Network/HaskellNet/POP3/Connection.hs b/src/Network/HaskellNet/POP3/Connection.hs --- a/src/Network/HaskellNet/POP3/Connection.hs +++ b/src/Network/HaskellNet/POP3/Connection.hs @@ -1,5 +1,6 @@ module Network.HaskellNet.POP3.Connection ( POP3Connection + , stream , newConnection , apopKey ) @@ -7,20 +8,10 @@ import Network.HaskellNet.BSStream -data BSStream s => POP3Connection s = - POP3C { stream :: !s +data POP3Connection = + POP3C { stream :: !BSStream , apopKey :: !String -- ^ APOP key } -newConnection :: BSStream s => s -> String -> POP3Connection s +newConnection :: BSStream -> String -> POP3Connection newConnection = POP3C - -instance BSStream s => BSStream (POP3Connection s) where - bsGetLine = bsGetLine . stream - bsGet = bsGet . stream - bsPut h s = bsPut (stream h) s - bsPutStrLn h s = bsPutStrLn (stream h) s - bsPutNoFlush = bsPutNoFlush . stream - bsFlush = bsFlush . stream - bsClose = bsClose . stream - bsIsOpen = bsIsOpen . stream diff --git a/src/Network/HaskellNet/SMTP.hs b/src/Network/HaskellNet/SMTP.hs --- a/src/Network/HaskellNet/SMTP.hs +++ b/src/Network/HaskellNet/SMTP.hs @@ -26,6 +26,7 @@ import Network.BSD (getHostName) import Network +import Control.Applicative ((<$>)) import Control.Exception import Control.Monad (unless) @@ -44,7 +45,7 @@ import Prelude hiding (catch) -data (BSStream s) => SMTPConnection s = SMTPC !s ![ByteString] +data SMTPConnection = SMTPC !BSStream ![ByteString] data Command = HELO String | EHLO String @@ -89,16 +90,17 @@ -- | connecting SMTP server with the specified name and port number. connectSMTPPort :: String -- ^ name of the server -> PortNumber -- ^ port number - -> IO (SMTPConnection Handle) + -> IO SMTPConnection connectSMTPPort hostname port = - connectTo hostname (PortNumber port) >>= connectStream + (handleToStream <$> connectTo hostname (PortNumber port)) + >>= connectStream -- | connecting SMTP server with the specified name and port 25. connectSMTP :: String -- ^ name of the server - -> IO (SMTPConnection Handle) + -> IO SMTPConnection connectSMTP = flip connectSMTPPort 25 -tryCommand :: BSStream s => s -> Command -> Int -> ReplyCode +tryCommand :: BSStream -> Command -> Int -> ReplyCode -> IO ByteString tryCommand st cmd tries expectedReply | tries <= 0 = do bsClose st @@ -111,7 +113,7 @@ tryCommand st cmd (tries - 1) expectedReply -- | create SMTPConnection from already connected Stream -connectStream :: BSStream s => s -> IO (SMTPConnection s) +connectStream :: BSStream -> IO SMTPConnection connectStream st = do (code1, _) <- parseResponse st unless (code1 == 220) $ @@ -121,7 +123,7 @@ msg <- tryCommand st (EHLO senderHost) 3 250 return (SMTPC st (tail $ BS.lines msg)) -parseResponse :: BSStream s => s -> IO (ReplyCode, ByteString) +parseResponse :: BSStream -> IO (ReplyCode, ByteString) parseResponse st = do (code, bdy) <- readLines return (read $ BS.unpack code, BS.unlines bdy) @@ -135,8 +137,7 @@ -- | send a method to a server -sendCommand :: BSStream s => SMTPConnection s -> Command - -> IO (ReplyCode, ByteString) +sendCommand :: SMTPConnection -> Command -> IO (ReplyCode, ByteString) sendCommand (SMTPC conn _) (DATA dat) = do bsPutCrLf conn $ BS.pack "DATA" (code, _) <- parseResponse conn @@ -183,7 +184,7 @@ -- | 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 :: SMTPConnection -> IO () closeSMTP (SMTPC conn _) = bsClose conn {- @@ -201,11 +202,10 @@ -- | 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 +sendMail :: String -- ^ sender mail -> [String] -- ^ receivers -> ByteString -- ^ data - -> SMTPConnection s + -> SMTPConnection -> IO () sendMail sender receivers dat conn = catcher `handle` mainProc @@ -219,25 +219,26 @@ -- | 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 :: String -> PortNumber -> (SMTPConnection -> 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 :: String -> (SMTPConnection -> 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 :: BSStream -> (SMTPConnection -> IO a) -> IO a doSMTPStream s execution = bracket (connectStream s) closeSMTP execution -sendMimeMail :: BSStream s => String -> String -> String -> LT.Text - -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection s -> IO () +sendMimeMail :: String -> String -> String -> LT.Text + -> LT.Text -> [(T.Text, FilePath)] -> SMTPConnection -> IO () sendMimeMail to from subject plainBody htmlBody attachments con = do - myMail <- simpleMail (T.pack to) (T.pack from) (T.pack subject) - plainBody htmlBody attachments + myMail <- simpleMail (Address Nothing $ T.pack to) (Address Nothing + $ T.pack from) + (T.pack subject) plainBody htmlBody attachments renderedMail <- renderMail' myMail sendMail from [to] (lazyToStrict renderedMail) con closeSMTP con @@ -247,3 +248,8 @@ lazyToStrict :: B.ByteString -> S.ByteString lazyToStrict = S.concat . B.toChunks +crlf :: BS.ByteString +crlf = BS.pack "\r\n" + +bsPutCrLf :: BSStream -> ByteString -> IO () +bsPutCrLf h s = bsPut h s >> bsPut h crlf >> bsFlush h diff --git a/src/Text/Packrat/Parse.hs b/src/Text/Packrat/Parse.hs --- a/src/Text/Packrat/Parse.hs +++ b/src/Text/Packrat/Parse.hs @@ -5,8 +5,8 @@ import Prelude hiding (exp, rem) -import Char -import List +import Data.Char +import Data.List import Text.Packrat.Pos