From 2f47e04206a3869eadc5c93076e0b50d4362f9df Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Fri, 29 Sep 2017 00:11:52 +0200 Subject: Text.Pandoc.Lua: add mediabag submodule --- src/Text/Pandoc/App.hs | 13 ++-- src/Text/Pandoc/Class.hs | 28 +++++--- src/Text/Pandoc/Lua.hs | 36 +++++++++-- src/Text/Pandoc/Lua/PandocModule.hs | 125 ++++++++++++++++++++++++++++++++---- 4 files changed, 166 insertions(+), 36 deletions(-) (limited to 'src') diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs index 206c47b30..82c40f5a4 100644 --- a/src/Text/Pandoc/App.hs +++ b/src/Text/Pandoc/App.hs @@ -850,16 +850,15 @@ expandFilterPath mbDatadir fp = liftIO $ do else return fp _ -> return fp -applyLuaFilters :: MonadIO m - => Maybe FilePath -> [FilePath] -> String -> Pandoc - -> m Pandoc +applyLuaFilters :: Maybe FilePath -> [FilePath] -> String -> Pandoc + -> PandocIO Pandoc applyLuaFilters mbDatadir filters format d = do expandedFilters <- mapM (expandFilterPath mbDatadir) filters - let go f d' = liftIO $ do - res <- E.try (runLuaFilter mbDatadir f format d') + let go f d' = do + res <- runLuaFilter mbDatadir f format d' case res of - Right x -> return x - Left (LuaException s) -> E.throw (PandocFilterError f s) + Right x -> return x + Left (LuaException s) -> E.throw (PandocFilterError f s) foldrM ($) d $ map go expandedFilters applyFilters :: MonadIO m diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index 98c567afc..f60062d6c 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -79,6 +79,7 @@ module Text.Pandoc.Class ( PandocMonad(..) , runPure , readDefaultDataFile , readDataFile + , fetchMediaResource , fillMediaBag , extractMedia , toLang @@ -246,9 +247,9 @@ getMediaBag = getsCommonState stMediaBag insertMedia :: PandocMonad m => FilePath -> Maybe MimeType -> BL.ByteString -> m () insertMedia fp mime bs = do - mb <- getsCommonState stMediaBag + mb <- getMediaBag let mb' = MB.insertMedia fp mime bs mb - modifyCommonState $ \st -> st{stMediaBag = mb' } + setMediaBag mb' getInputFiles :: PandocMonad m => m (Maybe [FilePath]) getInputFiles = getsCommonState stInputFiles @@ -633,6 +634,20 @@ withPaths (p:ps) action fp = catchError (action (p fp)) (\_ -> withPaths ps action fp) +-- | Fetch local or remote resource (like an image) and provide data suitable +-- for adding it to the MediaBag. +fetchMediaResource :: PandocMonad m + => Maybe String -> String + -> m (FilePath, Maybe MimeType, BL.ByteString) +fetchMediaResource sourceUrl src = do + (bs, mt) <- downloadOrRead sourceUrl src + let ext = fromMaybe (takeExtension src) + (mt >>= extensionFromMimeType) + let bs' = BL.fromChunks [bs] + let basename = showDigest $ sha1 bs' + let fname = basename <.> ext + return (fname, mt, bs') + -- | Traverse tree, filling media bag for any images that -- aren't already in the media bag. fillMediaBag :: PandocMonad m => Maybe String -> Pandoc -> m Pandoc @@ -643,13 +658,8 @@ fillMediaBag sourceURL d = walkM handleImage d case lookupMedia src mediabag of Just (_, _) -> return $ Image attr lab (src, tit) Nothing -> do - (bs, mt) <- downloadOrRead sourceURL src - let ext = fromMaybe (takeExtension src) - (mt >>= extensionFromMimeType) - let bs' = BL.fromChunks [bs] - let basename = showDigest $ sha1 bs' - let fname = basename <.> ext - insertMedia fname mt bs' + (fname, mt, bs) <- fetchMediaResource sourceURL src + insertMedia fname mt bs return $ Image attr lab (fname, tit)) (\e -> case e of diff --git a/src/Text/Pandoc/Lua.hs b/src/Text/Pandoc/Lua.hs index ab3b5f4ca..f7e74d0a8 100644 --- a/src/Text/Pandoc/Lua.hs +++ b/src/Text/Pandoc/Lua.hs @@ -39,26 +39,40 @@ import Control.Monad.Trans (MonadIO (..)) import Data.Data (DataType, Data, toConstr, showConstr, dataTypeOf, dataTypeConstrs, dataTypeName, tyconUQname) import Data.Foldable (foldrM) +import Data.IORef (IORef, newIORef, readIORef) import Data.Map (Map) import Data.Maybe (isJust) import Foreign.Lua (Lua, FromLuaStack (peek), LuaException (..), StackIndex, Status (OK), ToLuaStack (push)) +import Text.Pandoc.Class (PandocIO, getMediaBag, setMediaBag) +import Text.Pandoc.MediaBag (MediaBag) import Text.Pandoc.Definition -import Text.Pandoc.Lua.PandocModule (pushPandocModule) +import Text.Pandoc.Lua.PandocModule (pushPandocModule, pushMediaBagModule) import Text.Pandoc.Walk (walkM) import qualified Data.Map as Map import qualified Foreign.Lua as Lua -runLuaFilter :: (MonadIO m) - => Maybe FilePath -> FilePath -> String -> Pandoc -> m Pandoc -runLuaFilter datadir filterPath format pd = liftIO . Lua.runLua $ do +runLuaFilter :: Maybe FilePath -> FilePath -> String + -> Pandoc -> PandocIO (Either LuaException Pandoc) +runLuaFilter datadir filterPath format pd = do + mediaBag <- getMediaBag + mediaBagRef <- liftIO (newIORef mediaBag) + res <- liftIO . Lua.runLuaEither $ + runLuaFilter' datadir filterPath format mediaBagRef pd + newMediaBag <- liftIO (readIORef mediaBagRef) + setMediaBag newMediaBag + return res + +runLuaFilter' :: Maybe FilePath -> FilePath -> String -> IORef MediaBag + -> Pandoc -> Lua Pandoc +runLuaFilter' datadir filterPath format mbRef pd = do Lua.openlibs -- store module in global "pandoc" pushPandocModule datadir Lua.setglobal "pandoc" - push format - Lua.setglobal "FORMAT" + addMediaBagModule + registerFormat top <- Lua.gettop stat <- Lua.dofile filterPath if stat /= OK @@ -71,6 +85,16 @@ runLuaFilter datadir filterPath format pd = liftIO . Lua.runLua $ do when (newtop - top < 1) pushGlobalFilter luaFilters <- peek (-1) runAll luaFilters pd + where + addMediaBagModule = do + Lua.getglobal "pandoc" + push "mediabag" + pushMediaBagModule mbRef + Lua.rawset (-3) + registerFormat = do + push format + Lua.setglobal "FORMAT" + pushGlobalFilter :: Lua () pushGlobalFilter = do diff --git a/src/Text/Pandoc/Lua/PandocModule.hs b/src/Text/Pandoc/Lua/PandocModule.hs index afb9aeca6..ffd681d30 100644 --- a/src/Text/Pandoc/Lua/PandocModule.hs +++ b/src/Text/Pandoc/Lua/PandocModule.hs @@ -15,6 +15,10 @@ You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE CPP #-} +#if !MIN_VERSION_hslua(0,9,0) +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif {- | Module : Text.Pandoc.Lua.PandocModule Copyright : Copyright © 2017 Albert Krewinkel @@ -25,28 +29,37 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Pandoc module for lua. -} -module Text.Pandoc.Lua.PandocModule ( pushPandocModule ) where +module Text.Pandoc.Lua.PandocModule + ( pushPandocModule + , pushMediaBagModule + ) where -import Control.Monad (unless) +import Control.Monad (unless, zipWithM_) import Data.ByteString.Char8 (unpack) import Data.Default (Default (..)) +import Data.IORef import Data.Text (pack) -import Foreign.Lua (Lua, Status (OK), NumResults, call, loadstring, liftIO, - push, pushHaskellFunction, rawset) -import Text.Pandoc.Class (readDataFile, runIO, runIOorExplode, setUserDataDir) +import Foreign.Lua (Lua, FromLuaStack, ToLuaStack, NumResults, liftIO) +import Text.Pandoc.Class (fetchMediaResource, readDataFile, runIO, + runIOorExplode, setUserDataDir) import Text.Pandoc.Options (ReaderOptions(readerExtensions)) import Text.Pandoc.Lua.StackInstances () import Text.Pandoc.Readers (Reader (..), getReader) +import Text.Pandoc.MIME (MimeType) + +import qualified Foreign.Lua as Lua +import qualified Data.ByteString.Lazy as BL +import qualified Text.Pandoc.MediaBag as MB -- | Push the "pandoc" on the lua stack. pushPandocModule :: Maybe FilePath -> Lua () pushPandocModule datadir = do script <- liftIO (pandocModuleScript datadir) - status <- loadstring script - unless (status /= OK) $ call 0 1 - push "__read" - pushHaskellFunction readDoc - rawset (-3) + status <- Lua.loadstring script + unless (status /= Lua.OK) $ Lua.call 0 1 + Lua.push "__read" + Lua.pushHaskellFunction readDoc + Lua.rawset (-3) -- | Get the string representation of the pandoc module pandocModuleScript :: Maybe FilePath -> IO String @@ -56,14 +69,98 @@ pandocModuleScript datadir = unpack <$> readDoc :: String -> String -> Lua NumResults readDoc formatSpec content = do case getReader formatSpec of - Left s -> push s -- Unknown reader + Left s -> Lua.push s -- Unknown reader Right (reader, es) -> case reader of TextReader r -> do res <- liftIO $ runIO $ r def{ readerExtensions = es } (pack content) case res of - Left s -> push $ show s -- error while reading - Right pd -> push pd -- success, push Pandoc - _ -> push "Only string formats are supported at the moment." + Left s -> Lua.push $ show s -- error while reading + Right pd -> Lua.push pd -- success, push Pandoc + _ -> Lua.push "Only string formats are supported at the moment." + return 1 + +-- +-- MediaBag submodule +-- +pushMediaBagModule :: IORef MB.MediaBag -> Lua () +pushMediaBagModule mediaBagRef = do + Lua.newtable + addFunction "insert" (insertMediaFn mediaBagRef) + addFunction "lookup" (lookupMediaFn mediaBagRef) + addFunction "list" (mediaDirectoryFn mediaBagRef) + addFunction "fetch" (insertResource mediaBagRef) + return () + where + addFunction name fn = do + Lua.push name + Lua.pushHaskellFunction fn + Lua.rawset (-3) + +insertMediaFn :: IORef MB.MediaBag + -> FilePath + -> OrNil MimeType + -> BL.ByteString + -> Lua NumResults +insertMediaFn mbRef fp nilOrMime contents = do + liftIO . modifyIORef' mbRef $ MB.insertMedia fp (toMaybe nilOrMime) contents + return 0 + +lookupMediaFn :: IORef MB.MediaBag + -> FilePath + -> Lua NumResults +lookupMediaFn mbRef fp = do + res <- MB.lookupMedia fp <$> liftIO (readIORef mbRef) + case res of + Nothing -> Lua.pushnil *> return 1 + Just (mimeType, contents) -> do + Lua.push mimeType + Lua.push contents + return 2 + +mediaDirectoryFn :: IORef MB.MediaBag + -> Lua NumResults +mediaDirectoryFn mbRef = do + dirContents <- MB.mediaDirectory <$> liftIO (readIORef mbRef) + Lua.newtable + zipWithM_ addEntry [1..] dirContents return 1 + where + addEntry :: Int -> (FilePath, MimeType, Int) -> Lua () + addEntry idx (fp, mimeType, contentLength) = do + Lua.newtable + Lua.push "path" *> Lua.push fp *> Lua.rawset (-3) + Lua.push "type" *> Lua.push mimeType *> Lua.rawset (-3) + Lua.push "length" *> Lua.push contentLength *> Lua.rawset (-3) + Lua.rawseti (-2) idx + +insertResource :: IORef MB.MediaBag + -> String + -> OrNil String + -> Lua NumResults +insertResource mbRef src sourceUrlOrNil = do + (fp, mimeType, bs) <- liftIO . runIOorExplode $ + fetchMediaResource (toMaybe sourceUrlOrNil) src + liftIO $ print (fp, mimeType) + insertMediaFn mbRef fp (OrNil mimeType) bs + +-- +-- Helper types and orphan instances +-- + +newtype OrNil a = OrNil { toMaybe :: Maybe a } + +instance FromLuaStack a => FromLuaStack (OrNil a) where + peek idx = do + noValue <- Lua.isnil idx + if noValue + then return (OrNil Nothing) + else OrNil . Just <$> Lua.peek idx + +#if !MIN_VERSION_hslua(0,9,0) +instance ToLuaStack BL.ByteString where + push = Lua.push . BL.toStrict +instance FromLuaStack BL.ByteString where + peek = fmap BL.fromStrict . Lua.peek +#endif -- cgit v1.2.3