module Hoodle.ModelAction.File where
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.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.Process
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
import Hoodle.Type.HoodleState
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)
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
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
-> FilePath
-> IO (Maybe Hoodle)
makeNewHoodleWithPDF doesembed fp = do
canonicalfp <- canonicalizePath fp
let fname = C.pack canonicalfp
mdoc <- popplerGetDocFromFile fname
case mdoc of
Nothing -> do
putStrLn $ "no such file " ++ fp
return Nothing
Just doc -> do
n <- Poppler.documentGetNPages doc
let createPageAct i = do
pg <- Poppler.documentGetPage doc (i1)
(w,h) <- PopplerPage.pageGetSize pg
let dim = Dim w h
return (createPage doesembed dim fname i)
pgs <- mapM createPageAct [1..n]
hdl <- set title fname . set pages pgs <$> emptyHoodle
nhdl <- if doesembed
then do
bstr <- C.readFile canonicalfp
let ebdsrc = makeEmbeddedPdfSrcString bstr
return (set embeddedPdf (Just ebdsrc) hdl)
else return hdl
return (Just nhdl)
createPage :: Bool
-> 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
= 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 )
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