IPC using named pipe with poppler lib

popplerpipe.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Concurrent
import Control.Monad
import Control.Monad.Loops 
import qualified Data.ByteString.Lazy as B
import Data.Monoid
-- import Data.UUID
import Data.UUID.V4 
import Graphics.Rendering.Cairo 
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Poppler.Document 
import Graphics.UI.Gtk.Poppler.Page
import System.Directory
import System.FilePath
import System.IO
-- import System.IO.MMap
import System.Posix.Files
-- import System.Posix.Files.ByteString 
import System.Posix.IO
import System.Posix.Process 
-- import System.Process

popplerGetDocFromFile :: FilePath -> IO (Maybe Document)
popplerGetDocFromFile fp = 
  documentNewFromFile ("file://localhost" <> fp) Nothing 

popplerGetPageFromDoc :: Document -> Int -> IO Page
popplerGetPageFromDoc doc pn = do 
  pg <- documentGetPage doc (pn-1) 
  return pg 

pipeReceiver :: FilePath -> (B.ByteString -> IO a) -> IO a
pipeReceiver fp receiver = do 
  (pipestr :: B.ByteString) <- 
    iterateUntil (not.B.null) $ threadDelay 10000 >> B.readFile fp 
  receiver pipestr


mkTmpFileName :: IO FilePath 
mkTmpFileName = do
  tdir <- getTemporaryDirectory 
  tuuid <- nextRandom
  return $ tdir </> show tuuid <.> "fifo"

existThenRemove :: FilePath -> IO () 
existThenRemove fp = fileExist fp >>= \b -> when b (removeLink fp) 

pipeAction :: IO () -> (B.ByteString -> IO ()) -> IO () 
pipeAction sender receiver = do 
  filename <- mkTmpFileName 
  existThenRemove filename 
  createNamedPipe filename (unionFileModes ownerReadMode ownerWriteMode)
  forkProcess $ do  
    fd <- openFd filename WriteOnly Nothing defaultFileFlags
    dupTo fd stdOutput 
    closeFd fd
    sender 
    hFlush stdout 
  pipeReceiver filename receiver 
  removeLink filename  

main :: IO () 
main = do 
  initGUI
  pwd <- getCurrentDirectory 
  putStrLn " poppler test "
  Just doc <- popplerGetDocFromFile (pwd </> "1212.2600v2.pdf")
  pg <- popplerGetPageFromDoc doc 1 
  -- 
  pipeAction (withPDFSurface "/dev/stdout" 610 720 $ \sfc -> 
                renderWith sfc (pageRender pg)) 
             (print . B.length) 

  -- 
  return ()