pandoc_rb 0.2.2

data/ext/pandoc_rb/pandoc-rb.cabal

@@ -0,0 +1,74 @@
+name:          pandoc-rb
+version:       0.1.0.0
+synopsis:      Call pandoc from ruby using the FFI
+description:   This package provides C exports made for use by Ruby for calling Pandoc
+homepage:      https://github.com/michaeljklein/pandoc_rb
+license:       BSD3
+author:        Michael Klein
+maintainer:    lambdamichael@gmail.com
+category:      FFI
+build-type:    Simple
+cabal-version: >=1.10
+
+executable PandocRb.dylib
+  main-is: PandocRb.hs
+  other-extensions:    ForeignFunctionInterface
+  build-depends:       base >= 4.7 && < 5
+                     , pandoc-rb
+                     , bytestring
+                     , either
+                     , pandoc
+                     , pandoc-types
+                     , storable-tuple
+                     , transformers
+                     , aeson
+                     , parsec
+  hs-source-dirs:      src
+  other-modules:       Text.Pandoc.C
+                     , Text.Pandoc.C.Types
+                     , Text.Pandoc.C.Utils
+  default-language:    Haskell2010
+  include-dirs:        src
+  ghc-options:         -O3 -shared -fPIC -dynamic -Wall
+  extra-libraries:     HSrts-ghc8.0.2
+
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Text.Pandoc.C
+                     , Text.Pandoc.C.Types
+                     , Text.Pandoc.C.Utils
+  build-depends:       base >= 4.7 && < 5
+                     , bytestring
+                     , either
+                     , pandoc == 1.19.2.1337
+                     , pandoc-types
+                     , storable-tuple
+                     , transformers
+                     , aeson
+                     , parsec
+  ghc-options:         -O3 -Wall
+  default-language:    Haskell2010
+
+test-suite pandoc-rb-test
+  type:                detailed-0.9
+  hs-source-dirs:      test
+  test-module:         DetailedSpec
+  build-depends:       base >= 4.7 && < 5
+                     , Cabal >= 1.20.0
+                     , QuickCheck
+                     , bytestring
+                     , either
+                     , pandoc == 1.19.2.1337
+                     , pandoc-types
+                     , pandoc-rb
+                     , storable-tuple
+                     , transformers
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/michaeljklein/pandoc_rb
+
+

data/ext/pandoc_rb/pandoc_rb.c

