diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Assistant.hs | 72 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Map.hs | 4 | ||||
| -rw-r--r-- | Command/Sync.hs | 43 | ||||
| -rw-r--r-- | Command/Watch.hs | 11 | ||||
| -rw-r--r-- | Command/WebApp.hs | 118 |
6 files changed, 227 insertions, 23 deletions
diff --git a/Command/Assistant.hs b/Command/Assistant.hs new file mode 100644 index 000000000..24cc3ec6c --- /dev/null +++ b/Command/Assistant.hs @@ -0,0 +1,72 @@ +{- 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 + programfile <- programFile + program <- catchDefaultIO (readFile programfile) "git-annex" + 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/Fsck.hs b/Command/Fsck.hs index 10cca489b..0e3cc934c 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 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/Sync.hs b/Command/Sync.hs index bdb5d47a7..dfaed5949 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -39,7 +39,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 <- currentBranch remotes <- syncRemotes rs return $ concat [ [ commit ] @@ -49,6 +49,11 @@ seek rs = do , [ pushLocal branch ] , [ pushRemote remote branch | remote <- remotes ] ] + +currentBranch :: Annex Git.Ref +currentBranch = do + !branch <- fromMaybe nobranch <$> inRepo Git.Branch.current + return branch where nobranch = error "no branch is checked out" @@ -98,7 +103,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 +112,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 @@ -143,19 +148,27 @@ mergeRemote remote branch = all id <$> (mapM merge =<< tomerge) 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 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..3b1952073 --- /dev/null +++ b/Command/WebApp.hs @@ -0,0 +1,118 @@ +{- 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.Threads.WebApp +import Utility.WebApp +import Utility.Daemon (checkDaemon, lockPidFile) +import Init +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 + f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim + ifM (checkpid <&&> checkshim f) $ + ( liftIO $ openBrowser f + , startDaemon True True $ Just $ + const openBrowser + ) + 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 + v <- newEmptyMVar + let callback a = Just $ a v + webAppThread Nothing dstatus scanremotes transferqueue + (callback signaler) (callback mainthread) + where + signaler v = do + putMVar v "" + takeMVar v + mainthread v _url htmlshim = do + openBrowser 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 :: FilePath -> IO () +openBrowser htmlshim = unlessM (runBrowser url) $ + error $ "failed to start web browser on url " ++ url + where + url = fileUrl htmlshim + +fileUrl :: FilePath -> String +fileUrl file = "file://" ++ file |