File: RsyncGUI.hs

package info (click to toggle)
gtkrsync 1.0.4
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 236 kB
  • ctags: 4
  • sloc: haskell: 222; makefile: 71; sh: 62
file content (169 lines) | stat: -rw-r--r-- 6,262 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
{- Copyright (c) 2007 John Goerzen <jgoerzen@complete.org>
   Please see the COPYRIGHT file -}

module RsyncGUI where

import System.IO
import Control.Concurrent.MVar
import Control.Concurrent
import Data.List
import Text.Regex.Posix
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Control.Monad
import System.Exit
import Data.Progress.Tracker
import System.Time.Utils
import RsyncParser
import Paths_gtkrsync(getDataFileName)

data GUIParts = GUIParts {
    lfile :: Label,
    ltotal :: Label,
    mainwin :: Window,
    pbfile :: ProgressBar,
    pbtotal :: ProgressBar,
    messages :: TextView,
    messageswin :: ScrolledWindow,
    btdone :: Button}

initRsyncGUI :: IO () -> IO GUIParts
initRsyncGUI exitfunc = 
     do initGUI
        timeoutAddFull (yield >> return True)
                       priorityDefaultIdle 50
        gladefn <- getDataFileName "gtkrsync.glade"
        Just xml <- xmlNew gladefn
        -- Just xml <- xmlNew "gtkrsync.glade"

        window' <- xmlGetWidget xml castToWindow "mainwindow"
        onDestroy window' exitfunc

        pbfile' <- xmlGetWidget xml castToProgressBar "progressbarfile"
        pbtotal' <- xmlGetWidget xml castToProgressBar "progressbaroverall"
        lfile' <- xmlGetWidget xml castToLabel "labelfile"
        ltotal' <- xmlGetWidget xml castToLabel "labeloverall"
        messages' <- xmlGetWidget xml castToTextView "messages"
        messageswin' <- xmlGetWidget xml castToScrolledWindow "messageswindow"
        button' <- xmlGetWidget xml castToButton "donebutton"
        onClicked button' exitfunc

        let gui = GUIParts lfile' ltotal' window' pbfile' pbtotal' messages'
                  messageswin' button'
        
        forkIO mainGUI
        return gui

runGUI gui rsyncstream exitmv = 
    do streamWithMsgActions <- procmessages gui rsyncstream
       procstream gui streamWithMsgActions
       modifyMVar_ exitmv mvdone

       labelSetText (lfile gui) ""
       labelSetText (ltotal gui) "Sync process has finished"
       progressBarSetFraction (pbfile gui) 1.0
       progressBarSetText (pbfile gui) ""
       progressBarSetFraction (pbtotal gui) 1.0
       progressBarSetText (pbtotal gui) ""
       buttonSetLabel (btdone gui) "gtk-close"
    where mvdone Nothing = return (Just ExitSuccess)
          mvdone (Just x) = return (Just x)

exitApp exitmv = 
    do mainQuit
       ec <- takeMVar exitmv
       case ec of
            Nothing -> exitWith (ExitFailure 20)
            Just x -> exitWith x

procmessages gui stream = 
    do buf <- textViewGetBuffer (messages gui)
       iter <- textBufferGetEndIter buf
       mark <- textBufferCreateMark buf Nothing iter True
       -- tag <- textTagNew Nothing
       -- set tag [textTagFamily := "Monospace"]
       -- textBufferApplyTag buf tag iter iter
       return $ map (\x -> (procmsg gui buf mark x, snd x)) stream

procmsg gui buf mark (ltype, msg) =
    do end <- textBufferGetEndIter buf
       ipoint <- textBufferGetIterAtMark buf mark
       textBufferDelete buf ipoint end
       textBufferInsert buf ipoint ('\n' : msg)

       lines <- textBufferGetLineCount buf
       when (lines > 500) $ do
               start <- textBufferGetStartIter buf
               eol <- textBufferGetIterAtLine buf 1
               textBufferDelete buf start eol 

       -- scroll to the end of the buffer
       adj <- scrolledWindowGetVAdjustment (messageswin gui)
       upper <- adjustmentGetUpper adj
       adjustmentSetValue adj upper

       -- Update the iterator the new offset
       case ltype of
            HardLine -> do end <- textBufferGetEndIter buf
                           textBufferMoveMark buf mark end
            SoftLine -> return () -- leave the mark where it is
       return ()

procstream gui stream =
    do (totalfiles, remainingstream) <- procscanning gui stream
       progress <- newProgress "total" totalfiles
       mapM_ (procprogress gui progress) remainingstream

procscanning gui [] = return (0, [])
procscanning gui ((action,x):xs)
    | isSuffixOf "files..." x = 
        action 
        >> labelSetText (ltotal gui) ("Scanned " ++ (head (words x)) ++ " files")
        >> progressBarPulse (pbtotal gui)
        >> procscanning gui xs
    | isSuffixOf "files to consider" x =
        action
        >> labelSetText (ltotal gui) "" 
        >> progressBarSetFraction (pbtotal gui) 0.0
        >> return (read . head . words $ x, xs)
    | otherwise = action >> procscanning gui xs

procprogress gui progress (action, line)
    | progressl /= [] =
        do action
           case head progressl of
             [_, bytes, pct] -> 
               progressBarSetFraction (pbfile gui) ((read pct) / 100)
               >> progressBarSetText (pbfile gui) (pct ++ "%")
             x -> fail $ "Couldn't handle " ++ show x
           case tocheck of
             [] -> return ()
             [[_, thisfile, total]] ->
                 progressBarSetFraction (pbtotal gui) 
                    (1.0 - (ithisfile / itotal))
                 >> progressBarSetText (pbtotal gui)
                      ("File " ++ show (floor (itotal - ithisfile))
                       ++ " of " ++ total ++ " (" ++ show (intpct) ++ "%)")
                 >> setP progress (floor (itotal - ithisfile))
                 >> setetr
                 where itotal = read total 
                       ithisfile = read thisfile 
                       intpct = floor (100 * (1.0 - (ithisfile / itotal)))
                       setetr = do etr <- getETR progress
                                   labelSetText (ltotal gui) 
                                     ("ETA: " ++ renderSecs etr)
             x -> fail $ "Tocheck couldn't handle " ++ show x
    | otherwise =
        action >> labelSetText (lfile gui) line

    where progressl :: [[String]]
          progressl = line =~ "^ *([0-9]+) +([0-9]+)%" -- .+[0-9]+:[0-9]+:[0-9]+" =~ line
          tocheck = line =~ "xfer#[0-9]+, to-check=([0-9]+)/([0-9]+)"

oobError gui msg = 
    do dlg <- messageDialogNew (Just (mainwin gui)) [] MessageError ButtonsOk
              ("An error has been detected:\n\n" ++ msg ++ 
               "\n\nExpand the Messages area in the main window for details.")
       dialogRun dlg
       widgetDestroy dlg