diff --git a/exe/hoodle-publish.hs b/exe/hoodle-publish.hs --- a/exe/hoodle-publish.hs +++ b/exe/hoodle-publish.hs @@ -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 @@ -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 diff --git a/hoodle-publish.cabal b/hoodle-publish.cabal --- a/hoodle-publish.cabal +++ b/hoodle-publish.cabal @@ -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 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 diff --git a/lib/Hoodle/Publish/PDF.hs b/lib/Hoodle/Publish/PDF.hs new file mode 100644 --- /dev/null +++ b/lib/Hoodle/Publish/PDF.hs @@ -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 +-- 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