IMAP.hs

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