.guix/modules/tiedote-md-package.scm

@@ -26,11 +26,8 @@
                         #:select? vcs-file?))
     (build-system haskell-build-system)
     (inputs (list ghc-acid-state
-                  ghc-attoparsec
-                  ghc-base64
                   ghc-cryptonite
                   ghc-case-insensitive
-                  ghc-glob
                   ghc-purebred-email
                   ghc-optparse-applicative
                   ghc-filestore

src/Main.hs

@@ -26,7 +26,7 @@ import Web.Scotty (scotty, post, liftAndCatchIO, defaultHandler)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy.IO as LT
 
-import TiedoteMD.Read (updateMessages)
+import TiedoteMD.Read
 import TiedoteMD.Review
 import TiedoteMD.Send
 import TiedoteMD.State

src/TiedoteMD/Read.hs

@@ -1,51 +1,35 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module TiedoteMD.Read where
 
-import Control.Exception (throwIO, catch)
+import Control.Exception (throwIO)
 import Control.Monad ((>=>), join, unless)
-import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks)
-import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.Trans (lift)
 import Crypto.Hash (hashWith, SHA256(..))
 import Data.Acid (AcidState, update)
 import Data.Bifunctor (first, second)
 import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
-import "base64" Data.ByteString.Base64.URL
 import Data.Default (def)
-import Data.Either (rights, lefts, fromRight)
+import Data.Either (rights, lefts)
-import Data.FileStore (FileStore(..), Revision(..), FileStoreError(..), gitFileStore)
+import Data.FileStore (FileStore(..), gitFileStore)
-import Data.List (singleton, isSuffixOf)
+import Data.List (singleton)
-import Data.MIME (ContentID, makeContentID, renderContentID)
-import Data.Maybe (fromMaybe)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time (UTCTime, zonedTimeToUTC)
 import Data.Time (getCurrentTime)
 import Data.Time.Format.ISO8601 (iso8601ParseM)
 import System.Exit (ExitCode(..))
-import System.FilePath ((</>), takeDirectory, normalise)
-import System.FilePath.Glob (match, compile)
 import System.IO (hClose)
 import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..))
-import Text.Pandoc (Pandoc(..), PandocMonad, PandocIO, PandocError(..))
+import Text.Pandoc (Pandoc(..), ReaderOptions(..), WriterOptions(..), Meta(..), MetaValue(..), nullMeta, Inline, Block(Plain), runIO, lookupMeta, runPure, pandocExtensions)
-import Text.Pandoc.MediaBag (MediaItem(..), lookupMedia, mediaItems)
 import Text.Pandoc.Readers (readMarkdown)
-import Text.Pandoc.Walk (walkM)
 import Text.Pandoc.Writers (writePlain, writeMarkdown, writeHtml5String)
 
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as Map
-import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
-import qualified Text.Pandoc as Pandoc
 
 import TiedoteMD.Git
 import TiedoteMD.State
@@ -59,106 +43,22 @@ updateMessages acid repoPath =
 readMessageFiles :: FileStore -> IO [Message]
 readMessageFiles store = do
     files <- index store 
-    messages <- mapM (readMessageFile store) $ filter (".md" `isSuffixOf`) files
+    messages <- mapM (readMessageFile store) files
     mapM_ (T.putStrLn . renderError) $ lefts messages
     currentTime <- getCurrentTime
     print currentTime
     pure $ filter ((currentTime <) . sendTime) $ rights messages
 -- TODO: files could be read in parallel instead of sequentially with mapM
 
-newtype ReadM a = ReadM (ReaderT ReadMState PandocIO a)
-    deriving (Functor, Applicative, Monad, MonadIO, MonadReader ReadMState, MonadError PandocError)
-
-data ReadMState = ReadMState
-    { fileStoreHandle :: FileStore
-    , currentFile :: FilePath
-    }
-
-liftPandoc :: PandocIO a -> ReadM a
-liftPandoc = ReadM . lift
-
-runReadM :: FileStore -> FilePath -> ReadM a -> IO (Either PandocError a)
-runReadM store file (ReadM m) = Pandoc.runIO $ runReaderT m $ ReadMState store file
-
-readStoreFile :: FilePath -> ReadM LBS.ByteString
-readStoreFile file = do
-    store <- asks fileStoreHandle
-    errorOrFile <- liftIO $ (Right <$> retrieve store file Nothing)
-        `catch` \NotFound -> pure $ Left $ PandocResourceNotFound $ T.pack file
-    either throwError pure errorOrFile
-
-getCurrentDirectory :: ReadM FilePath
-getCurrentDirectory = takeDirectory <$> asks currentFile
-
-getRealPath :: FilePath -> ReadM FilePath
-getRealPath file = normalise . (</> file) <$> getCurrentDirectory
-
-instance PandocMonad ReadM where
-    readFileLazy = getRealPath >=> readStoreFile
-    readFileStrict = getRealPath >=> fmap LBS.toStrict . readStoreFile
-    getDataFileName = pure
-    getModificationTime file = do
-        store <- asks fileStoreHandle
-        file' <- getRealPath file
-        liftIO $ fmap revDateTime . revision store =<< latest store file'
-    fileExists file = do
-        store <- asks fileStoreHandle
-        file' <- getRealPath file
-        liftIO $ (const True <$> latest store file') `catch` \NotFound -> pure False
-    glob pattern = do
-        store <- asks fileStoreHandle
-        directory <- getCurrentDirectory
-        filter (match $ compile $ directory </> pattern) <$> liftIO (index store)
-    lookupEnv = liftPandoc . Pandoc.lookupEnv
-    getCurrentTime = liftPandoc Pandoc.getCurrentTime
-    getCurrentTimeZone = liftPandoc Pandoc.getCurrentTimeZone
-    newStdGen = liftPandoc Pandoc.newStdGen
-    newUniqueHash = liftPandoc Pandoc.newUniqueHash
-    openURL = liftPandoc . Pandoc.openURL
-    readStdinStrict = pure mempty
-    getCommonState = liftPandoc Pandoc.getCommonState
-    putCommonState = liftPandoc . Pandoc.putCommonState
-    logOutput = liftPandoc . Pandoc.logOutput
-
 readMessageFile :: FileStore -> FilePath -> IO (Either Error Message)
-readMessageFile store file = retrieve store file Nothing >>=
+readMessageFile store = flip (retrieve store) Nothing >=>
-    uncurry (parseMessageFile store file) . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
+    uncurry parseMessageFile . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
         where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text)
 
-cidOf :: MediaItem -> ContentID
+parseMessageFile :: ByteString -> T.Text -> IO (Either Error Message)
-cidOf MediaItem {mediaContents, mediaMimeType} =
+parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
-    fromRight (error "makeContentID failed with valid input!") $
-        makeContentID $ "<" <> encodedHash <> "@tiedote.md.sha256>"
-            where encodedHash = encodeBase64' $ convert $ hashWith SHA256 $
-                      LBS.toStrict mediaContents <> encodeUtf8 mediaMimeType
-
-cidUrl :: ContentID -> T.Text
-cidUrl = mappend "cid:" . stripAngleBrackets . decodeUtf8 . renderContentID
-    where stripAngleBrackets = T.init . T.tail
-          -- The string is always surrounded by < > so this is safe
-
-makeMediaPart :: MediaItem -> MediaPart
-makeMediaPart mediaItem@MediaItem {..} = MediaPart
-    { mediaPartMimeType = encodeUtf8 mediaMimeType
-    , mediaPartContentID = renderContentID $ cidOf mediaItem
-    , mediaPartContents = LBS.toStrict mediaContents
-    }
-
-reconstructMediaItem :: (FilePath, T.Text, LBS.ByteString) -> MediaItem
-reconstructMediaItem (mediaPath, mediaMimeType, mediaContents) = MediaItem {..}
-
-replaceImagesWithCid :: PandocMonad m => Pandoc -> m Pandoc
-replaceImagesWithCid = Pandoc.fillMediaBag >=> walkM handleImage
-    where handleImage (Pandoc.Image attr lab (src, title)) = do
-              mediaItem <- (\media -> fromMaybe (error $ "fillMediaBag left an image uncollected! impossible!")
-                           $ lookupMedia (T.unpack src) media) <$> Pandoc.getMediaBag
-              pure $ Pandoc.Image attr lab (cidUrl $ cidOf mediaItem, title)
-          handleImage x = pure x
-
-parseMessageFile :: FileStore -> FilePath -> ByteString -> T.Text -> IO (Either Error Message)
-parseMessageFile store file hash text = fmap (join . first PandocError) . runReadM store file $ do
     pandoc@(Pandoc meta _) <- flip readMarkdown text