@@ -0,0 +1,100 @@
+#include <stdio.h>
+#include "ruby.h"
+#include "HsFFI.h"
+#include "PandocRb_stub.h"
+
+VALUE PandocRb = Qnil;
+
+void Init_pandoc_rb();
+
+// a global designating whether the haskell runtime has been initialized
+int hs_inited = 0;
+
+VALUE method_convert_init(VALUE self);
+VALUE method_convert_exit(VALUE self);
+VALUE method_convert_raw(VALUE self, VALUE in_format, VALUE out_format, VALUE input, VALUE extract_media_path);
+
+void Init_pandoc_rb() {
+  PandocRb = rb_define_module("PandocRb");
+  rb_define_module_function(PandocRb, "convert_init", method_convert_init, 0);
+  rb_define_module_function(PandocRb, "convert_exit", method_convert_exit, 0);
+  rb_define_module_function(PandocRb, "convert_raw" , method_convert_raw , 4);
+}
+
+VALUE method_convert_init(VALUE self) {
+  if (hs_inited) {
+    printf("pandoc_rb warning: Called convert_init after init\n");
+  } else {
+    hs_init(NULL, NULL);
+    hs_inited = 1;
+  }
+  return Qnil;
+}
+
+VALUE method_convert_exit(VALUE self) {
+  if (hs_inited) {
+    hs_exit();
+    hs_inited = 0;
+  } else {
+    printf("pandoc_rb warning: Called convert_exit before init\n");
+  }
+  return Qnil;
+}
+
+// Only checks whether inputs are strings, has no defaults and niether inits nor exits
+VALUE method_convert_raw(VALUE self, VALUE in_format, VALUE out_format, VALUE input, VALUE extract_media_path) {
+  char * in_format_ptr;
+  char * out_format_ptr;
+  char * input_ptr;
+  char * extract_media_path_ptr;
+  long in_format_len;
+  long out_format_len;
+  long input_len;
+  long extract_media_path_len;
+
+  void * output_ptr;
+
+  VALUE success;
+  VALUE result_str;
+  VALUE result_pair;
+
+  SafeStringValue(in_format);
+  SafeStringValue(out_format);
+  SafeStringValue(input);
+  SafeStringValue(extract_media_path);
+  in_format_ptr          = StringValuePtr(in_format);
+  out_format_ptr         = StringValuePtr(out_format);
+  input_ptr              = StringValuePtr(input);
+  extract_media_path_ptr = StringValuePtr(extract_media_path);
+  in_format_len          = RSTRING_LEN(in_format);
+  out_format_len         = RSTRING_LEN(out_format);
+  input_len              = RSTRING_LEN(input);
+  extract_media_path_len = RSTRING_LEN(extract_media_path);
+
+  output_ptr = convert_hs(in_format_ptr,          in_format_len,
+                          out_format_ptr,         out_format_len,
+                          input_ptr,              input_len,
+                          extract_media_path_ptr, extract_media_path_len);
+
+  RB_GC_GUARD(in_format);
+  RB_GC_GUARD(out_format);
+  RB_GC_GUARD(input);
+  RB_GC_GUARD(extract_media_path);
+
+  if (result_success(output_ptr)) {
+    success = Qtrue;
+  } else {
+    success = Qfalse;
+  }
+  result_str = rb_utf8_str_new(result_ptr(output_ptr), result_len(output_ptr));
+
+  free_result(output_ptr);
+
+  result_pair = rb_ary_new_from_args(2, success, result_str);
+
+  RB_GC_GUARD(success);
+  RB_GC_GUARD(result_str);
+
+  return result_pair;
+}     
+

data/ext/pandoc_rb/src/PandocRb.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module PandocRb where
+
+import Foreign.C.Types            (CChar, CLong(..), CInt(..))
+import Foreign.Ptr                (Ptr)
+import Text.Pandoc.C              (convert_hs, result_success, result_ptr, result_len, free_result)
+
+
+foreign export ccall convert_hs     :: Ptr CChar -> CLong -> Ptr CChar -> CLong -> Ptr CChar -> CLong -> Ptr CChar -> CLong -> IO (Ptr (CInt, Ptr CChar, CLong))
+
+foreign export ccall result_success :: Ptr (CInt, Ptr CChar, CLong) -> IO CInt
+
+foreign export ccall result_ptr     :: Ptr (CInt, Ptr CChar, CLong) -> IO (Ptr CChar)
+
+foreign export ccall result_len     :: Ptr (CInt, Ptr CChar, CLong) -> IO CLong
+
+foreign export ccall free_result    :: Ptr (CInt, Ptr CChar, CLong) -> IO ()
+

