----------------------------------------------------------------------------- -- | -- Module : Network.IMAP -- Copyright : 2016 Michal Kawalec -- License : BSD-style (see the file LICENSE) -- Maintainer : Michal Kawalec -- Stability : experimental -- Portability : non-portable -- -- Usage: -- -- @ -- import Network.Connection -- import Network.IMAP -- -- let tls = TLSSettingsSimple False False False -- let params = ConnectionParams "imap.gmail.com" 993 (Just tls) Nothing -- conn <- connectServer params -- simpleFormat $ login conn "mylogin" "mypass" -- @ -- -- For more usage examples, please see the readme module Network.IMAP ( connectServer, sendCommand, startTLS, capability, noop, logout, login, authenticate, select, examine, create, delete, rename, subscribe, unsubscribe, list, lsub, status, append, Network.IMAP.check, close, expunge, search, uidSearch, fetch, uidFetch, fetchG, uidFetchG, store, copy, simpleFormat ) where import Network.Connection import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.ByteString.Char8 as BSC import qualified Data.STM.RollingQueue as RQ import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Control.Monad.STM import Data.Maybe (isJust, fromJust) import Control.Concurrent (forkIO, killThread) import Network.IMAP.Types import Network.IMAP.RequestWatcher import Network.IMAP.Utils import Control.Monad (MonadPlus(..), when) import Control.Monad.IO.Class (MonadIO(..)) import ListT (toList, ListT) import qualified Data.List as L -- |Connects to the server and gives you a connection object -- that needs to be passed to any other command. You should only call it once -- for every connection you wish to create connectServer :: ConnectionParams -> Maybe IMAPSettings -> IO IMAPConnection connectServer connParams wrappedSettings = do context <- initConnectionContext connection <- connectTo context connParams let settings = if isJust wrappedSettings then fromJust wrappedSettings else defaultImapSettings untaggedRespsQueue <- RQ.newIO $ untaggedQueueLength settings responseRequestsQueue <- newTQueueIO connState <- newTVarIO UndefinedState watcherId <- newTVarIO Nothing requests <- newTVarIO [] let state = IMAPState { rawConnection = connection, connectionContext = context, responseRequests = responseRequestsQueue, serverWatcherThread = watcherId, outstandingReqs = requests, imapSettings = settings } let conn = IMAPConnection { connectionState = connState, untaggedQueue = untaggedRespsQueue, imapState = state } watcherThreadId <- forkIO $ requestWatcher conn atomically $ writeTVar (serverWatcherThread . imapState $ conn) (Just watcherThreadId) return conn -- |An escape hatch, gives you the ability to send any command to the server, -- even one not implemented by this library sendCommand :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> BSC.ByteString -> m CommandResult sendCommand conn command = ifNotDisconnected conn $ do let state = imapState conn requestId <- liftIO genRequestId responseQ <- liftIO . atomically $ newTQueue let commandLine = BSC.concat [requestId, " ", command, "\r\n"] let responseRequest = ResponseRequest responseQ requestId liftIO . atomically $ writeTQueue (responseRequests state) responseRequest connectionPut' (rawConnection state) commandLine readResults state responseRequest -- | -- = Connected state commands -- |Upgrade a connection to a TLS connection from an insecure one. Accepts TLS settings -- you wish your connection to use startTLS :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> TLSSettings -> m CommandResult startTLS conn tls = do res <- sendCommand conn "STARTTLS" let state = imapState conn case res of Tagged (TaggedResult _ resState _) -> when (resState == OK) $ do threadId <- liftIO . atomically . readTVar $ serverWatcherThread state liftIO . killThread . fromJust $ threadId liftIO $ connectionSetSecure (connectionContext state) (rawConnection state) tls watcherThreadId <- liftIO . forkIO $ requestWatcher conn liftIO . atomically $ do writeTVar (serverWatcherThread state) $ Just watcherThreadId writeTVar (connectionState conn) Connected _ -> return () return res capability :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult capability conn = sendCommand conn "CAPABILITY" noop :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult noop conn = sendCommand conn "NOOP" logout :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult logout conn = sendCommand conn "LOGOUT" -- |A simple authentication method, with user and password. -- Probably what's needed in 90% of cases. login :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> T.Text -> m CommandResult login conn username password = sendCommand conn . encodeUtf8 $ T.intercalate " " ["LOGIN", escapeText username, escapeText password] -- |Authenticate with the server. During the authentication control is given -- to the library user and is returned to the library at the end of authentication authenticate :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> BSC.ByteString -> (IMAPConnection -> m ()) -> m () authenticate conn method authAction = do requestId <- liftIO genRequestId let state = imapState conn let commandLine = BSC.concat [requestId, " AUTHENTICATE ", method, "\r\n"] connectionPut' (rawConnection . imapState $ conn) commandLine -- kill the watcher thread threadId <- liftIO . atomically . readTVar . serverWatcherThread $ state liftIO . killThread . fromJust $ threadId authAction conn -- Bring the watcher back up watcherThreadId <- liftIO . forkIO $ requestWatcher conn liftIO . atomically $ do writeTVar (serverWatcherThread state) $ Just watcherThreadId writeTVar (connectionState conn) Connected return () -- | -- = Authenticated state commands select :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult select conn mboxName = oneParamCommand "SELECT" conn escapedMailbox where escapedMailbox = T.concat ["\"", mboxName, "\""] examine :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult examine conn mboxName = oneParamCommand "EXAMINE" conn escapedMailbox where escapedMailbox = T.concat ["\"", mboxName, "\""] create :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult create = oneParamCommand "CREATE" delete :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult delete = oneParamCommand "DELETE" rename :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> T.Text -> m CommandResult rename conn fromName toName = sendCommand conn wholeCommand where wholeCommand = encodeUtf8 $ T.intercalate " " ["RENAME", fromName, toName] subscribe :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult subscribe = oneParamCommand "SUBSCRIBE" unsubscribe :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult unsubscribe = oneParamCommand "UNSUBSCRIBE" list :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult list conn mailboxName = sendCommand conn wholeCommand where wholeCommand = encodeUtf8 $ T.intercalate " " ["LIST", "\"\"", mailboxName] lsub :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult lsub conn mailboxName = sendCommand conn wholeCommand where wholeCommand = encodeUtf8 $ T.intercalate " " ["LSUB", "\"\"", mailboxName] status :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult status conn mailboxName = sendCommand conn $ encodeUtf8 command where command = T.intercalate " " ["STATUS", mailboxName, "(MESSAGES", "RECENT", "UIDNEXT", "UIDVALIDITY", "UNSEEN)"] append :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> BSC.ByteString -> Maybe [Flag] -> Maybe T.Text -> m CommandResult append conn mailboxName message flagL dateTime = do let encodedFlags = if isJust flagL then BSC.concat [" ", flagsToText $ fromJust flagL] else BSC.empty let encodedDate = if isJust dateTime then BSC.concat [" \"", encodeUtf8 . fromJust $ dateTime, "\""] else BSC.empty let command = BSC.concat ["APPEND ", encodeUtf8 mailboxName, encodedFlags, encodedDate, " {", BSC.pack . show . BSC.length $ message, "}\r\n", message] return () sendCommand conn command -- | -- = Selected state commands check :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult check conn = sendCommand conn "CHECK" close :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult close conn = sendCommand conn "CLOSE" expunge :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> m CommandResult expunge conn = sendCommand conn "EXPUNGE" search :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult search = oneParamCommand "SEARCH" uidSearch :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult uidSearch = oneParamCommand "UID SEARCH" -- |Fetch message body by message sequence id fetch :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult fetch conn query = sendCommand conn $ encodeUtf8 command where command = T.intercalate " " ["FETCH", query, "BODY[]"] -- |Fetch message body my message UID uidFetch :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult uidFetch conn query = sendCommand conn $ encodeUtf8 command where command = T.intercalate " " ["UID FETCH", query, "BODY[]"] -- |A general fetch, you have to specify everything that -- goes after the `FETCH` keyword fetchG :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult fetchG = oneParamCommand "FETCH" -- |A general fetch using UIDs uidFetchG :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> m CommandResult uidFetchG = oneParamCommand "UID FETCH" store :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> T.Text -> [Flag] -> m CommandResult store conn sequenceSet dataItem flagList = do let command = BSC.intercalate " " ["STORE", encodeUtf8 sequenceSet, encodeUtf8 dataItem, flagsToText flagList] sendCommand conn command copy :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> T.Text -> T.Text -> m CommandResult copy conn sequenceSet mailboxName = sendCommand conn command where command = BSC.intercalate " " ["COPY", encodeUtf8 sequenceSet, encodeUtf8 mailboxName] -- |Return the untagged replies or an error message if the tagged reply -- is of type NO or BAD. Also return all untagged replies received if -- replies list contains a BYE response -- (when the server decided to cleanly disconnect) simpleFormat :: (MonadIO m) => ListT m CommandResult -> m SimpleResult simpleFormat action = do results <- toList action let hasBye = L.find (\i -> case i of Untagged u -> isBye u Tagged _ -> False) results if isJust hasBye then return . Right $ map (\(Untagged u) -> u) $ filter isUntagged results else case last results of Untagged _ -> return . Left $ "Last result is untagged, something went wrong" Tagged t -> case resultState t of OK -> return . Right $ map (\(Untagged u) -> u) (init results) _ -> return . Left . resultRest $ t oneParamCommand :: (MonadPlus m, MonadIO m, Universe m) => T.Text -> IMAPConnection -> T.Text -> m CommandResult oneParamCommand commandName conn params = sendCommand conn wholeCommand where wholeCommand = encodeUtf8 $ T.intercalate " " [commandName, params]