packages feed

git-annex 5.20140402 → 5.20140405

raw patch · 25 files changed

+713/−183 lines, 25 files

Files

Annex/Notification.hs view
@@ -7,7 +7,7 @@  {-# LANGUAGE CPP #-} -module Annex.Notification where+module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where  import Common.Annex import Logs.Transfer@@ -29,22 +29,16 @@ #ifdef WITH_DBUS_NOTIFICATIONS notifyTransfer direction (Just f) a = do 	wanted <- Annex.getState Annex.desktopnotify-	let action = if direction == Upload then "uploading" else "downloading"-	let basedesc = action ++ " " ++ f-	let startdesc = "started " ++ basedesc-	let enddesc ok = if ok-		then "finished " ++ basedesc-		else basedesc ++ " failed" 	if (notifyStart wanted || notifyFinish wanted) 		then do 			client <- liftIO DBus.Client.connectSession 			startnotification <- liftIO $ if notifyStart wanted-				then Just <$> Notify.notify client (mkNote startdesc)+				then Just <$> Notify.notify client (startedTransferNote direction f) 				else pure Nothing 			ok <- a NotifyWitness 			when (notifyFinish wanted) $ liftIO $ void $ maybe -				(Notify.notify client $ mkNote $ enddesc ok)-				(\n -> Notify.replace client n $ mkNote $ enddesc ok)+				(Notify.notify client $ finishedTransferNote ok direction f)+				(\n -> Notify.replace client n $ finishedTransferNote ok direction f) 				startnotification 			return ok 		else a NotifyWitness@@ -59,22 +53,48 @@ 	wanted <- Annex.getState Annex.desktopnotify 	when (notifyFinish wanted) $ liftIO $ do 		client <- DBus.Client.connectSession-		let msg = if ok-			then "dropped " ++ f-			else "failed to drop" ++ f-		void $ Notify.notify client (mkNote msg)+		void $ Notify.notify client (droppedNote ok f) #else notifyDrop (Just _) _ = noop #endif  #ifdef WITH_DBUS_NOTIFICATIONS-mkNote :: String -> Notify.Note-mkNote desc = Notify.blankNote+startedTransferNote :: Direction -> FilePath -> Notify.Note+startedTransferNote Upload   = mkNote Notify.Transfer Notify.Low iconUpload+	"Uploading"+startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload+	"Downloading"++finishedTransferNote :: Bool -> Direction -> FilePath -> Notify.Note+finishedTransferNote False Upload   = mkNote Notify.TransferError Notify.Normal iconFailure+	"Failed to upload"+finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure+	"Failed to download"+finishedTransferNote True  Upload   = mkNote Notify.TransferComplete Notify.Low iconSuccess+	"Finished uploading"+finishedTransferNote True  Download = mkNote Notify.TransferComplete Notify.Low iconSuccess+	"Finished downloading"++droppedNote :: Bool -> FilePath -> Notify.Note+droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure+	"Failed to drop"+droppedNote True  = mkNote Notify.TransferComplete Notify.Low iconSuccess+	"Dropped"++iconUpload, iconDownload, iconFailure, iconSuccess :: String+iconUpload   = "network-transmit"+iconDownload = "network-receive"+iconFailure  = "dialog-error"+iconSuccess  = "git-annex"  -- Is there a standard icon for success/completion?++mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note+mkNote category urgency icon desc path = Notify.blankNote 	{ Notify.appName = "git-annex"-	, Notify.body = Just $ Notify.Text desc+	, Notify.appImage = Just (Notify.Icon icon)+	, Notify.summary = desc ++ " " ++ path 	, Notify.hints =-		[ Notify.Category Notify.Transfer-		, Notify.Urgency Notify.Low+		[ Notify.Category category+		, Notify.Urgency urgency 		, Notify.SuppressSound True 		] 	}
Assistant/Install.hs view
@@ -87,8 +87,9 @@ #ifdef linux_HOST_OS installNautilus program = do 	scriptdir <- (\d -> d </> "nautilus" </> "scripts") <$> userDataDir-	genscript scriptdir "get"-	genscript scriptdir "drop"+	whenM (doesDirectoryExist scriptdir) $ do+		genscript scriptdir "get"+		genscript scriptdir "drop"   where 	genscript scriptdir action = 		installscript (scriptdir </> scriptname action) $ unlines
Build/LinuxMkLibs.hs view
@@ -14,12 +14,10 @@ import System.Directory import Control.Monad import Data.List-import Data.List.Utils import System.Posix.Files-import Data.Char import Control.Monad.IfElse -import Utility.PartialPrelude+import Utility.LinuxMkLibs import Utility.Directory import Utility.Process import Utility.Monad@@ -41,7 +39,7 @@ 	libs <- parseLdd <$> readProcess "ldd" exes 	glibclibs <- glibcLibs 	let libs' = nub $ libs ++ glibclibs-	libdirs <- nub . catMaybes <$> mapM (installLib top) libs'+	libdirs <- nub . catMaybes <$> mapM (installLib installFile top) libs'  	-- Various files used by runshell to set up env vars used by the 	-- linker shims.@@ -53,26 +51,6 @@ 	 	mapM_ (installLinkerShim top) exes -{- Installs a library. If the library is a symlink to another file,- - install the file it links to, and update the symlink to be relative. -}-installLib :: FilePath -> FilePath -> IO (Maybe FilePath)-installLib top lib = ifM (doesFileExist lib)-	( do-		installFile top lib-		checksymlink lib-		return $ Just $ parentDir lib-	, return Nothing-	)-  where-	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do-		l <- readSymbolicLink (inTop top f)-		let absl = absPathFrom (parentDir f) l-		let target = relPathDirToFile (parentDir f) absl-		installFile top absl-		nukeFile (top ++ f)-		createSymbolicLink target (inTop top f)-		checksymlink absl- {- Installs a linker shim script around a binary.  -  - Note that each binary is put into its own separate directory,@@ -108,10 +86,6 @@   where 	destdir = inTop top $ parentDir f --- Note that f is not relative, so cannot use </>-inTop :: FilePath -> FilePath -> FilePath-inTop top f = top ++ f -- - checkExe :: FilePath -> IO Bool checkExe f 	| ".so" `isSuffixOf` f = return False@@ -127,18 +101,3 @@ 	[ "ELF" `isInfixOf` s 	, "executable" `isInfixOf` s || "shared object" `isInfixOf` s 	]--{- Parse ldd output, getting all the libraries that the input files- - link to. Note that some of the libraries may not exist - - (eg, linux-vdso.so) -}-parseLdd :: String -> [FilePath]-parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines-  where-	getlib l = headMaybe . words =<< lastMaybe (split " => " l)--{- Get all glibc libs and other support files, including gconv files- -- - XXX Debian specific. -}-glibcLibs :: IO [FilePath]-glibcLibs = lines <$> readProcess "sh"-	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
CHANGELOG view
@@ -1,3 +1,13 @@+git-annex (5.20140405) unstable; urgency=medium++  * git-annex-shell: Added notifychanges command.+  * Improve display of dbus notifications. Thanks, Johan Kiviniemi.+  * Fix nautilus script installation to not crash when the nautilus script dir+    does not exist. Instead, only install scripts when the directory already+    exists.++ -- Joey Hess <joeyh@debian.org>  Sat, 05 Apr 2014 16:54:33 -0400+ git-annex (5.20140402) unstable; urgency=medium    * unannex, uninit: Avoid committing after every file is unannexed,
CmdLine/GitAnnexShell.hs view
@@ -29,6 +29,7 @@ import qualified Command.SendKey import qualified Command.TransferInfo import qualified Command.Commit+import qualified Command.NotifyChanges import qualified Command.GCryptSetup  cmds_readonly :: [Command]@@ -37,6 +38,7 @@ 	, gitAnnexShellCheck Command.InAnnex.def 	, gitAnnexShellCheck Command.SendKey.def 	, gitAnnexShellCheck Command.TransferInfo.def+	, gitAnnexShellCheck Command.NotifyChanges.def 	]  cmds_notreadonly :: [Command]
+ Command/NotifyChanges.hs view
@@ -0,0 +1,83 @@+{- git-annex-shell command+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.NotifyChanges where++import Common.Annex+import Command+import Utility.DirWatcher+import Utility.DirWatcher.Types+import qualified Git+import Git.Sha+import RemoteDaemon.EndPoint.GitAnnexShell.Types++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM++def :: [Command]+def = [noCommit $ command "notifychanges" paramNothing seek SectionPlumbing+	"sends notification when git refs are changed"]++seek :: CommandSeek+seek = withNothing start++start :: CommandStart+start = do+	-- This channel is used to accumulate notifcations,+	-- because the DirWatcher might have multiple threads that find+	-- changes at the same time.+	chan <- liftIO newTChanIO+	+	g <- gitRepo+	let refdir = Git.localGitDir g </> "refs"+	liftIO $ createDirectoryIfMissing True refdir++	let notifyhook = Just $ notifyHook chan+	let hooks = mkWatchHooks+		{ addHook = notifyhook+		, modifyHook = notifyhook+		}++	void $ liftIO $ watchDir refdir (const False) True hooks id++	let sender = do+		send READY+		forever $ send . CHANGED =<< drain chan+	+	-- No messages need to be received from the caller,+	-- but when it closes the connection, notice and terminate.+	let receiver = forever $ void $ getLine+	void $ liftIO $ concurrently sender receiver+	stop++notifyHook :: TChan Git.Sha -> FilePath -> Maybe FileStatus -> IO ()+notifyHook chan reffile _+	| ".lock" `isSuffixOf` reffile = noop+	| otherwise = void $ do+		sha <- catchDefaultIO Nothing $+			extractSha <$> readFile reffile+		maybe noop (atomically . writeTChan chan) sha++-- When possible, coalesce ref writes that occur closely together+-- in time. Delay up to 0.05 seconds to get more ref writes.+drain :: TChan Git.Sha -> IO [Git.Sha]+drain chan = do+	r <- atomically $ readTChan chan+	threadDelay 50000+	rs <- atomically $ drain' chan+	return (r:rs)++drain' :: TChan Git.Sha -> STM [Git.Sha]+drain' chan = loop []+  where+	loop rs = maybe (return rs) (\r -> loop (r:rs)) =<< tryReadTChan chan++send :: Notification -> IO ()+send n = do+	putStrLn $ unwords $ formatMessage n+	hFlush stdout
Remote/External/Types.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Remote.External.Types ( 	External(..),@@ -15,9 +16,9 @@ 	withExternalLock, 	ExternalState(..), 	PrepareStatus(..),-	parseMessage,-	Sendable(..),-	Receivable(..),+	Proto.parseMessage,+	Proto.Sendable(..),+	Proto.Receivable(..), 	Request(..), 	needsPREPARE, 	Response(..),@@ -39,12 +40,11 @@ import Config.Cost (Cost) import Types.Remote (RemoteConfig) import Types.Availability (Availability(..))+import qualified Utility.SimpleProtocol as Proto -import Data.Char import Control.Concurrent.STM  -- If the remote is not yet running, the ExternalState TMVar is empty.--- The  data External = External 	{ externalType :: ExternalType 	, externalUUID :: UUID@@ -85,22 +85,6 @@ 	cleanup = atomically . putTMVar v 	v = externalLock external --- Messages that git-annex can send.-class Sendable m where-	formatMessage :: m -> [String]---- Messages that git-annex can receive.-class Receivable m where-	-- Passed the first word of the message, returns-	-- a Parser that can be be fed the rest of the message to generate-	-- the value.-	parseCommand :: String -> Parser m--parseMessage :: (Receivable m) => String -> Maybe m-parseMessage s = parseCommand command rest-  where-	(command, rest) = splitWord s- -- Messages that can be sent to the external remote to request it do something. data Request  	= PREPARE @@ -118,15 +102,19 @@ needsPREPARE INITREMOTE = False needsPREPARE _ = True -instance Sendable Request where+instance Proto.Sendable Request where 	formatMessage PREPARE = ["PREPARE"] 	formatMessage INITREMOTE = ["INITREMOTE"] 	formatMessage GETCOST = ["GETCOST"] 	formatMessage GETAVAILABILITY = ["GETAVAILABILITY"] 	formatMessage (TRANSFER direction key file) =-		[ "TRANSFER", serialize direction, serialize key, serialize file ]-	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ]-	formatMessage (REMOVE key) = [ "REMOVE", serialize key ]+		[ "TRANSFER"+		, Proto.serialize direction+		, Proto.serialize key+		, Proto.serialize file+		]+	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", Proto.serialize key ]+	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]  -- Responses the external remote can make to requests. data Response@@ -146,22 +134,22 @@ 	| UNSUPPORTED_REQUEST 	deriving (Show) -instance Receivable Response where-	parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS-	parseCommand "PREPARE-FAILURE" = parse1 PREPARE_FAILURE-	parseCommand "TRANSFER-SUCCESS" = parse2 TRANSFER_SUCCESS-	parseCommand "TRANSFER-FAILURE" = parse3 TRANSFER_FAILURE-	parseCommand "CHECKPRESENT-SUCCESS" = parse1 CHECKPRESENT_SUCCESS-	parseCommand "CHECKPRESENT-FAILURE" = parse1 CHECKPRESENT_FAILURE-	parseCommand "CHECKPRESENT-UNKNOWN" = parse2 CHECKPRESENT_UNKNOWN-	parseCommand "REMOVE-SUCCESS" = parse1 REMOVE_SUCCESS-	parseCommand "REMOVE-FAILURE" = parse2 REMOVE_FAILURE-	parseCommand "COST" = parse1 COST-	parseCommand "AVAILABILITY" = parse1 AVAILABILITY-	parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS-	parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE-	parseCommand "UNSUPPORTED-REQUEST" = parse0 UNSUPPORTED_REQUEST-	parseCommand _ = parseFail+instance Proto.Receivable Response where+	parseCommand "PREPARE-SUCCESS" = Proto.parse0 PREPARE_SUCCESS+	parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE+	parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS+	parseCommand "TRANSFER-FAILURE" = Proto.parse3 TRANSFER_FAILURE+	parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS+	parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE+	parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN+	parseCommand "REMOVE-SUCCESS" = Proto.parse1 REMOVE_SUCCESS+	parseCommand "REMOVE-FAILURE" = Proto.parse2 REMOVE_FAILURE+	parseCommand "COST" = Proto.parse1 COST+	parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY+	parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS+	parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE+	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST+	parseCommand _ = Proto.parseFail  -- Requests that the external remote can send at any time it's in control. data RemoteRequest@@ -181,22 +169,22 @@ 	| DEBUG String 	deriving (Show) -instance Receivable RemoteRequest where-	parseCommand "VERSION" = parse1 VERSION-	parseCommand "PROGRESS" = parse1 PROGRESS-	parseCommand "DIRHASH" = parse1 DIRHASH-	parseCommand "SETCONFIG" = parse2 SETCONFIG-	parseCommand "GETCONFIG" = parse1 GETCONFIG-	parseCommand "SETCREDS" = parse3 SETCREDS-	parseCommand "GETCREDS" = parse1 GETCREDS-	parseCommand "GETUUID" = parse0 GETUUID-	parseCommand "GETGITDIR" = parse0 GETGITDIR-	parseCommand "SETWANTED" = parse1 SETWANTED-	parseCommand "GETWANTED" = parse0 GETWANTED-	parseCommand "SETSTATE" = parse2 SETSTATE-	parseCommand "GETSTATE" = parse1 GETSTATE-	parseCommand "DEBUG" = parse1 DEBUG-	parseCommand _ = parseFail+instance Proto.Receivable RemoteRequest where+	parseCommand "VERSION" = Proto.parse1 VERSION+	parseCommand "PROGRESS" = Proto.parse1 PROGRESS+	parseCommand "DIRHASH" = Proto.parse1 DIRHASH+	parseCommand "SETCONFIG" = Proto.parse2 SETCONFIG+	parseCommand "GETCONFIG" = Proto.parse1 GETCONFIG+	parseCommand "SETCREDS" = Proto.parse3 SETCREDS+	parseCommand "GETCREDS" = Proto.parse1 GETCREDS+	parseCommand "GETUUID" = Proto.parse0 GETUUID+	parseCommand "GETGITDIR" = Proto.parse0 GETGITDIR+	parseCommand "SETWANTED" = Proto.parse1 SETWANTED+	parseCommand "GETWANTED" = Proto.parse0 GETWANTED+	parseCommand "SETSTATE" = Proto.parse2 SETSTATE+	parseCommand "GETSTATE" = Proto.parse1 GETSTATE+	parseCommand "DEBUG" = Proto.parse1 DEBUG+	parseCommand _ = Proto.parseFail  -- Responses to RemoteRequest. data RemoteResponse@@ -204,21 +192,21 @@ 	| CREDS String String 	deriving (Show) -instance Sendable RemoteResponse where-	formatMessage (VALUE s) = [ "VALUE", serialize s ]-	formatMessage (CREDS login password) = [ "CREDS", serialize login, serialize password ]+instance Proto.Sendable RemoteResponse where+	formatMessage (VALUE s) = [ "VALUE", Proto.serialize s ]+	formatMessage (CREDS login password) = [ "CREDS", Proto.serialize login, Proto.serialize password ]  -- Messages that can be sent at any time by either git-annex or the remote. data AsyncMessage 	= ERROR ErrorMsg 	deriving (Show) -instance Sendable AsyncMessage where-	formatMessage (ERROR err) = [ "ERROR", serialize err ]+instance Proto.Sendable AsyncMessage where+	formatMessage (ERROR err) = [ "ERROR", Proto.serialize err ] -instance Receivable AsyncMessage where-	parseCommand "ERROR" = parse1 ERROR-	parseCommand _ = parseFail+instance Proto.Receivable AsyncMessage where+	parseCommand "ERROR" = Proto.parse1 ERROR+	parseCommand _ = Proto.parseFail  -- Data types used for parameters when communicating with the remote. -- All are serializable.@@ -229,11 +217,7 @@ supportedProtocolVersions :: [ProtocolVersion] supportedProtocolVersions = [1] -class ExternalSerializable a where-	serialize :: a -> String-	deserialize :: String -> Maybe a--instance ExternalSerializable Direction where+instance Proto.Serializable Direction where 	serialize Upload = "STORE" 	serialize Download = "RETRIEVE" @@ -241,23 +225,23 @@ 	deserialize "RETRIEVE" = Just Download 	deserialize _ = Nothing -instance ExternalSerializable Key where+instance Proto.Serializable Key where 	serialize = key2file 	deserialize = file2key -instance ExternalSerializable [Char] where+instance Proto.Serializable [Char] where 	serialize = id 	deserialize = Just -instance ExternalSerializable ProtocolVersion where+instance Proto.Serializable ProtocolVersion where 	serialize = show 	deserialize = readish -instance ExternalSerializable Cost where+instance Proto.Serializable Cost where 	serialize = show 	deserialize = readish -instance ExternalSerializable Availability where+instance Proto.Serializable Availability where 	serialize GloballyAvailable = "GLOBAL" 	serialize LocallyAvailable = "LOCAL" @@ -265,37 +249,6 @@ 	deserialize "LOCAL" = Just LocallyAvailable 	deserialize _ = Nothing -instance ExternalSerializable BytesProcessed where+instance Proto.Serializable BytesProcessed where 	serialize (BytesProcessed n) = show n 	deserialize = BytesProcessed <$$> readish--{- Parsing the parameters of messages. Using the right parseN ensures- - that the string is split into exactly the requested number of words,- - which allows the last parameter of a message to contain arbitrary- - whitespace, etc, without needing any special quoting.- -}-type Parser a = String -> Maybe a--parseFail :: Parser a-parseFail _ = Nothing--parse0 :: a -> Parser a-parse0 mk "" = Just mk-parse0 _ _ = Nothing--parse1 :: ExternalSerializable p1 => (p1 -> a) -> Parser a-parse1 mk p1 = mk <$> deserialize p1--parse2 :: (ExternalSerializable p1, ExternalSerializable p2) => (p1 -> p2 -> a) -> Parser a-parse2 mk s = mk <$> deserialize p1 <*> deserialize p2-  where-	(p1, p2) = splitWord s--parse3 :: (ExternalSerializable p1, ExternalSerializable p2, ExternalSerializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a-parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3-  where-	(p1, rest) = splitWord s-	(p2, p3) = splitWord rest--splitWord :: String -> (String, String)-splitWord = separate isSpace
+ RemoteDaemon/EndPoint/GitAnnexShell/Types.hs view
@@ -0,0 +1,32 @@+{- git-remote-daemon, git-annex-shell endpoint, datatypes+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module RemoteDaemon.EndPoint.GitAnnexShell.Types (+	Notification(..),+	Proto.serialize,+	Proto.deserialize,+	Proto.formatMessage,+) where++import qualified Utility.SimpleProtocol as Proto+import RemoteDaemon.Types (ShaList)++data Notification+	= READY+	| CHANGED ShaList++instance Proto.Sendable Notification where+	formatMessage READY = ["READY"]+	formatMessage (CHANGED shas) = ["CHANGED", Proto.serialize shas]++instance Proto.Receivable Notification where+	parseCommand "READY" = Proto.parse0 READY+	parseCommand "CHANGED" = Proto.parse1 CHANGED+	parseCommand _ = Proto.parseFail
+ RemoteDaemon/Types.hs view
@@ -0,0 +1,83 @@+{- git-remote-daemon data types.+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module RemoteDaemon.Types where++import qualified Git.Types as Git+import qualified Utility.SimpleProtocol as Proto++-- Messages that the daemon emits.+data Emitted+	= CONNECTED RemoteName+	| DISCONNECTED RemoteName+	| CHANGED RemoteName ShaList+	| STATUS RemoteName UserMessage+	| ERROR RemoteName UserMessage++-- Messages that the deamon consumes.+data Consumed+	= PAUSE+	| RESUME+	| PUSH RemoteName+	| RELOAD++type RemoteName = String+type UserMessage = String+type ShaList = [Git.Sha]++instance Proto.Sendable Emitted where+	formatMessage (CONNECTED remote) =+		["CONNECTED", Proto.serialize remote]+	formatMessage (DISCONNECTED remote) =+		["DISCONNECTED", Proto.serialize remote]+	formatMessage (CHANGED remote shas) =+		["CHANGED"+		, Proto.serialize remote+		, Proto.serialize shas+		]+	formatMessage (STATUS remote msg) =+		["STATUS"+		, Proto.serialize remote+		, Proto.serialize msg+		]+	formatMessage (ERROR remote msg) =+		["ERROR"+		, Proto.serialize remote+		, Proto.serialize msg+		]++instance Proto.Sendable Consumed where+	formatMessage PAUSE = ["PAUSE"]+	formatMessage RESUME = ["RESUME"]+	formatMessage (PUSH remote) = ["PUSH", Proto.serialize remote]+	formatMessage RELOAD = ["RELOAD"]++instance Proto.Receivable Emitted where+	parseCommand "CONNECTED" = Proto.parse1 CONNECTED+	parseCommand "DISCONNECTED" = Proto.parse1 DISCONNECTED+	parseCommand "CHANGED" = Proto.parse2 CHANGED+	parseCommand "STATUS" = Proto.parse2 STATUS+	parseCommand "ERROR" = Proto.parse2 ERROR+	parseCommand _ = Proto.parseFail++instance Proto.Receivable Consumed where+	parseCommand "PAUSE" = Proto.parse0 PAUSE+	parseCommand "RESUME" = Proto.parse0 RESUME+	parseCommand "PUSH" = Proto.parse1 PUSH+	parseCommand "RELOAD" = Proto.parse0 RELOAD+	parseCommand _ = Proto.parseFail++instance Proto.Serializable [Char] where+	serialize = id+	deserialize = Just++instance Proto.Serializable ShaList where+	serialize = unwords . map Git.fromRef+	deserialize = Just . map Git.Ref . words
+ Utility/LinuxMkLibs.hs view
@@ -0,0 +1,61 @@+{- Linux library copier and binary shimmer+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.LinuxMkLibs where++import Control.Applicative+import Data.Maybe+import System.Directory+import Data.List.Utils+import System.Posix.Files+import Data.Char+import Control.Monad.IfElse++import Utility.PartialPrelude+import Utility.Directory+import Utility.Process+import Utility.Monad+import Utility.Path++{- Installs a library. If the library is a symlink to another file,+ - install the file it links to, and update the symlink to be relative. -}+installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)+installLib installfile top lib = ifM (doesFileExist lib)+	( do+		installfile top lib+		checksymlink lib+		return $ Just $ parentDir lib+	, return Nothing+	)+  where+	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do+		l <- readSymbolicLink (inTop top f)+		let absl = absPathFrom (parentDir f) l+		let target = relPathDirToFile (parentDir f) absl+		installfile top absl+		nukeFile (top ++ f)+		createSymbolicLink target (inTop top f)+		checksymlink absl++-- Note that f is not relative, so cannot use </>+inTop :: FilePath -> FilePath -> FilePath+inTop top f = top ++ f++{- Parse ldd output, getting all the libraries that the input files+ - link to. Note that some of the libraries may not exist + - (eg, linux-vdso.so) -}+parseLdd :: String -> [FilePath]+parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines+  where+	getlib l = headMaybe . words =<< lastMaybe (split " => " l)++{- Get all glibc libs and other support files, including gconv files+ -+ - XXX Debian specific. -}+glibcLibs :: IO [FilePath]+glibcLibs = lines <$> readProcess "sh"+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
+ Utility/SimpleProtocol.hs view
@@ -0,0 +1,75 @@+{- Simple line-based protocols.+ -+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.SimpleProtocol (+	Sendable(..),+	Receivable(..),+	parseMessage,+	Serializable(..),+	Parser,+	parseFail,+	parse0,+	parse1,+	parse2,+	parse3,+) where++import Control.Applicative+import Data.Char++import Utility.Misc++-- Messages that can be sent.+class Sendable m where+	formatMessage :: m -> [String]++-- Messages that can be received.+class Receivable m where+	-- Passed the first word of the message, returns+	-- a Parser that can be be fed the rest of the message to generate+	-- the value.+	parseCommand :: String -> Parser m++parseMessage :: (Receivable m) => String -> Maybe m+parseMessage s = parseCommand command rest+  where+	(command, rest) = splitWord s++class Serializable a where+	serialize :: a -> String+	deserialize :: String -> Maybe a++{- Parsing the parameters of messages. Using the right parseN ensures+ - that the string is split into exactly the requested number of words,+ - which allows the last parameter of a message to contain arbitrary+ - whitespace, etc, without needing any special quoting.+ -}+type Parser a = String -> Maybe a++parseFail :: Parser a+parseFail _ = Nothing++parse0 :: a -> Parser a+parse0 mk "" = Just mk+parse0 _ _ = Nothing++parse1 :: Serializable p1 => (p1 -> a) -> Parser a+parse1 mk p1 = mk <$> deserialize p1++parse2 :: (Serializable p1, Serializable p2) => (p1 -> p2 -> a) -> Parser a+parse2 mk s = mk <$> deserialize p1 <*> deserialize p2+  where+	(p1, p2) = splitWord s++parse3 :: (Serializable p1, Serializable p2, Serializable p3) => (p1 -> p2 -> p3 -> a) -> Parser a+parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3+  where+	(p1, rest) = splitWord s+	(p2, p3) = splitWord rest++splitWord :: String -> (String, String)+splitWord = separate isSpace
debian/changelog view
@@ -1,3 +1,13 @@+git-annex (5.20140405) unstable; urgency=medium++  * git-annex-shell: Added notifychanges command.+  * Improve display of dbus notifications. Thanks, Johan Kiviniemi.+  * Fix nautilus script installation to not crash when the nautilus script dir+    does not exist. Instead, only install scripts when the directory already+    exists.++ -- Joey Hess <joeyh@debian.org>  Sat, 05 Apr 2014 16:54:33 -0400+ git-annex (5.20140402) unstable; urgency=medium    * unannex, uninit: Avoid committing after every file is unannexed,
+ doc/bugs/Repository_Information_Is_Lost.mdwn view
@@ -0,0 +1,31 @@+### Please describe the problem.++Clone of a repository does not contain the names of other repositories.++### What steps will reproduce the problem?+++### What version of git-annex are you using? On what operating system?++Mac OS X++git-annex version: 5.20140308-g06fb279+build flags: Assistant Webapp Pairing Testsuite S3 WebDAV FsEvents XMPP DNS Feeds Qu+vi TDFA CryptoHash                                                                 +key/value backends: SHA256E SHA1E SHA512E SHA224E SHA384E SKEIN256E SKEIN512E SHA256+ SHA1 SHA512 SHA224 SHA384 SKEIN256 SKEIN512 WORM URL                              +remote types: git gcrypt S3 bup directory rsync web webdav tahoe glacier hook extern+al +++### Please provide any additional information below.++Clones of my repositories lost all track of other repositories they only seem to know about them selfs attempting to remove other repositories (git annex dead name-of-an-existing-repo) fails, telling me that the repository with the name is not found.++[[!format sh """+# If you can, paste a complete transcript of the problem occurring here.+# If the problem is with the git-annex assistant, paste in .git/annex/daemon.log+++# End of transcript or log.+"""]]
doc/design/assistant/telehash.mdwn view
@@ -66,8 +66,7 @@  ## separate daemon? -A `gathd` could contain all the telehash specific code, and git-annex-communicate with it via a local socket.+See [[git-remote-daemon]] for a design.  Advantages: @@ -88,8 +87,4 @@  Disadvantages: -* Adds a memcopy when large files are being transferred through telehash.-  Unlikely to be a bottleneck. * Adds some complexity.-* What IPC to use on Windows? Might have to make git-annex communicate-  with it over its stdin/stdout there.
+ doc/design/git-remote-daemon.mdwn view
@@ -0,0 +1,159 @@+# goals++* be configured like a regular git remote, with an unusual url+  or other configuration+* receive notifications when a remote has received new commits,+  and take some action+* optionally, do receive-pack and send-pack to a remote that+  is only accessible over an arbitrary network transport+  (like assistant does with XMPP)+* optionally, send/receive git-annex objects to remote+  over an arbitrary network transport++# difficulties++* authentication & configuration+* multiple nodes may be accessible over a single network transport,+  with it desirable to sync with any/all of them. For example, with+  XMPP, there can be multiple friends synced with. This means that+  one git remote can map to multiple remote nodes. Specific to git-annex,+  this means that a set of UUIDs known to be associated with the remote+  needs to be maintained, while currently each remote can only have one+  annex-uuid in .git/config.++# payoffs++* support [[assistant/telehash]]!+* Allow running against a normal ssh git remote. This would run+  git-annex-shell on the remote, watching for changes, and so be able to+  notify when a commit was pushed to the remote repo. This would let the+  assistant immediately notice and pull. So the assistant would be fully+  usable with a single ssh remote and no other configuration!+  **do this first**+* clean up existing XMPP support, make it not a special case, and not+  tightly tied to the assistant+* git-remote-daemon could be used independantly of git-annex,+  in any git repository.++# design++Let git-remote-daemon be the name. It runs in a repo and+either:++* forks to background and performs configured actions (ie, `git pull`)+* with --foreground, communicates over stdio+  with its caller using a simple protocol (exiting when its caller closes its+  stdin handle so it will stop when the assistant stops).++It is configured entirely by .git/config.++# encryption & authentication++For simplicity, the network transports have to do their own end-to-end+encryption. Encryption is not part of this design.++(XMPP does not do end-to-end encryption, but might be supported+transitionally.)++Ditto for authentication that we're talking to who we indend to talk to.+Any public key data etc used for authenticion is part of the remote's+configuration (or hidden away in a secure chmodded file, if neccesary).+This design does not concern itself with authenticating the remote node,+it just takes the auth token and uses it.++For example, in telehash, each node has its own keypair, which is used+or authentication and encryption, and is all that's needed to route+messages to that node.++# stdio protocol++This is an asynchronous protocol. Ie, either side can send any message+at any time, and the other side does not send a reply.++It is line based and intended to be low volume and not used for large data.++TODO: Expand with commands for sending/receiving git-annex objects, and+progress during transfer.++TODO: Will probably need to add something for whatever pairing is done by+the webapp.++## emitted messages++* `CONNECTED $remote`++  Send when a connection has been made with a remote.++* `DISCONNECTED $remote`++  Send when connection with a remote has been lost.++* `CHANGED $remote $sha ...`++  This indicates that refs in the named git remote have changed,+  and indicates the new shas.++* `STATUS $remote $string`++  A user-visible status message about a named remote.++* `ERROR $remote $string`++  A user-visible error about a named remote.  +  (Can continue running past this point, for this or other remotes.)++## consumed messages++* `PAUSE`++  This indicates that the network connection has gone down,+  or the user has requested a pause.+  git-remote-daemon should close connections and idle.++  Affects all remotes.++* `RESUME`++  This indicates that the network connection has come back up, or the user+  has asked it to run again. Start back up network connections.++  Affects all remotes.++* `PUSH $remote`++  Requests that a git push be done with the remote over the network+  transport when next possible. May be repeated many times before the push+  finally happens.++* `RELOAD`++  Indicates that configs have changed. Daemon should reload .git/config+  and/or restart.++# send-pack and receive-pack++Done as the assistant does with XMPP currently. Does not involve+communication over the above stdio protocol.++# network level protocol++How do peers communicate with one another over the network?++This seems to need to be network-layer dependant. Telehash will need+one design, and git-annex-shell on a central ssh server has a very different+(and much simpler) design.++## git-annex-shell++Speak a subset of the stdio protocol between git-annex-shell and+git-remote-daemon, over ssh.++Only thing that seems to be needed is CHANGED, actually!++## telehash ++TODO++## XMPP++Reuse [[assistant/xmpp]]
+ doc/devblog/day_145__a_plan.mdwn view
@@ -0,0 +1,16 @@+I have a plan for this month. While waiting for telehash, I am going to+build [[design/git-remote-daemon]], which is the infrastructure git-annex+will need, to use telehash. Since it's generalized to support other protocols,+I'll be able to start using it before telehash is ready.++In fact, I plan to first make it work with ssh:// remotes, where+it will talk with git-annex-shell on the remote server. This will let the+assistant immediately know when the server has received a commit, and that+will simplify using the assistant with a ssh server -- no more need for+XMPP in this case! It should also work with git-remote-gcrypt encrypted+repositories, so also covers the case of an untrusted ssh server where+everything is end-to-end encrypted.++Building the git-annex-shell part of this should be pretty easy, and+building enough of the [[design/git-remote-daemon]] design to support it+also not hard.
+ doc/devblog/day_146__halfway_to_git-remote-daemon.mdwn view
@@ -0,0 +1,17 @@+Added `git-annex-shell notifychanges` command, which uses inotify (etc)+to detect when git refs have changed, and informs the caller about the+changes. This was relatively easy to write; I reused the existing inotify+code, and factored out code for simple line-based protocols from the+external special remote protocol. Also implemented the git-remote-daemon+protocol. 200 lines of code total.++Meanwhile, Johan Kiviniemi improved the dbus notifications, making them+work on Ubuntu and adding icons. Awesome!++There's going to be some fun to get git-annex-shell upgraded so that the+assistant can use this new notify feaure. While I have not started working+on the assistant side of this, you can get a jump by installing today's+upcoming release of git-annex. I had to push this out early because there+was a bug that prevented the webapp from running on non-gnome systems. Since+all changes in this release only affected Linux, today's release will be a+Linux-only release.
+ doc/forum/A_tiny_filesystem__63__.mdwn view
@@ -0,0 +1,7 @@+First of all, thanks for the amazing work! I've already tried Owncloud, SparkleShare, Unison, rsync and lsycnd. Finally I may have found the real deal.++My main problem with git-annex right now is that it is not fast/reliable enough. The main issues being: broken links now and then (I've probably done something wrong) and the slow: "startup scans", "consistency checks", "attempting to fix here" and "syncing with server". (50 Giga, Work-Server-Home, setup via webapp assistant)++Please, tell me if I'm wrong, but I have the impression that git-annex would get much more robust if it was 100% sure that nobody could mess with its file tree. One possibility would be to add the option (when creating a repo) to make a protected filesystem controlled by git-annex only via FUSE (not something like ShareBox). This could be a tiny filesystem (such as loggedfs) that does nothing but make sure that only git-annex can mount/change files. This would definitely add to speed (reducing checks) and stability.++I'm I being too naive? Most likely there is something I'm overlooking, like the amount of work this would involve.
doc/git-annex-shell.mdwn view
@@ -65,6 +65,11 @@   This commits any staged changes to the git-annex branch.   It also runs the annex-content hook. +* notifychanges++  This is used by `git-annex remote-daemon` to be notified when+  refs in the remote repository are changed.+ * gcryptsetup gcryptid    Sets up a repository as a gcrypt repository.
+ doc/todo/Recursive_addurl_simlar_to_wget_--recursive.mdwn view
@@ -0,0 +1,7 @@+## Use Case++I want to import a bunch of files that are hosted somewhere, they nicely sorted by year and such. Instead of addurl'ing each by hand (or writing a custom script each time this happens) I want to simply:++git-annex addurl --recursive http://somehost.tld/somedir/++For sanity, mimicking wget closely with default depth of 5, but customizable with the --level switch.
git-annex-shell.1 view
@@ -55,6 +55,10 @@ This commits any staged changes to the git\-annex branch. It also runs the annex\-content hook. .IP+.IP "notifychanges"+This is used by \fBgit\-annex remote\-daemon\fP to be notified when+refs in the remote repository are changed.+.IP .IP "gcryptsetup gcryptid" Sets up a repository as a gcrypt repository. .IP
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 5.20140402+Version: 5.20140405 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <joey@kitenet.net>
standalone/android/buildchroot view
@@ -20,7 +20,7 @@  echo echo-echo "debian-stable-android is set up, with a user androidbuilder"+echo "debian-stable-android is set up, with a user builder" echo "your next step is probably to check out git-annex in this chroot" echo "and run standalone/android/install-haskell-packages" echo
standalone/android/buildchroot-inchroot view
@@ -7,7 +7,7 @@ fi  # java needs this mounted to work-mount -t proc proc /proc+mount -t proc proc /proc || true  echo "deb-src http://ftp.us.debian.org/debian stable main" >> /etc/apt/sources.list apt-get update@@ -22,5 +22,5 @@ wget http://snapshot.debian.org/archive/debian/20130903T155330Z/pool/main/a/automake-1.14/automake_1.14-1_all.deb dpkg -i automake*.deb rm *.deb-useradd androidbuilder --create-home-su androidbuilder -c $0-asuser+useradd builder --create-home || true+su builder -c $0-asuser
standalone/android/buildchroot-inchroot-asuser view
@@ -3,7 +3,7 @@ set -e  cd-rm -rf .ghc .cabal+rm -rf .ghc .cabal .android cabal update cabal install happy alex --bindir=$HOME/bin PATH=$HOME/bin:$PATH