Lisää ReadM-monadi PandocIO-operaatioille

Tällä saadaan pandoc lukemaan tiedostot filestoren Git-tietovarannosta
sekä estettyä niiden lukeminen muualta.

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

@@ -28,6 +28,7 @@
     (inputs (list ghc-acid-state
                   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
+import TiedoteMD.Read (updateMessages)
 import TiedoteMD.Review
 import TiedoteMD.Send
 import TiedoteMD.State

src/TiedoteMD/Read.hs

@@ -1,11 +1,16 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module TiedoteMD.Read where
 
-import Control.Exception (throwIO)
+import Control.Exception (throwIO, catch)
 import Control.Monad ((>=>), join, unless)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, ask)
+import Control.Monad.Except (MonadError)
+import Control.Monad.Trans (lift)
 import Crypto.Hash (hashWith, SHA256(..))
 import Data.Acid (AcidState, update)
 import Data.Bifunctor (first, second)
@@ -13,20 +18,22 @@ import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
 import Data.Default (def)
 import Data.Either (rights, lefts)
-import Data.FileStore (FileStore(..), gitFileStore)
+import Data.FileStore (FileStore(..), Revision(..), FileStoreError(..), gitFileStore)
 import Data.List (singleton, isSuffixOf)
 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.Glob (match, compile)
 import System.IO (hClose)
 import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..))
-import Text.Pandoc (Pandoc(..))
+import Text.Pandoc (Pandoc(..), PandocMonad, PandocIO, PandocError)
 import Text.Pandoc.Readers (readMarkdown)
 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.Text as T
 import qualified Data.Text.IO as T
@@ -51,13 +58,51 @@ readMessageFiles store = do
     pure $ filter ((currentTime <) . sendTime) $ rights messages
 -- TODO: files could be read in parallel instead of sequentially with mapM
 
+newtype ReadM a = ReadM (ReaderT FileStore PandocIO a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader FileStore, MonadError PandocError)
+
+liftPandoc :: PandocIO a -> ReadM a
+liftPandoc = ReadM . lift
+
+runReadM :: FileStore -> ReadM a -> IO (Either PandocError a)
+runReadM store (ReadM m) = Pandoc.runIO $ runReaderT m store
+
+readStoreFile :: FilePath -> ReadM LBS.ByteString
+readStoreFile file = do
+    store <- ask
+    liftIO $ retrieve store file Nothing
+
+instance PandocMonad ReadM where
+    readFileLazy = readStoreFile
+    readFileStrict = fmap LBS.toStrict . readStoreFile
+    getDataFileName = pure
+    getModificationTime file = do
+        store <- ask
+        liftIO $ fmap revDateTime . revision store =<< latest store file
+    fileExists file = do
+        store <- ask
+        liftIO $ (const True <$> latest store file) `catch` \NotFound -> pure False
+    glob pattern = do
+        store <- ask
+        filter (match $ compile 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 = flip (retrieve store) Nothing >=>
-    uncurry parseMessageFile . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
+    uncurry (parseMessageFile store) . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
         where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text)
 
-parseMessageFile :: ByteString -> T.Text -> IO (Either Error Message)
-parseMessageFile hash text = fmap (join . first PandocError) . Pandoc.runIO $ do
+parseMessageFile :: FileStore -> ByteString -> T.Text -> IO (Either Error Message)
+parseMessageFile store hash text = fmap (join . first PandocError) . runReadM store $ do
     pandoc@(Pandoc meta _) <- flip readMarkdown text
         def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions}
     let tiedoteMeta = do

tiedote-md.cabal

@@ -36,6 +36,7 @@ executable tiedote.md
     exit-codes,
     file-embed,
     filestore,
+    Glob,
     hostname,
     lens,
     memory,