diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Michal Kawalec + +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 Michal Kawalec 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/imap.cabal b/imap.cabal new file mode 100644 --- /dev/null +++ b/imap.cabal @@ -0,0 +1,99 @@ +-- Initial imap.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: imap +version: 0.1.0.0 +synopsis: An efficient IMAP client library +description: A fairly low-level, efficient, easy to use, streaming IMAP library +license: BSD3 +license-file: LICENSE +author: Michal Kawalec +maintainer: michal@monad.cat +-- copyright: +category: Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/mkawalec/imap + +library + exposed-modules: + Network.IMAP + Network.IMAP.Parsers + Network.IMAP.RequestWatcher + Network.IMAP.Types + Network.IMAP.Utils + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9, + attoparsec == 0.13.0.1, + text == 1.2.2.0, + connection == 0.2.5, + bytestring == 0.10.6.0, + random == 1.1, + word8 == 0.1.2, + rolling-queue == 0.1, + stm == 2.4.4.1, + either == 4.4.1, + hslogger == 1.2.9, + transformers == 0.4.2.0, + list-t == 0.4.5.1, + monadIO == 0.10.1.4, + derive == 2.5.23, + data-default == 0.5.3, + stm-delay == 0.1.1.1, + exceptions == 0.8.2.1 + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: OverloadedStrings, + GeneralizedNewtypeDeriving, + BangPatterns, + ScopedTypeVariables, + TypeSynonymInstances, + DeriveFunctor, + FlexibleInstances, + TemplateHaskell, + LambdaCase + ghc-options: -Wall -fno-warn-unused-do-bind + +Test-Suite imap-test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test, src + build-depends: base >=4.8 && <4.9, + attoparsec == 0.13.0.1, + text == 1.2.2.0, + connection == 0.2.5, + bytestring == 0.10.6.0, + random == 1.1, + word8 == 0.1.2, + rolling-queue == 0.1, + stm == 2.4.4.1, + either == 4.4.1, + hslogger == 1.2.9, + transformers == 0.4.2.0, + list-t == 0.4.5.1, + monadIO == 0.10.1.4, + derive == 2.5.23, + data-default == 0.5.3, + stm-delay == 0.1.1.1, + exceptions == 0.8.2.1, + + tasty == 0.11.0.2, + HUnit == 1.3.1.1, + QuickCheck == 2.8.2, + tasty-hunit == 0.9.2, + tasty-quickcheck == 0.8.4, + mtl == 2.2.1 + default-language: Haskell2010 + default-extensions: OverloadedStrings, + GeneralizedNewtypeDeriving, + BangPatterns, + ScopedTypeVariables, + TypeSynonymInstances, + DeriveFunctor, + FlexibleInstances, + TemplateHaskell, + LambdaCase diff --git a/src/Network/IMAP.hs b/src/Network/IMAP.hs new file mode 100644 --- /dev/null +++ b/src/Network/IMAP.hs @@ -0,0 +1,351 @@ +----------------------------------------------------------------------------- +-- | +-- 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, decodeUtf8) +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(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import ListT (toList, ListT) +import qualified Data.List as L +import qualified Debug.Trace as DT + +-- |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 -> IO IMAPConnection +connectServer connParams = do + context <- initConnectionContext + connection <- connectTo context connParams + + untaggedRespsQueue <- RQ.newIO 20 + responseRequestsQueue <- newTQueueIO + connState <- newTVarIO UndefinedState + watcherId <- newTVarIO Nothing + requests <- newTVarIO [] + + let state = IMAPState { + rawConnection = connection, + connectionContext = context, + responseRequests = responseRequestsQueue, + serverWatcherThread = watcherId, + outstandingReqs = requests + } + + 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 responseQ + +-- | +-- = Connected state commands + +-- |Upgrade a connection to a TLS connection from an insecure one. Accepts TLS settings +-- you with 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 _) -> if resState == OK + then 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 + else return () + _ -> 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 = oneParamCommand "SELECT" + +examine :: (MonadPlus m, MonadIO m, Universe m) => IMAPConnection -> + T.Text -> m CommandResult +examine = oneParamCommand "EXAMINE" + +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] + + DT.traceShow command $ 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, Universe 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 . decodeUtf8 . resultRest $ t + +oneParamCommand :: (MonadPlus m, MonadIO m, Universe m) => T.Text -> + IMAPConnection -> T.Text -> m CommandResult +oneParamCommand commandName conn mailboxName = sendCommand conn wholeCommand + where wholeCommand = encodeUtf8 $ T.intercalate " " [commandName, mailboxName] diff --git a/src/Network/IMAP/Parsers.hs b/src/Network/IMAP/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Network/IMAP/Parsers.hs @@ -0,0 +1,63 @@ +module Network.IMAP.Parsers where + +import Network.IMAP.Types +import Network.IMAP.Parsers.Fetch +import Network.IMAP.Parsers.Utils +import Network.IMAP.Parsers.Untagged + + +import Data.Attoparsec.ByteString +import qualified Data.Attoparsec.ByteString as AP +import Data.Word8 + +import Control.Applicative + +parseReply :: Parser (Either ErrorMessage CommandResult) +parseReply = parseFetch <|> parseLine + +parseLine :: Parser (Either ErrorMessage CommandResult) +parseLine = do + parsed <- parseUntagged <|> parseTagged + string "\r\n" + return parsed + +parseTagged :: Parser (Either ErrorMessage CommandResult) +parseTagged = do + requestId <- takeWhile1 isLetter + word8 _space + + commandState <- takeWhile1 isLetter + word8 _space + + rest <- takeWhile1 (/= _cr) + let state = case commandState of + "OK" -> OK + "NO" -> NO + "BAD" -> BAD + _ -> BAD + + return . Right . Tagged $ TaggedResult requestId state rest + +parseUntagged :: Parser (Either ErrorMessage CommandResult) +parseUntagged = do + string "* " + result <- parseFlags <|> + parseExists <|> + parseHighestModSeq <|> + parseRecent <|> + parseUnseen <|> + (Right <$> parsePermanentFlags) <|> + parseUidNext <|> + parseUidValidity <|> + parseCapabilityList <|> + (Right <$> parseOk) <|> + (Right <$> parseBye) <|> + (Right <$> parseListLikeResp "LIST") <|> + (Right <$> parseListLikeResp "LSUB") <|> + parseStatus <|> + parseExpunge <|> + parseSearchResult + + -- Take the rest + _ <- AP.takeWhile (/= _cr) + return $ result >>= Right . Untagged diff --git a/src/Network/IMAP/RequestWatcher.hs b/src/Network/IMAP/RequestWatcher.hs new file mode 100644 --- /dev/null +++ b/src/Network/IMAP/RequestWatcher.hs @@ -0,0 +1,172 @@ +module Network.IMAP.RequestWatcher (requestWatcher) where + +import Network.IMAP.Types +import Network.IMAP.Parsers + +import Data.Either (isRight) +import Data.Either.Combinators (fromRight') +import Data.Maybe (isJust, fromJust) + +import Network.Connection +import Data.Attoparsec.ByteString +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +import qualified Data.List as L +import qualified Data.Text as T + +import qualified Data.STM.RollingQueue as RQ +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar +import Control.Concurrent (killThread) +import Control.Monad.STM +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (SomeException) +import qualified Control.Monad.Catch as C +import Control.Monad.Catch (MonadCatch) + +import System.Log.Logger (errorM) + + +requestWatcher :: (MonadIO m, Universe m, MonadCatch m) => IMAPConnection -> m () +requestWatcher conn = flip C.catch (handleExceptions conn) $ do + parsedLine <- getParsedChunk (rawConnection . imapState $ conn) (AP.parse parseReply) + + if isRight parsedLine + then reactToReply conn $ fromRight' parsedLine + else return () + + requestWatcher conn + +reactToReply :: (MonadIO m, Universe m, MonadCatch m) => IMAPConnection -> CommandResult -> m () +reactToReply conn parsedReply = do + let state = imapState conn + requests <- liftIO . atomically $ do + newReqs <- getOutstandingReqs $ responseRequests state + knownReqs <- readTVar $ outstandingReqs state + return $ knownReqs ++ newReqs + + updateConnState conn parsedReply + pendingReqs <- case parsedReply of + Tagged t -> dispatchTagged requests t + Untagged u -> dispatchUntagged conn requests u + + liftIO . atomically $ writeTVar (outstandingReqs state) pendingReqs + + shouldIDie conn + +updateConnState :: (MonadIO m, Universe m) => IMAPConnection -> CommandResult -> m () +updateConnState conn command = do + let connState = connectionState conn + + case command of + Untagged u -> case u of + OKResult _ -> liftIO . atomically $ writeTVar connState Connected + Bye -> liftIO . atomically $ writeTVar connState Disconnected + + _ -> return () + _ -> return () + +shouldIDie :: (MonadIO m, Universe m) => IMAPConnection -> m () +shouldIDie conn = liftIO $ do + threadId <- atomically . readTVar . serverWatcherThread . imapState $ conn + connState <- atomically . readTVar $ connectionState conn + + if isDisconnected connState && isJust threadId + then killThread $ fromJust threadId + else return () + +dispatchTagged :: (MonadIO m, Universe m) => [ResponseRequest] -> + TaggedResult -> m [ResponseRequest] +dispatchTagged requests response = do + let reqId = commandId response + let pendingRequest = L.find (\r -> respRequestId r == reqId) requests + + if isJust pendingRequest + then liftIO . atomically $ do + writeTQueue (responseQueue . fromJust $ pendingRequest) $ Tagged response + else liftIO $ errorM "RequestWatcher" "Received a reply for an unknown request" + + return $ if isJust pendingRequest + then filter (/= fromJust pendingRequest) requests + else requests + +dispatchUntagged :: (MonadIO m, Universe m) => IMAPConnection -> + [ResponseRequest] -> + UntaggedResult -> + m [ResponseRequest] +dispatchUntagged conn requests response = do + if null requests + then liftIO . atomically $ RQ.write (untaggedQueue conn) response + else liftIO . atomically $ do + let responseQ = responseQueue . head $ requests + writeTQueue responseQ $ Untagged response + return requests + +getOutstandingReqs :: TQueue ResponseRequest -> + STM [ResponseRequest] +getOutstandingReqs reqsQueue = do + isEmpty <- isEmptyTQueue reqsQueue + if isEmpty + then return [] + else do + req <- readTQueue reqsQueue + next <- getOutstandingReqs reqsQueue + return (req:next) + +omitOneLine :: BSC.ByteString -> BSC.ByteString +omitOneLine bytes = if BSC.length withLF > 0 then BSC.tail withLF else withLF + where withLF = BSC.dropWhile (/= '\n') bytes + +type ParseResult = Either ErrorMessage CommandResult +parseChunk :: (BSC.ByteString -> Result ParseResult) -> + BSC.ByteString -> + ((Maybe ParseResult, Maybe (BSC.ByteString -> Result ParseResult)), BSC.ByteString) +parseChunk parser chunk = + case parser chunk of + Fail left _ msg -> ((Just . Left . T.pack $ msg, Nothing), omitOneLine left) + Partial continuation -> ((Nothing, Just continuation), BS.empty) + Done left result -> ((Just result, Nothing), left) + +getParsedChunk :: (MonadIO m, Universe m) => Connection -> + (BSC.ByteString -> Result ParseResult) -> + m ParseResult +getParsedChunk conn parser = do + (parsed, cont) <- connectionGetChunk'' conn $ parseChunk parser + + if isJust cont + then getParsedChunk conn $ fromJust cont + else return . fromJust $ parsed + +-- |Reject all outstanding requests with the exception handler, close the watcher +handleExceptions :: (MonadIO m, Universe m, MonadCatch m) => IMAPConnection -> + SomeException -> + m () +handleExceptions conn e = do + let state = imapState conn + + threadId <- liftIO . atomically $ do + writeTVar (connectionState conn) Disconnected + let actualThreadId = readTVar $ serverWatcherThread state + writeTVar (serverWatcherThread state) Nothing + actualThreadId + + requests <- liftIO . atomically $ do + newReqs <- getOutstandingReqs $ responseRequests state + knownReqs <- readTVar $ outstandingReqs state + return $ knownReqs ++ newReqs + + let reply = TaggedResult { + commandId = "noid", + resultState = BAD, + resultRest = BSC.append "Exception caught " (BSC.pack . show $ e) + } + liftIO . atomically $ mapM_ (sendResponse reply) requests + + if isJust threadId + then liftIO . killThread $ fromJust threadId + else return () + +sendResponse :: TaggedResult -> ResponseRequest -> STM () +sendResponse response request = writeTQueue (responseQueue request) $ Tagged response diff --git a/src/Network/IMAP/Types.hs b/src/Network/IMAP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/IMAP/Types.hs @@ -0,0 +1,202 @@ +module Network.IMAP.Types where + +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BSC +import qualified Data.STM.RollingQueue as RQ +import Control.Concurrent.STM.TVar (TVar) +import Data.DeriveTH + +import Control.Concurrent (ThreadId) +import Control.Concurrent.STM.TQueue (TQueue) +import Network.Connection (Connection, ConnectionContext, + connectionPut, connectionGetChunk') +import ListT (ListT) +import Control.Monad.IO.Class (liftIO) + +-- |A type alias used for an error message +type ErrorMessage = T.Text +-- |Each command sent to the server is identified by a random id. +-- this alias helps noticing where this happens +type CommandId = BSC.ByteString + +-- |Connection with the server can be in one of these states +data ConnectionState = UndefinedState + | Connected + | Disconnected + deriving (Show) + +data IMAPConnection = IMAPConnection { + -- |The current connection state + connectionState :: TVar ConnectionState, + -- |Contains commands sent by the server which we didn't expect. + -- Probably message and mailbox state updates + untaggedQueue :: RQ.RollingQueue UntaggedResult, + -- |Internal state of the library + imapState :: IMAPState +} + +data IMAPState = IMAPState { + -- |The actual connection with the server from + -- Network.Connection. Only use if you know what you're doing + rawConnection :: !Connection, + -- |Context from Network.Connection + connectionContext :: ConnectionContext, + -- |Contains requests for response that weren't yet read by the watcher thread. + responseRequests :: TQueue ResponseRequest, + -- |Id of the thread the watcher executes on + serverWatcherThread :: TVar (Maybe ThreadId), + -- |All the unfulfilled requests the watcher thread knows about + outstandingReqs :: TVar [ResponseRequest] +} + +data ResponseRequest = ResponseRequest { + -- |Thread that posted the request should watch this + -- queue for responses to the request. + responseQueue :: TQueue CommandResult, + -- |Id of the request, which is the same as the id sent to the server. + respRequestId :: CommandId +} deriving (Eq) + +data EmailAddress = EmailAddress { + emailLabel :: Maybe T.Text, + emailAddress :: T.Text +} deriving (Show, Eq) + +data Flag = FSeen + | FAnswered + | FFlagged + | FDeleted + | FDraft + | FRecent + | FAny + | FOther T.Text + deriving (Show, Eq, Ord) + +data Capability = CIMAP4 + | CUnselect + | CIdle + | CNamespace + | CQuota + | CId + | CExperimental T.Text + | CChildren + | CUIDPlus + | CCompress T.Text + | CEnable + | CMove + | CCondstore + | CEsearch + | CUtf8 T.Text + | CAuth T.Text + | CListExtended + | CListStatus + | CAppendLimit Int + -- |First parameter is the name of a capability + -- and the second can contain a value, if the capability + -- is of the form `NAME=VALUE` + | COther T.Text (Maybe T.Text) + deriving (Show, Eq, Ord) + + +-- |Always the last result of the command, contains it's metadata +data TaggedResult = TaggedResult { + -- |Id of the command that completes + commandId :: CommandId, + -- |State returned by the serverside + resultState :: !ResultState, + -- |Rest of the result, usually a human-readable form of a result + resultRest :: BSC.ByteString + } deriving (Show, Eq) + +-- |Tagged results can be in on of these three states +data ResultState = OK | NO | BAD deriving (Show, Eq) + +-- |Untagged replies are the actual data returned in response to the commands. +data UntaggedResult = Flags [Flag] -- ^ A list of flags a mailbox has + | Exists Int -- ^ How many messages exist in a mailbox + | Expunge Int -- ^ How many messages are expunged + | Bye -- ^ Returned by the server when it cleanly disconnects + | HighestModSeq Int + | Recent Int -- ^ Number of recent messages + | Messages Int -- ^ Number of messages in a mailbox + | Unseen Int -- ^ Number of unseen messages + | PermanentFlags [Flag] + | UID Int -- ^ UID of a message + | MessageId Int -- ^ A sequence id of a message + -- |UID that will be given to the next message added to this mailbox + | UIDNext Int + -- |A triple of mailbox name, it's UIDValidity value and message UID + -- is always unique for a given message + | UIDValidity Int + | OKResult T.Text -- ^ Result of an OK response + | Capabilities [Capability] -- ^ What server advertises that it supports + -- |Response to the `LIST` command + | ListR { + flags :: [NameAttribute], -- ^ flags that a mailbox has + -- |Character sequence that marks a new level of hierarchy + -- in the inbox name (usually a slash) + hierarchyDelimiter :: T.Text, + -- |Name of the mailbox + inboxName :: T.Text + } + | Fetch [UntaggedResult] -- ^ Fetch response, contains many responses + -- |Status of a mailbox, will contain many different responses inside + | StatusR T.Text [UntaggedResult] + -- |A list of message IDs or UIDs fullfilling the search criterions + | Search [Int] + -- |A parsed ENVELOPE reply, prefixed to avoid name clashes + | Envelope { + eDate :: Maybe T.Text, + eSubject :: Maybe T.Text, + eFrom :: Maybe [EmailAddress], + eSender :: Maybe [EmailAddress], + eReplyTo :: Maybe [EmailAddress], + eTo :: Maybe [EmailAddress], + eCC :: Maybe [EmailAddress], + eBCC :: Maybe [EmailAddress], + eInReplyTo :: Maybe T.Text, + eMessageId :: Maybe T.Text + } + | InternalDate T.Text + | Size Int -- ^ Message size + | Unknown BSC.ByteString -- ^ An unsupported value + | Body BSC.ByteString -- ^ Message body, or headers + | BodyStructure BSC.ByteString -- ^ An unparsed bodystructure + deriving (Show, Eq) + +data NameAttribute = Noinferiors + | Noselect + | Marked + | Unmarked + | HasNoChildren + | OtherNameAttr T.Text + deriving (Show, Eq, Ord) + +-- |Command result consits of a sequence of untagged results followed +-- by a single tagged result that specifies if the command overall succeeded. +-- This is a sum type to bind those two types together +data CommandResult = Tagged TaggedResult | Untagged UntaggedResult + deriving (Show, Eq) + +-- |If you don't care about streaming you will get results in this simplified +-- data type, in which the ErrorMessage comes from TaggedResult if it failed. +type SimpleResult = Either ErrorMessage [UntaggedResult] + +-- |Every function that communicates with the outside world should run +-- in the Universe monad, which provides an ability to use mocks when testing +class Monad m => Universe m where + connectionPut' :: Connection -> BSC.ByteString -> m () + connectionGetChunk'' :: Connection -> (BSC.ByteString -> (a, BSC.ByteString)) -> m a + +instance Universe IO where + connectionPut' = connectionPut + connectionGetChunk'' = connectionGetChunk' + +instance Universe (ListT IO) where + connectionPut' c d = liftIO $ connectionPut c d + connectionGetChunk'' c cont = liftIO $ connectionGetChunk' c cont + +$(derive makeIs ''Flag) +$(derive makeIs ''UntaggedResult) +$(derive makeIs ''CommandResult) +$(derive makeIs ''ConnectionState) diff --git a/src/Network/IMAP/Utils.hs b/src/Network/IMAP/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/IMAP/Utils.hs @@ -0,0 +1,73 @@ +module Network.IMAP.Utils where + +import Network.IMAP.Types +import qualified Data.ByteString.Char8 as BSC +import System.Random +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) + +import Control.Monad.STM +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TVar + +import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Concurrent.STM.Delay + +genRequestId :: IO BSC.ByteString +genRequestId = do + randomGen <- newStdGen + return $ BSC.pack . Prelude.take 9 $ randomRs ('a', 'z') randomGen + +readResults :: (MonadPlus m, MonadIO m, Universe m) => + TQueue CommandResult -> + m CommandResult +readResults resultsQueue = do + delay <- liftIO . newDelay $ 10 * 1000000 + let d_wait = do + didComplete <- tryWaitDelay delay + if didComplete + then return . Tagged $ TaggedResult { + commandId="noid", + resultState=BAD, + resultRest="Connection timeout" + } + else retry + readResult = readTQueue $ resultsQueue + + nextResult <- liftIO . atomically $ d_wait `orElse` readResult + case nextResult of + Tagged _ -> return nextResult + Untagged _ -> (return nextResult) `mplus` readResults resultsQueue + +escapeText :: T.Text -> T.Text +escapeText t = T.replace "{" "\\{" $ + T.replace "}" "\\}" $ + T.replace "\"" "\\\"" $ + T.replace "\\" "\\\\" t + + +ifNotDisconnected :: (MonadPlus m, MonadIO m, Universe m) => + IMAPConnection -> m CommandResult -> m CommandResult +ifNotDisconnected conn action = do + connState <- liftIO . atomically . readTVar $ connectionState conn + if isDisconnected connState + then return . Tagged $ TaggedResult { + commandId = "noid", + resultState = BAD, + resultRest = "Cannot post a command when watcher is disconnected" + } + else action + +flagsToText :: [Flag] -> BSC.ByteString +flagsToText flagList = BSC.concat ["(", encodedFlags, ")"] + where encodedFlags = BSC.intercalate " " textFlags + textFlags = flip map flagList (\case + FSeen -> "\\Seen" + FAnswered -> "\\Answered" + FFlagged -> "\\Flagged" + FDeleted -> "\\Deleted" + FDraft -> "\\Draft" + FRecent -> "\\Recent" + FAny -> "*" + FOther t -> encodeUtf8 t) diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.Utils (getConn) +import qualified Network.IMAP.Tests +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain $ testGroup "Tests" + [Network.IMAP.Tests.tests]