diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ +Copyright (c) 2011, MarketPsych Advisor LLC +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of the HAppS.org; nor the names of its 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. diff --git a/SSLWrap.hs b/SSLWrap.hs new file mode 100644 --- /dev/null +++ b/SSLWrap.hs @@ -0,0 +1,74 @@ +module SSLWrap(mapSSL,myForkIO) where + +import qualified OpenSSL.Session as SSL ( context, contextSetVerificationMode, contextSetDefaultCiphers + , VerificationMode(VerifyPeer), contextSetCAFile, connection, shutdown + , ShutdownType(Bidirectional), connect, write, read + ) +import OpenSSL ( withOpenSSL ) +import Network as N ( listenOn, PortID(PortNumber), accept, PortNumber ) +import Network.Socket as S ( withSocketsDo, sClose, socket, Family(AF_INET), SocketType(Stream) + , connect, SockAddr(SockAddrInet) ) +import Network.BSD ( getHostByName, defaultProtocol, hostAddress ) +import qualified Data.ByteString as B ( hGetSome, hPut, null ) +import Control.Exception ( bracket, finally, bracketOnError ) +import Control.Concurrent ( killThread, takeMVar, MVar, ThreadId, newEmptyMVar, forkIOUnmasked + , putMVar + ) +import Control.Monad ( liftM2 ) +import qualified System.IO as I ( hClose, hSetBuffering, BufferMode(NoBuffering) ) + + +mapSSL :: FilePath -> PortNumber -> String -> PortNumber -> IO () +mapSSL cafile in_port out_host out_port = withSocketsDo$ withOpenSSL$ do + bracket + (N.listenOn (PortNumber in_port)) + sClose + $ \sockin -> do + (h,_,_) <- N.accept sockin + I.hSetBuffering h I.NoBuffering + bracketOnError + (socket AF_INET Stream defaultProtocol) + sClose + $ \sout -> do + he <- getHostByName out_host + S.connect sout (SockAddrInet (fromIntegral out_port) (hostAddress he)) + + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx + SSL.contextSetVerificationMode ctx (SSL.VerifyPeer True False Nothing) + SSL.contextSetCAFile ctx cafile + bracket + (SSL.connection ctx sout) + (flip SSL.shutdown SSL.Bidirectional) + $ \ssl -> do + SSL.connect ssl + + bracket + (liftM2 (,) (myForkIO (readWriteLoop h ssl)) (myForkIO (readWriteLoop0 h ssl))) + (\((_,t0),(_,t1)) -> killThread t0 >> killThread t1) + $ \((m0,_),(m1,_)) -> do + + takeMVar m0 + takeMVar m1 + + where + readWriteLoop h ssl = do + b <- B.hGetSome h 1024 + SSL.write ssl b + if B.null b then SSL.shutdown ssl SSL.Bidirectional + else readWriteLoop h ssl + readWriteLoop0 h ssl = do + b <- SSL.read ssl 1024 + B.hPut h b + if B.null b then I.hClose h + else readWriteLoop0 h ssl + +myForkIO :: IO () -> IO (MVar (),ThreadId) +myForkIO io = do + m <- newEmptyMVar + t <- forkIOUnmasked (io `finally` putMVar m ()) + return (m,t) + + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/imapget.cabal b/imapget.cabal new file mode 100644 --- /dev/null +++ b/imapget.cabal @@ -0,0 +1,52 @@ +Name: imapget +Version: 0.0.1 +Synopsis: Downloads email from imap SSL servers. +Description: This programs shows how to use HaskellNet to download email from imap SSL servers. + The IMAP implementation is provided by HaskellNet, and the SSL implementation is + provided by HsOpenSSL. The program uses HsOpenSSL to forward a tcp connection on + a local port to a remote imap server and wraps the connection over SSL. HaskellNet + simply connects to the local port. + . + Currently imapget is able to list imap folders and print downloaded messages + in the standard output. + . + When run the first time, it will create a configuration file which you can edit + to specify username, password, imap server and ports. + . + > hostname=imap.gmail.com + > port=993 + > username= + > passwd= + > ssl_wrap_port=3004 + . + ssl_wrap_port is the local port used to wrap IMAP traffic over SSL. + + +License: BSD3 +License-file: COPYING +Author: Facundo Domínguez, MarketPsych Advisor LLC +Maintainer: Facundo Domínguez +Category: Network +Build-Type: Simple +Cabal-Version: >= 1.8 + +source-repository head + type: darcs + location: http://patch-tag.com/r/facundo/imapget + +Executable imapget + main-is: imapget.hs + other-modules: + SSLWrap + + build-depends: base < 5 + , bytestring + , directory + , HaskellNet<0.4 + , HsOpenSSL + , network + , text + + + ghc-options: -threaded -Wall + diff --git a/imapget.hs b/imapget.hs new file mode 100644 --- /dev/null +++ b/imapget.hs @@ -0,0 +1,126 @@ + +import Control.Arrow ( second ) +import Control.Concurrent ( forkIO, threadDelay ) +import Control.Exception ( mask_ ) +import Control.Monad ( when ) +import qualified Data.ByteString as B ( ByteString, putStrLn ) +import Data.Char ( isDigit ) +import Network.HaskellNet.IMAP.Connection as I ( IMAPConnection ) +import Network.HaskellNet.IMAP as I ( list, select, search, SearchQuery(..), fetch + , connectIMAPPort, login + ) +import Network.Socket as S ( HostName, PortNumber ) +import System.Directory ( canonicalizePath ) +import System.Environment ( getArgs ) +import System.Exit ( exitFailure ) +import System.IO ( Handle ) +import System.IO.Error ( isDoesNotExistError ) + +import SSLWrap ( mapSSL ) + + +main :: IO () +main = do + let config_file = "config.txt" + parseConfig = map (second (drop 1) . break (=='=')) . lines + defaultConfig = unlines + [ "hostname=imap.gmail.com" + , "port=993" + , "username=facundominguez@gmail.com" + , "passwd=haskellisnice" + , "ssl_wrap_port=3004" + ] + opts <- catch (fmap parseConfig$ readFile config_file)$ \e -> do + when (isDoesNotExistError e)$ do + writeFile config_file defaultConfig + putStrLn$ unlines + [ "" + , "Thanks for using imapget!" + , "" + , "You need to edit a configuration file to specify where to connect" + , "and which username and password to use." + , "" + , "I just created a default ./"++config_file++" file." + , "Please edit it to set your options." + ] + exitFailure + + let readConfig name action = maybe (putStrLn$ "error: missing "++name++" option from "++config_file) action$ lookup name opts + + readConfig "hostname"$ \hostname -> + readConfig "port"$ \port -> + readConfig "username"$ \username -> + readConfig "passwd"$ \passwd -> + readConfig "ssl_wrap_port"$ \ssl_wrap_port -> do + + args <- getArgs + + case args of + ["list"] | all isDigit port -> + main' IMAPConf + { icHostname = hostname + , icPort = fromIntegral (read port :: Int) + , icUsername = username + , icPasswd = passwd + , icSSLWrapPort = fromIntegral (read ssl_wrap_port :: Int) + } + Nothing + ["fetch",label] | all isDigit port -> + main' IMAPConf + { icHostname =hostname + , icPort = fromIntegral (read port :: Int) + , icUsername = username + , icPasswd = passwd + , icSSLWrapPort = fromIntegral (read ssl_wrap_port :: Int) + } + (Just label) + _ -> putStrLn "USAGE: imapget [list|fetch label]" + + +type UserName = String +type Password = String +type Label = String + +data IMAPConf = IMAPConf + { icHostname :: S.HostName + , icPort :: S.PortNumber + , icUsername :: UserName + , icPasswd :: Password + , icSSLWrapPort :: S.PortNumber + } + +main' :: IMAPConf -> Maybe Label -> IO () +main' conf mlabel = do + case mlabel of + Nothing -> do + withIMAP conf$ \ic -> do + putStrLn$ "Fetching mailbox ..." + I.list ic >>= mapM_ (putStrLn . snd) + Just label -> getEmails conf label B.putStrLn + + +getEmails :: IMAPConf -> Label -> (B.ByteString -> IO a) -> IO () +getEmails c label f = withIMAP c$ \ic -> do + putStrLn$ "Selecting "++label++" ..." + I.select ic label + putStrLn$ "Retrieving "++label++" ..." + I.search ic [ALLs] + >>= mapM_ (\uid -> I.fetch ic uid >>= f) + + + +withIMAP :: IMAPConf -> (I.IMAPConnection Handle -> IO a) -> IO a +withIMAP c action = do + -- launch thread for wrapping tcp with SSL + cafile <- canonicalizePath "cacert.pem" + _ <- mask_$ forkIO$ mapSSL cafile (icSSLWrapPort c) (icHostname c) (icPort c) + + -- start imap communication + threadDelay$ 500*1000 + putStrLn$ "Connecting to "++icHostname c++":"++show (icPort c)++" (wrapping with ssl through localhost:"++show (icSSLWrapPort c)++") ..." + ic <- connectIMAPPort "localhost" (icSSLWrapPort c) + putStrLn$ "Authenticating user "++icUsername c++" ..." + I.login ic (icUsername c) (icPasswd c) + action ic + +