use the ~/.config/git-annex/program file to find command when running transfers

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
+		go program = getNextTransfer transferqueue dstatus notrunning >>= handle program
-		handle Nothing = go
+		handle program Nothing = go program
-		handle (Just (t, info)) = do
+		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 :: DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> TransferSlotRunner -> FilePath -> IO ()
-transferThread dstatus slots t info runner = case (transferRemote info, associatedFile info) of
+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

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

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

Command/Assistant.hs

@@ -55,8 +55,7 @@ autoStart = do
 	ifM (doesFileExist autostartfile)
 		( do
 			dirs <- lines <$> readFile autostartfile
-			programfile <- programFile
+			program <- readProgramFile
-			program <- catchDefaultIO (readFile programfile) "git-annex"
 			when (null dirs) nothing
 			forM_ dirs $ \d -> do
 				putStrLn $ "git-annex autostart in " ++ d

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"