{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.File -- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Hoodle.ModelAction.File where -- from other package import Control.Applicative import Control.Lens (view,set) import Data.Attoparsec import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.IntMap as IM import Data.Maybe import Data.Monoid ((<>)) import Data.Time.Clock import Graphics.GD.ByteString import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import System.Directory (canonicalizePath) import System.FilePath (takeExtension) import System.IO (hClose, hFileSize, openFile, IOMode(..)) import System.Process -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Simple import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Background import Graphics.Hoodle.Render.Type.Background import Graphics.Hoodle.Render.Type.Hoodle import Text.Hoodle.Builder (builder) import qualified Text.Hoodle.Parse.Attoparsec as PA import qualified Text.Hoodle.Migrate.V0_1_1_to_V0_2 as MV import qualified Text.Xournal.Parse.Conduit as XP import Text.Hoodle.Migrate.FromXournal -- from this package import Hoodle.Type.HoodleState import Hoodle.Util -- | check hoodle version and migrate if necessary checkVersionAndMigrate :: C.ByteString -> IO (Either String Hoodle) checkVersionAndMigrate bstr = do case parseOnly PA.checkHoodleVersion bstr of Left str -> error str Right v -> do if ( v <= "0.1.1" ) then MV.migrate bstr else return (parseOnly PA.hoodle bstr) -- | get file content from xournal file and update xournal state getFileContent :: Maybe FilePath -> HoodleState -> IO HoodleState getFileContent (Just fname) xstate = do let ext = takeExtension fname case ext of ".hdl" -> do bstr <- C.readFile fname r <- checkVersionAndMigrate bstr case r of Left err -> putStrLn err >> return xstate Right h -> do nxstate <- constructNewHoodleStateFromHoodle h xstate ctime <- getCurrentTime return . set (hoodleFileControl.hoodleFileName) (Just fname) . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate ".xoj" -> do XP.parseXojFile fname >>= \x -> case x of Left str -> do putStrLn $ "file reading error : " ++ str return xstate Right xojcontent -> do hdlcontent <- mkHoodleFromXournal xojcontent nxstate <- constructNewHoodleStateFromHoodle hdlcontent xstate ctime <- getCurrentTime return . set (hoodleFileControl.hoodleFileName) (Just fname) . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate ".pdf" -> do let doesembed = view (settings.doesEmbedPDF) xstate mhdl <- makeNewHoodleWithPDF doesembed fname case mhdl of Nothing -> getFileContent Nothing xstate Just hdl -> do newhdlstate <- constructNewHoodleStateFromHoodle hdl xstate return . set (hoodleFileControl.hoodleFileName) Nothing $ newhdlstate _ -> getFileContent Nothing xstate getFileContent Nothing xstate = do newhdl <- cnstrctRHoodle =<< defaultHoodle let newhdlstate = ViewAppendState newhdl xstate' = set (hoodleFileControl.hoodleFileName) Nothing . set hoodleModeState newhdlstate $ xstate return xstate' -- | constructNewHoodleStateFromHoodle :: Hoodle -> HoodleState -> IO HoodleState constructNewHoodleStateFromHoodle hdl' xstate = do hdl <- cnstrctRHoodle hdl' let startinghoodleModeState = ViewAppendState hdl return $ set hoodleModeState startinghoodleModeState xstate -- | this is very temporary, need to be changed. findFirstPDFFile :: [(Int,RPage)] -> Maybe C.ByteString findFirstPDFFile xs = let ys = (filter isJust . map f) xs in if null ys then Nothing else head ys where f (_,p) = case view gbackground p of RBkgPDF _ fi _ _ _ -> Just fi _ -> Nothing findAllPDFPages :: [(Int,RPage)] -> [Int] findAllPDFPages = catMaybes . map f where f (n,p) = case view gbackground p of RBkgPDF _ _ _ _ _ -> Just n _ -> Nothing replacePDFPages :: [(Int,RPage)] -> [(Int,RPage)] replacePDFPages xs = map f xs where f (n,p) = case view gbackground p of RBkgPDF _ _ pdfn mpdf msfc -> (n, set gbackground (RBkgEmbedPDF pdfn mpdf msfc) p) _ -> (n,p) -- | embedPDFInHoodle :: RHoodle -> IO RHoodle embedPDFInHoodle hdl = do let pgs = (IM.toAscList . view gpages) hdl mfn = findFirstPDFFile pgs allpdfpg = findAllPDFPages pgs case mfn of Nothing -> return hdl Just fn -> do let fnstr = C.unpack fn pglst = map show allpdfpg cmdargs = [fnstr, "cat"] ++ pglst ++ ["output", "-"] print cmdargs (_,Just hout,_,_) <- createProcess (proc "pdftk" cmdargs) { std_out = CreatePipe } bstr <- C.hGetContents hout let ebdsrc = makeEmbeddedPdfSrcString bstr npgs = (IM.fromAscList . replacePDFPages) pgs (return . set gembeddedpdf (Just ebdsrc) . set gpages npgs) hdl makeEmbeddedPdfSrcString :: C.ByteString -> C.ByteString makeEmbeddedPdfSrcString = ("data:application/x-pdf;base64," <>) . encode -- | makeNewHoodleWithPDF :: Bool -- ^ doesEmbedPDF -> FilePath -- ^ pdf file -> IO (Maybe Hoodle) makeNewHoodleWithPDF doesembed ofp = do ocanonicalfp <- canonicalizePath ofp let ofname = C.pack ocanonicalfp let sizelimit = 10000000 siz <- do h <- openFile ofp ReadMode s <- hFileSize h hClose h return s (nfp,nfname) <- if (siz > sizelimit) then do putStrLn $ "size is " ++ show siz ++ ", which is larger than " ++ show sizelimit nfp' <- mkTmpFile "pdf" let nfname' = C.pack nfp' readProcess "gs" [ "-q", "-dNOPAUSE", "-dBATCH", "-dSAFER" , "-sDEVICE=pdfwrite", "-dCompatibilityLevel=1.3" , "-dPDFSETTINGS=/screen", "-dEmbedAllFonts=true" , "-dSubsetFonts=true", "-dColorImageDownsampleType=/Bicubic" , "-dColorImageResolution=72", "-dGrayImageDownsampleType=/Bicubic" , "-dGrayImageResolution=72", "-dMonoImageDownsampleType=/Bicubic" , "-dMonoImageResolution=72", "-sOutputFile="++nfp' , ofp ] "" return (nfp',nfname') else return (ocanonicalfp,ofname) mdoc <- popplerGetDocFromFile nfname case mdoc of Nothing -> do putStrLn $ "no such file " ++ nfp return Nothing Just doc -> do n <- Poppler.documentGetNPages doc let createPageAct i = do pg <- Poppler.documentGetPage doc (i-1) (w,h) <- PopplerPage.pageGetSize pg let dim = Dim w h return (createPage doesembed dim nfname i) pgs <- mapM createPageAct [1..n] hdl <- set title nfname . set pages pgs <$> emptyHoodle nhdl <- if doesembed then do bstr <- C.readFile nfp let ebdsrc = makeEmbeddedPdfSrcString bstr return (set embeddedPdf (Just ebdsrc) hdl) else return hdl return (Just nhdl) -- | createPage :: Bool -- ^ does embed pdf? -> Dimension -> C.ByteString -> Int -> Page createPage doesembed dim fn n = let bkg | not doesembed && n == 1 = BackgroundPdf "pdf" (Just "absolute") (Just fn ) n | not doesembed && n /= 1 = BackgroundPdf "pdf" Nothing Nothing n | otherwise -- doesembed = BackgroundEmbedPdf "embedpdf" n in Page dim bkg [emptyLayer] -- | saveHoodle :: HoodleState -> IO HoodleState saveHoodle xstate = do let hdl = (rHoodle2Hoodle . getHoodle) xstate case view (hoodleFileControl.hoodleFileName) xstate of Nothing -> return xstate Just filename -> do L.writeFile filename . builder $ hdl ctime <- getCurrentTime let ui = view gtkUIManager xstate toggleSave ui False return (set isSaved True . set (hoodleFileControl.lastSavedTime) (Just ctime) $ xstate ) -- | this function must be moved to GUI.Reflect toggleSave :: UIManager -> Bool -> IO () toggleSave ui b = do agr <- uiManagerGetActionGroups ui >>= \x -> case x of [] -> error "No action group?" y:_ -> return y Just savea <- actionGroupGetAction agr "SAVEA" actionSetSensitive savea b -- | makeNewItemImage :: Bool -- ^ isEmbedded? -> FilePath -> IO Item makeNewItemImage isembedded filename = if isembedded then let fileext = takeExtension filename imgaction | fileext == ".PNG" || fileext == ".png" = loadpng | fileext == ".JPG" || fileext == ".jpg" = loadjpg | otherwise = loadsrc in imgaction else loadsrc where loadsrc = (return . ItemImage) (Image (C.pack filename) (100,100) (Dim 300 300)) loadpng = do img <- loadPngFile filename (w,h) <- imageSize img let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 bstr <- savePngByteString img let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str return . ItemImage $ Image ebdsrc (100,100) dim loadjpg = do img <- loadJpegFile filename (w,h) <- imageSize img let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 bstr <- savePngByteString img let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str return . ItemImage $ Image ebdsrc (100,100) dim