diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/AddUnused.hs | 3 | ||||
| -rw-r--r-- | Command/Assistant.hs | 71 | ||||
| -rw-r--r-- | Command/DropKey.hs | 3 | ||||
| -rw-r--r-- | Command/Find.hs | 2 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/Fsck.hs | 7 | ||||
| -rw-r--r-- | Command/Map.hs | 4 | ||||
| -rw-r--r-- | Command/Move.hs | 9 | ||||
| -rw-r--r-- | Command/ReKey.hs | 2 | ||||
| -rw-r--r-- | Command/RecvKey.hs | 5 | ||||
| -rw-r--r-- | Command/SendKey.hs | 13 | ||||
| -rw-r--r-- | Command/Status.hs | 4 | ||||
| -rw-r--r-- | Command/Sync.hs | 76 | ||||
| -rw-r--r-- | Command/TransferKey.hs | 55 | ||||
| -rw-r--r-- | Command/Unused.hs | 3 | ||||
| -rw-r--r-- | Command/Watch.hs | 11 | ||||
| -rw-r--r-- | Command/WebApp.hs | 130 |
17 files changed, 339 insertions, 61 deletions
diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index c498216dc..f70500354 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -11,6 +11,7 @@ import Common.Annex import Logs.Unused import Command import qualified Command.Add +import Types.Key def :: [Command] def = [command "addunused" (paramRepeating paramNumRange) @@ -25,7 +26,7 @@ start = startUnused "addunused" perform (performOther "bad") (performOther "tmp" perform :: Key -> CommandPerform perform key = next $ Command.Add.cleanup file key True where - file = "unused." ++ show key + file = "unused." ++ key2file key {- The content is not in the annex, but in another directory, and - it seems better to error out, rather than moving bad/tmp content into diff --git a/Command/Assistant.hs b/Command/Assistant.hs new file mode 100644 index 000000000..eb2a4a500 --- /dev/null +++ b/Command/Assistant.hs @@ -0,0 +1,71 @@ +{- git-annex assistant + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Assistant where + +import Common.Annex +import Command +import qualified Option +import qualified Command.Watch +import Init +import Locations.UserConfig + +import System.Environment +import System.Posix.Directory + +def :: [Command] +def = [noRepo checkAutoStart $ dontCheck repoExists $ + withOptions [Command.Watch.foregroundOption, Command.Watch.stopOption, autoStartOption] $ + command "assistant" paramNothing seek "automatically handle changes"] + +autoStartOption :: Option +autoStartOption = Option.flag [] "autostart" "start in known repositories" + +seek :: [CommandSeek] +seek = [withFlag Command.Watch.stopOption $ \stopdaemon -> + withFlag Command.Watch.foregroundOption $ \foreground -> + withFlag autoStartOption $ \autostart -> + withNothing $ start foreground stopdaemon autostart] + +start :: Bool -> Bool -> Bool -> CommandStart +start foreground stopdaemon autostart + | autostart = do + liftIO $ autoStart + stop + | otherwise = do + ensureInitialized + Command.Watch.start True foreground stopdaemon + +{- Run outside a git repository. Check to see if any parameter is + - --autostart and enter autostart mode. -} +checkAutoStart :: IO () +checkAutoStart = ifM (any (== "--autostart") <$> getArgs) + ( autoStart + , error "Not in a git repository." + ) + +autoStart :: IO () +autoStart = do + autostartfile <- autoStartFile + let nothing = error $ "Nothing listed in " ++ autostartfile + ifM (doesFileExist autostartfile) + ( do + dirs <- lines <$> readFile autostartfile + program <- readProgramFile + when (null dirs) nothing + forM_ dirs $ \d -> do + putStrLn $ "git-annex autostart in " ++ d + ifM (catchBoolIO $ go program d) + ( putStrLn "ok" + , putStrLn "failed" + ) + , nothing + ) + where + go program dir = do + changeWorkingDirectory dir + boolSystem program [Param "assistant"] diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 68fdbfdd9..d55c5e83a 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -12,6 +12,7 @@ import Command import qualified Annex import Logs.Location import Annex.Content +import Types.Key def :: [Command] def = [oneShot $ command "dropkey" (paramRepeating paramKey) seek @@ -24,7 +25,7 @@ start :: Key -> CommandStart start key = stopUnless (inAnnex key) $ do unlessM (Annex.getState Annex.force) $ error "dropkey can cause data loss; use --force if you're sure you want to do this" - showStart "dropkey" (show key) + showStart "dropkey" (key2file key) next $ perform key perform :: Key -> CommandPerform diff --git a/Command/Find.hs b/Command/Find.hs index e568c3510..177b794cd 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -53,7 +53,7 @@ start format file (key, _) = do where vars = [ ("file", file) - , ("key", show key) + , ("key", key2file key) , ("backend", keyBackendName key) , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) diff --git a/Command/FromKey.hs b/Command/FromKey.hs index f7841c977..f998fe1e6 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -22,7 +22,7 @@ seek = [withWords start] start :: [String] -> CommandStart start (keyname:file:[]) = notBareRepo $ do - let key = fromMaybe (error "bad key") $ readKey keyname + let key = fromMaybe (error "bad key") $ file2key keyname inbackend <- inAnnex key unless inbackend $ error $ "key ("++ keyname ++") is not present in backend" diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 10cca489b..89ba0eef8 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -7,6 +7,8 @@ module Command.Fsck where +import System.Posix.Process (getProcessID) + import Common.Annex import Command import qualified Annex @@ -24,6 +26,7 @@ import Utility.DataUnits import Utility.FileMode import Config import qualified Option +import Types.Key def :: [Command] def = [withOptions options $ command "fsck" paramPaths seek @@ -112,7 +115,7 @@ startBare :: Key -> CommandStart startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of Nothing -> stop Just backend -> do - showStart "fsck" (show key) + showStart "fsck" (key2file key) next $ performBare key backend {- Note that numcopies cannot be checked in a bare repository, because @@ -120,7 +123,7 @@ startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName ke - files. -} performBare :: Key -> Backend -> CommandPerform performBare key backend = check - [ verifyLocationLog key (show key) + [ verifyLocationLog key (key2file key) , checkKeySize key , checkBackend backend key ] diff --git a/Command/Map.hs b/Command/Map.hs index 0773f6828..3dbdadbd6 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -199,8 +199,10 @@ tryScan r Left _ -> return Nothing Right r' -> return $ Just r' pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd (toCommand params) $ + withHandle StdoutHandle createProcessSuccess p $ Git.Config.hRead r + where + p = proc cmd $ toCommand params configlist = onRemote r (pipedconfig, Nothing) "configlist" [] [] diff --git a/Command/Move.hs b/Command/Move.hs index e7c11e80d..7955cecd3 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -135,13 +135,12 @@ fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform fromPerform src move key file = moveLock move key $ ifM (inAnnex key) ( handle move True - , download (Remote.uuid src) key (Just file) $ do - showAction $ "from " ++ Remote.name src - ok <- getViaTmp key $ - Remote.retrieveKeyFile src key (Just file) - handle move ok + , handle move =<< go ) where + go = download (Remote.uuid src) key (Just file) $ do + showAction $ "from " ++ Remote.name src + getViaTmp key $ Remote.retrieveKeyFile src key (Just file) handle _ False = stop -- failed handle False True = next $ return True -- copy complete handle True True = do -- finish moving diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 6de7e45e3..5bd419ca3 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -26,7 +26,7 @@ seek = [withPairs start] start :: (FilePath, String) -> CommandStart start (file, keyname) = ifAnnexed file go stop where - newkey = fromMaybe (error "bad key") $ readKey keyname + newkey = fromMaybe (error "bad key") $ file2key keyname go (oldkey, _) | oldkey == newkey = stop | otherwise = do diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index ce8bff997..0606f9c51 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -13,6 +13,7 @@ import CmdLine import Annex.Content import Utility.RsyncFile import Logs.Transfer +import Command.SendKey (fieldTransfer) def :: [Command] def = [oneShot $ command "recvkey" paramKey seek @@ -30,7 +31,7 @@ start key = ifM (inAnnex key) -- forcibly quit after receiving one key, -- and shutdown cleanly _ <- shutdown True - liftIO exitSuccess - , liftIO exitFailure + return True + , return False ) ) diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 5eca70d24..8f914b5ed 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -12,6 +12,7 @@ import Command import Annex.Content import Utility.RsyncFile import Logs.Transfer +import qualified Fields def :: [Command] def = [oneShot $ command "sendkey" paramKey seek @@ -24,9 +25,17 @@ start :: Key -> CommandStart start key = ifM (inAnnex key) ( fieldTransfer Upload key $ do file <- inRepo $ gitAnnexLocation key - liftIO $ ifM (rsyncServerSend file) - ( exitSuccess , exitFailure ) + liftIO $ rsyncServerSend file , do warning "requested key is not present" liftIO exitFailure ) + +fieldTransfer :: Direction -> Key -> Annex Bool -> CommandStart +fieldTransfer direction key a = do + afile <- Fields.getField Fields.associatedFile + ok <- maybe a (\u -> runTransfer (Transfer direction (toUUID u) key) afile a) + =<< Fields.getField Fields.remoteUUID + if ok + then liftIO exitSuccess + else liftIO exitFailure diff --git a/Command/Status.hs b/Command/Status.hs index 2d63c525c..7bb4dc8ca 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -183,8 +183,8 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do pp _ c [] = c pp uuidmap c ((t, i):xs) = "\n\t" ++ line uuidmap t i ++ pp uuidmap c xs line uuidmap t i = unwords - [ show (transferDirection t) ++ "ing" - , fromMaybe (show $ transferKey t) (associatedFile i) + [ showLcDirection (transferDirection t) ++ "ing" + , fromMaybe (key2file $ transferKey t) (associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap diff --git a/Command/Sync.hs b/Command/Sync.hs index bdb5d47a7..2a27bf870 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -6,8 +6,6 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Command.Sync where import Common.Annex @@ -27,8 +25,8 @@ import qualified Git import Git.Types (BlobType(..)) import qualified Types.Remote import qualified Remote.Git +import Types.Key -import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import Data.Hash.MD5 @@ -39,7 +37,7 @@ def = [command "sync" (paramOptional (paramRepeating paramRemote)) -- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do - !branch <- fromMaybe nobranch <$> inRepo Git.Branch.current + branch <- fromMaybe nobranch <$> inRepo Git.Branch.current remotes <- syncRemotes rs return $ concat [ [ commit ] @@ -63,23 +61,19 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) where pickfast = (++) <$> listed <*> (good =<< fastest <$> available) wanted - | null rs = good =<< concat . byspeed <$> available + | null rs = good =<< concat . Remote.byCost <$> available | otherwise = listed listed = do l <- catMaybes <$> mapM (Remote.byName . Just) rs - let s = filter special l + let s = filter Remote.specialRemote l unless (null s) $ error $ "cannot sync special remotes: " ++ unwords (map Types.Remote.name s) return l - available = filter nonspecial <$> Remote.enabledRemoteList + available = filter (not . Remote.specialRemote) + <$> Remote.enabledRemoteList good = filterM $ Remote.Git.repoAvail . Types.Remote.repo - nonspecial r = Types.Remote.remotetype r == Remote.Git.remote - special = not . nonspecial - fastest = fromMaybe [] . headMaybe . byspeed - byspeed = map snd . sort . M.toList . costmap - costmap = M.fromListWith (++) . map costpair - costpair r = (Types.Remote.cost r, [r]) + fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: CommandStart commit = do @@ -98,7 +92,7 @@ mergeLocal branch = go =<< needmerge syncbranch = syncBranch branch needmerge = do unlessM (inRepo $ Git.Ref.exists syncbranch) $ - updateBranch syncbranch + inRepo $ updateBranch syncbranch inRepo $ Git.Branch.changed branch syncbranch go False = stop go True = do @@ -107,17 +101,17 @@ mergeLocal branch = go =<< needmerge pushLocal :: Git.Ref -> CommandStart pushLocal branch = do - updateBranch $ syncBranch branch + inRepo $ updateBranch $ syncBranch branch stop -updateBranch :: Git.Ref -> Annex () -updateBranch syncbranch = +updateBranch :: Git.Ref -> Git.Repo -> IO () +updateBranch syncbranch g = unlessM go $ error $ "failed to update " ++ show syncbranch where - go = inRepo $ Git.Command.runBool "branch" + go = Git.Command.runBool "branch" [ Param "-f" , Param $ show $ Git.Ref.base syncbranch - ] + ] g pullRemote :: Remote -> Git.Ref -> CommandStart pullRemote remote branch = do @@ -125,7 +119,7 @@ pullRemote remote branch = do next $ do showOutput stopUnless fetch $ - next $ mergeRemote remote branch + next $ mergeRemote remote (Just branch) where fetch = inRepo $ Git.Command.runBool "fetch" [Param $ Remote.name remote] @@ -134,32 +128,46 @@ pullRemote remote branch = do - Which to merge from? Well, the master has whatever latest changes - were committed, while the synced/master may have changes that some - other remote synced to this remote. So, merge them both. -} -mergeRemote :: Remote -> Git.Ref -> CommandCleanup -mergeRemote remote branch = all id <$> (mapM merge =<< tomerge) +mergeRemote :: Remote -> (Maybe Git.Ref) -> CommandCleanup +mergeRemote remote b = case b of + Nothing -> do + branch <- inRepo Git.Branch.currentUnsafe + all id <$> (mapM merge $ branchlist branch) + Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b)) where merge = mergeFrom . remoteBranch remote - tomerge = filterM (changed remote) [branch, syncBranch branch] + tomerge branches = filterM (changed remote) branches + branchlist Nothing = [] + branchlist (Just branch) = [branch, syncBranch branch] pushRemote :: Remote -> Git.Ref -> CommandStart pushRemote remote branch = go =<< needpush where - needpush = anyM (newer remote) [syncbranch, Annex.Branch.name] + needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name] go False = stop go True = do showStart "push" (Remote.name remote) next $ next $ do showOutput - inRepo $ Git.Command.runBool "push" - [ Param (Remote.name remote) - , Param (show Annex.Branch.name) - , Param refspec - ] - refspec = show (Git.Ref.base branch) ++ ":" ++ show (Git.Ref.base syncbranch) - syncbranch = syncBranch branch + inRepo $ pushBranch remote branch + +pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool +pushBranch remote branch g = + Git.Command.runBool "push" + [ Param (Remote.name remote) + , Param (show Annex.Branch.name) + , Param refspec + ] g + where + refspec = concat + [ show $ Git.Ref.base branch + , ":" + , show $ Git.Ref.base $ syncBranch branch + ] mergeAnnex :: CommandStart mergeAnnex = do - Annex.Branch.forceUpdate + void $ Annex.Branch.forceUpdate stop mergeFrom :: Git.Ref -> Annex Bool @@ -248,8 +256,8 @@ resolveMerge' u -} mergeFile :: FilePath -> Key -> FilePath mergeFile file key - | doubleconflict = go $ show key - | otherwise = go $ shortHash $ show key + | doubleconflict = go $ key2file key + | otherwise = go $ shortHash $ key2file key where varmarker = ".variant-" doubleconflict = varmarker `isSuffixOf` (dropExtension file) diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs new file mode 100644 index 000000000..1af95f170 --- /dev/null +++ b/Command/TransferKey.hs @@ -0,0 +1,55 @@ +{- git-annex command, used internally by assistant + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.TransferKey where + +import Common.Annex +import Command +import Annex.Content +import Logs.Location +import Logs.Transfer +import qualified Remote +import Types.Remote +import qualified Command.Move +import qualified Option + +def :: [Command] +def = [withOptions options $ + oneShot $ command "transferkey" paramKey seek + "transfers a key from or to a remote"] + +options :: [Option] +options = fileOption : Command.Move.options + +fileOption :: Option +fileOption = Option.field [] "file" paramFile "the associated file" + +seek :: [CommandSeek] +seek = [withField Command.Move.toOption Remote.byName $ \to -> + withField Command.Move.fromOption Remote.byName $ \from -> + withField fileOption return $ \file -> + withKeys $ start to from file] + +start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart +start to from file key = + case (from, to) of + (Nothing, Just dest) -> next $ toPerform dest key file + (Just src, Nothing) -> next $ fromPerform src key file + _ -> error "specify either --from or --to" + +toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform +toPerform remote key file = next $ + upload (uuid remote) key file $ do + ok <- Remote.storeKey remote key file + when ok $ + Remote.logStatus remote key InfoPresent + return ok + +fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform +fromPerform remote key file = next $ + download (uuid remote) key file $ + getViaTmp key $ Remote.retrieveKeyFile remote key file diff --git a/Command/Unused.hs b/Command/Unused.hs index 09b4be5df..39a7a59cf 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -34,6 +34,7 @@ import qualified Remote import qualified Annex.Branch import qualified Option import Annex.CatFile +import Types.Key def :: [Command] def = [withOptions [fromOption] $ command "unused" paramNothing seek @@ -100,7 +101,7 @@ number n (x:xs) = (n+1, x) : number (n+1) xs table :: [(Int, Key)] -> [String] table l = " NUMBER KEY" : map cols l where - cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ show k + cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k pad n s = s ++ replicate (n - length s) ' ' staleTmpMsg :: [(Int, Key)] -> String diff --git a/Command/Watch.hs b/Command/Watch.hs index 5681b3861..eb70ef6b1 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - {- git-annex watch command - - Copyright 2012 Joey Hess <joey@kitenet.net> @@ -22,7 +19,7 @@ def = [withOptions [foregroundOption, stopOption] $ seek :: [CommandSeek] seek = [withFlag stopOption $ \stopdaemon -> withFlag foregroundOption $ \foreground -> - withNothing $ start foreground stopdaemon] + withNothing $ start False foreground stopdaemon] foregroundOption :: Option foregroundOption = Option.flag [] "foreground" "do not daemonize" @@ -30,9 +27,9 @@ foregroundOption = Option.flag [] "foreground" "do not daemonize" stopOption :: Option stopOption = Option.flag [] "stop" "stop daemon" -start :: Bool -> Bool -> CommandStart -start foreground stopdaemon = notBareRepo $ do +start :: Bool -> Bool -> Bool -> CommandStart +start assistant foreground stopdaemon = notBareRepo $ do if stopdaemon then stopDaemon - else startDaemon foreground -- does not return + else startDaemon assistant foreground Nothing -- does not return stop diff --git a/Command/WebApp.hs b/Command/WebApp.hs new file mode 100644 index 000000000..c8a7c7f59 --- /dev/null +++ b/Command/WebApp.hs @@ -0,0 +1,130 @@ +{- git-annex webapp launcher + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.WebApp where + +import Common.Annex +import Command +import Assistant +import Assistant.DaemonStatus +import Assistant.ScanRemotes +import Assistant.TransferQueue +import Assistant.TransferSlots +import Assistant.Threads.WebApp +import Utility.WebApp +import Utility.Daemon (checkDaemon, lockPidFile) +import Init +import qualified Git +import qualified Git.Config +import qualified Git.CurrentRepo +import qualified Annex +import Locations.UserConfig + +import System.Posix.Directory +import Control.Concurrent +import Control.Concurrent.STM + +def :: [Command] +def = [oneShot $ noRepo startNoRepo $ dontCheck repoExists $ + command "webapp" paramNothing seek "launch webapp"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = notBareRepo $ do + ifM (isInitialized) ( go , liftIO startNoRepo ) + stop + where + go = do + browser <- fromRepo webBrowser + f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim + ifM (checkpid <&&> checkshim f) $ + ( liftIO $ openBrowser browser f + , startDaemon True True $ Just $ + const $ openBrowser browser + ) + checkpid = do + pidfile <- fromRepo gitAnnexPidFile + liftIO $ isJust <$> checkDaemon pidfile + checkshim f = liftIO $ doesFileExist f + +{- When run without a repo, see if there is an autoStartFile, + - and if so, start the first available listed repository. + - If not, it's our first time being run! -} +startNoRepo :: IO () +startNoRepo = do + autostartfile <- autoStartFile + ifM (doesFileExist autostartfile) ( autoStart autostartfile , firstRun ) + +autoStart :: FilePath -> IO () +autoStart autostartfile = do + dirs <- lines <$> readFile autostartfile + edirs <- filterM doesDirectoryExist dirs + case edirs of + [] -> firstRun -- what else can I do? Nothing works.. + (d:_) -> do + changeWorkingDirectory d + state <- Annex.new =<< Git.CurrentRepo.get + void $ Annex.eval state $ doCommand start + +{- Run the webapp without a repository, which prompts the user, makes one, + - changes to it, starts the regular assistant, and redirects the + - browser to its url. + - + - This is a very tricky dance -- The first webapp calls the signaler, + - which signals the main thread when it's ok to continue by writing to a + - MVar. The main thread starts the second webapp, and uses its callback + - to write its url back to the MVar, from where the signaler retrieves it, + - returning it to the first webapp, which does the redirect. + - + - Note that it's important that mainthread never terminates! Much + - of this complication is due to needing to keep the mainthread running. + -} +firstRun :: IO () +firstRun = do + dstatus <- atomically . newTMVar =<< newDaemonStatus + scanremotes <- newScanRemoteMap + transferqueue <- newTransferQueue + transferslots <- newTransferSlots + v <- newEmptyMVar + let callback a = Just $ a v + webAppThread Nothing dstatus scanremotes transferqueue transferslots + (callback signaler) (callback mainthread) + where + signaler v = do + putMVar v "" + takeMVar v + mainthread v _url htmlshim = do + browser <- webBrowser <$> Git.Config.global + openBrowser browser htmlshim + + _wait <- takeMVar v + + state <- Annex.new =<< Git.CurrentRepo.get + Annex.eval state $ do + dummydaemonize + startAssistant True id $ Just $ sendurlback v + sendurlback v url _htmlshim = putMVar v url + {- Set up the pid file in the new repo. -} + dummydaemonize = do + liftIO . lockPidFile =<< fromRepo gitAnnexPidFile + +openBrowser :: Maybe FilePath -> FilePath -> IO () +openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd + where + url = fileUrl htmlshim + go a = unlessM (a url) $ + error $ "failed to start web browser on url " ++ url + runCustomBrowser c u = boolSystem c [Param u] + +{- web.browser is a generic git config setting for a web browser program -} +webBrowser :: Git.Repo -> Maybe FilePath +webBrowser = Git.Config.getMaybe "web.browser" + +fileUrl :: FilePath -> String +fileUrl file = "file://" ++ file |