data/ext/pandoc_rb/src/Text/Pandoc/C.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Text.Pandoc.C where
+
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Either (EitherT(..))
+import Data.Bifunctor             (bimap, second)
+import Data.ByteString            (useAsCStringLen)
+import Data.ByteString.Lazy       (toStrict, fromStrict)
+import Data.ByteString.Unsafe     (unsafePackCStringLen)
+import Data.Monoid                ((<>))
+import Foreign.C.String           (CStringLen, peekCStringLen, newCStringLen)
+import Foreign.C.Types            (CChar, CLong(..), CInt(..))
+import Foreign.Marshal.Alloc      (malloc, free)
+import Foreign.Ptr                (Ptr)
+import Foreign.Storable           (peek, poke)
+import Foreign.Storable.Tuple     ()
+import Text.Pandoc                (ReaderOptions, WriterOptions(..), Reader(..), Writer(..), HTMLMathMethod(..), writerMediaBag, getReader, getWriter, def)
+
+import Text.Pandoc.C.Utils
+import Text.Pandoc.C.Types
+
+
+-- | Convert a `Reader` to a `CReader`
+mkCReader :: Reader -> CReader
+mkCReader  !(StringReader     reader) !opts !cstr = mapML showPandocError . EitherT $ do
+  str          <- peekCStringLen cstr
+  readerResult <- reader opts str
+  return $ second (, mempty) $! readerResult
+mkCReader ~(ByteStringReader  reader) !opts  str = mapML showPandocError . EitherT $ do
+  bs           <- unsafePackCStringLen str
+  readerResult <- reader opts $! fromStrict bs
+  return readerResult
+
+
+-- | Convert a `Writer` to a `CWriter`
+mkCWriter :: Writer -> CWriter
+mkCWriter !(PureStringWriter   writer) !opts !pandoc = lift $ newCStringLen (writer opts pandoc)
+mkCWriter !(IOStringWriter     writer) !opts !pandoc = lift $ writer opts pandoc >>= newCStringLen
+mkCWriter !(IOByteStringWriter writer) !opts !pandoc = lift $ writer opts pandoc >>= flip useAsCStringLen return . toStrict
+
+
+-- | `getReader` for foreign C exports. Retrieve reader based on formatSpec (format+extensions).
+getCReader :: CStringLen -> EitherT CStringLen IO CReader
+getCReader !cstr = do
+  str <- lift . peekCStringLen $! cstr
+  EitherT $ case getReader str of
+    ( Left  err   ) ->     Left  <$> newCStringLen err
+    ~(Right reader) -> return . Right $! mkCReader reader
+
+-- | `getWriter` for foreign C exports. Retrieve writer based on formatSpec (format+extensions).
+getCWriter :: CStringLen -> EitherT CStringLen IO CWriter
+getCWriter !cstr = do
+  str <- lift $ peekCStringLen cstr
+  EitherT $ case getWriter str of
+    ( Left  err   ) ->      Left <$> newCStringLen err
+    ~(Right writer) -> return . Right $! mkCWriter writer
+
+
+-- | The main conversion function.
+-- Takes `ReaderOptions`, `WriterOptions`, reader's formatSpec,
+-- writer's formatSpec, input and returns either an error string
+-- or the output
+convert :: ReaderOptions
+        -> WriterOptions
+        -> CStringLen                       -- ^ Reader specification
+        -> CStringLen                       -- ^ Writer specification
+        -> CStringLen                       -- ^ Input
+        -> CStringLen                       -- ^ Extract media dir
+        -> EitherT CStringLen IO CStringLen -- ^ Either an error string or the output
+convert !readerOpts !writerOpts !readerStr !writerStr !input !mediaBagStr = do
+  reader             <- getCReader $! readerStr
+  (pandoc, mediaBag) <- reader readerOpts $! input
+  pandoc'            <- extractCMediabag mediaBagStr mediaBag pandoc
+  writer             <- getCWriter $! writerStr
+  let writerOpts'    = writerOpts { writerMediaBag = writerMediaBag writerOpts <> mediaBag }
+  writer writerOpts' pandoc'
+
+
+-- | The `ReaderOptions` wired into the foreign export
+readerOptions :: ReaderOptions
+readerOptions = def
+
+-- | The `WriterOptions` wired into the foreign export
+writerOptions :: WriterOptions
+writerOptions = def { writerHTMLMathMethod = MathJax "https://fail.cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" }
+
+
+-- | Takes: reader, writer, input and returns (isSuccess, output pointer, output length)
+convert_hs :: Ptr CChar                         -- ^ reader format pointer
+           -> CLong                             -- ^ reader format length
+           -> Ptr CChar                         -- ^ writer format pointer
+           -> CLong                             -- ^ writer format length
+           -> Ptr CChar                         -- ^ input pointer
+           -> CLong                             -- ^ input length
+           -> Ptr CChar                         -- ^ media extraction path pointer
+           -> CLong                             -- ^ media extraction path length
+           -> IO (Ptr (CInt, Ptr CChar, CLong)) -- ^ Pointer to @(success, output pointer, output length)@
+convert_hs !readerStr !readerLen !writerStr !writerLen !input !inputLen !mediaBagStr !mediaBagLen = do
+  let readerStr'                    =  (readerStr  , fromEnum readerLen  )
+  let writerStr'                    =  (writerStr  , fromEnum writerLen  )
+  let input'                        =  (input      , fromEnum inputLen   )
+  let mediaBagStr'                  =  (mediaBagStr, fromEnum mediaBagLen)
+  let converted                     =  convert readerOptions writerOptions readerStr' writerStr' input' mediaBagStr'
+  let EitherT safeConverted         =  timeoutEitherT (10 * {- minutes -} 60000000) converted
+  result                            <- bimap (second toEnum) (second toEnum) <$> safeConverted
+  let (success, (rstrPtr, rstrLen)) =  either (0,) (1,) result
+  addr                              <- malloc
+  addr `poke` (success, rstrPtr, rstrLen)
+  return addr
+
+
+-- | Extract the success value from a result pointer
+result_success :: Ptr (CInt, Ptr CChar, CLong) -> IO CInt
+result_success addr = do
+  (success, _, _) <- peek addr
+  return success
+
+-- | Extract the pointer to the result string from a result pointer
+result_ptr :: Ptr (CInt, Ptr CChar, CLong) -> IO (Ptr CChar)
+result_ptr addr = do
+  (_, ptr, _) <- peek addr
+  return ptr
+
+-- | Extract the length (in bytes) of the result string from a result pointer
+result_len :: Ptr (CInt, Ptr CChar, CLong) -> IO CLong
+result_len addr = do
+  (_, _, len) <- peek addr
+  return len
+
+-- | Free a result pointer. Note: This only frees the struct that wraps the
+-- result values, it does not free the result string's memory
+free_result :: Ptr (CInt, Ptr CChar, CLong) -> IO ()
+free_result addr = do
+  -- (_, ptr, _) <- peek addr -- this is commented out because the caller manages it
+  -- free ptr
+  free addr
+  return ()
+
+

