diff --git a/.guix/modules/tiedote-md-package.scm b/.guix/modules/tiedote-md-package.scm index 2ff2595..e6c5c50 100644 --- a/.guix/modules/tiedote-md-package.scm +++ b/.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 diff --git a/src/Main.hs b/src/Main.hs index d3648df..42445cc 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/TiedoteMD/Read.hs b/src/TiedoteMD/Read.hs index 0dfa602..2d8a0c9 100644 --- a/src/TiedoteMD/Read.hs +++ b/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 diff --git a/tiedote-md.cabal b/tiedote-md.cabal index 40a7c67..cff816e 100644 --- a/tiedote-md.cabal +++ b/tiedote-md.cabal @@ -36,6 +36,7 @@ executable tiedote.md exit-codes, file-embed, filestore, + Glob, hostname, lens, memory,