Text.Pandoc.Lua: add mediabag submodule

5 files changed, 173 insertions, 39 deletions

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
diff --git a/test/Tests/Lua.hs b/test/Tests/Lua.hs
index fea813890..ba6196ccb 100644
--- a/test/Tests/Lua.hs
+++ b/test/Tests/Lua.hs
@@ -7,10 +7,11 @@ import Test.Tasty (TestTree, localOption)
 import Test.Tasty.HUnit (Assertion, assertEqual, testCase)
 import Test.Tasty.QuickCheck (ioProperty, testProperty, QuickCheckTests(..))
 import Text.Pandoc.Arbitrary ()
-import Text.Pandoc.Definition (Block, Inline, Meta, Pandoc)
 import Text.Pandoc.Builder ( (<>), bulletList, doc, doubleQuoted, emph
                            , linebreak, rawBlock, singleQuoted, para, plain
                            , space, str, strong)
+import Text.Pandoc.Class (runIOorExplode)
+import Text.Pandoc.Definition (Block, Inline, Meta, Pandoc)
 import Text.Pandoc.Lua
 
 import Foreign.Lua
@@ -80,8 +81,11 @@ tests = map (localOption (QuickCheckTests 20))
 
 assertFilterConversion :: String -> FilePath -> Pandoc -> Pandoc -> Assertion
 assertFilterConversion msg filterPath docIn docExpected = do
-  docRes <- runLuaFilter (Just "../data") ("lua" </> filterPath) [] docIn
-  assertEqual msg docExpected docRes
+  docEither <- runIOorExplode $
+               runLuaFilter (Just "../data") ("lua" </> filterPath) [] docIn
+  case docEither of
+    Left _ -> fail "lua filter failed"
+    Right docRes -> assertEqual msg docExpected docRes
 
 roundtripEqual :: (Eq a, FromLuaStack a, ToLuaStack a) => a -> IO Bool
 roundtripEqual x = (x ==) <$> roundtripped