data/ext/pandoc_rb/src/Text/Pandoc/C/Types.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Text.Pandoc.C.Types where
+
+import Control.Monad.Trans.Either (EitherT(..))
+import Data.Aeson                 (ToJSON(..), genericToEncoding, defaultOptions, genericToJSON, encode)
+import Data.ByteString.Lazy       (toStrict)
+import Data.ByteString            (useAsCStringLen)
+import Foreign.C.String           (CStringLen)
+import Foreign.C.Types            (CChar, CLong(..))
+import Foreign.Ptr                (Ptr)
+import GHC.Generics               (Generic)
+import Text.Pandoc                (ReaderOptions, Pandoc, WriterOptions(..), PandocError(..))
+import Text.Pandoc.MediaBag       (MediaBag)
+import Text.Parsec.Error          (ParseError, Message(..), errorPos, errorMessages)
+import Text.Parsec.Pos            (SourcePos, SourceName, Line, Column, sourceName, sourceLine, sourceColumn)
+
+
+-- | The `Reader` type modified for foreign C exports
+type CReader = ReaderOptions -> CStringLen -> EitherT CStringLen IO (Pandoc, MediaBag)
+
+-- | The `Writer` type modified for foreign C exports
+type CWriter = WriterOptions -> Pandoc -> EitherT CStringLen IO CStringLen
+
+
+-- | A clone of `SourcePos`, to allow deriving `Generic`
+data SourcePos' = SourcePos' SourceName !Line !Column deriving (Eq, Ord, Show, Generic)
+
+instance ToJSON SourcePos' where
+  toEncoding = genericToEncoding defaultOptions
+
+deriving instance Generic Message
+
+instance ToJSON Message where
+  toEncoding = genericToEncoding defaultOptions
+
+-- | A clone of `ParseError`, to allow deriving `Generic`
+data ParseError' = ParseError' !SourcePos' [Message] deriving (Generic)
+
+-- | Convert to our clone of `SourcePos`
+sourcePos' :: SourcePos -> SourcePos'
+sourcePos' !sp = SourcePos' (sourceName sp) (sourceLine sp) (sourceColumn sp)
+
+-- | Convert to our clone of `ParseError`
+parseError' :: ParseError -> ParseError'
+parseError' !pe = ParseError' (sourcePos' (errorPos pe)) (errorMessages pe)
+
+
+instance ToJSON ParseError where
+  toJSON = genericToJSON defaultOptions . parseError'
+  toEncoding = genericToEncoding defaultOptions . parseError'
+
+instance ToJSON PandocError where
+    toEncoding = genericToEncoding defaultOptions
+
+-- | Convert a `PandocError` to JSON
+showPandocError :: PandocError -> IO CStringLen
+showPandocError = flip useAsCStringLen return . toStrict . encode
+
+
+-- | `CStringLen` for use by Ruby
+type RStringLen = (Ptr CChar, CLong)
+
+
+
+

data/ext/pandoc_rb/src/Text/Pandoc/C/Utils.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Text.Pandoc.C.Utils where
+
+import Control.Concurrent
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Either (EitherT(..))
+import Foreign.C.String           (CStringLen, peekCStringLen, newCStringLen)
+import System.Timeout             (timeout)
+import Text.Pandoc                (Pandoc, Inline(..))
+import Text.Pandoc.MediaBag       (MediaBag, extractMediaBag, mediaDirectory)
+import Text.Pandoc.Walk           (walk)
+
+
+-- | Apply a monadic action to the left of an `EitherT`
+mapML :: Monad m => (a -> m b) -> EitherT a m c -> EitherT b m c
+mapML !f !(EitherT m) = EitherT $ do
+  m' <- m
+  case m' of
+    ( Left  x) ->     Left  <$> f x
+    ~(Right y) -> return $ Right     y
+
+-- | Apply a monadic action to the right of an `EitherT`
+mapMR :: Monad m => (b -> m c) -> EitherT a m b -> EitherT a m c
+mapMR !f !(EitherT m) = EitherT $ do
+  m' <- m
+  case m' of
+    ( Left  x) -> return $ Left      x
+    ~(Right y) ->     Right <$> f y
+
+
+-- | This function forks a thread to both catch exceptions and better kill infinite loops that can't be caught with `timeout` alone.
+-- For example, @timeout 10 (forever $ return ())@ will never time out, but @timeoutEitherT 10 (lift $ forever $ return ())@ will.
+--
+-- timeoutEitherT is strict within the created thread
+timeoutEitherT :: Int -> EitherT CStringLen IO b -> EitherT CStringLen IO b
+timeoutEitherT !us !(EitherT io) = EitherT $ do
+  mvar   <- newEmptyMVar
+  tid    <- io `forkFinally` (putMVar mvar $!)
+  result <- timeout us (takeMVar mvar)
+  case result of
+    ( Nothing       )                          -> killThread tid >> Left <$> newCStringLen ("Pandoc timed out after " ++ show us ++ "microseconds")
+    ~(Just noTimeout) -> case noTimeout of
+                           ( Right successful) -> return successful
+                           ~(Left  err       ) -> Left <$> newCStringLen ("Pandoc internal error: " ++ show err)
+
+
+-- | Taken from pandoc's executable, adjust the paths and extract the media to the given directory
+-- https://github.com/jgm/pandoc/blob/9849ba7fd744f529f063e0802a18fa18c8433eeb/src/Text/Pandoc/Class.hs#L385
+extractMedia :: MediaBag -> FilePath -> Pandoc -> IO Pandoc
+extractMedia media dir d =
+  case [fp | (fp, _, _) <- mediaDirectory media] of
+        []  -> return d
+        fps -> do
+          extractMediaBag True dir media
+          return $ walk (adjustImagePath dir fps) d
+
+-- | Also taken from pandoc's executable, adjust the image paths of inline elements
+adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
+adjustImagePath dir paths (Image attr lab (src, tit))
+   | src `elem` paths = Image attr lab (dir ++ "/" ++ src, tit)
+adjustImagePath _ _ x = x
+
+-- | Extract the media bag to the given directory, unless that directory string is empty
+extractCMediabag :: CStringLen -> MediaBag -> Pandoc -> EitherT CStringLen IO Pandoc
+extractCMediabag !(_, 0)  _        !pandoc = return pandoc
+extractCMediabag !cPath  !mediaBag !pandoc = do
+  nonEmptyPath <- lift $ peekCStringLen cPath
+  lift $ extractMedia mediaBag nonEmptyPath pandoc
+
+