From 2d5bec9a2d6f3fcc86e6f79fdfcf507838c0250a Mon Sep 17 00:00:00 2001
From: Saku Laesvuori <saku@laesvuori.fi>
Date: Fri, 26 Apr 2024 10:21:59 +0300
Subject: [PATCH] Lue media suhteessa tiedotteen polkuun

---
 src/TiedoteMD/Read.hs | 59 ++++++++++++++++++++++++++++---------------
 1 file changed, 38 insertions(+), 21 deletions(-)

diff --git a/src/TiedoteMD/Read.hs b/src/TiedoteMD/Read.hs
index 4e5bd4b..d54ddb5 100644
--- a/src/TiedoteMD/Read.hs
+++ b/src/TiedoteMD/Read.hs
@@ -9,8 +9,8 @@ module TiedoteMD.Read where
 import Control.Exception (throwIO, catch)
 import Control.Monad ((>=>), join, unless)
 import Control.Monad.IO.Class (liftIO, MonadIO)
-import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, ask)
-import Control.Monad.Except (MonadError)
+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)
@@ -29,10 +29,11 @@ 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(..), PandocMonad, PandocIO, PandocError(..))
 import Text.Pandoc.MediaBag (MediaItem(..), lookupMedia, mediaItems)
 import Text.Pandoc.Readers (readMarkdown)
 import Text.Pandoc.Walk (walkM)
@@ -65,33 +66,49 @@ 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)
+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 -> ReadM a -> IO (Either PandocError a)
-runReadM store (ReadM m) = Pandoc.runIO $ runReaderT m store
+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 <- ask
-    liftIO $ retrieve store file Nothing
+    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 = readStoreFile
-    readFileStrict = fmap LBS.toStrict . readStoreFile
+    readFileLazy = getRealPath >=> readStoreFile
+    readFileStrict = getRealPath >=> fmap LBS.toStrict . readStoreFile
     getDataFileName = pure
     getModificationTime file = do
-        store <- ask
-        liftIO $ fmap revDateTime . revision store =<< latest store file
+        store <- asks fileStoreHandle
+        file' <- getRealPath file
+        liftIO $ fmap revDateTime . revision store =<< latest store file'
     fileExists file = do
-        store <- ask
-        liftIO $ (const True <$> latest store file) `catch` \NotFound -> pure False
+        store <- asks fileStoreHandle
+        file' <- getRealPath file
+        liftIO $ (const True <$> latest store file') `catch` \NotFound -> pure False
     glob pattern = do
-        store <- ask
-        filter (match $ compile pattern) <$> liftIO (index store)
+        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
@@ -104,8 +121,8 @@ instance PandocMonad ReadM where
     logOutput = liftPandoc . Pandoc.logOutput
 
 readMessageFile :: FileStore -> FilePath -> IO (Either Error Message)
-readMessageFile store = flip (retrieve store) Nothing >=>
-    uncurry (parseMessageFile store) . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
+readMessageFile store file = retrieve store file Nothing >>=
+    uncurry (parseMessageFile store file) . addHash . T.filter (/= '\r') . decodeUtf8 . BS.toStrict
         where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text)
 
 cidOf :: MediaItem -> ContentID
@@ -138,8 +155,8 @@ replaceImagesWithCid = Pandoc.fillMediaBag >=> walkM handleImage
               pure $ Pandoc.Image attr lab (cidUrl $ cidOf mediaItem, title)
           handleImage x = pure x
 
-parseMessageFile :: FileStore -> ByteString -> T.Text -> IO (Either Error Message)
-parseMessageFile store hash text = fmap (join . first PandocError) . runReadM store $ do
+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
     let tiedoteMeta = do