{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) 2013 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- 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 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 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 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 } 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 } mode :: HoodlePublish mode = modes [publish] -- | main :: IO () main = do initGUI params <- cmdArgs mode -- args <- getArgs -- let urlbase = args !! 0 -- rootpath = args !! 1 -- buildpath = args !! 2 -- fn = args !! 1 (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 updatedpairs <- filterM isUpdated pairs mapM_ (createPdf (urlbase params) (rootpath params)) updatedpairs