hoodle-core-0.15: src/Hoodle/Coroutine/File.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.File
-- Copyright : (c) 2011-2015 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.File where
-- from other packages
import Control.Applicative
import Control.Lens (at,view,set,over,(.~))
import Control.Monad.State hiding (mapM,mapM_,forM_)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Attoparsec.ByteString.Char8 (parseOnly)
import Data.ByteString.Char8 as B (pack,unpack,readFile)
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.MD5 (md5)
import Data.Foldable (mapM_,forM_)
import qualified Data.List as List
import Data.Maybe
import Data.Time.Clock
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.UI.Gtk as Gtk
import System.Directory
import System.FilePath
import System.IO (hClose, hFileSize, openFile, IOMode(..))
import System.Process
#ifdef HUB
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad.Trans.Reader
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
#endif
-- from hoodle-platform
import Control.Monad.Trans.Crtn
import Data.Hoodle.Generic
import Data.Hoodle.Simple
import Data.Hoodle.Select
import Graphics.Hoodle.Render (Xform4Page(..),cnstrctRHoodle)
import Graphics.Hoodle.Render.Generic
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
import Hoodle.Publish.PDF (renderHoodleToPDF)
import Text.Hoodle.Builder
import Text.Hoodle.Migrate.FromXournal
import qualified Text.Hoodlet.Parse.Attoparsec as Hoodlet
import qualified Text.Xournal.Parse.Conduit as XP
-- from this package
import Hoodle.Accessor
import Hoodle.Coroutine.Dialog
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.Layer
import Hoodle.Coroutine.Minibuffer
import Hoodle.Coroutine.Mode
import Hoodle.Coroutine.Page
import Hoodle.Coroutine.Scroll
import Hoodle.Coroutine.Select.Clipboard
import Hoodle.Coroutine.TextInput
import Hoodle.GUI.Reflect
import Hoodle.ModelAction.File
import Hoodle.ModelAction.Layer
import Hoodle.ModelAction.Page
import Hoodle.ModelAction.Select
import Hoodle.ModelAction.Window
import qualified Hoodle.Script.Coroutine as S
import Hoodle.Script.Hook
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Enum
import Hoodle.Type.Event hiding (TypSVG)
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
import Hoodle.Util
#ifdef HUB
import Hoodle.Coroutine.Hub
import Hoodle.Coroutine.Hub.Common
import Hoodle.Coroutine.HubInternal
import Hoodle.Type.Hub
import Hoodle.Type.Synchronization
#endif
--
import Prelude hiding (readFile,concat,mapM,mapM_)
-- |
askIfSave :: MainCoroutine () -> MainCoroutine ()
askIfSave action = do
uhdl <- view (unitHoodles.currentUnit) <$> get
if not (view isSaved uhdl)
then
okCancelMessageBox "Current canvas is not saved yet. Will you proceed without save?" >>= flip when action
else action
-- |
askIfOverwrite :: FilePath -> MainCoroutine () -> MainCoroutine ()
askIfOverwrite fp action = do
b <- liftIO $ doesFileExist fp
if b
then do
r <- okCancelMessageBox ("Overwrite " ++ fp ++ "???")
if r then action else return ()
else action
-- | get file content from xournal file and update hoodle state
getFileContent :: FileStore -> MainCoroutine ()
getFileContent store@(LocalDir (Just fname)) = do
xstate <- get
let ext = takeExtension fname
case ext of
".hdl" -> do
bstr <- liftIO $ B.readFile fname
r <- liftIO $ checkVersionAndMigrate bstr
case r of
Left err -> liftIO $ putStrLn err
Right h -> do
constructNewHoodleStateFromHoodle h
ctime <- liftIO $ getCurrentTime
#ifdef HUB
-- let uhdluuid = view (unitHoodles.currentUnit.unitUUID) xstate
msqlfile <- view (settings.sqliteFileName) <$> get
let fileuuidbstr = view hoodleID h
fileuuidtxt = TE.decodeUtf8 fileuuidbstr
liftIO $ print fileuuidtxt
mfstat <- case msqlfile of
Nothing -> return Nothing
Just sqlfile -> liftIO (getLastSyncStatus sqlfile fileuuidtxt)
let mmd5 = fileSyncStatusMd5 <$> mfstat
#else
let mmd5 = Nothing
#endif
pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ store)
. (hoodleFileControl.lastSavedTime .~ Just ctime)
. (hoodleFileControl.syncMD5History .~ maybeToList mmd5) )
commit_
".xoj" -> do
liftIO (XP.parseXojFile fname) >>= \x -> case x of
Left str -> msgShout $ "file reading error : " ++ str
Right xojcontent -> do
hdlcontent <- liftIO $ mkHoodleFromXournal xojcontent
constructNewHoodleStateFromHoodle hdlcontent
ctime <- liftIO $ getCurrentTime
pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)
. (hoodleFileControl.lastSavedTime .~ Just ctime) )
commit_
".pdf" -> do
let doesembed = view (settings.doesEmbedPDF) xstate
mhdl <- liftIO $ makeNewHoodleWithPDF doesembed fname
case mhdl of
Nothing -> getFileContent (LocalDir Nothing)
Just hdl -> do
constructNewHoodleStateFromHoodle hdl
pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)
commit_
_ -> getFileContent (LocalDir Nothing)
xstate' <- get
doIOaction_ $ Gtk.postGUIAsync (setTitleFromFileName xstate')
getFileContent (LocalDir Nothing) = do
constructNewHoodleStateFromHoodle =<< liftIO defaultHoodle
pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)
commit_
#ifdef HUB
getFileContent store@(TempDir fname) = do
-- xstate <- get
-- let uhdluuid = view (unitHoodles.currentUnit.unitUUID) xstate
let ext = takeExtension fname
when (ext == ".hdl") $ do
bstr <- liftIO $ B.readFile fname
r <- liftIO $ checkVersionAndMigrate bstr
case r of
Left err -> liftIO $ putStrLn err
Right h -> do
constructNewHoodleStateFromHoodle h
ctime <- liftIO $ getCurrentTime
let -- fileuuidbstr = view hoodleID h
-- fileuuidtxt = TE.decodeUtf8 fileuuidbstr
md5txt = T.pack . show . md5 . L.fromStrict $ bstr
pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ store)
. (hoodleFileControl.lastSavedTime .~ Just ctime)
. (hoodleFileControl.syncMD5History .~ [md5txt] )
)
commit_
xstate' <- get
doIOaction_ $ Gtk.postGUIAsync (setTitleFromFileName xstate')
#else
getFileContent _ = return ()
#endif
-- |
constructNewHoodleStateFromHoodle :: Hoodle -> MainCoroutine ()
constructNewHoodleStateFromHoodle hdl' = do
callRenderer $ cnstrctRHoodle hdl' >>= return . GotRHoodle
RenderEv (GotRHoodle rhdl) <- waitSomeEvent (\case RenderEv (GotRHoodle _) -> True; _ -> False)
pureUpdateUhdl (hoodleModeState .~ ViewAppendState rhdl)
-- | deprecated
fileNew :: MainCoroutine ()
fileNew = do
getFileContent (LocalDir Nothing)
updateUhdl $ \uhdl -> do
ncvsinfo <- liftIO $ setPage uhdl 0 (getCurrentCanvasId uhdl)
return $ (currentCanvasInfo .~ ncvsinfo) uhdl
xst <- get
liftIO (setTitleFromFileName xst)
commit_
invalidateAll
-- |
fileSave :: MainCoroutine ()
fileSave = do
uhdl <- view (unitHoodles.currentUnit) <$> get
case getHoodleFilePath uhdl of
Nothing -> fileSaveAs
Just filename -> do
-- this is rather temporary not to make mistake
if takeExtension filename == ".hdl"
then do
updateUhdl $ liftIO . saveHoodle . const uhdl
(S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) uhdl
#ifdef HUB
hubUpload
#endif
else fileExtensionInvalid (".hdl","save") >> fileSaveAs
-- | 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
-- |
fileExport :: MainCoroutine ()
fileExport = fileChooser Gtk.FileChooserActionSave Nothing >>= maybe (return ()) action
where
action filename = do
-- this is rather temporary not to make mistake
if takeExtension filename /= ".pdf"
then fileExtensionInvalid (".pdf","export") >> fileExport
else do
hdl <- rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) <$> get
liftIO (renderHoodleToPDF hdl filename)
-- | need to be merged with ContextMenuEventSVG
exportCurrentPageAsSVG :: MainCoroutine ()
exportCurrentPageAsSVG = fileChooser Gtk.FileChooserActionSave Nothing >>= maybe (return ()) action
where
action filename =
-- this is rather temporary not to make mistake
if takeExtension filename /= ".svg"
then fileExtensionInvalid (".svg","export") >> exportCurrentPageAsSVG
else do
cvsid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get
cache <- renderCache
cpg <- getCurrentPageCurr
let Dim w h = view gdimension cpg
liftIO $ Cairo.withSVGSurface filename w h $ \s -> Cairo.renderWith s $
cairoRenderOption (InBBoxOption Nothing) cache cvsid (InBBox cpg,Nothing :: Maybe Xform4Page) >> return ()
-- |
fileLoad :: FileStore -> MainCoroutine ()
fileLoad filestore = do
getFileContent filestore
updateUhdl $ \uhdl -> do
ncvsinfo <- liftIO $ setPage uhdl 0 (getCurrentCanvasId uhdl)
return . (currentCanvasInfo .~ ncvsinfo) . (isSaved .~ True) $ uhdl
xst <- get
let ui = view gtkUIManager xst
liftIO $ reflectUIToggle ui "SAVEA" False
liftIO $ setTitleFromFileName xst
clearUndoHistory
modeChange ToViewAppendMode
canvasZoomUpdateAll
resetHoodleBuffers
invalidateAll
applyActionToAllCVS adjustScrollbarWithGeometryCvsId
-- |
resetHoodleBuffers :: MainCoroutine ()
resetHoodleBuffers = do
updateUhdl $ \uhdl -> do
let hdlst = view hoodleModeState uhdl
cvsid = getCurrentCanvasId uhdl
callRenderer_ $ resetHoodleModeStateBuffers cvsid hdlst
return . (hoodleModeState .~ hdlst) $ uhdl
-- | main coroutine for open a file
fileOpen :: MainCoroutine ()
fileOpen = do
mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing
forM_ mfilename (fileLoad . LocalDir . Just)
-- | main coroutine for save as
fileSaveAs :: MainCoroutine ()
fileSaveAs = do
hdl <- (rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit)) <$> get
maybe (defSaveAsAction hdl) (\f -> liftIO (f hdl)) =<< hookSaveAsAction
where
hookSaveAsAction = (saveAsHook <=< view hookSet) <$> get
msuggestedact = (fileNameSuggestionHook <=< view hookSet) <$> get
defSaveAsAction hdl = do
(msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) =<< msuggestedact
mr <- fileChooser Gtk.FileChooserActionSave msuggested
maybe (return ()) (action hdl) mr
where action hd filename =
if takeExtension filename /= ".hdl"
then fileExtensionInvalid (".hdl","save")
else do
askIfOverwrite filename $ do
updateUhdl $ \uhdl -> do
let ntitle = B.pack . snd . splitFileName $ filename
(hdlmodst',hdl') = case view hoodleModeState uhdl of
ViewAppendState hdlmap ->
if view gtitle hdlmap == "untitled"
then ( ViewAppendState . set gtitle ntitle
$ hdlmap
, (set title ntitle hd))
else (ViewAppendState hdlmap,hd)
SelectState thdl ->
if view gselTitle thdl == "untitled"
then ( SelectState $ set gselTitle ntitle thdl
, set title ntitle hd)
else (SelectState thdl,hd)
liftIO . L.writeFile filename . builder $ hdl'
return . (hoodleFileControl.hoodleFileName .~ LocalDir (Just filename))
. (hoodleModeState .~ hdlmodst')
. (isSaved .~ True)
$ uhdl
xst <- get
let ui = view gtkUIManager xst
hdl'' = (rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit)) xst
liftIO $ reflectUIToggle ui "SAVEA" False
liftIO $ setTitleFromFileName xst
S.afterSaveHook filename hdl''
#ifdef HUB
hubUpload
#endif
-- | main coroutine for open a file
fileReload :: MainCoroutine ()
fileReload = do
uhdl <- view (unitHoodles.currentUnit) <$> get
let filestore = view (hoodleFileControl.hoodleFileName) uhdl
if not (view isSaved uhdl)
then do
b <- okCancelMessageBox "Discard changes and reload the file?"
when b (fileLoad filestore)
else fileLoad filestore
-- |
fileExtensionInvalid :: (String,String) -> MainCoroutine ()
fileExtensionInvalid (ext,a) =
okMessageBox $ "only "
++ ext
++ " extension is supported for "
++ a
-- |
fileAnnotatePDF :: MainCoroutine ()
fileAnnotatePDF =
fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action
where
warning = do
okMessageBox "cannot load the pdf file. Check your hoodle compiled with poppler library"
invalidateAll
action filename = do
xstate <- get
let doesembed = view (settings.doesEmbedPDF) xstate
mhdl <- liftIO $ makeNewHoodleWithPDF doesembed filename
flip (maybe warning) mhdl $ \hdl -> do
constructNewHoodleStateFromHoodle hdl
pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)
commit_
setTitleFromFileName_
canvasZoomUpdateAll
-- | set frame title according to file name
setTitleFromFileName_ :: MainCoroutine ()
setTitleFromFileName_ = get >>= liftIO . setTitleFromFileName
-- |
checkEmbedImageSize :: FilePath -> MainCoroutine (Maybe FilePath)
checkEmbedImageSize filename = do
xst <- get
runMaybeT $ do
sizelimit <- (MaybeT . return) (warningEmbedImageSize =<< view hookSet xst)
siz <- liftIO $ do
h <- openFile filename ReadMode
s <- hFileSize h
hClose h
return s
guard (siz > sizelimit)
let suggestscale :: Double = sqrt (fromIntegral sizelimit / fromIntegral siz)
b <- lift . okCancelMessageBox $ "The size of " ++ filename ++ "=" ++ show siz ++ "\nis bigger than limit=" ++ show sizelimit ++ ".\nWill you reduce size?"
guard b
let ext = let x' = takeExtension filename
in if (not.null) x' then tail x' else ""
tmpfile <- liftIO $ mkTmpFile ext
cmd <- (MaybeT . return) (shrinkCmd4EmbedImage =<< view hookSet xst)
liftIO $ cmd suggestscale filename tmpfile
return tmpfile
-- |
fileLoadPNGorJPG :: MainCoroutine ()
fileLoadPNGorJPG = do
fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) embedImage
-- |
fileLoadImageBackground :: MainCoroutine ()
fileLoadImageBackground = do
fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action
where
action filename = do
xst <- get
let fDoesEmbedImg = view (settings.doesEmbedImage) xst
uhdl = view (unitHoodles.currentUnit) xst
hdl = getHoodle uhdl
Dim pw _ph = (view gdimension . fromJust . view (gpages.at 0)) hdl
itm <- if fDoesEmbedImg
then checkEmbedImageSize filename
>>= maybe (liftIO $ makeNewItemImage True filename)
(liftIO . makeNewItemImage True)
else liftIO (makeNewItemImage False filename)
let ItemImage img = itm
Dim w h = img_dim img
ratio = h/w
ndim = Dim pw (pw*ratio)
img' = img { img_dim = ndim }
changePage (const 0)
newPage (Just ndim) PageBefore
callRenderer $ cnstrctRItem (ItemImage img') >>= return . GotRItem
RenderEv (GotRItem nitm) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False)
insertItemAt (Just (PageNum 0, PageCoord (0,0))) nitm
modeChange ToViewAppendMode
makeNewLayer
embedImage :: FilePath -> MainCoroutine ()
embedImage filename = do
xst <- get
let fDoesEmbedImg = view (settings.doesEmbedImage) xst
uhdl = view (unitHoodles.currentUnit) xst
nitm <-
if fDoesEmbedImg
then do
mf <- checkEmbedImageSize filename
--
callRenderer $ case mf of
Nothing -> liftIO (makeNewItemImage True filename) >>= cnstrctRItem >>= return . GotRItem
Just f -> liftIO (makeNewItemImage True f) >>= cnstrctRItem >>= return . GotRItem
RenderEv (GotRItem r) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False )
return r
else do
callRenderer $ liftIO (makeNewItemImage False filename) >>= cnstrctRItem >>= return . GotRItem
RenderEv (GotRItem r) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False )
return r
let cpn = view (currentCanvasInfo . unboxLens currentPageNum) uhdl
my <- autoPosText
let mpos = (\y->(PageNum cpn,PageCoord (50,y)))<$>my
insertItemAt mpos nitm
-- |
fileLoadSVG :: MainCoroutine ()
fileLoadSVG = do
fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action
where
action filename = do
xst <- get
bstr <- liftIO $ B.readFile filename
let uhdl = view (unitHoodles.currentUnit) xst
cvsid = getCurrentCanvasId uhdl
pgnum = view (currentCanvasInfo . unboxLens currentPageNum) uhdl
hdl = getHoodle uhdl
currpage = getPageFromGHoodleMap pgnum hdl
currlayer = getCurrentLayer currpage
--
callRenderer $ return . GotRItem =<< (cnstrctRItem . ItemSVG)
(SVG Nothing Nothing bstr (100,100) (Dim 300 300))
RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False )
--
let otheritems = view gitems currlayer
let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty)
modeChange ToSelectMode
updateUhdl $ \uhdl' -> do
thdl <- case view hoodleModeState uhdl' of
SelectState thdl' -> return thdl'
_ -> (lift . EitherT . return . Left . Other) "fileLoadSVG"
nthdl <- updateTempHoodleSelectM cvsid thdl ntpg pgnum
return . (hoodleModeState .~ SelectState nthdl)
. (isOneTimeSelectMode .~ YesAfterSelect) $ uhdl'
commit_
invalidateAll
-- |
askQuitProgram :: MainCoroutine ()
askQuitProgram = do
b <- okCancelMessageBox "Current canvas is not saved yet. Will you close hoodle?"
case b of
True -> doIOaction_ $ Gtk.postGUIAsync Gtk.mainQuit >> return (UsrEv ActionOrdered)
False -> return ()
-- |
embedPredefinedImage :: MainCoroutine ()
embedPredefinedImage = do
mpredefined <- S.embedPredefinedImageHook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
-- | this is temporary. I will remove it
embedPredefinedImage2 :: MainCoroutine ()
embedPredefinedImage2 = do
mpredefined <- S.embedPredefinedImage2Hook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
-- | this is temporary. I will remove it
embedPredefinedImage3 :: MainCoroutine ()
embedPredefinedImage3 = do
mpredefined <- S.embedPredefinedImage3Hook
case mpredefined of
Nothing -> return ()
Just filename -> embedImage filename
-- |
embedAllPDFBackground :: MainCoroutine ()
embedAllPDFBackground = do
hdl <- (rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit)) <$> get
nhdl <- liftIO . embedPDFInHoodle $ hdl
constructNewHoodleStateFromHoodle nhdl
commit_
invalidateAll
-- | embed an item from hoodlet using hoodlet identifier
embedHoodlet :: String -> MainCoroutine ()
embedHoodlet str = loadHoodlet str >>= mapM_ (insertItemAt Nothing)
-- |
mkRevisionHdlFile :: Hoodle -> IO (String,String)
mkRevisionHdlFile hdl = do
hdir <- getHomeDirectory
tempfile <- mkTmpFile "hdl"
let hdlbstr = builder hdl
L.writeFile tempfile hdlbstr
ctime <- getCurrentTime
let idstr = B.unpack (view hoodleID hdl)
md5str = show (md5 hdlbstr)
name = "UUID_"++idstr++"_MD5Digest_"++md5str++"_ModTime_"++ show ctime
nfilename = name <.> "hdl"
vcsdir = hdir </> ".hoodle.d" </> "vcs"
b <- doesDirectoryExist vcsdir
unless b $ createDirectory vcsdir
renameFile tempfile (vcsdir </> nfilename)
return (md5str,name)
mkRevisionPdfFile :: Hoodle -> String -> IO ()
mkRevisionPdfFile hdl fname = do
hdir <- getHomeDirectory
tempfile <- mkTmpFile "pdf"
renderHoodleToPDF hdl tempfile
let nfilename = fname <.> "pdf"
vcsdir = hdir </> ".hoodle.d" </> "vcs"
b <- doesDirectoryExist vcsdir
unless b $ createDirectory vcsdir
renameFile tempfile (vcsdir </> nfilename)
-- |
fileVersionSave :: MainCoroutine ()
fileVersionSave = do
hdl <- rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) <$> get
rmini <- minibufDialog "Commit Message:"
case rmini of
Right [] -> return ()
Right strks' -> do
doIOaction $ \_evhandler -> do
(md5str,fname) <- mkRevisionHdlFile hdl
mkRevisionPdfFile hdl fname
return (UsrEv (GotRevisionInk md5str strks'))
r <- waitSomeEvent (\case GotRevisionInk _ _ -> True ; _ -> False )
let GotRevisionInk md5str strks = r
nrev = RevisionInk (B.pack md5str) strks
pureUpdateUhdl $ \uhdl ->
let hdlmodst = view hoodleModeState uhdl
in case hdlmodst of
ViewAppendState rhdl' ->
let nrhdl = over grevisions (<> [nrev]) rhdl'
in (hoodleModeState .~ ViewAppendState nrhdl) uhdl
SelectState thdl ->
let nthdl = over gselRevisions (<> [nrev]) thdl
in (hoodleModeState .~ SelectState nthdl) uhdl
commit_
Left () -> do
txtstr <- maybe "" id <$> textInputDialog "revision description"
doIOaction $ \_evhandler -> do
(md5str,fname) <- mkRevisionHdlFile hdl
mkRevisionPdfFile hdl fname
return (UsrEv (GotRevision md5str txtstr))
r <- waitSomeEvent (\case GotRevision _ _ -> True ; _ -> False )
let GotRevision md5str txtstr' = r
nrev = Revision (B.pack md5str) (B.pack txtstr')
pureUpdateUhdl $ \uhdl ->
let hdlmodst = view hoodleModeState uhdl
in case hdlmodst of
ViewAppendState rhdl' ->
let nrhdl = over grevisions (<> [nrev]) rhdl'
in (hoodleModeState .~ ViewAppendState nrhdl) uhdl
SelectState thdl ->
let nthdl = over gselRevisions (<> [nrev]) thdl
in (hoodleModeState .~ SelectState nthdl) uhdl
commit_
showRevisionDialog :: Hoodle -> [Revision] -> MainCoroutine ()
showRevisionDialog hdl revs = do
cvsid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get
cache <- renderCache
doIOaction (action (cache,cvsid))
waitSomeEvent (\case GotOk -> True ; _ -> False)
return ()
where
action (cache,cvsid) _evhandler = do
dialog <- Gtk.dialogNew
#ifdef GTK3
upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)
vbox <- Gtk.vBoxNew False 0
Gtk.containerAdd upper vbox
#else
vbox <- Gtk.dialogGetUpper dialog
#endif
mapM_ (addOneRevisionBox cache cvsid vbox hdl) revs
_btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk
Gtk.widgetShowAll dialog
_res <- Gtk.dialogRun dialog
Gtk.widgetDestroy dialog
return (UsrEv GotOk)
mkPangoText :: String -> Cairo.Render ()
mkPangoText str = do
let pangordr = do
ctxt <- Gtk.cairoCreateContext Nothing
layout <- Gtk.layoutEmpty ctxt
fdesc <- Gtk.fontDescriptionNew
Gtk.fontDescriptionSetFamily fdesc ("Sans Mono" :: String)
Gtk.fontDescriptionSetSize fdesc 8.0
Gtk.layoutSetFontDescription layout (Just fdesc)
Gtk.layoutSetWidth layout (Just 250)
Gtk.layoutSetWrap layout Gtk.WrapAnywhere
Gtk.layoutSetText layout str
return layout
rdr layout = do Cairo.setSourceRGBA 0 0 0 1
Gtk.updateLayout layout
Gtk.showLayout layout
layout <- liftIO $ pangordr
rdr layout
addOneRevisionBox :: RenderCache -> CanvasId -> Gtk.VBox -> Hoodle -> Revision -> IO ()
addOneRevisionBox cache cvsid vbox hdl rev = do
cvs <- Gtk.drawingAreaNew
cvs `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 250 25)
cvs `Gtk.on` Gtk.exposeEvent $ Gtk.tryEvent $ do
#ifdef GTK3
Just drawwdw <- liftIO $ Gtk.widgetGetWindow cvs
#else
drawwdw <- liftIO $ Gtk.widgetGetDrawWindow cvs
#endif
#ifdef GTK3
liftIO . Gtk.renderWithDrawWindow drawwdw $ do
#else
liftIO . Gtk.renderWithDrawable drawwdw $ do
#endif
case rev of
RevisionInk _ strks -> Cairo.scale 0.5 0.5 >> mapM_ (cairoRender cache cvsid) strks
Revision _ txt -> mkPangoText (B.unpack txt)
hdir <- getHomeDirectory
let vcsdir = hdir </> ".hoodle.d" </> "vcs"
btn <- Gtk.buttonNewWithLabel ("view" :: String)
btn `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do
files <- liftIO $ getDirectoryContents vcsdir
let fstrinit = "UUID_" ++ B.unpack (view hoodleID hdl)
++ "_MD5Digest_" ++ B.unpack (view revmd5 rev)
matched = filter ((== "fdp") . take 3 . reverse)
. filter (\f -> fstrinit `List.isPrefixOf` f) $ files
case matched of
x : _ ->
liftIO (createProcess (proc "evince" [vcsdir </> x]))
>> return ()
_ -> return ()
hbox <- Gtk.hBoxNew False 0
Gtk.boxPackStart hbox cvs Gtk.PackNatural 0
Gtk.boxPackStart hbox btn Gtk.PackGrow 0
Gtk.boxPackStart vbox hbox Gtk.PackNatural 0
fileShowRevisions :: MainCoroutine ()
fileShowRevisions = do
rhdl <- getHoodle . view (unitHoodles.currentUnit) <$> get
let hdl = rHoodle2Hoodle rhdl
let revs = view grevisions rhdl
showRevisionDialog hdl revs
fileShowUUID :: MainCoroutine ()
fileShowUUID = do
hdl <- getHoodle . view (unitHoodles.currentUnit) <$> get
let uuidstr = view ghoodleID hdl
okMessageBox (B.unpack uuidstr)
loadHoodlet :: String -> MainCoroutine (Maybe RItem)
loadHoodlet str = do
homedir <- liftIO getHomeDirectory
let hoodled = homedir </> ".hoodle.d"
hoodletdir = hoodled </> "hoodlet"
b' <- liftIO $ doesDirectoryExist hoodletdir
if b'
then do
let fp = hoodletdir </> str <.> "hdlt"
bstr <- liftIO $ B.readFile fp
case parseOnly Hoodlet.hoodlet bstr of
Left err -> msgShout err >> return Nothing
Right itm -> do
--
callRenderer $ cnstrctRItem itm >>= return . GotRItem
RenderEv (GotRItem ritm) <-
waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False )
--
return (Just ritm)
else return Nothing
#ifdef HUB
-- |
syncFile :: MainCoroutine ()
syncFile = do
liftIO (putStrLn "syncFile called")
xst <- get
let uhdl = view (unitHoodles.currentUnit) xst
hdir <- liftIO $ getHomeDirectory
let tokfile = hdir </> ".hoodle.d" </> "token.txt"
runMaybeT $ do
let hdlidtxt = getHoodleID uhdl
hset <- (MaybeT . return . view hookSet) xst
hinfo <- (MaybeT . return) (hubInfo hset)
sqlfile <- (MaybeT . return . view (settings.sqliteFileName)) xst
hdlfp <- MaybeT . return $ getHoodleFilePath uhdl
mfstat <- liftIO $ getLastSyncStatus sqlfile hdlidtxt
lift $ prepareToken hinfo tokfile
lift $ doIOaction $ \evhandler -> do
forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e >> return ())) $
withHub hinfo tokfile $ \manager coojar -> do
flip runReaderT (manager,coojar) $ do
Just fstatServer <- sessionGetJSON (hubURL hinfo </> "sync" </> T.unpack hdlidtxt)
let patchwork =
rsyncPatchWork hinfo hdlfp fstatServer $ do
putStrLn "Am I called?"
(evhandler . UsrEv . SyncFileFinished) fstatServer
case mfstat of
Nothing -> patchwork
Just fstat ->
if fileSyncStatusTime fstat < fileSyncStatusTime fstatServer
then patchwork
else (liftIO . Gtk.postGUIAsync . evhandler . UsrEv . SyncFileFinished) fstat
return (UsrEv ActionOrdered)
SyncFileFinished nfstat <-
lift (waitSomeEvent (\case SyncFileFinished _-> True ; _ -> False ))
liftIO $ print nfstat
lift (updateSyncInfoAll nfstat)
when (Just nfstat /= mfstat) (lift fileReload)
return ()
#endif