hoodle-publish 0.1 → 0.2
raw patch · 3 files changed
+456/−406 lines, 3 filesdep +gtk3dep +hoodle-publishdep +network-uridep −coroutine-objectdep −networkdep −popplerdep ~directorydep ~filepathdep ~gtk
Dependencies added: gtk3, hoodle-publish, network-uri, unordered-containers
Dependencies removed: coroutine-object, network, poppler
Dependency ranges changed: directory, filepath, gtk, hoodle-parser, hoodle-types, pdf-toolbox-core, pdf-toolbox-document
Files
- exe/hoodle-publish.hs +22/−379
- hoodle-publish.cabal +52/−27
- lib/Hoodle/Publish/PDF.hs +382/−0
exe/hoodle-publish.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Main--- Copyright : (c) 2013 Ian-Woo Kim+-- Copyright : (c) 2013,2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -17,387 +14,30 @@ module Main where -import Control.Applicative -import Control.Concurrent -import Control.Exception hiding (try)-import Control.Lens (_1,_2,_3,_4,view,at )-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State -import Data.Attoparsec.Char8-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as BSL-import Data.Data-import Data.Typeable-import Data.Int-import qualified Data.IntMap as IM-import Data.List -import Data.UUID.V4-import Graphics.Rendering.Cairo-import Graphics.UI.Gtk (initGUI)-import Network.HTTP.Base-import Network.URI-import Pdf.Toolbox.Core-import Pdf.Toolbox.Document-import Pdf.Toolbox.Document.Internal.Types +import Control.Applicative ((<$>),(<*>))+import Control.Monad (filterM)+import Data.Maybe (isNothing, catMaybes)+import qualified Graphics.UI.Gtk as Gtk (initGUI) import System.Console.CmdArgs-import System.Directory-import System.Directory.Tree -import System.FilePath -import System.Environment-import System.IO-import qualified System.IO.Streams as Streams-import System.Process+import System.Directory (removeFile)+import System.Directory.Tree (AnchoredDirTree(..),build,flattenDir)+import System.FilePath (makeRelative,replaceExtension,(</>)) -- -import qualified Data.Hoodle.Simple as S-import Data.Hoodle.Generic-import Graphics.Hoodle.Render -import Graphics.Hoodle.Render.Generic-import Graphics.Hoodle.Render.Type.Background-import Graphics.Hoodle.Render.Type.Hoodle-import Text.Hoodle.Parse.Attoparsec +import Hoodle.Publish.PDF -- -import Debug.Trace ---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) )- rem <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput)- return (b,rem) - r = parseOnly p (B.pack str)- in case r of - Left _ -> Nothing -- Just (FileUrl str) - 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 (File _ _) = True-isFile _ = False--takeFile x | isFile x = (Just . file) x -takeFile x | otherwise = Nothing ------- | Get the relative url to the site root, for a given (absolute) url-toSiteRoot :: String -> String-toSiteRoot = emptyException . joinPath . map parent- . filter relevant . splitPath . takeDirectory- where- parent = const ".."- emptyException [] = "."- emptyException x = x- relevant "." = False- relevant "/" = False- relevant _ = True---data Annot = Annot { annot_rect :: (Int, Int, Int, Int) - , annot_border :: (Int ,Int, Int) - , annot_url :: 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)]-- count <- gets stNextFree- lift $ writeXRefTable 0 (Dict [("Size", ONumber $ NumInt $ count - 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 = Dict [ ("S", OName "URI" ) - , ("URI", OStr (Str (B.pack annot_url)))- ] - 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 page@(Page _ pageDict) = do- parentRef <- lift.lift $ gets stRootNode- pageIndex <- (lift.lift) nextFreeIndex- let pageRef = Ref pageIndex 0- lift.lift $ putPageRef pageRef- contentRefs <- pageContents page- 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_url = 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_url = urlbase </> rdir </> urlEncode fb <.> "pdf"- })- else return Nothing ---- | -writePdfFile :: S.Dimension- -> String -- ^ url base - -> (FilePath,FilePath) -- ^ (root path, curr path)- -> FilePath -- ^ pdf file - -> [(Int,[S.Link])]- -> StateT AppState (PdfWriter IO) ()-writePdfFile dim urlbase (rootpath,currpath) path nlnks = do- handle <- liftIO $ openBinaryFile path ReadMode- res <- runPdfWithHandle handle knownFilters $ do- encrypted <- isEncrypted- when encrypted $ setUserPassword defaultUserPassord- root <- document >>= documentCatalog >>= catalogPageNode- count <- pageNodeNKids root- forM_ [0..count-1] $ \i -> do- page <- pageNodePageByNum root i- -- let dim = S.Dim 612.0 792.0 - liftIO $ print dim- mannots <- runMaybeT $ do - lnks <- MaybeT . return $ lookup (i+1) nlnks- liftM catMaybes . mapM (liftIO . makeAnnot dim urlbase (rootpath,currpath)) $ lnks - writePdfPageWithAnnot dim mannots page- when (isLeft res) $ error $ show res- liftIO $ hClose handle--getLinks :: S.Page -> [S.Link]-getLinks pg = do - l <- view S.layers pg - S.ItemLink lnk <- view S.items l- return lnk --isHdl = ( == ".hdl") <$> 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 ----- | -renderjob :: RHoodle -> FilePath -> IO () -renderjob h ofp = do - let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h) - let S.Dim width height = view gdimension p - let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) x >> return () - withPDFSurface ofp width height $ \s -> renderWith s $ - (sequence1_ showPage . map rf . IM.elems . view gpages ) h ---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)- ----createPdf :: String -> FilePath -> (FilePath,FilePath) -> IO ()-createPdf urlbase 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 - rhdl <- cnstrctRHoodle hdl - tempfile <- (</>) <$> getTemporaryDirectory <*> liftM show nextRandom- renderjob rhdl tempfile- runPdfWriter ostr $ do - writePdfHeader- deleteObject (Ref 0 65535) 0 - flip evalStateT initialAppState $ do - index <- nextFreeIndex - modify $ \st -> st { stRootNode = Ref index 0} - writePdfFile dim urlbase (rootpath,currpath) tempfile npglnks- writeTrailer- removeFile tempfile -------------------------------------------------------------------------- main program ------------------------------------------------------------------------ data HoodlePublish = Publish { urlbase :: String , rootpath :: FilePath , buildpath :: FilePath+ , specialurlbase :: String } deriving (Show,Data,Typeable) - publish :: HoodlePublish publish = Publish { urlbase = def &= typ "URLBASE" &= argPos 0 , rootpath = def &= typ "ORIGNALFILEDIR" &= argPos 1 , buildpath = def &= typ "TARGETFILEDIR" &= argPos 2 + , specialurlbase = def &= typ "SPECIALURLBASE" } mode :: HoodlePublish @@ -406,18 +46,21 @@ -- | main :: IO () main = do- initGUI + Gtk.initGUI params <- cmdArgs mode - -- args <- getArgs - -- let urlbase = args !! 0- -- rootpath = args !! 1- -- buildpath = args !! 2 - -- fn = args !! 1 - (r :/ r') <- build (rootpath params)+ (_r :/ r') <- build (rootpath params) let files = catMaybes . map takeFile . flattenDir $ r' hdlfiles = filter isHdl files pairs = map ((,) <$> id <*> (buildpath params </>) . flip replaceExtension "pdf" . makeRelative (rootpath params)) hdlfiles + swappedpairs = map (\(x,y)->(y,x)) pairs + (_b :/ b') <- build (buildpath params)+ let files2 = catMaybes . map takeFile . flattenDir $ b' + pdffiles = filter isPdf files2+ willbeerased = filter (\x -> isNothing (lookup x swappedpairs )) pdffiles + + mapM_ removeFile willbeerased + updatedpairs <- filterM isUpdated pairs - mapM_ (createPdf (urlbase params) (rootpath params)) updatedpairs+ mapM_ (createPdf (urlbase params,specialurlbase params) (rootpath params)) updatedpairs
hoodle-publish.cabal view
@@ -1,5 +1,5 @@ Name: hoodle-publish-Version: 0.1+Version: 0.2 Synopsis: publish hoodle files as a static web site Description: This package provieds a simple tool hoodle-publish which make a static web site from a directory containing hoodle files Homepage: http://ianwookim.org/hoodle@@ -8,7 +8,7 @@ Author: Ian-Woo Kim Maintainer: Ian-Woo Kim <ianwookim@gmail.com> Category: Application-Tested-with: GHC == 7.6+Tested-with: GHC == 7.8 Build-Type: Simple Cabal-Version: >= 1.8 data-files: @@ -16,35 +16,60 @@ type: git location: http://www.github.com/wavewave/hoodle-publish +Flag Gtk3+ Description: compile with gtk3+ Default: False ++Library+ hs-source-dirs: lib+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans + ghc-prof-options: -caf-all -auto-all+ Build-Depends: + base == 4.*, + --+ attoparsec >= 0.10,+ bytestring >= 0.9, + cairo > 0.12,+ containers >= 0.4,+ directory > 1,+ directory-tree, + filepath > 1, + hoodle-parser >= 0.3.0,+ hoodle-render >= 0.3.1,+ hoodle-types >= 0.3.0,+ HTTP,+ io-streams, + lens >= 2.5,+ mtl > 2,+ network-uri > 2.6,+ pdf-toolbox-core >= 0.0.3, + pdf-toolbox-document >= 0.0.3, + process >= 1.1, + transformers >= 0.3,+ unordered-containers,+ uuid >= 1.2.7 + if flag(gtk3) + Build-depends: gtk3 > 0.13 + else + Build-depends: gtk > 0.13+++ Exposed-modules: + Hoodle.Publish.PDF+ Executable hoodle-publish Main-is: hoodle-publish.hs hs-source-dirs: exe ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans ghc-prof-options: -caf-all -auto-all - Build-Depends: base == 4.*, - containers >= 0.4,- mtl > 2,- transformers >= 0.3,- lens >= 2.5,- cmdargs, + Build-Depends: base == 4.*,+ cmdargs,+ directory, directory-tree, - directory > 1,- filepath > 1, - process >= 1.1, - uuid >= 1.2.7, - gtk > 0.12, - cairo > 0.12,- poppler >= 0.12.2.2, - pdf-toolbox-document, - pdf-toolbox-core, - io-streams, - network, - HTTP,- attoparsec >= 0.10,- bytestring >= 0.9, - coroutine-object >= 0.2, - hoodle-types >= 0.2,- hoodle-parser >= 0.2,- hoodle-render >= 0.3.1-+ filepath,+ hoodle-publish+ if flag(gtk3) + Build-depends: gtk3 > 0.13 + else + Build-depends: gtk > 0.13
+ lib/Hoodle/Publish/PDF.hs view
@@ -0,0 +1,382 @@+{-# 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 <ianwookim@gmail.com>+-- 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