tiedote.md/src/TiedoteMD/Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies #-}

module TiedoteMD.Types
    ( Email(..)
    , Error(..)
    , GitOrigin(..)
    , MailID
    , MediaPart(..)
    , Message(..)
    , MessageContent(..)
    , SendJob(..)
    , TiedoteM(..)
    , email
    , emailToByteString
    , emailToMailbox
    , mailIDToMessageID
    , messageIDToMailID
    , renderError
    , renderMailID
    , uniqueMailID
    ) where

import Control.Exception (Exception, displayException)
import Control.Monad.Reader (ReaderT)
import Data.Acid (AcidState)
import Data.ByteString (ByteString)
import Data.CaseInsensitive (original, mk)
import Data.IMF (MessageID, Mailbox(..), AddrSpec(..), Domain(..), mailbox, parseMessageID, parse, renderMessageID, renderMailbox)
import Data.List.NonEmpty (NonEmpty)
import Data.MIME.Charset (defaultCharsets)
import Data.SafeCopy (Migrate(..), base, deriveSafeCopy, extension)
import Data.Semigroup (sconcat)
import Data.Set (Set)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time (UTCTime, getCurrentTime, defaultTimeLocale, formatTime)
import Data.Typeable (Typeable)
import System.Exit (ExitCode)
import System.Process (getCurrentPid)
import Text.Pandoc (PandocError)

import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Text.Pandoc as P

-- Unfortunately we have to define our own types for Email and MessageContent
-- instead of using Mailbox and Pandoc, because they do not implement SafeCopy

newtype TiedoteM s a = TiedoteM (ReaderT (AcidState s) IO a)

data Email = Email
    { emailName :: Maybe Text
    , emailLocalPart :: ByteString
    , emailDomainPart :: Domain'
    } deriving (Show, Eq, Typeable)

data Domain' = DomainDotAtom' (NonEmpty ByteString)
             | DomainLiteral' ByteString
             deriving (Show, Eq, Typeable)

email :: ByteString -> Maybe Email
email = fmap mailboxToEmail . either (const Nothing) Just . parse (mailbox defaultCharsets)

emailToByteString :: Email -> ByteString
emailToByteString = renderMailbox . emailToMailbox

mailboxToEmail :: Mailbox -> Email
mailboxToEmail (Mailbox name (AddrSpec local domain)) = Email
    { emailName = name
    , emailLocalPart = local
    , emailDomainPart = fromDomain domain
    } where fromDomain (DomainDotAtom dotAtoms) = DomainDotAtom' $ fmap original dotAtoms
            fromDomain (DomainLiteral bs) = DomainLiteral' bs

emailToMailbox :: Email -> Mailbox
emailToMailbox Email {..} = Mailbox emailName (AddrSpec emailLocalPart (toDomain emailDomainPart))
    where toDomain (DomainDotAtom' dotAtoms) = DomainDotAtom $ fmap mk dotAtoms
          toDomain (DomainLiteral' bs) = DomainLiteral bs

data Message = Message
    { messageHash :: ByteString
    , previewTo :: [Email]
    , previewTime :: UTCTime
    , sendTime :: UTCTime
    , messageContent :: MessageContent
    , subject :: Text
    , recipients :: [Email]
    , previewMailID :: Maybe MailID
    } deriving (Show, Eq, Typeable)

data MessageContent = MessageContent
    { plainTextMessage :: Text
    , markdownMessage :: Text
    , htmlMessage :: Text
    , mediaParts :: Set MediaPart
    } deriving (Show, Eq, Typeable)

data MediaPart = MediaPart
  -- XXX Ideally purebred-email would implement safecopy and we could use proper types
    { mediaPartMimeType :: ByteString -- ContentTypeWith Parameters
    , mediaPartContentID :: ByteString -- ContentID
    , mediaPartContents :: ByteString
    } deriving (Show, Typeable, Ord)

instance Eq MediaPart where
    MediaPart {mediaPartContentID = a} == MediaPart {mediaPartContentID = b} = a == b

data MessageContent_v0 = MessageContent_v0
    { plainTextMessage :: Text
    , markdownMessage :: Text
    , htmlMessage :: Text
    } deriving (Show, Eq, Typeable)

data SendJob = SendJob
    { sendJobMessage :: Message
    , toSend :: NonEmpty Email
    } deriving (Show, Eq, Typeable)

newtype MailID = MailID ByteString deriving (Show, Eq, Typeable)

uniqueMailID :: Mailbox -> IO MailID
uniqueMailID (Mailbox _ (AddrSpec _ domain)) = do
    time <- formatTime defaultTimeLocale "%s%q" <$> getCurrentTime
    pid <- (show :: Integer -> String) . fromIntegral <$> getCurrentPid
    pure . MailID . encodeUtf8 $
        "<" <> T.intercalate "." (map T.pack [time, pid]) <> "@" <> mailDomain <> ">"
            where mailDomain = case domain of
                    (DomainLiteral bs) -> decodeUtf8 bs
                    (DomainDotAtom atoms) -> sconcat $ NE.intersperse "." $
                        NE.map (decodeUtf8 . original) atoms

mailIDToMessageID :: MailID -> MessageID
mailIDToMessageID (MailID bs) = either error id $ parse parseMessageID bs

messageIDToMailID :: MessageID -> MailID
messageIDToMailID = MailID . renderMessageID

renderMailID :: MailID -> ByteString
renderMailID = renderMessageID . mailIDToMessageID

data GitOrigin = GitOrigin { url :: String, branch :: Maybe String }
    deriving (Show)

data Error = PandocError PandocError
           | NoMeta Text
           | InvalidTime Text
           | InvalidData
           | InvalidEmail Text
           | TemplateError Text
           | EmailParseError Text
           | ProcessError Text ExitCode
           | FileNotFoundError FilePath
           deriving (Show, Typeable)

instance Exception Error where
    displayException = T.unpack . renderError

renderError :: Error -> Text
renderError (PandocError err) = "Pandoc error: " <> P.renderError err
renderError (NoMeta missingKey) = "Metadata field '" <> missingKey <> "' missing"
renderError (InvalidTime text) = "Failed to read '" <> text <> "' as a time"
renderError InvalidData = "Wrong type of data"
renderError (InvalidEmail text) = "Failed to read '" <> text <> "' as an email address"
renderError (TemplateError err) = "Error compiling templates: " <> err
renderError (EmailParseError err) = "Error parsing incoming email: " <> err
renderError (ProcessError process code) = process <> " exited with error code " <> T.pack (show code)
renderError (FileNotFoundError path) = T.pack path <> " not found"


deriveSafeCopy 0 'base ''Domain'
deriveSafeCopy 0 'base ''Email
deriveSafeCopy 0 'base ''MessageContent_v0
deriveSafeCopy 0 'base ''MediaPart

instance Migrate MessageContent where
    type MigrateFrom MessageContent = MessageContent_v0
    migrate MessageContent_v0 {..} = MessageContent {mediaParts = mempty, ..}

deriveSafeCopy 1 'extension ''MessageContent
deriveSafeCopy 0 'base ''MailID
deriveSafeCopy 0 'base ''Message
deriveSafeCopy 0 'base ''SendJob