imap (empty) → 0.1.0.0
raw patch · 9 files changed
+1001/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed
Dependencies added: HUnit, QuickCheck, attoparsec, base, bytestring, connection, data-default, derive, either, exceptions, hslogger, list-t, monadIO, mtl, random, rolling-queue, stm, stm-delay, tasty, tasty-hunit, tasty-quickcheck, text, transformers, word8
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- imap.cabal +99/−0
- src/Network/IMAP.hs +351/−0
- src/Network/IMAP/Parsers.hs +63/−0
- src/Network/IMAP/RequestWatcher.hs +172/−0
- src/Network/IMAP/Types.hs +202/−0
- src/Network/IMAP/Utils.hs +73/−0
- test/main.hs +9/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ imap.cabal view
@@ -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
+ src/Network/IMAP.hs view
@@ -0,0 +1,351 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.IMAP+-- Copyright : 2016 Michal Kawalec+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Michal Kawalec <michal@monad.cat>+-- 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]
+ src/Network/IMAP/Parsers.hs view
@@ -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
+ src/Network/IMAP/RequestWatcher.hs view
@@ -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
+ src/Network/IMAP/Types.hs view
@@ -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)
+ src/Network/IMAP/Utils.hs view
@@ -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)
+ test/main.hs view
@@ -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]