diff --git a/imap.cabal b/imap.cabal --- a/imap.cabal +++ b/imap.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: imap -version: 0.1.0.3 +version: 0.2.0.0 synopsis: An efficient IMAP client library, with SSL and streaming license: BSD3 license-file: LICENSE @@ -37,9 +37,9 @@ . > let tls = TLSSettingsSimple False False False > let params = ConnectionParams "imap.gmail.com" 993 (Just tls) Nothing - > conn <- connectServer params + > conn <- connectServer params Nothing . - From now on you can run commands on this connection. We will use the `simpleFormat` helper function to convert from `ListT` to `IO`. Let's log in: + From now on you can run commands on this connection. The second parameter to `connectServer` is `Maybe IMAPSettings`. If settings are not provided, sane defaults will be used. We will use the `simpleFormat` helper function to convert from `ListT` to `IO`. Let's log in: . > simpleFormat $ login conn "mylogin" "mypass" > Right [Capabilities [CIMAP4,CUnselect,CIdle,CNamespace,CQuota,CId,CExperimental "XLIST",CChildren,CExperimental "X-GM-EXT-1",CUIDPlus,CCompress "DEFLATE",CEnable,CMove,CCondstore,CEsearch,CUtf8 "ACCEPT",CListExtended,CListStatus,CAppendLimit 35882577]] @@ -87,7 +87,7 @@ . /Streaming/ . - There's an excellent article by Gabriel Gonzalez you should read :) + There's by Gabriel Gonzalez you should read :) source-repository head type: git location: https://github.com/mkawalec/imap @@ -103,22 +103,23 @@ -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9, - attoparsec >= 0.13 && <0.14, - text >= 1.2 && <1.3, - connection >= 0.2 && <0.3, - bytestring >= 0.10.6.0 && <0.11, - random >= 1.1 && <1.2, - word8 >= 0.1.2 && <0.2, + attoparsec == 0.13.*, + text == 1.2.*, + connection == 0.2.*, + bytestring == 0.10.*, + random == 1.1.*, + word8 == 0.1.* && <0.2, rolling-queue == 0.1, - stm >= 2.4.4.1 && <2.5, - either >= 4.4.1 && <4.5, - hslogger >= 1.2.9 && < 1.3, - transformers >= 0.4.2.0 && <0.5, - list-t >= 0.4.5.1 && <0.5, - monadIO >= 0.10.1.4 && <0.11, - derive >= 2.5.23 && <2.6, - stm-delay >= 0.1.1.1 && <0.2, - exceptions >= 0.8.2.1 && <0.9 + stm == 2.4.* && <2.5, + either == 4.4.*, + hslogger == 1.2.*, + transformers == 0.4.*, + list-t == 0.4.*, + monadIO == 0.10.*, + derive == 2.5.*, + stm-delay == 0.1.*, + exceptions == 0.8.*, + data-default == 0.5.* hs-source-dirs: src default-language: Haskell2010 default-extensions: OverloadedStrings, @@ -137,29 +138,30 @@ main-is: main.hs hs-source-dirs: test, src build-depends: base >=4.8 && <4.9, - attoparsec >= 0.13 && <0.14, - text >= 1.2 && <1.3, - connection >= 0.2 && <0.3, - bytestring >= 0.10.6.0 && <0.11, - random >= 1.1 && <1.2, - word8 >= 0.1.2 && <0.2, + attoparsec == 0.13.*, + text == 1.2.*, + connection == 0.2.*, + bytestring == 0.10.*, + random == 1.1.*, + word8 == 0.1.* && <0.2, rolling-queue == 0.1, - stm >= 2.4.4.1 && <2.5, - either >= 4.4.1 && <4.5, - hslogger >= 1.2.9 && < 1.3, - transformers >= 0.4.2.0 && <0.5, - list-t >= 0.4.5.1 && <0.5, - monadIO >= 0.10.1.4 && <0.11, - derive >= 2.5.23 && <2.6, - stm-delay >= 0.1.1.1 && <0.2, - exceptions >= 0.8.2.1 && <0.9, + stm == 2.4.* && <2.5, + either == 4.4.*, + hslogger == 1.2.*, + transformers == 0.4.*, + list-t == 0.4.*, + monadIO == 0.10.*, + derive == 2.5.*, + stm-delay == 0.1.*, + exceptions == 0.8.*, + data-default == 0.5.*, - tasty >= 0.11.0.2 && <0.12, - HUnit >= 1.3.1.1 && <1.4, - QuickCheck >= 2.8.2 && <2.9, - tasty-hunit >= 0.9.2 && <0.10, - tasty-quickcheck >= 0.8.4 && <0.9, - mtl >= 2.2.1 + tasty == 0.11.*, + HUnit == 1.3.*, + QuickCheck == 2.8.*, + tasty-hunit == 0.9.*, + tasty-quickcheck == 0.8.*, + mtl == 2.2.* default-language: Haskell2010 default-extensions: OverloadedStrings, GeneralizedNewtypeDeriving, diff --git a/src/Network/IMAP.hs b/src/Network/IMAP.hs --- a/src/Network/IMAP.hs +++ b/src/Network/IMAP.hs @@ -76,16 +76,18 @@ import ListT (toList, ListT) import qualified Data.List as L import qualified Debug.Trace as DT +import Data.Default (def) -- |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 +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 def - untaggedRespsQueue <- RQ.newIO 20 + untaggedRespsQueue <- RQ.newIO $ untaggedQueueLength settings responseRequestsQueue <- newTQueueIO connState <- newTVarIO UndefinedState watcherId <- newTVarIO Nothing @@ -96,7 +98,8 @@ connectionContext = context, responseRequests = responseRequestsQueue, serverWatcherThread = watcherId, - outstandingReqs = requests + outstandingReqs = requests, + imapSettings = settings } let conn = IMAPConnection { @@ -127,7 +130,7 @@ liftIO . atomically $ writeTQueue (responseRequests state) responseRequest connectionPut' (rawConnection state) commandLine - readResults responseQ + readResults state responseRequest -- | -- = Connected state commands diff --git a/src/Network/IMAP/RequestWatcher.hs b/src/Network/IMAP/RequestWatcher.hs --- a/src/Network/IMAP/RequestWatcher.hs +++ b/src/Network/IMAP/RequestWatcher.hs @@ -53,7 +53,6 @@ Untagged u -> dispatchUntagged conn requests u liftIO . atomically $ writeTVar (outstandingReqs state) pendingReqs - shouldIDie conn updateConnState :: (MonadIO m, Universe m) => IMAPConnection -> CommandResult -> m () diff --git a/src/Network/IMAP/Types.hs b/src/Network/IMAP/Types.hs --- a/src/Network/IMAP/Types.hs +++ b/src/Network/IMAP/Types.hs @@ -12,6 +12,7 @@ connectionPut, connectionGetChunk') import ListT (ListT) import Control.Monad.IO.Class (liftIO) +import Data.Default (Default, def) -- |A type alias used for an error message type ErrorMessage = T.Text @@ -46,7 +47,9 @@ -- |Id of the thread the watcher executes on serverWatcherThread :: TVar (Maybe ThreadId), -- |All the unfulfilled requests the watcher thread knows about - outstandingReqs :: TVar [ResponseRequest] + outstandingReqs :: TVar [ResponseRequest], + -- |Configuration settings + imapSettings :: IMAPSettings } data ResponseRequest = ResponseRequest { @@ -57,6 +60,13 @@ respRequestId :: CommandId } deriving (Eq) +data IMAPSettings = IMAPSettings { + -- Number of seconds after which request timeouts + imapTimeout :: Int, + -- Length of a queue containing messages we weren't expecting + untaggedQueueLength :: Int +} + data EmailAddress = EmailAddress { emailLabel :: Maybe T.Text, emailAddress :: T.Text @@ -195,6 +205,9 @@ instance Universe (ListT IO) where connectionPut' c d = liftIO $ connectionPut c d connectionGetChunk'' c cont = liftIO $ connectionGetChunk' c cont + +instance Default IMAPSettings where + def = IMAPSettings 30 10 $(derive makeIs ''Flag) $(derive makeIs ''UntaggedResult) diff --git a/src/Network/IMAP/Utils.hs b/src/Network/IMAP/Utils.hs --- a/src/Network/IMAP/Utils.hs +++ b/src/Network/IMAP/Utils.hs @@ -20,25 +20,32 @@ 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 + IMAPState -> ResponseRequest -> m CommandResult +readResults state req@(ResponseRequest resultsQueue requestId) = do + let timeout = imapTimeout . imapSettings $ state + let reqs = outstandingReqs state + + delay <- liftIO . newDelay $ timeout * 1000000 let d_wait = do didComplete <- tryWaitDelay delay if didComplete - then return . Tagged $ TaggedResult { - commandId="noid", - resultState=BAD, - resultRest="Connection timeout" - } + then do + -- Remove current request from the list of outstanding ones + allReqs <- readTVar reqs + writeTVar reqs $ filter (/=req) allReqs + + return . Tagged $ TaggedResult { + commandId=requestId, + 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 + Untagged _ -> return nextResult `mplus` readResults state req escapeText :: T.Text -> T.Text escapeText t = T.replace "{" "\\{" $