Merge branch 'master' of ssh://git-annex.branchable.com
This commit is contained in:
commit
1c1596c2db
12 changed files with 153 additions and 77 deletions
3
.gitignore
vendored
3
.gitignore
vendored
|
@ -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
|
||||
|
|
8
Annex.hs
8
Annex.hs
|
@ -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
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
42
RemoteDaemon/Common.hs
Normal 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)
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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
12
doc/contribute.mdwn
Normal 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.
|
|
@ -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.
|
||||
|
|
|
@ -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/).
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue