Types.hs

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)
import qualified Pipes as P

-- |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)

isUndefinedState, isConnected, isDisconnected :: ConnectionState -> Bool

isUndefinedState UndefinedState = True; isUndefinedState _ = False
isConnected Connected = True; isConnected _ = False
isDisconnected Disconnected = True; isDisconnected _ = False

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],
  -- |Configuration settings
  imapSettings :: IMAPSettings
}

type ParseResult = Either ErrorMessage CommandResult

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 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,
  emailRoute :: Maybe T.Text,
  emailUsername :: Maybe T.Text,
  emailDomain :: Maybe T.Text
} deriving (Show, Eq)

data Flag = FSeen
          | FAnswered
          | FFlagged
          | FDeleted
          | FDraft
          | FRecent
          | FAny
          | FOther T.Text
  deriving (Show, Eq, Ord)

isFOther, isFAny, isFRecent, isFDraft, isFDeleted, isFFlagged, isFAnswered, isFSeen :: Flag -> Bool
isFOther (FOther _) = True; isFOther _ = False
isFAny FAny = True; isFAny _ = False
isFRecent FRecent = True; isFRecent _ = False
isFDraft FDraft = True; isFDraft _ = False
isFDeleted FDeleted = True; isFDeleted _ = False
isFFlagged FFlagged = True; isFFlagged _ = False
isFAnswered FAnswered = True; isFAnswered _ = False
isFSeen FSeen = True; isFSeen _ = False

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 server side
                      resultState :: !ResultState,
                      -- |Rest of the result, usually the human-readable part
                      resultRest :: T.Text
                    } 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 Integer -- ^ How many messages exist in a mailbox
                    | Expunge Integer -- ^ Sequence id of a deleted message
                    | Bye -- ^ Returned by the server when it cleanly disconnects
                    | HighestModSeq Integer
                    | Recent Integer -- ^ Number of recent messages
                    | Messages Integer -- ^ Number of messages in a mailbox
                    | Unseen Integer -- ^ Number of unseen messages
                    | PermanentFlags [Flag]
                    | UID Integer -- ^ UID of a message
                    | MessageId Integer -- ^ A sequence id of a message
                    -- |UID that will be given to the next message added to this mailbox
                    | UIDNext Integer
                    -- |A triple of mailbox name, it's UIDValidity value and message UID
                    --  is always unique for a given message
                    | UIDValidity Integer
                    | OKResult T.Text -- ^ Result of an OK response
                    | NOResult T.Text -- ^ Result of a NO response
                    | BADResult T.Text -- ^ Result of a BAD 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 [Integer]
                    -- |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 Integer -- ^ Message size
                    | Unknown BSC.ByteString -- ^ An unsupported value
                    | Body BSC.ByteString -- ^ Message body, or headers
                    | BodyStructure BSC.ByteString -- ^ An unparsed bodystructure
                    | Extension BSC.ByteString ExtensionPayload -- ^ A format extension
                    deriving (Show, Eq)

isFlags, isExists, isExpunge, isBye, isHighestModSeq, isRecent, isMessages :: UntaggedResult -> Bool
isUnseen, isPermanentFlags, isUID, isMessageId, isUIDNext, isUIDValidity :: UntaggedResult -> Bool
isOKResult, isNOResult, isBADResult, isCapabilities, isListR, isFetch :: UntaggedResult -> Bool
isStatusR, isSearch, isEnvelope, isInternalDate, isSize, isUnknown :: UntaggedResult -> Bool
isBody, isBodyStructure, isExtension :: UntaggedResult -> Bool

isFlags (Flags _) = True; isFlags _ = False
isExists (Exists{}) = True; isExists _ = False
isExpunge (Expunge _) = True; isExpunge _ = False
isBye Bye = True; isBye _ = False
isHighestModSeq (HighestModSeq _) = True; isHighestModSeq _ = False
isRecent (Recent _) = True; isRecent _ = False
isMessages (Messages _) = True; isMessages _ = False
isUnseen (Unseen _) = True; isUnseen _ = False
isPermanentFlags (PermanentFlags _) = True; isPermanentFlags _ = False
isUID (UID _) = True; isUID _ = False
isMessageId (MessageId _) = True; isMessageId _ = False
isUIDNext (UIDNext _) = True; isUIDNext _ = False
isUIDValidity (UIDValidity _) = True; isUIDValidity _ = False
isOKResult (OKResult _) = True; isOKResult _ = False
isNOResult (NOResult _) = True; isNOResult _ = False
isBADResult (BADResult _) = True; isBADResult _ = False
isCapabilities (Capabilities _) = True; isCapabilities _ = False
isListR (ListR{}) = True; isListR _ = False
isFetch (Fetch{}) = True; isFetch _ = False
isStatusR (StatusR{}) = True; isStatusR _ = False
isSearch (Search{}) = True; isSearch _ = False
isEnvelope (Envelope{}) = True; isEnvelope _ = False
isInternalDate (InternalDate{}) = True; isInternalDate _ = False
isSize (Size{}) = True; isSize _ = False
isUnknown (Unknown{}) = True; isUnknown _ = False
isBody  (Body{}) = True; isBody _ = False
isBodyStructure  (BodyStructure{}) = True; isBodyStructure _ = False
isExtension  (Extension{}) = True; isExtension _ = False

data ExtensionPayload = ExtInt Integer | ExtLabels [BSC.ByteString]
  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)

isTagged, isUntagged :: CommandResult -> Bool
isTagged (Tagged{}) = True; isTagged _ = False
isUntagged (Untagged{}) = True; isUntagged _ = False



-- |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

instance Universe (P.ListT IO) where
  connectionPut' c d = liftIO $ connectionPut c d
  connectionGetChunk'' c cont = liftIO $ connectionGetChunk' c cont

defaultImapSettings :: IMAPSettings
defaultImapSettings = IMAPSettings 30 10