File: gtkrsync.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 (74 lines) | stat: -rw-r--r-- 2,509 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
{- Copyright (c) 2007 John Goerzen <jgoerzen@complete.org>
   Please see the COPYRIGHT file -}

import System.IO
import Control.Concurrent.MVar
import RsyncParser
import RsyncGUI
import System.Environment
import System.Process
import System.Posix.IO
import System.Posix.Signals
import System.Posix.Process
import System.Exit

main = do
    args <- getArgs
    rsyncbin <- catch (getEnv "RSYNC") (\_ -> return "rsync")

    (readfd, writefd) <- createPipe
    pid <- forkProcess (childFunc args rsyncbin readfd writefd)
    closeFd writefd
    hasExited <- newMVar False

    readh <- fdToHandle readfd
    hSetBuffering readh (BlockBuffering Nothing)

    rsyncinput <- hGetContents readh
    let rsyncstream = customlines rsyncinput
    exitmv <- newMVar Nothing
    gui <- initRsyncGUI (exitButton pid hasExited exitmv)
    installHandler sigCHLD (Catch (chldHandler gui pid hasExited exitmv)) Nothing

    -- Check to see if we died before installing the handler
    ps <- getProcessStatus False False pid
    case ps of
         Nothing -> return ()
         Just x -> chldPs gui x hasExited exitmv

    runGUI gui rsyncstream exitmv

exitButton pid mv exitmv = withMVar mv $ \hasexited ->
    if hasexited
       then exitApp exitmv
       else do -- Cancel signal handler since we don't want notification to
               -- user of exit due to user's own action
               installHandler sigCHLD Default Nothing
               -- No need to update the MVar here since there won't be
               -- anything else to read it.  Besides, doing so would cause
               -- deadlock anyway.
               signalProcess sigKILL pid
               exitApp exitmv

childFunc args rsyncbin readfd writefd =
    do closeFd readfd
       dupTo writefd stdOutput
       dupTo writefd stdError
       closeFd writefd
       executeFile rsyncbin True args Nothing

chldHandler gui pid mv exitmv = 
    do ps <- getProcessStatus True False pid
       case ps of
            Just ps -> chldPs gui ps mv exitmv
            Nothing -> return ()

chldPs gui ps mv exitmv =
    do installHandler sigCHLD Default Nothing
       swapMVar mv True
       case ps of
         Exited ExitSuccess -> return ()
         Exited x -> do oobError gui ("rsync exited with unexpected error: " ++ show x)
                        swapMVar exitmv (Just x) >> return ()
         x -> do oobError gui ("rsync exited with unexpected condition: " ++ show x)
                 swapMVar exitmv (Just (ExitFailure 255)) >> return ()