summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-04-08 13:41:36 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-04-08 13:42:57 -0400
commit6e47a1412175cbc00f44ea8dc663ad83331cfb6d (patch)
treeecd8cec02d1a56ea38513cfb893b86504c606a3c
parent4772321f6a7359f282270c48be0e73563f8d7ae6 (diff)
cleaned up AnnexState handling in transports
-rw-r--r--Config.hs5
-rw-r--r--RemoteDaemon/Common.hs42
-rw-r--r--RemoteDaemon/Core.hs41
-rw-r--r--RemoteDaemon/Transport/Ssh.hs33
-rw-r--r--RemoteDaemon/Types.hs14
-rw-r--r--doc/design/git-remote-daemon.mdwn2
6 files changed, 95 insertions, 42 deletions
diff --git a/Config.hs b/Config.hs
index 10d4fd190..32644263f 100644
--- a/Config.hs
+++ b/Config.hs
@@ -32,7 +32,10 @@ getConfigMaybe (ConfigKey key) = fromRepo $ Git.Config.getMaybe key
setConfig :: ConfigKey -> String -> Annex ()
setConfig (ConfigKey key) value = do
inRepo $ Git.Command.run [Param "config", Param key, Param value]
- Annex.changeGitRepo =<< inRepo Git.Config.reRead
+ reloadConfig
+
+reloadConfig :: Annex ()
+reloadConfig = Annex.changeGitRepo =<< inRepo Git.Config.reRead
{- Unsets a git config setting. (Leaves it in state currently.) -}
unsetConfig :: ConfigKey -> Annex ()
diff --git a/RemoteDaemon/Common.hs b/RemoteDaemon/Common.hs
new file mode 100644
index 000000000..29aeb00d3
--- /dev/null
+++ b/RemoteDaemon/Common.hs
@@ -0,0 +1,42 @@
+{- git-remote-daemon utilities
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module RemoteDaemon.Common
+ ( liftAnnex
+ , inLocalRepo
+ , checkNewShas
+ ) where
+
+import qualified Annex
+import Common.Annex
+import RemoteDaemon.Types
+import qualified Git
+import Annex.CatFile
+
+import Control.Concurrent
+
+-- Runs an Annex action. Long-running actions should be avoided,
+-- since only one liftAnnex can be running at a time, amoung all
+-- transports.
+liftAnnex :: TransportHandle -> Annex a -> IO a
+liftAnnex (TransportHandle _ annexstate) a = do
+ st <- takeMVar annexstate
+ (r, st') <- Annex.run st a
+ putMVar annexstate st'
+ return r
+
+inLocalRepo :: TransportHandle -> (Git.Repo -> IO a) -> IO a
+inLocalRepo (TransportHandle g _) a = a g
+
+-- Check if any of the shas are actally new in the local git repo,
+-- to avoid unnecessary fetching.
+checkNewShas :: TransportHandle -> [Git.Sha] -> IO Bool
+checkNewShas transporthandle = check
+ where
+ check [] = return True
+ check (r:rs) = maybe (check rs) (const $ return False)
+ =<< liftAnnex transporthandle (catObjectDetails r)
diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs
index 8960bf8d3..cd4a0aaed 100644
--- a/RemoteDaemon/Core.hs
+++ b/RemoteDaemon/Core.hs
@@ -10,15 +10,17 @@ module RemoteDaemon.Core (runForeground) where
import qualified Annex
import Common
import Types.GitConfig
+import RemoteDaemon.Common
import RemoteDaemon.Types
import RemoteDaemon.Transport
import qualified Git
import qualified Git.Types as Git
import qualified Git.CurrentRepo
import Utility.SimpleProtocol
+import Config
import Control.Concurrent.Async
-import Control.Concurrent.Chan
+import Control.Concurrent
import Network.URI
import qualified Data.Map as M
@@ -50,36 +52,38 @@ type RemoteMap = M.Map Git.Repo (IO (), Chan Consumed)
-- the main control messages.
controller :: Chan Consumed -> Chan Emitted -> IO ()
controller ichan ochan = do
- m <- getRemoteMap ochan
+ h <- genTransportHandle
+ m <- genRemoteMap h ochan
startrunning m
- go False m
+ go h False m
where
- go paused m = do
+ go h paused m = do
cmd <- readChan ichan
case cmd of
RELOAD -> do
- m' <- getRemoteMap ochan
+ liftAnnex h reloadConfig
+ m' <- genRemoteMap h ochan
let common = M.intersection m m'
let new = M.difference m' m
let old = M.difference m m'
stoprunning old
unless paused $
startrunning new
- go paused (M.union common new)
+ go h paused (M.union common new)
PAUSE -> do
stoprunning m
- go True m
+ go h True m
RESUME -> do
when paused $
startrunning m
- go False m
+ go h False m
STOP -> exitSuccess
-- All remaining messages are sent to
-- all Transports.
msg -> do
unless paused $
forM_ chans (`writeChan` msg)
- go paused m
+ go h paused m
where
chans = map snd (M.elems m)
@@ -90,17 +94,12 @@ controller ichan ochan = do
stoprunning m = forM_ (M.elems m) stoprunning'
stoprunning' (_, c) = writeChan c STOP
-getRemoteMap :: Chan Emitted -> IO RemoteMap
-getRemoteMap ochan = do
- annexstate <- Annex.new =<< Git.CurrentRepo.get
- genRemoteMap annexstate ochan
-
-- Generates a map with a transport for each supported remote in the git repo,
-- except those that have annex.sync = false
-genRemoteMap :: Annex.AnnexState -> Chan Emitted -> IO RemoteMap
-genRemoteMap annexstate ochan = M.fromList . catMaybes <$> mapM gen rs
+genRemoteMap :: TransportHandle -> Chan Emitted -> IO RemoteMap
+genRemoteMap h@(TransportHandle g _) ochan =
+ M.fromList . catMaybes <$> mapM gen (Git.remotes g)
where
- rs = Git.remotes (Annex.repo annexstate)
gen r = case Git.location r of
Git.Url u -> case M.lookup (uriScheme u) remoteTransports of
Just transport
@@ -108,7 +107,13 @@ genRemoteMap annexstate ochan = M.fromList . catMaybes <$> mapM gen rs
ichan <- newChan :: IO (Chan Consumed)
return $ Just
( r
- , (transport r (Git.repoDescribe r) annexstate ichan ochan, ichan)
+ , (transport r (Git.repoDescribe r) h ichan ochan, ichan)
)
_ -> return Nothing
_ -> return Nothing
+
+genTransportHandle :: IO TransportHandle
+genTransportHandle = do
+ annexstate <- newMVar =<< Annex.new =<< Git.CurrentRepo.get
+ g <- Annex.repo <$> readMVar annexstate
+ return $ TransportHandle g annexstate
diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs
index 8f4d007e8..557a3dce9 100644
--- a/RemoteDaemon/Transport/Ssh.hs
+++ b/RemoteDaemon/Transport/Ssh.hs
@@ -8,13 +8,11 @@
module RemoteDaemon.Transport.Ssh (transport) where
import Common.Annex
-import qualified Annex
import RemoteDaemon.Types
-import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
+import RemoteDaemon.Common
import Remote.Helper.Ssh
+import qualified RemoteDaemon.Transport.Ssh.Types as SshRemote
import Utility.SimpleProtocol
-import qualified Git
-import Annex.CatFile
import Git.Command
import Control.Concurrent.Chan
@@ -22,13 +20,12 @@ import Control.Concurrent.Async
import System.Process (std_in, std_out)
transport :: Transport
-transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
- v <- git_annex_shell r "notifychanges" [] []
+transport r remotename transporthandle ichan ochan = do
+ v <- liftAnnex transporthandle $ git_annex_shell r "notifychanges" [] []
case v of
Nothing -> noop
- Just (cmd, params) -> liftIO $ go cmd (toCommand params)
+ Just (cmd, params) -> go cmd (toCommand params)
where
- send msg = writeChan ochan (msg remotename)
go cmd params = do
(Just toh, Just fromh, _, pid) <- createProcess (proc cmd params)
{ std_in = CreatePipe
@@ -45,9 +42,9 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
l <- hGetLine fromh
case parseMessage l of
Just SshRemote.READY -> send CONNECTED
- Just (SshRemote.CHANGED refs) ->
- Annex.eval annexstate $
- fetchNew remotename refs
+ Just (SshRemote.CHANGED shas) ->
+ whenM (checkNewShas transporthandle shas) $
+ fetch
Nothing -> shutdown
-- The only control message that matters is STOP.
@@ -66,10 +63,10 @@ transport r remotename annexstate ichan ochan = Annex.eval annexstate $ do
void $ tryIO $ concurrently fromshell handlecontrol
shutdown
--- Check if any of the shas are actally new, to avoid unnecessary fetching.
-fetchNew :: RemoteName -> [Git.Sha] -> Annex ()
-fetchNew remotename = check
- where
- check [] = void $ inRepo $ runBool [Param "fetch", Param remotename]
- check (r:rs) = maybe (check rs) (const noop)
- =<< catObjectDetails r
+ send msg = writeChan ochan (msg remotename)
+
+ fetch = do
+ send SYNCING
+ ok <- inLocalRepo transporthandle $
+ runBool [Param "fetch", Param remotename]
+ send (DONESYNCING ok)
diff --git a/RemoteDaemon/Types.hs b/RemoteDaemon/Types.hs
index 5cb0ef758..025c602df 100644
--- a/RemoteDaemon/Types.hs
+++ b/RemoteDaemon/Types.hs
@@ -18,14 +18,20 @@ import Control.Concurrent
-- A Transport for a particular git remote consumes some messages
-- from a Chan, and emits others to another Chan.
-type Transport = Git.Repo -> RemoteName -> Annex.AnnexState -> Chan Consumed -> Chan Emitted -> IO ()
+type Transport = RemoteRepo -> RemoteName -> TransportHandle -> Chan Consumed -> Chan Emitted -> IO ()
+
+type RemoteRepo = Git.Repo
+type LocalRepo = Git.Repo
+
+-- All Transports share a single AnnexState MVar
+data TransportHandle = TransportHandle LocalRepo (MVar Annex.AnnexState)
-- Messages that the daemon emits.
data Emitted
= CONNECTED RemoteName
| DISCONNECTED RemoteName
| SYNCING RemoteName
- | DONESYNCING RemoteName Bool
+ | DONESYNCING Bool RemoteName
-- Messages that the deamon consumes.
data Consumed
@@ -45,8 +51,8 @@ instance Proto.Sendable Emitted where
["DISCONNECTED", Proto.serialize remote]
formatMessage (SYNCING remote) =
["SYNCING", Proto.serialize remote]
- formatMessage (DONESYNCING remote status) =
- ["DONESYNCING", Proto.serialize remote, Proto.serialize status]
+ formatMessage (DONESYNCING status remote) =
+ ["DONESYNCING", Proto.serialize status, Proto.serialize remote]
instance Proto.Sendable Consumed where
formatMessage PAUSE = ["PAUSE"]
diff --git a/doc/design/git-remote-daemon.mdwn b/doc/design/git-remote-daemon.mdwn
index 5599a6f30..ad41fa447 100644
--- a/doc/design/git-remote-daemon.mdwn
+++ b/doc/design/git-remote-daemon.mdwn
@@ -82,7 +82,7 @@ the webapp.
Indicates that a pull or a push with a remote is in progress.
Always followed by DONESYNCING.
-* `DONESYNCING $remote 1|0`
+* `DONESYNCING 1|0 $remote`
Indicates that syncing with a remote is done, and either succeeded
(1) or failed (0).