{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Publish.PDF -- Copyright : (c) 2013-2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.Publish.PDF where import Control.Applicative import Control.Exception (SomeException(..),catch) import Control.Lens (_1,_2,_3,_4,view) import Control.Monad import Control.Monad.Trans import Control.Monad.Trans.Maybe import Control.Monad.Trans.State import Data.Attoparsec.ByteString.Char8 (parseOnly,anyChar,satisfy,inClass,endOfInput,try,string,manyTill) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as BSL import Data.Int import Data.UUID (fromString, UUID) import Data.UUID.V4 import Graphics.Rendering.Cairo import Network.HTTP.Base import Network.URI (unEscapeString) import Pdf.Toolbox.Core import Pdf.Toolbox.Document import Pdf.Toolbox.Document.Internal.Types import System.Directory import System.Directory.Tree (DirTree(..)) import System.FilePath import System.IO import qualified System.IO.Streams as Streams import System.Process -- import qualified Data.Hoodle.Simple as S import Graphics.Hoodle.Render import Text.Hoodle.Parse.Attoparsec (hoodle) data UrlPath = FileUrl FilePath | HttpUrl String deriving (Show,Eq) data T = N | F | H | HS deriving (Show,Eq) -- | urlParse :: String -> Maybe UrlPath urlParse str = if length str < 7 then Just (FileUrl str) else let p = do b <- (try (string "file://" *> return F) <|> try (string "http://" *> return H) <|> try (string "https://" *> return HS) <|> (return N) ) remain <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput) return (b,remain) r = parseOnly p (B.pack str) in case r of Left _ -> Nothing Right (b,f) -> case b of N -> Just (FileUrl f) F -> Just (FileUrl (unEscapeString f)) H -> Just (HttpUrl ("http://" ++ f)) HS -> Just (HttpUrl ("https://" ++ f)) isFile :: DirTree a -> Bool isFile (File _ _) = True isFile _ = False takeFile :: DirTree a -> Maybe a takeFile x | isFile x = (Just . file) x takeFile _ | otherwise = Nothing data Annot = Annot { annot_rect :: (Int, Int, Int, Int) , annot_border :: (Int ,Int, Int) , annot_act :: AnnotActions } data AnnotActions = OpenURI String | OpenApp String data AppState = AppState { stNextFree :: Int , stPageRefs :: [Ref] , stRootNode :: Ref } initialAppState :: AppState initialAppState = AppState { stNextFree = 1 , stPageRefs = [] , stRootNode = error "stRootNode" } nextFreeIndex :: Monad m => StateT AppState m Int nextFreeIndex = do st <- get let index = stNextFree st put $ st {stNextFree = index + 1} return index putPageRef :: Monad m => Ref -> StateT AppState m () putPageRef ref = modify $ \st -> st {stPageRefs = ref : stPageRefs st} writeTrailer :: StateT AppState (PdfWriter IO) () writeTrailer = do pageRefs <- gets stPageRefs rootRef <- gets stRootNode lift $ writeObject rootRef $ ODict $ Dict [ ("Type", OName "Pages"), ("Count", ONumber $ NumInt $ length pageRefs), ("Kids", OArray $ Array $ map ORef $ reverse pageRefs) ] catalogIndex <- nextFreeIndex let catalogRef = Ref catalogIndex 0 lift $ writeObject catalogRef $ ODict $ Dict [("Type", OName "Catalog"), ("Pages", ORef rootRef)] n <- gets stNextFree lift $ writeXRefTable 0 (Dict [("Size", (ONumber . NumInt) (n-1)), ("Root", ORef catalogRef)]) writeObjectChildren :: Object () -> Pdf (StateT AppState (PdfWriter IO)) (Object ()) writeObjectChildren (ORef r) = do o <- lookupObject r case o of OStream s -> do ref <- writeStream s return $ ORef ref _ -> do let o' = mapObject (error "impossible") o o'' <- writeObjectChildren o' index <- (lift.lift) nextFreeIndex let ref = Ref index 0 (lift.lift.lift) $ writeObject ref $ mapObject (error "impossible") o'' return $ ORef ref writeObjectChildren (ODict (Dict vals)) = do vals' <- forM vals $ \(key, val) -> do val' <- writeObjectChildren val return (key, val') return $ ODict $ Dict vals' writeObjectChildren (OArray (Array vals)) = do vals' <- forM vals writeObjectChildren return $ OArray $ Array vals' writeObjectChildren o = return o -- | writeStream :: Stream Int64 -> Pdf (StateT AppState (PdfWriter IO)) Ref writeStream s@(Stream dict _) = do len <- lookupDict "Length" dict >>= deref >>= fromObject >>= intValue ris <- getRIS Stream _ is <- rawStreamContent ris len s content <- liftIO $ BSL.fromChunks `liftM` Streams.toList is index <- (lift . lift) nextFreeIndex let ref = Ref index 0 dict' <- writeObjectChildren (ODict dict) >>= fromObject lift . lift . lift $ writeObject ref $ OStream $ Stream dict' content return ref -- | writeAnnot :: Annot -> Pdf (StateT AppState (PdfWriter IO)) Ref writeAnnot Annot{..} = do annotIndex <- (lift.lift) nextFreeIndex actionIndex <- (lift.lift) nextFreeIndex let annotRef = Ref annotIndex 0 actionRef = Ref actionIndex 0 let annotDict = Dict [ ("Type", OName "Annot") , ("Subtype", OName "Link") , ("Rect", OArray $ Array [ ONumber (NumInt (view _1 annot_rect)) , ONumber (NumInt (view _2 annot_rect)) , ONumber (NumInt (view _3 annot_rect)) , ONumber (NumInt (view _4 annot_rect)) ] ) , ("Border", OArray $ Array [ ONumber (NumInt (view _1 annot_border)) , ONumber (NumInt (view _2 annot_border)) , ONumber (NumInt (view _3 annot_border)) ] ) , ("A", ORef actionRef) ] actionDict = case annot_act of OpenURI uri -> Dict [ ("S", OName "URI" ) , ("URI", OStr (Str (B.pack uri))) ] OpenApp str -> Dict [ ("S", OName "Launch" ) , ("F", OStr (Str (B.pack str))) ] lift.lift.lift $ writeObject annotRef $ ODict annotDict lift.lift.lift $ writeObject actionRef $ ODict actionDict return annotRef -- | writePdfPageWithAnnot :: S.Dimension -> Maybe [Annot] -> Page -> Pdf (StateT AppState (PdfWriter IO)) () writePdfPageWithAnnot (S.Dim w h) mannots pg@(Page _ pageDict) = do parentRef <- lift.lift $ gets stRootNode pageIndex <- (lift.lift) nextFreeIndex let pageRef = Ref pageIndex 0 lift.lift $ putPageRef pageRef contentRefs <- pageContents pg contentRefs' <- forM contentRefs $ \r -> do s <- lookupObject r >>= toStream writeStream s resources <- lookupDict "Resources" pageDict >>= deref >>= writeObjectChildren case mannots of Nothing -> lift.lift.lift $ writeObject pageRef $ ODict $ Dict [ ("Type", OName "Page") , ("Contents", OArray $ Array $ map ORef contentRefs') , ("MediaBox", OArray $ Array $ map (ONumber . NumInt) [0,0,floor w,floor h]) , ("Resources", resources) , ("Parent", ORef parentRef) ] Just anns -> do annrefs <- mapM writeAnnot anns lift.lift.lift $ writeObject pageRef $ ODict $ Dict [ ("Type", OName "Page") , ("Contents", OArray $ Array $ map ORef contentRefs') , ("MediaBox", OArray $ Array $ map (ONumber . NumInt) [0,0,floor w,floor h]) , ("Resources", resources) , ("Parent", ORef parentRef) , ("Annots", (OArray . Array . map ORef) annrefs) ] -- | makeAnnot :: S.Dimension -> String -> (FilePath,FilePath) -> S.Link -> IO (Maybe Annot) makeAnnot (S.Dim _pw ph) urlbase (rootpath,_currpath) lnk = do let (x,y) = S.link_pos lnk S.Dim w h = S.link_dim lnk -- pwi = floor pw phi = floor ph xi = floor x yi = floor y wi = floor w hi = floor h linkpath = (B.unpack . S.link_location) lnk case urlParse linkpath of Nothing -> return Nothing Just urlpath -> do case urlpath of HttpUrl url -> return (Just Annot { annot_rect = (xi,phi-yi,xi+wi,phi-(yi+hi)) , annot_border = (16,16,1) , annot_act = OpenURI url }) FileUrl _path -> do b <- doesFileExist linkpath if b then do fp <- canonicalizePath linkpath let (dir,fn) = splitFileName fp rdir = makeRelative rootpath dir (fb,_ext) = splitExtension fn return (Just Annot { annot_rect = (xi,phi-yi,xi+wi,phi-(yi+hi)) , annot_border = (16,16,1) , annot_act = OpenURI (urlbase rdir urlEncode fb <.> "pdf") }) else return Nothing -- | writePdfFile :: FilePath -- ^ hoodle file path -> S.Dimension -> (String,String) -- ^ (url base, special url base (for executing an app)) -> (FilePath,FilePath) -- ^ (root path, curr path) -> FilePath -- ^ pdf file -> [(Int,[S.Link])] -> Maybe UUID -> StateT AppState (PdfWriter IO) () writePdfFile _hdlfp dim (urlbase,specialurlbase) (rootpath,currpath) path nlnks muuid = do handle <- liftIO $ openBinaryFile path ReadMode res <- runPdfWithHandle handle knownFilters $ do encrypted <- isEncrypted when encrypted $ setUserPassword defaultUserPassword >> return () root <- document >>= documentCatalog >>= catalogPageNode count <- pageNodeNKids root forM_ [0..count-1] $ \i -> do page <- pageNodePageByNum root i mannots <- runMaybeT $ do lnks <- MaybeT . return $ lookup (i+1) nlnks liftM catMaybes . mapM (liftIO . makeAnnot dim urlbase (rootpath,currpath)) $ lnks -- hdlfp' <- liftIO $ canonicalizePath hdlfp let special = if i == 0 then let S.Dim _w h = dim in [ Annot { annot_rect = (0,floor h,100,floor h-100) , annot_border = (16,16,1) , annot_act = specialURIFunction specialurlbase muuid } ] else [] let mannots' = case mannots of Nothing -> Just special Just anns -> Just (anns ++ special) writePdfPageWithAnnot dim mannots' page when (isLeft res) $ error $ show res liftIO $ hClose handle specialURIFunction :: FilePath -> Maybe UUID -> AnnotActions specialURIFunction baseurl muuid = case muuid of Nothing -> error "muuid = Nothing?" -- OpenURI baseurl Just uuid -> OpenURI (baseurl urlEncode (show uuid)) getLinks :: S.Page -> [S.Link] getLinks pg = do l <- view S.layers pg S.ItemLink lnk <- view S.items l return lnk isHdl :: FilePath -> Bool isHdl = ( == ".hdl") <$> takeExtension isPdf :: FilePath -> Bool isPdf = ( == ".pdf") <$> takeExtension -- | interleaving a monadic action between each pair of subsequent actions sequence1_ :: (Monad m) => m () -> [m ()] -> m () sequence1_ _ [] = return () sequence1_ _ [a] = a sequence1_ i (a:as) = a >> i >> sequence1_ i as -- | render a hoodle file to PDF simply renderHoodleToPDF :: S.Hoodle -> FilePath -> IO () renderHoodleToPDF hdl ofp = do let p = head (view S.pages hdl) let S.Dim width height = view S.dimension p tdir <- getTemporaryDirectory uuid <- nextRandom let tempfile = tdir show uuid <.> "pdf" ctxt <- initRenderContext hdl let setsize sfc pg = let S.Dim w h = view S.dimension pg in pdfSurfaceSetSize sfc w h >> return pg withPDFSurface tempfile width height $ \s -> renderWith s . flip runStateT ctxt $ sequence1_ (lift showPage) . map (renderPage_StateT <=< setsize s) . view S.pages $ hdl readProcessWithExitCode "pdftk" [ tempfile, "cat", "output", ofp ] "" return () isUpdated :: (FilePath,FilePath) -> IO Bool isUpdated (ofp,nfp) = do b <- doesFileExist nfp if not b then return True else do otime <- getModificationTime ofp ntime <- getModificationTime nfp return (otime > ntime) -- | create pdf file with appropriate links createPdf :: (String,String) -> FilePath -> (FilePath,FilePath) -> IO () createPdf (urlbase,specialurlbase) rootpath (fn,ofn) = catch action (\(e :: SomeException) -> print e) where action = do putStrLn fn let (odir,_) = splitFileName ofn b <- doesDirectoryExist odir when (not b) $ system ("mkdir -p " ++ odir) >> return () let (currpath,_) = splitFileName fn Streams.withFileAsOutput ofn $ \ostr -> do bstr <- B.readFile fn case parseOnly hoodle bstr of Left str -> error str Right hdl -> do let npgs = zip [1..] (view S.pages hdl) npglnks = map ((,) <$> fst <*> getLinks . snd) npgs dim = (view S.dimension . snd . head) npgs muuid = (fromString . B.unpack . view S.hoodleID) hdl tempfile <- () <$> getTemporaryDirectory <*> liftM show nextRandom renderHoodleToPDF hdl tempfile -- runPdfWriter ostr $ do writePdfHeader deleteObject (Ref 0 65535) 0 flip evalStateT initialAppState $ do index <- nextFreeIndex modify $ \st -> st { stRootNode = Ref index 0} writePdfFile fn dim (urlbase,specialurlbase) (rootpath,currpath) tempfile npglnks muuid writeTrailer removeFile tempfile