{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Hoodle.Render.PDFBackground -- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Graphics.Hoodle.Render.Background where import Control.Concurrent import Control.Concurrent.STM import Control.Monad.State hiding (mapM_) import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader (ask) import Data.ByteString hiding (putStrLn,filter) import Data.Foldable (mapM_) import qualified Data.Map as M import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as C import Data.Monoid import Data.UUID.V4 (nextRandom) import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk (postGUIAsync) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import System.Directory import System.FilePath ((),(<.>)) -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Predefined import Data.Hoodle.Simple -- import Graphics.Hoodle.Render.Type.Background import Graphics.Hoodle.Render.Type.Renderer -- import Prelude hiding (mapM_) -- | popplerGetDocFromFile :: ByteString -> IO (Maybe Poppler.Document) popplerGetDocFromFile fp = Poppler.documentNewFromFile (C.unpack ("file://localhost" `mappend` fp)) Nothing -- | getByteStringIfEmbeddedPDF :: ByteString -> Maybe ByteString getByteStringIfEmbeddedPDF bstr = do guard (C.length bstr > 30) let (header,dat) = C.splitAt 30 bstr guard (header == "data:application/x-pdf;base64,") either (const Nothing) return (decode dat) -- | popplerGetDocFromDataURI :: ByteString -> IO (Maybe Poppler.Document) popplerGetDocFromDataURI dat = do let mdecoded = getByteStringIfEmbeddedPDF dat case mdecoded of Nothing -> return Nothing Just decoded -> do uuidstr <- liftM show nextRandom tmpdir <- getTemporaryDirectory let tmpfile = tmpdir uuidstr <.> "pdf" C.writeFile tmpfile decoded mdoc <- popplerGetDocFromFile (C.pack tmpfile) removeFile tmpfile return mdoc -- | popplerGetPageFromDoc :: Poppler.Document -> Int -- ^ page number -> IO (Maybe Poppler.Page) popplerGetPageFromDoc doc pn = do n <- Poppler.documentGetNPages doc if pn > n then return Nothing else do pg <- Poppler.documentGetPage doc (pn-1) return (Just pg) -- | draw ruling all drawRuling :: Double -> Double -> ByteString -> Cairo.Render () drawRuling w h style = do let drawHorizRules = do let (r,g,b,a) = predefined_RULING_COLOR Cairo.setSourceRGBA r g b a Cairo.setLineWidth predefined_RULING_THICKNESS let drawonerule y = do Cairo.moveTo 0 y Cairo.lineTo w y Cairo.stroke mapM_ drawonerule [ predefined_RULING_TOPMARGIN , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING .. h-1 ] case style of "plain" -> return () "lined" -> do drawHorizRules let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR Cairo.setSourceRGBA r2 g2 b2 a2 Cairo.setLineWidth predefined_RULING_THICKNESS Cairo.moveTo predefined_RULING_LEFTMARGIN 0 Cairo.lineTo predefined_RULING_LEFTMARGIN h Cairo.stroke "ruled" -> drawHorizRules "graph" -> do let (r3,g3,b3,a3) = predefined_RULING_COLOR Cairo.setSourceRGBA r3 g3 b3 a3 Cairo.setLineWidth predefined_RULING_THICKNESS let drawonegraphvert x = do Cairo.moveTo x 0 Cairo.lineTo x h Cairo.stroke let drawonegraphhoriz y = do Cairo.moveTo 0 y Cairo.lineTo w y Cairo.stroke mapM_ drawonegraphvert [0,predefined_RULING_GRAPHSPACING..w-1] mapM_ drawonegraphhoriz [0,predefined_RULING_GRAPHSPACING..h-1] _ -> return () -- | draw ruling in bbox drawRuling_InBBox :: BBox -> Double -> Double -> ByteString -> Cairo.Render () drawRuling_InBBox (BBox (x1,y1) (x2,y2)) w h style = do let drawonerule y = do Cairo.moveTo x1 y Cairo.lineTo x2 y Cairo.stroke let drawonegraphvert x = do Cairo.moveTo x y1 Cairo.lineTo x y2 Cairo.stroke let drawonegraphhoriz y = do Cairo.moveTo x1 y Cairo.lineTo x2 y Cairo.stroke fullRuleYs = [ predefined_RULING_TOPMARGIN , predefined_RULING_TOPMARGIN+predefined_RULING_SPACING .. h-1 ] ruleYs = filter (\y-> (y <= y2) && (y >= y1)) fullRuleYs fullGraphXs = [0,predefined_RULING_GRAPHSPACING..w-1] fullGraphYs = [0,predefined_RULING_GRAPHSPACING..h-1] graphXs = filter (\x->(x<=x2)&&(x>=x1)) fullGraphXs graphYs = filter (\y->(y<=y2)&&(y>=y1)) fullGraphYs let drawHorizRules = do let (r,g,b,a) = predefined_RULING_COLOR Cairo.setSourceRGBA r g b a Cairo.setLineWidth predefined_RULING_THICKNESS mapM_ drawonerule ruleYs case style of "plain" -> return () "lined" -> do drawHorizRules let (r2,g2,b2,a2) = predefined_RULING_MARGIN_COLOR Cairo.setSourceRGBA r2 g2 b2 a2 Cairo.setLineWidth predefined_RULING_THICKNESS Cairo.moveTo predefined_RULING_LEFTMARGIN 0 Cairo.lineTo predefined_RULING_LEFTMARGIN h Cairo.stroke "ruled" -> drawHorizRules "graph" -> do let (r3,g3,b3,a3) = predefined_RULING_COLOR Cairo.setSourceRGBA r3 g3 b3 a3 Cairo.setLineWidth predefined_RULING_THICKNESS mapM_ drawonegraphvert graphXs mapM_ drawonegraphhoriz graphYs _ -> return () -- | render background without any constraint renderBkg :: (Background,Dimension) -> Cairo.Render () renderBkg (Background _typ col sty,Dim w h) = do let c = M.lookup col predefined_bkgcolor case c of Just (r,g,b,_a) -> Cairo.setSourceRGB r g b Nothing -> Cairo.setSourceRGB 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill drawRuling w h sty renderBkg (BackgroundPdf _ _ _ _,Dim w h) = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill renderBkg (BackgroundEmbedPdf _ _,Dim w h) = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill -- | this has some bugs. need to fix cnstrctRBkg_StateT :: Dimension -> Background -> StateT (Maybe Context) Renderer RBackground cnstrctRBkg_StateT dim@(Dim w h) bkg = do (handler,qvar) <- lift ask uuid <- liftIO nextRandom case bkg of Background _t c s -> return (RBkgSmpl c s uuid) BackgroundPdf _t md mf pn -> do r <- runMaybeT $ do (pg,rbkg) <- case (md,mf) of (Just d, Just f) -> do uuiddoc <- liftIO nextRandom docvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand uuiddoc qvar (GetDocFromFile f docvar) doc <- MaybeT . liftIO $ atomically $ takeTMVar docvar lift . put $ Just (Context d f (Just doc) Nothing) -- uuidpg <- liftIO nextRandom pgvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand uuidpg qvar (GetPageFromDoc doc pn pgvar) pg <- MaybeT . liftIO $ atomically $ takeTMVar pgvar return (pg, RBkgPDF md f pn (Just pg) uuid) _ -> do Context oldd oldf olddoc _ <- MaybeT get doc <- MaybeT . return $ olddoc uuidpg <- liftIO nextRandom pgvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand uuidpg qvar (GetPageFromDoc doc pn pgvar) pg <- MaybeT . liftIO $ atomically $ takeTMVar pgvar return (pg, RBkgPDF (Just oldd) oldf pn (Just pg) uuid) return rbkg case r of Nothing -> error "error in cnstrctRBkg_StateT" Just x -> return x BackgroundEmbedPdf _ pn -> do r <- runMaybeT $ do Context _ _ _ mdoc <- MaybeT get doc <- (MaybeT . return) mdoc uuidpg <- liftIO nextRandom pgvar <- liftIO (atomically newEmptyTMVar) liftIO . atomically $ sendPDFCommand uuidpg qvar (GetPageFromDoc doc pn pgvar) pg <- MaybeT . liftIO $ atomically $ takeTMVar pgvar return (RBkgEmbedPDF pn (Just pg) uuid) case r of Nothing -> error "error in cnstrctRBkg_StateT" Just x -> return x