OMS/tiedote.md
3
0
Fork 0
Code Issues 14 Pull Requests Projects Releases Wiki Activity

Tuo 'Text.Pandoc' omaan 'Pandoc' nimiavaruuteen

Browse Source
This commit is contained in:
Saku Laesvuori 2024-04-24 16:09:57 +03:00
parent 20775ae1d5
commit dcf00955e9
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
1 changed files with 20 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
src/TiedoteMD/Read.hs
View File

@ -22,7 +22,7 @@ import Data.Time.Format.ISO8601 (iso8601ParseM)
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.IO (hClose) import System.IO (hClose)
import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..)) import System.Process (createProcess, proc, waitForProcess, CreateProcess(..), StdStream(..))
import Text.Pandoc (Pandoc(..), ReaderOptions(..), WriterOptions(..), Meta(..), MetaValue(..), nullMeta, Inline, Block(Plain), runIO, lookupMeta, runPure, pandocExtensions) import Text.Pandoc (Pandoc(..))
import Text.Pandoc.Readers (readMarkdown) import Text.Pandoc.Readers (readMarkdown)
import Text.Pandoc.Writers (writePlain, writeMarkdown, writeHtml5String) import Text.Pandoc.Writers (writePlain, writeMarkdown, writeHtml5String)
@ -30,6 +30,7 @@ import qualified Data.ByteString as BS
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Text.Pandoc as Pandoc
import TiedoteMD.Git import TiedoteMD.Git
import TiedoteMD.State import TiedoteMD.State
@ -56,9 +57,9 @@ readMessageFile store = flip (retrieve store) Nothing >=>
where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text) where addHash text = (convert $ hashWith SHA256 $ encodeUtf8 text, text)
parseMessageFile :: ByteString -> T.Text -> IO (Either Error Message) parseMessageFile :: ByteString -> T.Text -> IO (Either Error Message)
parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do parseMessageFile hash text = fmap (join . first PandocError) . Pandoc.runIO $ do
pandoc@(Pandoc meta _) <- flip readMarkdown text pandoc@(Pandoc meta _) <- flip readMarkdown text
def {readerStandalone = True, readerExtensions = pandocExtensions} def {Pandoc.readerStandalone = True, Pandoc.readerExtensions = Pandoc.pandocExtensions}
let tiedoteMeta = do let tiedoteMeta = do
previewTo <- lookupMeta' "tarkistaja" meta >>= metaToEmails previewTo <- lookupMeta' "tarkistaja" meta >>= metaToEmails
previewTime <- lookupMeta' "deadline" meta >>= metaToTime previewTime <- lookupMeta' "deadline" meta >>= metaToTime
@ -71,7 +72,7 @@ parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
plainTextMessage <- renderHelper writePlain plainTemplate pandoc plainTextMessage <- renderHelper writePlain plainTemplate pandoc
markdownMessage <- renderHelper writeMarkdown markdownTemplate pandoc markdownMessage <- renderHelper writeMarkdown markdownTemplate pandoc
let htmlPandoc = let Pandoc meta' blocks' = pandoc in Pandoc let htmlPandoc = let Pandoc meta' blocks' = pandoc in Pandoc
(Meta $ Map.insertWith (flip const) "pagetitle" (MetaString subject) $ unMeta meta') (Pandoc.Meta $ Map.insertWith (flip const) "pagetitle" (Pandoc.MetaString subject) $ Pandoc.unMeta meta')
blocks' blocks'
htmlMessage <- liftIO . inlineCSS =<< renderHelper writeHtml5String htmlTemplate htmlPandoc htmlMessage <- liftIO . inlineCSS =<< renderHelper writeHtml5String htmlTemplate htmlPandoc
pure $ pure $ Message pure $ pure $ Message
@ -81,11 +82,11 @@ parseMessageFile hash text = fmap (join . first PandocError) . runIO $ do
, previewMailID = Nothing , previewMailID = Nothing
, .. , ..
} }
where renderHelper writer template = writer (writerOpts {writerTemplate = Just template}) where renderHelper writer template = writer (writerOpts {Pandoc.writerTemplate = Just template})
writerOpts = def writerOpts = def
{ writerTOCDepth = 2 { Pandoc.writerTOCDepth = 2
, writerTableOfContents = True , Pandoc.writerTableOfContents = True
, writerSectionDivs = True , Pandoc.writerSectionDivs = True
} }
-- TODO: Store the media somewhere -- TODO: Store the media somewhere
@ -100,7 +101,7 @@ inlineCSS html = do
unless (exitCode == ExitSuccess) $ throwIO $ ProcessError "douceur" exitCode unless (exitCode == ExitSuccess) $ throwIO $ ProcessError "douceur" exitCode
pure inlined pure inlined
metaToTime :: MetaValue -> Either Error UTCTime metaToTime :: Pandoc.MetaValue -> Either Error UTCTime
metaToTime meta = do metaToTime meta = do
textMeta <- metaToTexts meta >>= headOrError textMeta <- metaToTexts meta >>= headOrError
maybe (Left $ InvalidTime textMeta) pure $ maybe (Left $ InvalidTime textMeta) pure $
@ -108,21 +109,21 @@ metaToTime meta = do
where headOrError (x:_) = pure x where headOrError (x:_) = pure x
headOrError _ = Left $ InvalidTime "" headOrError _ = Left $ InvalidTime ""
metaToEmails :: MetaValue -> Either Error [Email] metaToEmails :: Pandoc.MetaValue -> Either Error [Email]
metaToEmails meta = metaToTexts meta >>= mapM metaToEmails meta = metaToTexts meta >>= mapM
(\text -> maybe (Left $ InvalidEmail text) pure $ email $ encodeUtf8 $ T.strip text) (\text -> maybe (Left $ InvalidEmail text) pure $ email $ encodeUtf8 $ T.strip text)
metaToText :: MetaValue -> Either Error T.Text metaToText :: Pandoc.MetaValue -> Either Error T.Text
metaToText = second T.unwords . metaToTexts metaToText = second T.unwords . metaToTexts
metaToTexts :: MetaValue -> Either Error [T.Text] metaToTexts :: Pandoc.MetaValue -> Either Error [T.Text]
metaToTexts (MetaString text) = pure [text] metaToTexts (Pandoc.MetaString text) = pure [text]
metaToTexts (MetaInlines inlines) = second singleton $ inlinesToText inlines metaToTexts (Pandoc.MetaInlines inlines) = second singleton $ inlinesToText inlines
metaToTexts (MetaList metas) = second concat $ mapM metaToTexts metas metaToTexts (Pandoc.MetaList metas) = second concat $ mapM metaToTexts metas
metaToTexts _ = Left InvalidData metaToTexts _ = Left InvalidData
inlinesToText :: [Inline] -> Either Error T.Text inlinesToText :: [Pandoc.Inline] -> Either Error T.Text
inlinesToText = first PandocError . runPure . writeMarkdown def{writerExtensions = pandocExtensions} . Pandoc nullMeta . singleton . Plain inlinesToText = first PandocError . Pandoc.runPure . writeMarkdown def{Pandoc.writerExtensions = Pandoc.pandocExtensions} . Pandoc Pandoc.nullMeta . singleton . Pandoc.Plain
lookupMeta' :: T.Text -> Meta -> Either Error MetaValue lookupMeta' :: T.Text -> Pandoc.Meta -> Either Error Pandoc.MetaValue
lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ lookupMeta key meta lookupMeta' key meta = maybe (Left $ NoMeta key) Right $ Pandoc.lookupMeta key meta