diff options
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 20 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 2 | ||||
| -rw-r--r-- | Build/InstallDesktopFile.hs | 2 | ||||
| -rw-r--r-- | Command/Assistant.hs | 3 | ||||
| -rw-r--r-- | Locations/UserConfig.hs | 9 |
5 files changed, 21 insertions, 15 deletions
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index cb6f642bf..ae0adf300 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -18,6 +18,7 @@ import Logs.Location import Annex.Content import qualified Remote import Types.Key +import Locations.UserConfig import System.Process (create_group) @@ -30,23 +31,23 @@ maxTransfers = 1 {- Dispatches transfers from the queue. -} transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO () -transfererThread st dstatus transferqueue slots = go +transfererThread st dstatus transferqueue slots = go =<< readProgramFile where - go = getNextTransfer transferqueue dstatus notrunning >>= handle - handle Nothing = go - handle (Just (t, info)) = do + go program = getNextTransfer transferqueue dstatus notrunning >>= handle program + handle program Nothing = go program + handle program (Just (t, info)) = do ifM (runThreadState st $ shouldTransfer t info) ( do debug thisThread [ "Transferring:" , show t ] notifyTransfer dstatus - transferThread dstatus slots t info inTransferSlot + transferThread dstatus slots t info inTransferSlot program , do debug thisThread [ "Skipping unnecessary transfer:" , show t ] -- getNextTransfer added t to the -- daemonstatus's transfer map. void $ removeTransfer dstatus t ) - go + go program {- Skip transfers that are already running. -} notrunning i = startedTime i == Nothing @@ -79,8 +80,8 @@ shouldTransfer t info - the transfer info; the thread will also be killed when a transfer is - stopped, to avoid it displaying any alert about the transfer having - failed. -} -transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> IO () -transferThread dstatus slots t info runner = case (transferRemote info, associatedFile info) of +transferThread :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> FilePath -> IO () +transferThread dstatus slots t info runner program = case (transferRemote info, associatedFile info) of (Nothing, _) -> noop (_, Nothing) -> noop (Just remote, Just file) -> do @@ -93,14 +94,13 @@ transferThread dstatus slots t info runner = case (transferRemote info, associat transferprocess remote file = void $ do (_, _, _, pid) - <- createProcess (proc command $ toCommand params) + <- createProcess (proc program $ toCommand params) { create_group = True } status <- waitForProcess pid addAlert dstatus $ makeAlertFiller (status == ExitSuccess) $ transferFileAlert direction file where - command = "git-annex" params = [ Param "transferkey" , Param $ key2file $ transferKey t diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index e51eb7777..949793121 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -26,6 +26,7 @@ import Utility.DataUnits import Types.Key import qualified Remote import qualified Git +import Locations.UserConfig import Yesod import Text.Hamlet @@ -211,6 +212,7 @@ startTransfer t = do { transferPid = Nothing } liftIO $ Transferrer.transferThread dstatus slots t info inImmediateTransferSlot + =<< readProgramFile getCurrentTransfers :: Handler TransferMap getCurrentTransfers = currentTransfers diff --git a/Build/InstallDesktopFile.hs b/Build/InstallDesktopFile.hs index 891431ebe..3bcaecf9a 100644 --- a/Build/InstallDesktopFile.hs +++ b/Build/InstallDesktopFile.hs @@ -37,7 +37,7 @@ autostart command = genDesktopEntry (command ++ " assistant --autostart") [] -writeDesktop :: String -> IO () +writeDesktop :: FilePath -> IO () writeDesktop command = do destdir <- catchDefaultIO (getEnv "DESTDIR") "" uid <- fromIntegral <$> getRealUserID diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 24cc3ec6c..eb2a4a500 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -55,8 +55,7 @@ autoStart = do ifM (doesFileExist autostartfile) ( do dirs <- lines <$> readFile autostartfile - programfile <- programFile - program <- catchDefaultIO (readFile programfile) "git-annex" + program <- readProgramFile when (null dirs) nothing forM_ dirs $ \d -> do putStrLn $ "git-annex autostart in " ++ d diff --git a/Locations/UserConfig.hs b/Locations/UserConfig.hs index 9b04aed61..5da58eb9f 100644 --- a/Locations/UserConfig.hs +++ b/Locations/UserConfig.hs @@ -7,10 +7,9 @@ module Locations.UserConfig where +import Common import Utility.FreeDesktop -import System.FilePath - {- ~/.config/git-annex/file -} userConfigFile :: FilePath -> IO FilePath userConfigFile file = do @@ -24,3 +23,9 @@ autoStartFile = userConfigFile "autostart" - has installed it to some aweful non-PATH location. -} programFile :: IO FilePath programFile = userConfigFile "program" + +{- Returns a command to run for git-annex. -} +readProgramFile :: IO FilePath +readProgramFile = do + programfile <- programFile + catchDefaultIO (readFile programfile) "git-annex" |