-        def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions} >>= replaceImagesWithCid
+        def {readerStandalone = True, readerExtensions = pandocExtensions}
     let tiedoteMeta = do
             previewTo <- lookupMeta' "tarkistaja" meta >>= metaToEmails
             previewTime <- lookupMeta' "deadline" meta >>= metaToTime
@@ -171,10 +71,9 @@ parseMessageFile store file hash text = fmap (join . first PandocError) . runRea
           plainTextMessage <- renderHelper writePlain plainTemplate pandoc
           markdownMessage <- renderHelper writeMarkdown markdownTemplate pandoc
           let htmlPandoc = let Pandoc meta' blocks' = pandoc in Pandoc
-                  (Pandoc.Meta $ Map.insertWith (flip const) "pagetitle" (Pandoc.MetaString subject) $ Pandoc.unMeta meta')
+                  (Meta $ Map.insertWith (flip const) "pagetitle" (MetaString subject) $ unMeta meta')
                   blocks'
           htmlMessage <- liftIO . inlineCSS =<< renderHelper writeHtml5String htmlTemplate htmlPandoc
-          mediaParts <- Set.fromList . map (makeMediaPart . reconstructMediaItem) . mediaItems <$> Pandoc.getMediaBag
           pure $ pure $ Message
             { recipients = []
             , messageHash = hash
@@ -182,12 +81,13 @@ parseMessageFile store file hash text = fmap (join . first PandocError) . runRea
             , previewMailID = Nothing
             , ..
             }
-        where renderHelper writer template = writer (writerOpts {Pandoc.writerTemplate = Just template})
+        where renderHelper writer template = writer (writerOpts {writerTemplate = Just template})
               writerOpts = def
-                  { Pandoc.writerTOCDepth = 2
+                  { writerTOCDepth = 2
-                  , Pandoc.writerTableOfContents = True
+                  , writerTableOfContents = True
-                  , Pandoc.writerSectionDivs = True
+                  , writerSectionDivs = True
                   }
+    -- TODO: Store the media somewhere
 
 inlineCSS :: T.Text -> IO T.Text
 inlineCSS html = do
@@ -200,7 +100,7 @@ inlineCSS html = do
     unless (exitCode == ExitSuccess) $ throwIO $ ProcessError "douceur" exitCode
     pure inlined
 
-metaToTime :: Pandoc.MetaValue -> Either Error UTCTime
+metaToTime :: MetaValue -> Either Error UTCTime
 metaToTime meta = do
     textMeta <- metaToTexts meta >>= headOrError
     maybe (Left $ InvalidTime textMeta) pure $
@@ -208,21 +108,21 @@ metaToTime meta = do
             where headOrError (x:_) = pure x
                   headOrError _ = Left $ InvalidTime ""
 
-metaToEmails :: Pandoc.MetaValue -> Either Error [Email]
+metaToEmails :: MetaValue -> Either Error [Email]
 metaToEmails meta = metaToTexts meta >>= mapM
     (\text -> maybe (Left $ InvalidEmail text) pure $ email $ encodeUtf8 $ T.strip text)
 
-metaToText :: Pandoc.MetaValue -> Either Error T.Text
+metaToText :: MetaValue -> Either Error T.Text
 metaToText = second T.unwords . metaToTexts
 
-metaToTexts :: Pandoc.MetaValue -> Either Error [T.Text]
+metaToTexts :: MetaValue -> Either Error [T.Text]
-metaToTexts (Pandoc.MetaString text) = pure [text]
+metaToTexts (MetaString text) = pure [text]
-metaToTexts (Pandoc.MetaInlines inlines) = second singleton $ inlinesToText inlines
+metaToTexts (MetaInlines inlines) = second singleton $ inlinesToText inlines
-metaToTexts (Pandoc.MetaList metas) = second concat $ mapM metaToTexts metas
+metaToTexts (MetaList metas) = second concat $ mapM metaToTexts metas
 metaToTexts _ = Left InvalidData
 
-inlinesToText :: [Pandoc.Inline] -> Either Error T.Text
+inlinesToText :: [Inline] -> Either Error T.Text
-inlinesToText = first PandocError . Pandoc.runPure . writeMarkdown def{Pandoc.writerExtensions = Pandoc.pandocExtensions} . Pandoc Pandoc.nullMeta . singleton . Pandoc.Plain
+inlinesToText = first PandocError . runPure . writeMarkdown def{writerExtensions = pandocExtensions} . Pandoc nullMeta . singleton . Plain
 
-lookupMeta' :: T.Text -> Pandoc.Meta -> Either Error Pandoc.MetaValue
+lookupMeta' :: T.Text -> Meta -> Either Error MetaValue
-lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ Pandoc.lookupMeta key meta
+lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ lookupMeta key meta

src/TiedoteMD/Review.hs

@@ -54,8 +54,7 @@ managePreviews acid sender sendmailPath = forever $ do
       Just msg@(Message {..}) -> do
           mailID <- uniqueMailID sender
           boundary <- getStdRandom uniform
-          boundary' <- getStdRandom uniform
+          let mail = renderMessage' "Esikatselu: " (Just mailID) msg sender boundary
-          let mail = renderMessage' "Esikatselu: " (Just mailID) msg sender boundary boundary'
           sendmail sendmailPath $ toLazyByteString $ buildMessage $
               set (headerTo defaultCharsets) (map (Single . emailToMailbox) previewTo) mail
           update acid $ SetPreviewID messageHash mailID

src/TiedoteMD/Send.hs

@@ -5,14 +5,12 @@ module TiedoteMD.Send where
 
 import Control.Concurrent (threadDelay)
 import Control.Exception (throwIO)
-import Control.Lens (set, _Just)
+import Control.Lens (set)
 import Control.Monad (forever, unless)
 import Data.Acid (AcidState, query, update)
-import Data.Attoparsec.ByteString (endOfInput, parseOnly)
 import Data.Binary.Builder (toLazyByteString)
-import Data.MIME (Address(..), Mailbox, Boundary, MIMEMessage, MIME(..), Headers(..), MultipartSubtype(..), ContentTypeWith(..), DispositionType(..), buildMessage, headerTo, headerSubject, headerFrom, headerMessageID, headerContentID, header, createTextPlainMessage, contentType, contentDisposition, dispositionType, createAttachment, parseContentType, makeContentID)
+import Data.MIME (Address(..), Mailbox, Boundary, MIMEMessage, MIME(..), Headers(..), MultipartSubtype(..), buildMessage, headerTo, headerSubject, headerFrom, headerMessageID, header, createTextPlainMessage, contentType)
 import Data.MIME.Charset (defaultCharsets)
-import Data.Set (Set)
 import Data.Time (getCurrentTime)
 import System.Exit (ExitCode(..))
 import System.Exit.Codes (codeTempFail)
@@ -23,7 +21,6 @@ import System.Random (getStdRandom, uniform)
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.IMF as IMF
 import qualified Data.List.NonEmpty as NE
-import qualified Data.Set as Set
 import qualified Data.Text as T
 
 import TiedoteMD.State
@@ -45,8 +42,7 @@ manageQueue acid sender sendmailPath = forever $ do
       Nothing -> pure ()
       Just (address, message) -> do
           boundary <- getStdRandom uniform
-          boundary' <- getStdRandom uniform
+          let mail = renderMessage message sender boundary
-          let mail = renderMessage message sender boundary boundary'
           sendmail sendmailPath $ toLazyByteString $ buildMessage $
               set (headerTo defaultCharsets) [Single $ emailToMailbox address] mail
           update acid MarkMessageAsSent
@@ -62,11 +58,11 @@ manageQueueingMessages acid = forever $ do
 queueMessages :: AcidState State -> IO ()
 queueMessages acid = getCurrentTime >>= update acid . MoveToSendQueue
 
-renderMessage :: Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
+renderMessage :: Message -> Mailbox -> Boundary -> MIMEMessage
 renderMessage = renderMessage' "" Nothing
 
-renderMessage' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> Boundary -> MIMEMessage
+renderMessage' :: T.Text -> Maybe MailID -> Message -> Mailbox -> Boundary -> MIMEMessage
-renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary boundary' =
+renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageContent {..},..}) sender boundary =
     maybe id (set headerMessageID . Just . mailIDToMessageID) maybeMailID $
     set (headerSubject defaultCharsets) (Just $ subjectPrefix <> subject) $
     set (header "Precedence") "Bulk" $
@@ -75,25 +71,12 @@ renderMessage' subjectPrefix maybeMailID (Message {messageContent = MessageConte
     IMF.Message (Headers []) $ Multipart Alternative boundary $ NE.fromList
         [ createTextPlainMessage plainTextMessage
         , createTextMarkdownMessage markdownMessage
-        , createTextHtmlMessage boundary' mediaParts htmlMessage
+        , createTextHtmlMessage htmlMessage
         ]
 
 createTextMarkdownMessage :: T.Text -> MIMEMessage
 createTextMarkdownMessage = set contentType "text/markdown; charset=utf-8; variant=pandoc" . createTextPlainMessage
 
-createTextHtmlMessage :: Boundary -> Set MediaPart -> T.Text -> MIMEMessage
+createTextHtmlMessage :: T.Text -> MIMEMessage
-createTextHtmlMessage boundary mediaParts html = IMF.Message (Headers []) $ multipartRelated $
+createTextHtmlMessage = set contentType "text/html; charset=utf-8" . createTextPlainMessage
-    (set contentType "text/html; charset=utf-8" $ createTextPlainMessage html) NE.:| mediaAttachments
+-- TODO: multipart/related with media
-        where multipartRelated = Multipart
-                  (Related (Just $ ContentType "text" "html" ()) Nothing Nothing) boundary
-              mediaAttachments = mediaPartToAttachment <$> Set.toList mediaParts
-
-mediaPartToAttachment :: MediaPart -> MIMEMessage
-mediaPartToAttachment MediaPart {..} =
-    set (contentDisposition . _Just . dispositionType) Inline $
-    set headerContentID (Just contentID) $
-    createAttachment mimeType Nothing mediaPartContents
-        where mimeType = either (error "purebred-email couldn't parse pandoc's mime type!") id $
-                  parseOnly (parseContentType <* endOfInput) mediaPartMimeType
-              contentID = either (error "purebred-email couldn't parse it's own contentID!") id $
-                  makeContentID mediaPartContentID

src/TiedoteMD/Types.hs

@@ -1,14 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE TypeFamilies #-}
 
 module TiedoteMD.Types
     ( Email(..)
     , Error(..)
     , MailID
-    , MediaPart(..)
     , Message(..)
     , MessageContent(..)
     , SendJob(..)
@@ -31,9 +28,8 @@ 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.SafeCopy (base, deriveSafeCopy)
 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)
@@ -92,23 +88,6 @@ data Message = Message
     } 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
@@ -169,14 +148,7 @@ renderError (FileNotFoundError path) = T.pack path <> " not found"
 
 deriveSafeCopy 0 'base ''Domain'
 deriveSafeCopy 0 'base ''Email
-deriveSafeCopy 0 'base ''MessageContent_v0
+deriveSafeCopy 0 'base ''MessageContent
-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

tiedote-md.cabal

@@ -23,9 +23,7 @@ source-repository head
 executable tiedote.md
   build-depends:
     acid-state,
-    attoparsec,
     base,
-    base64,
     binary,
     bytestring,
     case-insensitive,
@@ -37,9 +35,7 @@ executable tiedote.md
     doctemplates,
     exit-codes,
     file-embed,
-    filepath,
     filestore,
-    Glob,
     hostname,
     lens,
     memory,
@@ -47,7 +43,6 @@ executable tiedote.md
     network,
     optparse-applicative,
     pandoc,
-    pandoc-types,
     process,
     purebred-email,
     random,