Merge branch 'master' of ssh://git-annex.branchable.com

This commit is contained in:
Joey Hess 2014-04-08 16:32:30 -04:00
commit 1c1596c2db
12 changed files with 153 additions and 77 deletions

3
.gitignore vendored
View file

@ -23,6 +23,9 @@ html
dist
# Sandboxed builds
cabal-dev
.cabal-sandbox
cabal.sandbox.config
cabal.config
# Project-local emacs configuration
.dir-locals.el
# OSX related

View file

@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving, PackageImports #-}
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-}
module Annex (
Annex,
@ -63,7 +63,9 @@ import Types.DesktopNotify
import Types.CleanupActions
import qualified Data.Map as M
import qualified Data.Set as S
#ifdef WITH_QUVI
import Utility.Quvi (QuviVersion)
#endif
{- git-annex's monad is a ReaderT around an AnnexState stored in a MVar.
- This allows modifying the state in an exception-safe fashion.
@ -117,7 +119,9 @@ data AnnexState = AnnexState
, useragent :: Maybe String
, errcounter :: Integer
, unusedkeys :: Maybe (S.Set Key)
#ifdef WITH_QUVI
, quviversion :: Maybe QuviVersion
#endif
, existinghooks :: M.Map Git.Hook.Hook Bool
, desktopnotify :: DesktopNotify
}
@ -160,7 +164,9 @@ newState c r = AnnexState
, useragent = Nothing
, errcounter = 0
, unusedkeys = Nothing
#ifdef WITH_QUVI
, quviversion = Nothing
#endif
, existinghooks = M.empty
, desktopnotify = mempty
}

View file

@ -16,8 +16,7 @@ import Logs.Location
import Annex.Transfer
import qualified Remote
import Types.Key
import GHC.IO.Handle
import Utility.SimpleProtocol (ioHandles)
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
@ -29,7 +28,8 @@ seek :: CommandSeek
seek = withNothing start
start :: CommandStart
start = withHandles $ \(readh, writeh) -> do
start = do
(readh, writeh) <- liftIO ioHandles
runRequests readh writeh runner
stop
where
@ -44,21 +44,6 @@ start = withHandles $ \(readh, writeh) -> do
download (Remote.uuid remote) key file forwardRetry $ \p ->
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
{- stdin and stdout are connected with the caller, to be used for
- communication with it. But doing a transfer might involve something
- that tries to read from stdin, or write to stdout. To avoid that, close
- stdin, and duplicate stderr to stdout. Return two new handles
- that are duplicates of the original (stdin, stdout). -}
withHandles :: ((Handle, Handle) -> Annex a) -> Annex a
withHandles a = do
readh <- liftIO $ hDuplicate stdin
writeh <- liftIO $ hDuplicate stdout
liftIO $ do
nullh <- openFile devNull ReadMode
nullh `hDuplicateTo` stdin
stderr `hDuplicateTo` stdout
a (readh, writeh)
runRequests
:: Handle
-> Handle

View file

@ -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 ()

42
RemoteDaemon/Common.hs Normal file
View file

@ -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)

View file

@ -10,76 +10,79 @@ 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
runForeground :: IO ()
runForeground = do
(readh, writeh) <- ioHandles
ichan <- newChan :: IO (Chan Consumed)
ochan <- newChan :: IO (Chan Emitted)
void $ async $ controller ichan ochan
let reader = forever $ do
l <- getLine
l <- hGetLine readh
case parseMessage l of
Nothing -> error $ "protocol error: " ++ l
Just cmd -> writeChan ichan cmd
let writer = forever $ do
msg <- readChan ochan
putStrLn $ unwords $ formatMessage msg
hFlush stdout
hPutStrLn writeh $ unwords $ formatMessage msg
hFlush writeh
let controller = runController ichan ochan
-- If the reader or writer fails, for example because stdin/stdout
-- gets closed, kill the other one, and throw an exception which
-- will take down the daemon.
void $ concurrently reader writer
-- If any thread fails, the rest will be killed.
void $ tryIO $
reader `concurrently` writer `concurrently` controller
type RemoteMap = M.Map Git.Repo (IO (), Chan Consumed)
-- Runs the transports, dispatching messages to them, and handling
-- the main control messages.
controller :: Chan Consumed -> Chan Emitted -> IO ()
controller ichan ochan = do
m <- getRemoteMap ochan
runController :: Chan Consumed -> Chan Emitted -> IO ()
runController ichan ochan = do
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 +93,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 +106,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

View file

@ -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)

View file

@ -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"]

View file

@ -16,12 +16,13 @@ module Utility.SimpleProtocol (
parse1,
parse2,
parse3,
ioHandles,
) where
import Control.Applicative
import Data.Char
import GHC.IO.Handle
import Utility.Misc
import Common
-- Messages that can be sent.
class Sendable m where
@ -73,3 +74,17 @@ parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
splitWord :: String -> (String, String)
splitWord = separate isSpace
{- When a program speaks a simple protocol over stdio, any other output
- to stdout (or anything that attempts to read from stdin)
- will mess up the protocol. To avoid that, close stdin, and
- and duplicate stderr to stdout. Return two new handles
- that are duplicates of the original (stdin, stdout). -}
ioHandles :: IO (Handle, Handle)
ioHandles = do
readh <- hDuplicate stdin
writeh <- hDuplicate stdout
nullh <- openFile devNull ReadMode
nullh `hDuplicateTo` stdin
stderr `hDuplicateTo` stdout
return (readh, writeh)

12
doc/contribute.mdwn Normal file
View file

@ -0,0 +1,12 @@
Help make git-annex better!
* This website is a wiki, so you can edit and improve any page.
* Write a [[new_tip|tips]] explaining how to accomplish something with
git-annex.
* [[download]] the source code and send patches!
* If you know Haskell, git-annex has lots of Haskell code that
could be improved. See the [[coding_style]] and have at it.
* If you don't know Haskell, git-annex has many other coding opportunities.
You could work to improve the Android port (Java etc) or improve the
Javascript and CSS of the git-annex webapp, or work on porting libraries
needed by the Windows port.

View file

@ -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).
@ -114,6 +114,10 @@ the webapp.
Indicates that configs have changed. Daemon should reload .git/config
and/or restart.
Possible config changes include adding a new remote, removing a remote,
or setting `remote.<name>.annex-sync` to configure whether to sync with a
particular remote.
* `STOP`
Shut down git-remote-daemon
@ -156,8 +160,6 @@ No pushing is done for CHANGED, since git handles ssh natively.
TODO:
* It already detects changes and pulls, but it then dies with a protocol
error.
* Remote system might not be available. Find a smart way to detect it,
ideally w/o generating network traffic. One way might be to check
if the ssh connection caching control socket exists, for example.

View file

@ -39,7 +39,8 @@ files with git.
----
git-annex is [[Free Software|license]]
git-annex is [[Free Software|license]], written in Haskell.
You can [[contribute]]!
git-annex's wiki is powered by [Ikiwiki](http://ikiwiki.info/) and
hosted by [Branchable](http://branchable.com/).