git-annex 4.20130927 → 4.20131002

raw patch · 57 files changed

+904/−571 lines, 57 files

Files

• Annex.hs +2/−0
• Annex/Content.hs +2/−2
• Annex/Url.hs +27/−0
• Assistant/MakeRemote.hs +4/−33
• Assistant/Pairing/MakeRemote.hs +7/−3
• Assistant/Ssh.hs +63/−11
• Assistant/WebApp/Configurators.hs +1/−1
• Assistant/WebApp/Configurators/AWS.hs +5/−4
• Assistant/WebApp/Configurators/Delete.hs +7/−2
• Assistant/WebApp/Configurators/Edit.hs +5/−7
• Assistant/WebApp/Configurators/IA.hs +4/−3
• Assistant/WebApp/Configurators/Local.hs +13/−14
• Assistant/WebApp/Configurators/Pairing.hs +1/−1
• Assistant/WebApp/Configurators/Ssh.hs +189/−135
• Assistant/WebApp/Configurators/WebDAV.hs +3/−2
• Assistant/WebApp/Configurators/XMPP.hs +2/−0
• Assistant/WebApp/DashBoard.hs +12/−9
• Assistant/WebApp/Documentation.hs +1/−1
• Assistant/WebApp/Gpg.hs +2/−2
• Assistant/WebApp/OtherRepos.hs +1/−1
• Assistant/WebApp/Page.hs +1/−1
• Assistant/WebApp/RepoList.hs +6/−5
• Assistant/WebApp/Utility.hs +11/−9
• Assistant/WebApp/routes +4/−2
• Backend.hs +2/−2
• Backend/Hash.hs +162/−0
• Backend/SHA.hs +0/−148
• CHANGELOG +20/−4
• Command/AddUrl.hs +4/−4
• Command/Direct.hs +12/−2
• Command/GCryptSetup.hs +35/−0
• Command/ImportFeed.hs +3/−2
• Command/RecvKey.hs +14/−3
• Command/Status.hs +1/−14
• Command/Version.hs +17/−6
• Git/Config.hs +11/−0
• GitAnnex/Options.hs +3/−0
• GitAnnexShell.hs +12/−10
• NEWS +1/−1
• Remote.hs +9/−3
• Remote/GCrypt.hs +31/−29
• Remote/Git.hs +10/−7
• Remote/Helper/Ssh.hs +2/−4
• Remote/Web.hs +2/−2
• Test.hs +2/−0
• Utility/Hash.hs +19/−0
• Utility/INotify.hs +9/−6
• Utility/Url.hs +28/−20
• debian/NEWS +1/−1
• debian/changelog +20/−4
• git-annex-shell.1 +3/−0
• git-annex.1 +3/−0
• git-annex.cabal +1/−1
• templates/configurators/rsync.net/encrypt.hamlet +2/−2
• templates/configurators/ssh/combine.hamlet +19/−0
• templates/configurators/ssh/confirm.hamlet +61/−48
• templates/configurators/ssh/setupmodal.hamlet +12/−0

@@ -108,6 +108,7 @@ 	, fields :: M.Map String String 	, cleanup :: M.Map String (Annex ()) 	, inodeschanged :: Maybe Bool+	, useragent :: Maybe String 	}  newState :: Git.Repo -> AnnexState@@ -141,6 +142,7 @@ 	, fields = M.empty 	, cleanup = M.empty 	, inodeschanged = Nothing+	, useragent = Nothing 	}  {- Makes an Annex state object for the specified git repo.

@@ -43,7 +43,7 @@ import qualified Annex.Branch import Utility.DiskFree import Utility.FileMode-import qualified Utility.Url as Url+import qualified Annex.Url as Url import Types.Key import Utility.DataUnits import Utility.CopyFile@@ -458,7 +458,7 @@   	go Nothing = do 		opts <- map Param . annexWebOptions <$> Annex.getGitConfig 		headers <- getHttpHeaders-		liftIO $ anyM (\u -> Url.download u headers opts file) urls+		anyM (\u -> Url.withUserAgent $ Url.download u headers opts file) urls 	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls 	downloadcmd basecmd url = 		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]

@@ -0,0 +1,27 @@+{- Url downloading, with git-annex user agent.+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.Url (+	module U,+	withUserAgent,+	getUserAgent,+) where++import Common.Annex+import qualified Annex+import Utility.Url as U+import qualified Build.SysConfig as SysConfig++defaultUserAgent :: U.UserAgent+defaultUserAgent = "git-annex/" ++ SysConfig.packageversion++getUserAgent :: Annex (Maybe U.UserAgent)+getUserAgent = Annex.getState $ +	Just . fromMaybe defaultUserAgent . Annex.useragent++withUserAgent :: (Maybe U.UserAgent -> IO a) -> Annex a+withUserAgent a = liftIO . a =<< getUserAgent

@@ -9,7 +9,6 @@  import Assistant.Common import Assistant.Ssh-import Assistant.Sync import qualified Types.Remote as R import qualified Remote import Remote.List@@ -21,47 +20,20 @@ import Logs.UUID import Logs.Remote import Git.Remote-import Config-import Config.Cost import Creds import Assistant.Gpg import Utility.Gpg (KeyId) -import qualified Data.Text as T import qualified Data.Map as M -{- Sets up and begins syncing with a new ssh or rsync remote. -}-makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote-makeSshRemote forcersync sshdata mcost = do-	r <- liftAnnex $-		addRemote $ maker (sshRepoName sshdata)-			(sshUrl forcersync sshdata)-	liftAnnex $ maybe noop (setRemoteCost r) mcost-	syncRemote r-	return r+{- Sets up a new git or rsync remote, accessed over ssh. -}+makeSshRemote :: SshData -> Annex RemoteName+makeSshRemote sshdata = maker (sshRepoName sshdata) (genSshUrl sshdata)   where-	rsync = forcersync || rsyncOnly sshdata 	maker-		| rsync = makeRsyncRemote+		| onlyCapability sshdata RsyncCapable = makeRsyncRemote 		| otherwise = makeGitRemote -{- Generates a ssh or rsync url from a SshData. -}-sshUrl :: Bool -> SshData -> String-sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $-	if (forcersync || rsyncOnly sshdata)-		then [u, h, T.pack ":", sshDirectory sshdata]-		else [T.pack "ssh://", u, h, d]-  where-	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata-	h = sshHostName sshdata-	d-		| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata-		| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]-		| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]-	addtrailingslash s-		| "/" `isSuffixOf` s = s-		| otherwise = s ++ "/"- {- Runs an action that returns a name of the remote, and finishes adding it. -} addRemote :: Annex RemoteName -> Annex Remote addRemote a = do@@ -146,7 +118,6 @@ 	g <- gitRepo 	if not (any samelocation $ Git.remotes g) 		then do-			 			let name = uniqueRemoteName basename 0 g 			a name 			return name

@@ -12,7 +12,9 @@ import Assistant.Pairing import Assistant.Pairing.Network import Assistant.MakeRemote+import Assistant.Sync import Config.Cost+import Config  import Network.Socket import qualified Data.Text as T@@ -22,7 +24,7 @@ setupAuthorizedKeys :: PairMsg -> FilePath -> IO () setupAuthorizedKeys msg repodir = do 	validateSshPubKey pubkey-	unlessM (liftIO $ addAuthorizedKeys False repodir pubkey) $+	unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $ 		error "failed setting up ssh authorized keys"   where 	pubkey = remoteSshPubKey $ pairMsgData msg@@ -43,7 +45,9 @@ 			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata) 			] 			Nothing-	void $ makeSshRemote False sshdata (Just semiExpensiveRemoteCost)+	r <- liftAnnex $ addRemote $ makeSshRemote sshdata+	liftAnnex $ setRemoteCost r semiExpensiveRemoteCost+	syncRemote r  {- Mostly a straightforward conversion.  Except:  -  * Determine the best hostname to use to contact the host.@@ -63,7 +67,7 @@ 		, sshRepoName = genSshRepoName hostname dir 		, sshPort = 22 		, needsPubKey = True-		, rsyncOnly = False+		, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] 		}  {- Finds the best hostname to use for the host that sent the PairMsg.

@@ -1,6 +1,6 @@ {- git-annex assistant ssh utilities  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,6 +11,7 @@ import Utility.Tmp import Utility.UserInfo import Utility.Shell+import Utility.Rsync import Git.Remote  import Data.Text (Text)@@ -25,10 +26,19 @@ 	, sshRepoName :: String 	, sshPort :: Int 	, needsPubKey :: Bool-	, rsyncOnly :: Bool+	, sshCapabilities :: [SshServerCapability] 	} 	deriving (Read, Show, Eq) +data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable+	deriving (Read, Show, Eq)++hasCapability :: SshData -> SshServerCapability -> Bool+hasCapability d c = c `elem` sshCapabilities d++onlyCapability :: SshData -> SshServerCapability -> Bool+onlyCapability d c = all (== c) (sshCapabilities d)+ data SshKeyPair = SshKeyPair 	{ sshPubKey :: String 	, sshPrivKey :: String@@ -52,6 +62,48 @@ genSshHost :: Text -> Maybe Text -> String genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host +{- Generates a ssh or rsync url from a SshData. -}+genSshUrl :: SshData -> String+genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $+	if (onlyCapability sshdata RsyncCapable)+		then [u, h, T.pack ":", sshDirectory sshdata]+		else [T.pack "ssh://", u, h, d]+  where+	u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata+	h = sshHostName sshdata+	d+		| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = sshDirectory sshdata+		| T.pack "~/" `T.isPrefixOf` sshDirectory sshdata = T.concat [T.pack "/", sshDirectory sshdata]+		| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]+	addtrailingslash s+		| "/" `isSuffixOf` s = s+		| otherwise = s ++ "/"++{- Reverses genSshUrl -}+parseSshUrl :: String -> Maybe SshData+parseSshUrl u+	| "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u)+	| otherwise = fromrsync u+  where+	mkdata (userhost, dir) = Just $ SshData+		{ sshHostName = T.pack host+		, sshUserName = if null user then Nothing else Just $ T.pack user+		, sshDirectory = T.pack dir+		, sshRepoName = genSshRepoName host dir+		-- dummy values, cannot determine from url+		, sshPort = 22+		, needsPubKey = True+		, sshCapabilities = []+		}+	  where+	  	(user, host) = if '@' `elem` userhost+			then separate (== '@') userhost+			else ("", userhost)+	fromrsync s+		| not (rsyncUrlIsShell u) = Nothing+		| otherwise = mkdata $ separate (== ':') s+	fromssh = mkdata . break (== '/')+ {- Generates a git remote name, like host_dir or host -} genSshRepoName :: String -> FilePath -> String genSshRepoName host dir@@ -92,12 +144,12 @@ 	safeincomment c = isAlphaNum c || c == '@' || c == '-' || c == '_' || c == '.'  addAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO Bool-addAuthorizedKeys rsynconly dir pubkey = boolSystem "sh"-	[ Param "-c" , Param $ addAuthorizedKeysCommand rsynconly dir pubkey ]+addAuthorizedKeys gitannexshellonly dir pubkey = boolSystem "sh"+	[ Param "-c" , Param $ addAuthorizedKeysCommand gitannexshellonly dir pubkey ]  removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()-removeAuthorizedKeys rsynconly dir pubkey = do-	let keyline = authorizedKeysLine rsynconly dir pubkey+removeAuthorizedKeys gitannexshellonly dir pubkey = do+	let keyline = authorizedKeysLine gitannexshellonly dir pubkey 	sshdir <- sshDir 	let keyfile = sshdir </> "authorized_keys" 	ls <- lines <$> readFileStrict keyfile@@ -110,7 +162,7 @@  - present.  -} addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String-addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"+addAuthorizedKeysCommand gitannexshellonly dir pubkey = intercalate "&&" 	[ "mkdir -p ~/.ssh" 	, intercalate "; " 		[ "if [ ! -e " ++ wrapper ++ " ]"@@ -122,7 +174,7 @@ 	, "chmod 600 ~/.ssh/authorized_keys" 	, unwords 		[ "echo"-		, shellEscape $ authorizedKeysLine rsynconly dir pubkey+		, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey 		, ">>~/.ssh/authorized_keys" 		] 	]@@ -141,11 +193,11 @@ 	runshell var = "exec git-annex-shell -c \"" ++ var ++ "\""  authorizedKeysLine :: Bool -> FilePath -> SshPubKey -> String-authorizedKeysLine rsynconly dir pubkey+authorizedKeysLine gitannexshellonly dir pubkey+	| gitannexshellonly = limitcommand ++ pubkey 	{- TODO: Locking down rsync is difficult, requiring a rather 	 - long perl script. -}-	| rsynconly = pubkey-	| otherwise = limitcommand ++ pubkey+	| otherwise = pubkey   where 	limitcommand = "command=\"GIT_ANNEX_SHELL_DIRECTORY="++shellEscape dir++" ~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding " 

@@ -17,7 +17,7 @@  {- The main configuration screen. -} getConfigurationR :: Handler Html-getConfigurationR = ifM (inFirstRun)+getConfigurationR = ifM inFirstRun 	( redirect FirstRepositoryR 	, page "Configuration" (Just Configuration) $ do #ifdef WITH_XMPP

@@ -94,10 +94,10 @@ 	<*> secretAccessKeyField (T.pack . snd <$> defcreds)  accessKeyIDField :: Widget -> Maybe Text -> MkAForm Text-accessKeyIDField help def = areq (textField `withNote` help) "Access Key ID" def+accessKeyIDField help = areq (textField `withNote` help) "Access Key ID"  accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text-accessKeyIDFieldWithHelp def = accessKeyIDField help def+accessKeyIDFieldWithHelp = accessKeyIDField help   where 	help = [whamlet| <a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">@@ -105,7 +105,7 @@ |]  secretAccessKeyField :: Maybe Text -> MkAForm Text-secretAccessKeyField def = areq passwordField "Secret Access Key" def+secretAccessKeyField = areq passwordField "Secret Access Key"  datacenterField :: AWS.Service -> MkAForm Text datacenterField service = areq (selectFieldList list) "Datacenter" defregion@@ -205,7 +205,8 @@ makeAWSRemote :: SpecialRemoteMaker -> RemoteType -> StandardGroup -> AWSCreds -> RemoteName -> RemoteConfig -> Handler () makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config = do 	liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)-	setupCloudRemote defaultgroup $ maker hostname remotetype config+	setupCloudRemote defaultgroup Nothing $+		maker hostname remotetype config   where 	{- AWS services use the remote name as the basis for a host 	 - name, so filter it to contain valid characters. -}

@@ -22,6 +22,7 @@ import Logs.Remote import Logs.PreferredContent import Types.StandardGroups+import Annex.UUID  import System.IO.HVFS (SystemFS(..)) import qualified Data.Text as T@@ -29,9 +30,13 @@ import System.Path  notCurrentRepo :: UUID -> Handler Html -> Handler Html-notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)+notCurrentRepo uuid a = do+	u <- liftAnnex getUUID+	if u == uuid+		then redirect DeleteCurrentRepositoryR+		else go =<< liftAnnex (Remote.remoteFromUUID uuid)   where-  	go Nothing = redirect DeleteCurrentRepositoryR+  	go Nothing = error "Unknown UUID" 	go (Just _) = a  getDisableRepositoryR :: UUID -> Handler Html

@@ -62,7 +62,7 @@ 		Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing) 		Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) 	-	description <- maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap+	description <- fmap T.pack . M.lookup uuid <$> uuidMap  	syncable <- case mremote of 		Just r -> return $ remoteAnnexSync $ Remote.gitconfig r@@ -99,7 +99,7 @@ 				, Param $ T.unpack $ repoName oldc 				, Param name 				]-			void $ Remote.remoteListRefresh+			void Remote.remoteListRefresh 		liftAssistant updateSyncRemotes 	when associatedDirectoryChanged $ case repoAssociatedDirectory newc of 		Nothing -> noop@@ -120,11 +120,9 @@ 		 - so avoid queueing a duplicate scan. -} 		when (repoSyncable newc && not syncableChanged) $ liftAssistant $ 			case mremote of-				Just remote -> do-					addScanRemotes True [remote]-				Nothing -> do-					addScanRemotes True-						=<< syncDataRemotes <$> getDaemonStatus+				Just remote -> addScanRemotes True [remote]+				Nothing -> addScanRemotes True+					=<< syncDataRemotes <$> getDaemonStatus 	when syncableChanged $ 		changeSyncable mremote (repoSyncable newc)   where

@@ -21,7 +21,7 @@ import Types.StandardGroups import Types.Remote (RemoteConfig) import Logs.Remote-import qualified Utility.Url as Url+import qualified Annex.Url as Url import Creds import Assistant.Gpg @@ -111,7 +111,7 @@ #endif  accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text-accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def+accessKeyIDFieldWithHelp = AWS.accessKeyIDField help   where 	help = [whamlet| <a href="http://archive.org/account/s3.php">@@ -190,7 +190,8 @@  getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = do-	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []+	ua <- liftAnnex Url.getUserAgent+	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url [] ua 	[whamlet| <a href="#{url}">   Internet Archive item

@@ -100,7 +100,7 @@ 			Nothing -> Right $ Just $ T.pack basepath 			Just prob -> Left prob   where-	runcheck (chk, msg) = ifM (chk) ( return $ Just msg, return Nothing )+	runcheck (chk, msg) = ifM chk ( return $ Just msg, return Nothing ) 	expandTilde home ('~':'/':path) = home </> path 	expandTilde _ path = path @@ -113,7 +113,7 @@  - browsed to a directory with git-annex and run it from there. -} defaultRepositoryPath :: Bool -> IO FilePath defaultRepositoryPath firstrun = do-	cwd <- liftIO $ getCurrentDirectory+	cwd <- liftIO getCurrentDirectory 	home <- myHomeDir 	if home == cwd && firstrun 		then inhome@@ -136,7 +136,7 @@ 		(Just $ T.pack $ addTrailingPathSeparator defpath) 	let (err, errmsg) = case pathRes of 		FormMissing -> (False, "")-		FormFailure l -> (True, concat $ map T.unpack l)+		FormFailure l -> (True, concatMap T.unpack l) 		FormSuccess _ -> (False, "") 	let form = do 		webAppFormAuthToken@@ -230,7 +230,7 @@ getAddDriveR = postAddDriveR postAddDriveR :: Handler Html postAddDriveR = page "Add a removable drive" (Just Configuration) $ do-	removabledrives <- liftIO $ driveList+	removabledrives <- liftIO driveList 	writabledrives <- liftIO $ 		filterM (canWrite . T.unpack . mountPoint) removabledrives 	((res, form), enctype) <- liftH $ runFormPost $@@ -276,7 +276,7 @@ setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal")  getGenKeyForDriveR :: RemovableDrive -> Handler Html-getGenKeyForDriveR drive = withNewSecretKey $ \keyid -> do+getGenKeyForDriveR drive = withNewSecretKey $ \keyid -> 	{- Generating a key takes a long time, and  	 - the removable drive may have been disconnected 	 - in the meantime. Check that it is still mounted@@ -329,7 +329,7 @@  - Next call syncRemote to get them in sync. -} combineRepos :: FilePath -> String -> Handler Remote combineRepos dir name = liftAnnex $ do-	hostname <- maybe "host" id <$> liftIO getHostname+	hostname <- fromMaybe "host" <$> liftIO getHostname 	hostlocation <- fromRepo Git.repoLocation 	liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation 	addRemote $ makeGitRemote name dir@@ -380,7 +380,7 @@ 		u <- initRepo isnew True path Nothing 		inDir path $ do 			setStandardGroup u repogroup-			maybe noop id setup+			fromMaybe noop setup 		addAutoStartFile path 		setCurrentDirectory path 		fromJust $ postFirstRun webapp@@ -440,13 +440,12 @@ 	getUUID  initRepo' :: Maybe String -> Annex ()-initRepo' desc = do-	unlessM isInitialized $ do-		initialize desc-		{- Ensure branch gets committed right away so it is-		 - available for merging when a removable drive repo is being-		 - added. -}-		Annex.Branch.commit "update"+initRepo' desc = unlessM isInitialized $ do+	initialize desc+	{- Ensure branch gets committed right away so it is+	 - available for merging when a removable drive repo is being+	 - added. -}+	Annex.Branch.commit "update"  {- Checks if the user can write to a directory.  -

@@ -152,7 +152,7 @@   where 	alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just 	setup repodir = setupAuthorizedKeys msg repodir-	cleanup repodir = removeAuthorizedKeys False repodir $+	cleanup repodir = removeAuthorizedKeys True repodir $ 		remoteSshPubKey $ pairMsgData msg 	uuid = Just $ pairUUID $ pairMsgData msg #else

@@ -1,6 +1,6 @@ {- git-annex assistant webapp configurator for ssh-based remotes  -- - Copyright 2012 Joey Hess <joey@kitenet.net>+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -14,17 +14,17 @@ import Assistant.WebApp.Gpg import Assistant.Ssh import Assistant.MakeRemote-import Utility.Rsync (rsyncUrlIsShell) import Logs.Remote import Remote-import Logs.PreferredContent import Types.StandardGroups import Utility.UserInfo import Utility.Gpg-import Types.Remote (RemoteConfigKey)+import Types.Remote (RemoteConfig) import Git.Remote import Assistant.WebApp.Utility import qualified Remote.GCrypt as GCrypt+import Annex.UUID+import Logs.UUID  import qualified Data.Text as T import qualified Data.Map as M@@ -54,7 +54,7 @@ 		(maybe "" T.unpack $ inputDirectory s) 	, sshPort = inputPort s 	, needsPubKey = False-	, rsyncOnly = False+	, sshCapabilities = [] -- untested 	}  mkSshInput :: SshData -> SshInput@@ -88,7 +88,7 @@ 		let h = T.unpack t 		let canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] } 		r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing-		return $ case catMaybes . map addrCanonName <$> r of+		return $ case mapMaybe addrCanonName <$> r of 			-- canonicalize input hostname if it had no dot 			Just (fullname:_) 				| '.' `elem` h -> Right t@@ -103,30 +103,27 @@ data ServerStatus 	= UntestedServer 	| UnusableServer Text -- reason why it's not usable-	| UsableRsyncServer-	| UsableSshInput+	| UsableServer [SshServerCapability] 	deriving (Eq) -usable :: ServerStatus -> Bool-usable UntestedServer = False-usable (UnusableServer _) = False-usable UsableRsyncServer = True-usable UsableSshInput = True+capabilities :: ServerStatus -> [SshServerCapability]+capabilities (UsableServer cs) = cs+capabilities _ = []  getAddSshR :: Handler Html getAddSshR = postAddSshR postAddSshR :: Handler Html postAddSshR = sshConfigurator $ do-	u <- liftIO $ T.pack <$> myUserName+	username <- liftIO $ T.pack <$> myUserName 	((result, form), enctype) <- liftH $ 		runFormPost $ renderBootstrap $ sshInputAForm textField $-			SshInput Nothing (Just u) Nothing 22+			SshInput Nothing (Just username) Nothing 22 	case result of 		FormSuccess sshinput -> do 			s <- liftIO $ testServer sshinput 			case s of 				Left status -> showform form enctype status-				Right sshdata -> liftH $ redirect $ ConfirmSshR sshdata+				Right (sshdata, u) -> liftH $ redirect $ ConfirmSshR sshdata u 		_ -> showform form enctype UntestedServer   where 	showform form enctype status = $(widgetFile "configurators/ssh/add")@@ -134,36 +131,41 @@ sshTestModal :: Widget sshTestModal = $(widgetFile "configurators/ssh/testmodal") -{- Note that there's no EnableSshR because ssh remotes are not special- - remotes, and so their configuration is not shared between repositories.- -}+sshSetupModal :: SshData -> Widget+sshSetupModal sshdata = $(widgetFile "configurators/ssh/setupmodal")+ getEnableRsyncR :: UUID -> Handler Html getEnableRsyncR = postEnableRsyncR postEnableRsyncR :: UUID -> Handler Html-postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync+postEnableRsyncR = enableSpecialSshRemote getsshinput enableRsyncNet enablersync   where-	enablersync sshdata = redirect $ ConfirmSshR $-		sshdata { rsyncOnly = True }+	enablersync sshdata u = redirect $ ConfirmSshR+		(sshdata { sshCapabilities = [RsyncCapable] }) u+	getsshinput = parseSshUrl <=< M.lookup "rsyncurl"  {- This only handles gcrypt repositories that are located on ssh servers;  - ones on local drives are handled via another part of the UI. -}-getEnableGCryptR :: UUID -> Handler Html-getEnableGCryptR = postEnableGCryptR-postEnableGCryptR :: UUID -> Handler Html-postEnableGCryptR u = whenGcryptInstalled $-	enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u+getEnableSshGCryptR :: UUID -> Handler Html+getEnableSshGCryptR = postEnableSshGCryptR+postEnableSshGCryptR :: UUID -> Handler Html+postEnableSshGCryptR u = whenGcryptInstalled $+	enableSpecialSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u   where-  	enablersync sshdata = error "TODO enable ssh gcrypt remote"+  	enablegcrypt sshdata _ = prepSsh True sshdata $ \sshdata' ->+		sshConfigurator $+			checkExistingGCrypt sshdata' $+				error "Expected to find an encrypted git repository, but did not."+	getsshinput = parseSshUrl <=< M.lookup "gitrepo" -{- To enable an special remote that uses ssh as its transport, +{- To enable a special remote that uses ssh as its transport,   - parse a config key to get its url, and display a form whose  - only real purpose is to check if ssh public keys need to be  - set up.  -}-enableSpecialSshRemote :: RemoteConfigKey -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> Handler ()) -> UUID -> Handler Html-enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do+enableSpecialSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html+enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do 	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog-	case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of+	case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of 		(Just sshinput, Just reponame) -> sshConfigurator $ do 			((result, form), enctype) <- liftH $ 				runFormPost $ renderBootstrap $ sshInputAForm textField sshinput@@ -175,38 +177,19 @@ 						s <- liftIO $ testServer sshinput' 						case s of 							Left status -> showform form enctype status-							Right sshdata -> liftH $ genericsetup sshdata-								{ sshRepoName = reponame }+							Right (sshdata, _u) -> void $ liftH $ genericsetup+								( sshdata { sshRepoName = reponame } ) u 				_ -> showform form enctype UntestedServer 		_ -> redirect AddSshR   where+  	unmangle sshdata = sshdata+		{ sshHostName = T.pack $ unMangleSshHostName $+			T.unpack $ sshHostName sshdata+		} 	showform form enctype status = do 		description <- liftAnnex $ T.pack <$> prettyUUID u 		$(widgetFile "configurators/ssh/enable") -{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync- - url; rsync:// urls or bare path names are not supported.- -- - The hostname is stored mangled in the remote log for rsync special- - remotes configured by this webapp. So that mangling has to reversed- - here to get back the original hostname.- -}-parseSshRsyncUrl :: String -> Maybe SshInput-parseSshRsyncUrl u-	| not (rsyncUrlIsShell u) = Nothing-	| otherwise = Just $ SshInput-			{ inputHostname = val $ unMangleSshHostName host-			, inputUsername = if null user then Nothing else val user-			, inputDirectory = val dir-			, inputPort = 22-			}-  where-	val = Just . T.pack-	(userhost, dir) = separate (== ':') u-	(user, host) = if '@' `elem` userhost-		then separate (== '@') userhost-		else (userhost, "")- {- Test if we can ssh into the server.  -  - Two probe attempts are made. First, try sshing in using the existing@@ -214,33 +197,41 @@  - passwordless login is already enabled, use it. Otherwise,  - a special ssh key will need to be generated just for this server.  -- - Once logged into the server, probe to see if git-annex-shell is- - available, or rsync. Note that, ~/.ssh/git-annex-shell may be+ - Once logged into the server, probe to see if git-annex-shell,+ - git, and rsync are available. + - Note that, ~/.ssh/git-annex-shell may be  - present, while git-annex-shell is not in PATH.+ -+ - Also probe to see if there is already a git repository at the location+ - with either an annex-uuid or a gcrypt-id set. (If not, returns NoUUID.)  -}-testServer :: SshInput -> IO (Either ServerStatus SshData)+testServer :: SshInput -> IO (Either ServerStatus (SshData, UUID)) testServer (SshInput { inputHostname = Nothing }) = return $ 	Left $ UnusableServer "Please enter a host name." testServer sshinput@(SshInput { inputHostname = Just hn }) = do-	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]-	if usable status-		then ret status False-		else do-			status' <- probe []-			if usable status'-				then ret status' True-				else return $ Left status'+	(status, u) <- probe [sshOpt "NumberOfPasswordPrompts" "0"]+	case capabilities status of+		[] -> do+			(status', u') <- probe []+			case capabilities status' of+				[] -> return $ Left status'+				cs -> ret cs True u'+		cs -> ret cs False u   where-	ret status needspubkey = return $ Right $ (mkSshData sshinput)-		{ needsPubKey = needspubkey-		, rsyncOnly = status == UsableRsyncServer-		}+	ret cs needspubkey u = do+		let sshdata = (mkSshData sshinput)+			{ needsPubKey = needspubkey+			, sshCapabilities = cs+			}+		return $ Right (sshdata, u) 	probe extraopts = do 		let remotecommand = shellWrap $ intercalate ";" 			[ report "loggedin" 			, checkcommand "git-annex-shell"+			, checkcommand "git" 			, checkcommand "rsync" 			, checkcommand shim+			, getgitconfig (T.unpack <$> inputDirectory sshinput) 			] 		knownhost <- knownHost hn 		let sshopts = filter (not . null) $ extraopts ++@@ -256,21 +247,35 @@ 			, remotecommand 			] 		parsetranscript . fst <$> sshTranscript sshopts Nothing-	parsetranscript s-		| reported "git-annex-shell" = UsableSshInput-		| reported shim = UsableSshInput-		| reported "rsync" = UsableRsyncServer-		| reported "loggedin" = UnusableServer-			"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"-		| otherwise = UnusableServer $ T.pack $-			"Failed to ssh to the server. Transcript: " ++ s+	parsetranscript s =+		let cs = map snd $ filter (reported . fst)+			[ ("git-annex-shell", GitAnnexShellCapable)+			, (shim, GitAnnexShellCapable)+			, ("git", GitCapable)+			, ("rsync", RsyncCapable)+			]+		    u = fromMaybe NoUUID $ headMaybe $ mapMaybe finduuid $+			map (separate (== '=')) $ lines s+		in if null cs+			then (UnusableServer unusablereason, u)+			else (UsableServer cs, u) 	  where 		reported r = token r `isInfixOf` s+		unusablereason = if reported "loggedin"+				then "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"+				else T.pack $ "Failed to ssh to the server. Transcript: " ++ s+		finduuid (k, v)+			| k == "annex.uuid" = Just $ toUUID v+			| k == GCrypt.coreGCryptId = Just $ genUUIDInNameSpace gCryptNameSpace v+			| otherwise = Nothing 	 	checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" 	token r = "git-annex-probe " ++ r 	report r = "echo " ++ token r 	shim = "~/.ssh/git-annex-shell"+	getgitconfig (Just d)+		| not (null d) = "cd " ++ shellEscape d ++ " && git config --list"+	getgitconfig _ = "echo"  {- Runs a ssh command; if it fails shows the user the transcript,  - and if it succeeds, runs an action. -}@@ -285,55 +290,125 @@ showSshErr msg = sshConfigurator $ 	$(widgetFile "configurators/ssh/error") -getConfirmSshR :: SshData -> Handler Html-getConfirmSshR sshdata = sshConfigurator $-	$(widgetFile "configurators/ssh/confirm")+{- The UUID will be NoUUID when the repository does not already exist. -}+getConfirmSshR :: SshData -> UUID -> Handler Html+getConfirmSshR sshdata u+	| u == NoUUID = handlenew+	| otherwise = handleexisting =<< (M.lookup u <$> liftAnnex uuidMap)+  where+	handlenew = sshConfigurator $ do+		secretkeys <- sortBy (comparing snd) . M.toList+			<$> liftIO secretKeys+		$(widgetFile "configurators/ssh/confirm")+  	handleexisting Nothing = sshConfigurator $+		-- Not a UUID we know, so prompt about combining.+		$(widgetFile "configurators/ssh/combine")+	handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do+		m <- liftAnnex readRemoteLog+		case M.lookup "type" =<< M.lookup u m of+			Just "gcrypt" -> combineExistingGCrypt sshdata' u+			-- This handles enabling git repositories+			-- that already exist.+			_ -> makeSshRepo sshdata' +{- The user has confirmed they want to combine with a ssh repository,+ - which is not known to us. So it might be using gcrypt. -}+getCombineSshR :: SshData -> Handler Html+getCombineSshR sshdata = prepSsh False sshdata $ \sshdata' ->+	sshConfigurator $+		checkExistingGCrypt sshdata' $+			void $ liftH $ makeSshRepo sshdata'+ getRetrySshR :: SshData -> Handler () getRetrySshR sshdata = do 	s <- liftIO $ testServer $ mkSshInput sshdata-	redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s+	redirect $ either (const $ ConfirmSshR sshdata NoUUID) (uncurry ConfirmSshR) s  getMakeSshGitR :: SshData -> Handler Html-getMakeSshGitR = makeSsh False+getMakeSshGitR sshdata = prepSsh False sshdata makeSshRepo  getMakeSshRsyncR :: SshData -> Handler Html-getMakeSshRsyncR = makeSsh True+getMakeSshRsyncR sshdata = prepSsh False (rsyncOnly sshdata) makeSshRepo -makeSsh :: Bool -> SshData -> Handler Html-makeSsh rsync sshdata+rsyncOnly :: SshData -> SshData+rsyncOnly sshdata = sshdata { sshCapabilities = [RsyncCapable] }++getMakeSshGCryptR :: SshData -> RepoKey -> Handler Html+getMakeSshGCryptR sshdata NoRepoKey = whenGcryptInstalled $+	withNewSecretKey $ getMakeSshGCryptR sshdata . RepoKey+getMakeSshGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $+	prepSsh True sshdata $ makeGCryptRepo keyid+	+{- Detect if the user entered a location with an existing, known+ - gcrypt repository, and enable it. Otherwise, runs the action. -}+checkExistingGCrypt :: SshData -> Widget -> Widget+checkExistingGCrypt sshdata nope = ifM (liftIO isGcryptInstalled)+	( checkGCryptRepoEncryption repourl nope $ do+		mu <- liftAnnex $ probeGCryptRemoteUUID repourl+		case mu of+			Just u -> void $ liftH $+				combineExistingGCrypt sshdata u+			Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."+	, nope+	)+  where+  	repourl = genSshUrl sshdata++{- Enables an existing gcrypt special remote. -}+enableGCrypt :: SshData -> RemoteName -> Handler Html+enableGCrypt sshdata reponame = +	setupCloudRemote TransferGroup Nothing $ +		enableSpecialRemote reponame GCrypt.remote $ M.fromList+			[("gitrepo", genSshUrl sshdata)]++{- Combining with a gcrypt repository that may not be+ - known in remote.log, so probe the gcrypt repo. -}+combineExistingGCrypt :: SshData -> UUID -> Handler Html+combineExistingGCrypt sshdata u = do+	reponame <- liftAnnex $ getGCryptRemoteName u repourl+	enableGCrypt sshdata reponame+  where+  	repourl = genSshUrl sshdata++{- Sets up remote repository for ssh, or directory for rsync. -}+prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html+prepSsh newgcrypt sshdata a 	| needsPubKey sshdata = do 		keypair <- liftIO genSshKeyPair 		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata-		makeSsh' rsync sshdata sshdata' (Just keypair)+		prepSsh' newgcrypt sshdata sshdata' (Just keypair) a 	| sshPort sshdata /= 22 = do 		sshdata' <- liftIO $ setSshConfig sshdata []-		makeSsh' rsync sshdata sshdata' Nothing-	| otherwise = makeSsh' rsync sshdata sshdata Nothing+		prepSsh' newgcrypt sshdata sshdata' Nothing a+	| otherwise = prepSsh' newgcrypt sshdata sshdata Nothing a -makeSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html-makeSsh' rsync origsshdata sshdata keypair = do-	sshSetup ["-p", show (sshPort origsshdata), sshhost, remoteCommand] "" $-		makeSshRepo rsync sshdata+prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html+prepSsh' newgcrypt origsshdata sshdata keypair a = sshSetup+	 [ "-p", show (sshPort origsshdata)+	 , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)+	 , remoteCommand+	 ] "" (a sshdata)   where-	sshhost = genSshHost (sshHostName origsshdata) (sshUserName origsshdata) 	remotedir = T.unpack $ sshDirectory sshdata 	remoteCommand = shellWrap $ intercalate "&&" $ catMaybes 		[ Just $ "mkdir -p " ++ shellEscape remotedir 		, Just $ "cd " ++ shellEscape remotedir-		, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"-		, if rsync then Nothing else Just "git annex init"-		, if needsPubKey sshdata-			then addAuthorizedKeysCommand (rsync || rsyncOnly sshdata) remotedir . sshPubKey <$> keypair+		, if rsynconly then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"+		, if rsynconly || newgcrypt then Nothing else Just "git annex init"+		, if needsPubKey origsshdata+			then addAuthorizedKeysCommand (hasCapability origsshdata GitAnnexShellCapable) remotedir . sshPubKey <$> keypair 			else Nothing 		]+	rsynconly = onlyCapability origsshdata RsyncCapable -makeSshRepo :: Bool -> SshData -> Handler Html-makeSshRepo forcersync sshdata = do-	r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing-	liftAnnex $ setStandardGroup (Remote.uuid r) TransferGroup-	redirect $ EditNewCloudRepositoryR $ Remote.uuid r+makeSshRepo :: SshData -> Handler Html+makeSshRepo sshdata = setupCloudRemote TransferGroup Nothing $+	makeSshRemote sshdata +makeGCryptRepo :: KeyId -> SshData -> Handler Html+makeGCryptRepo keyid sshdata = setupCloudRemote TransferGroup Nothing $ +	makeGCryptRemote (sshRepoName sshdata) (genSshUrl sshdata) keyid+ getAddRsyncNetR :: Handler Html getAddRsyncNetR = postAddRsyncNetR postAddRsyncNetR :: Handler Html@@ -366,68 +441,47 @@ 		let reponame = genSshRepoName "rsync.net"  			(maybe "" T.unpack $ inputDirectory sshinput) 		prepRsyncNet sshinput reponame $ \sshdata -> inpage $ -			checkexistinggcrypt sshdata $ do+			checkExistingGCrypt sshdata $ do 				secretkeys <- sortBy (comparing snd) . M.toList 					<$> liftIO secretKeys 				$(widgetFile "configurators/rsync.net/encrypt")-	{- Detect if the user entered an existing gcrypt repository,-	 - and enable it. -}-	checkexistinggcrypt sshdata a = ifM (liftIO isGcryptInstalled)-		( checkGCryptRepoEncryption repourl a $ do-			mu <- liftAnnex $ probeGCryptRemoteUUID repourl-			case mu of-				Just u -> do-					reponame <- liftAnnex $ getGCryptRemoteName u repourl-					void $ liftH $ enableRsyncNetGCrypt' sshdata reponame-				Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."-		, a-		)-	  where-	  	repourl = sshUrl True sshdata  getMakeRsyncNetSharedR :: SshData -> Handler Html-getMakeRsyncNetSharedR sshdata = makeSshRepo True sshdata+getMakeRsyncNetSharedR = makeSshRepo . rsyncOnly  {- Make a gcrypt special remote on rsync.net. -} getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html getMakeRsyncNetGCryptR sshdata NoRepoKey = whenGcryptInstalled $ 	withNewSecretKey $ getMakeRsyncNetGCryptR sshdata . RepoKey-getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do-	sshSetup [sshhost, gitinit] [] $-		setupCloudRemote TransferGroup $ -			makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid+getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $+	sshSetup [sshhost, gitinit] [] $ makeGCryptRepo keyid sshdata   where 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) 	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)  enableRsyncNet :: SshInput -> String -> Handler Html enableRsyncNet sshinput reponame = -	prepRsyncNet sshinput reponame $ makeSshRepo True+	prepRsyncNet sshinput reponame $ makeSshRepo . rsyncOnly  enableRsyncNetGCrypt :: SshInput -> RemoteName -> Handler Html enableRsyncNetGCrypt sshinput reponame =  	prepRsyncNet sshinput reponame $ \sshdata ->-		checkGCryptRepoEncryption (sshUrl True sshdata) notencrypted $-			enableRsyncNetGCrypt' sshdata reponame+		checkGCryptRepoEncryption (genSshUrl sshdata) notencrypted $+			enableGCrypt sshdata reponame   where 	notencrypted = error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."-enableRsyncNetGCrypt' :: SshData -> RemoteName -> Handler Html-enableRsyncNetGCrypt' sshdata reponame = -	setupCloudRemote TransferGroup $ -		enableSpecialRemote reponame GCrypt.remote $ M.fromList-			[("gitrepo", sshUrl True sshdata)]  {- Prepares rsync.net ssh key, and if successful, runs an action with  - its SshData. -} prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html prepRsyncNet sshinput reponame a = do 	knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)-	keypair <- liftIO $ genSshKeyPair+	keypair <- liftIO genSshKeyPair 	sshdata <- liftIO $ setupSshKeyPair keypair $ 		(mkSshData sshinput) 			{ sshRepoName = reponame  			, needsPubKey = True-			, rsyncOnly = True+			, sshCapabilities = [RsyncCapable] 			} 	{- I'd prefer to separate commands with && , but 	 - rsync.net's shell does not support that.

@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}+{-# LANGUAGE CPP, TemplateHaskell, OverloadedStrings #-}  module Assistant.WebApp.Configurators.WebDAV where @@ -126,7 +126,8 @@ makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler () makeWebDavRemote maker name creds config = do 	liftIO $ WebDAV.setCredsEnv creds-	setupCloudRemote TransferGroup $ maker name WebDAV.remote config+	setupCloudRemote TransferGroup Nothing $+		maker name WebDAV.remote config  {- Only returns creds previously used for the same hostname. -} previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)

@@ -151,6 +151,8 @@ 		catMaybes . map (buddySummary pairedwith) 			<$> (getBuddyList <<~ buddyList) 	$(widgetFile "configurators/xmpp/buddylist")+#else+	noop #endif   where 	ident = "buddylist"

@@ -52,7 +52,7 @@ simplifyTransfers (x:[]) = [x] simplifyTransfers (v@(t1, _):r@((t2, _):l)) 	| equivilantTransfer t1 t2 = simplifyTransfers (v:l)-	| otherwise = v : (simplifyTransfers r)+	| otherwise = v : simplifyTransfers r  {- Called by client to get a display of currently in process transfers.  -@@ -78,7 +78,7 @@ 	$(widgetFile "dashboard/main")  getDashboardR :: Handler Html-getDashboardR = ifM (inFirstRun)+getDashboardR = ifM inFirstRun 	( redirect ConfigurationR 	, page "" (Just DashBoard) $ dashboard True 	)@@ -107,7 +107,7 @@ {- Used by non-javascript browsers, where clicking on the link actually  - opens this page, so we redirect back to the referrer. -} getFileBrowserR :: Handler ()-getFileBrowserR = whenM openFileBrowser $ redirectBack+getFileBrowserR = whenM openFileBrowser redirectBack  {- Opens the system file browser on the repo, or, as a fallback,  - goes to a file:// url. Returns True if it's ok to redirect away@@ -137,14 +137,17 @@ {- Transfer controls. The GET is done in noscript mode and redirects back  - to the referring page. The POST is called by javascript. -} getPauseTransferR :: Transfer -> Handler ()-getPauseTransferR t = pauseTransfer t >> redirectBack+getPauseTransferR = noscript postPauseTransferR postPauseTransferR :: Transfer -> Handler ()-postPauseTransferR t = pauseTransfer t+postPauseTransferR = pauseTransfer getStartTransferR :: Transfer -> Handler ()-getStartTransferR t = startTransfer t >> redirectBack+getStartTransferR = noscript postStartTransferR postStartTransferR :: Transfer -> Handler ()-postStartTransferR t = startTransfer t+postStartTransferR = startTransfer getCancelTransferR :: Transfer -> Handler ()-getCancelTransferR t = cancelTransfer False t >> redirectBack+getCancelTransferR = noscript postCancelTransferR postCancelTransferR :: Transfer -> Handler ()-postCancelTransferR t = cancelTransfer False t+postCancelTransferR = cancelTransfer False++noscript :: (Transfer -> Handler ()) -> Transfer -> Handler ()+noscript a t = a t >> redirectBack

@@ -38,5 +38,5 @@ 			$(widgetFile "documentation/license")  getRepoGroupR :: Handler Html-getRepoGroupR = page "About repository groups" (Just About) $ do+getRepoGroupR = page "About repository groups" (Just About) $ 	$(widgetFile "documentation/repogroup")

@@ -48,7 +48,7 @@  withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html withNewSecretKey use = do-	userid <- liftIO $ newUserId+	userid <- liftIO newUserId 	liftIO $ genSecretKey RSA "" userid maxRecommendedKeySize 	results <- M.keys . M.filter (== userid) <$> liftIO secretKeys 	case results of@@ -70,7 +70,7 @@ 		[Params "remote add", Param tmpremote, Param $ Git.GCrypt.urlPrefix ++ repoloc] 	mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote]) 		( do-			void $ Annex.Branch.forceUpdate+			void Annex.Branch.forceUpdate 			(M.lookup "name" <=< M.lookup u) <$> readRemoteLog 		, return Nothing 		)

@@ -56,7 +56,7 @@ 				( return url 				, delayed $ waiturl urlfile 				)-	listening url = catchBoolIO $ fst <$> Url.exists url []+	listening url = catchBoolIO $ fst <$> Url.exists url [] Nothing 	delayed a = do 		threadDelay 100000 -- 1/10th of a second 		a

@@ -38,7 +38,7 @@ firstRunNavBar = [Configuration, About]  selectNavBar :: Handler [NavBarItem]-selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)+selectNavBar = ifM inFirstRun (return firstRunNavBar, return defaultNavBar)  {- A standard page of the webapp, with a title, a sidebar, and that may  - be highlighted on the navbar. -}

@@ -35,6 +35,7 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T+import Data.Function  data Actions 	= DisabledRepoActions@@ -100,7 +101,7 @@  {- List of cloud repositories, configured and not. -} cloudRepoList :: Widget-cloudRepoList = repoListDisplay $ RepoSelector+cloudRepoList = repoListDisplay RepoSelector 	{ onlyCloud = True 	, onlyConfigured = False 	, includeHere = False@@ -161,7 +162,7 @@ 		g <- gitRepo 		map snd . catMaybes . filter selectedremote  			. map (findinfo m g)-			<$> (trustExclude DeadTrusted $ M.keys m)+			<$> trustExclude DeadTrusted (M.keys m) 	selectedrepo r 		| Remote.readonly r = False 		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)@@ -185,14 +186,14 @@ 			-- handled separately. 			case getconfig "gitrepo" of 				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr g) ->-					val True EnableGCryptR+					val True EnableSshGCryptR 				_ -> Nothing 		_ -> Nothing 	  where 	  	getconfig k = M.lookup k =<< M.lookup u m 		val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) 	list l = liftAnnex $ do-		let l' = nubBy (\x y -> fst x == fst y) l+		let l' = nubBy ((==) `on` fst) l 		l'' <- zip 			<$> Remote.prettyListUUIDs (map fst l') 			<*> pure l'@@ -258,7 +259,7 @@ 	redirect DashboardR   where 	unstall r = do-		liftIO $ fixSshKeyPair+		liftIO fixSshKeyPair 		liftAnnex $ setConfig  			(remoteConfig (Remote.repo r) "ignore") 			(boolConfig False)

@@ -20,6 +20,7 @@ import qualified Assistant.Threads.Transferrer as Transferrer import Logs.Transfer import qualified Config+import Config.Cost import Config.Files import Git.Config import Assistant.Threads.Watcher@@ -37,7 +38,7 @@  {- Use Nothing to change autocommit setting; or a remote to change  - its sync setting. -}-changeSyncable :: (Maybe Remote) -> Bool -> Handler ()+changeSyncable :: Maybe Remote -> Bool -> Handler () changeSyncable Nothing enable = do 	liftAnnex $ Config.setConfig key (boolConfig enable) 	liftIO . maybe noop (`throwTo` signal)@@ -52,7 +53,7 @@ 	liftAssistant $ syncRemote r changeSyncable (Just r) False = do 	changeSyncFlag r False-	liftAssistant $ updateSyncRemotes+	liftAssistant updateSyncRemotes 	{- Stop all transfers to or from this remote. 	 - XXX Can't stop any ongoing scan, or git syncs. -} 	void $ liftAssistant $ dequeueTransfers tofrom@@ -65,7 +66,7 @@ changeSyncFlag :: Remote -> Bool -> Handler () changeSyncFlag r enabled = liftAnnex $ do 	Config.setConfig key (boolConfig enabled)-	void $ Remote.remoteListRefresh+	void Remote.remoteListRefresh   where 	key = Config.remoteConfig (Remote.repo r) "sync" @@ -125,12 +126,13 @@ getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus  {- Runs an action that creates or enables a cloud remote,- - and finishes setting it up; adding it to a group if it's not already in- - one, starts syncing with it, and finishes by displaying the page to edit- - it. -}-setupCloudRemote :: StandardGroup -> Annex RemoteName -> Handler a-setupCloudRemote defaultgroup maker = do+ - and finishes setting it up, then starts syncing with it,+ - and finishes by displaying the page to edit it. -}+setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a+setupCloudRemote defaultgroup mcost maker = do 	r <- liftAnnex $ addRemote maker-	liftAnnex $ setStandardGroup (Remote.uuid r) defaultgroup+	liftAnnex $ do+		setStandardGroup (Remote.uuid r) defaultgroup+		maybe noop (Config.setRemoteCost r) mcost 	liftAssistant $ syncRemote r 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r

@@ -40,10 +40,12 @@ /config/repository/add/drive/genkey/#RemovableDrive GenKeyForDriveR GET /config/repository/add/drive/finish/#RemovableDrive/#RepoKey FinishAddDriveR GET /config/repository/add/ssh AddSshR GET POST-/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET+/config/repository/add/ssh/confirm/#SshData/#UUID ConfirmSshR GET /config/repository/add/ssh/retry/#SshData RetrySshR GET /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET+/config/repository/add/ssh/make/gcrypt/#SshData/#RepoKey MakeSshGCryptR GET+/config/repository/add/ssh/combine/#SshData CombineSshR GET /config/repository/add/cloud/rsync.net AddRsyncNetR GET POST /config/repository/add/cloud/rsync.net/shared/#SshData MakeRsyncNetSharedR GET /config/repository/add/cloud/rsync.net/gcrypt/#SshData/#RepoKey MakeRsyncNetGCryptR GET@@ -65,7 +67,7 @@ /config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET  /config/repository/enable/rsync/#UUID EnableRsyncR GET POST-/config/repository/enable/gcrypt/#UUID EnableGCryptR GET POST+/config/repository/enable/gcrypt/#UUID EnableSshGCryptR GET POST /config/repository/enable/directory/#UUID EnableDirectoryR GET /config/repository/enable/S3/#UUID EnableS3R GET POST /config/repository/enable/IA/#UUID EnableIAR GET POST

@@ -27,12 +27,12 @@ import Config  -- When adding a new backend, import it here and add it to the list.-import qualified Backend.SHA+import qualified Backend.Hash import qualified Backend.WORM import qualified Backend.URL  list :: [Backend]-list = Backend.SHA.backends ++ Backend.WORM.backends ++ Backend.URL.backends+list = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends  {- List of backends in the order to try them when storing a new key. -} orderedList :: Annex [Backend]

@@ -0,0 +1,162 @@+{- git-annex hashing backends+ -+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Backend.Hash (backends) where++import Common.Annex+import qualified Annex+import Types.Backend+import Types.Key+import Types.KeySource+import Utility.Hash+import Utility.ExternalSHA++import qualified Build.SysConfig as SysConfig+import qualified Data.ByteString.Lazy as L+import Data.Char++data Hash = SHAHash HashSize | SkeinHash HashSize+type HashSize = Int++{- Order is slightly significant; want SHA256 first, and more general+ - sizes earlier. -}+hashes :: [Hash]+hashes = concat +	[ map SHAHash [256, 1, 512, 224, 384]+	, map SkeinHash [256, 512]+	]++{- The SHA256E backend is the default, so genBackendE comes first. -}+backends :: [Backend]+backends = catMaybes $ map genBackendE hashes ++ map genBackend hashes++genBackend :: Hash -> Maybe Backend+genBackend hash = Just Backend+	{ name = hashName hash+	, getKey = keyValue hash+	, fsckKey = Just $ checkKeyChecksum hash+	, canUpgradeKey = Just needsUpgrade+	}++genBackendE :: Hash -> Maybe Backend+genBackendE hash = do+	b <- genBackend hash+	return $ b +		{ name = hashNameE hash+		, getKey = keyValueE hash+		}++hashName :: Hash -> String+hashName (SHAHash size) = "SHA" ++ show size+hashName (SkeinHash size) = "SKEIN" ++ show size++hashNameE :: Hash -> String+hashNameE hash = hashName hash ++ "E"++{- A key is a hash of its contents. -}+keyValue :: Hash -> KeySource -> Annex (Maybe Key)+keyValue hash source = do+	let file = contentLocation source+	stat <- liftIO $ getFileStatus file+	let filesize = fromIntegral $ fileSize stat+	s <- hashFile hash file filesize+	return $ Just $ stubKey+		{ keyName = s+		, keyBackendName = hashName hash+		, keySize = Just filesize+		}++{- Extension preserving keys. -}+keyValueE :: Hash -> KeySource -> Annex (Maybe Key)+keyValueE hash source = keyValue hash source >>= maybe (return Nothing) addE+  where+	addE k = return $ Just $ k+		{ keyName = keyName k ++ selectExtension (keyFilename source)+		, keyBackendName = hashNameE hash+		}++selectExtension :: FilePath -> String+selectExtension f+	| null es = ""+	| otherwise = intercalate "." ("":es)+  where+	es = filter (not . null) $ reverse $+		take 2 $ takeWhile shortenough $+		reverse $ split "." $ filter validExtension $ takeExtensions f+	shortenough e = length e <= 4 -- long enough for "jpeg"++{- A key's checksum is checked during fsck. -}+checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool+checkKeyChecksum hash key file = do+	fast <- Annex.getState Annex.fast+	mstat <- liftIO $ catchMaybeIO $ getFileStatus file+	case (mstat, fast) of+		(Just stat, False) -> do+			let filesize = fromIntegral $ fileSize stat+			check <$> hashFile hash file filesize+		_ -> return True+  where+	expected = keyHash key+	check s+		| s == expected = True+		{- A bug caused checksums to be prefixed with \ in some+		 - cases; still accept these as legal now that the bug has been+		 - fixed. -}+		| '\\' : s == expected = True+		| otherwise = False++keyHash :: Key -> String+keyHash key = dropExtensions (keyName key)++validExtension :: Char -> Bool+validExtension c+	| isAlphaNum c = True+	| c == '.' = True+	| otherwise = False++{- Upgrade keys that have the \ prefix on their sha due to a bug, or+ - that contain non-alphanumeric characters in their extension. -}+needsUpgrade :: Key -> Bool+needsUpgrade key = "\\" `isPrefixOf` keyHash key ||+	any (not . validExtension) (takeExtensions $ keyName key)++hashFile :: Hash -> FilePath -> Integer -> Annex String+hashFile hash file filesize = do+	showAction "checksum"+	liftIO $ go hash+  where+  	go (SHAHash hashsize) = case shaHasher hashsize filesize of+		Left sha -> sha <$> L.readFile file+		Right command ->+			either error return +				=<< externalSHA command hashsize file+	go (SkeinHash hashsize) = skeinHasher hashsize <$> L.readFile file++shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) String+shaHasher hashsize filesize+	| hashsize == 1 = use SysConfig.sha1 sha1+	| hashsize == 256 = use SysConfig.sha256 sha256+	| hashsize == 224 = use SysConfig.sha224 sha224+	| hashsize == 384 = use SysConfig.sha384 sha384+	| hashsize == 512 = use SysConfig.sha512 sha512+	| otherwise = error $ "bad sha size " ++ show hashsize+  where+	use Nothing hasher = Left $ show . hasher+	use (Just c) hasher+		{- Use builtin, but slightly slower hashing for+		 - smallish files. Cryptohash benchmarks 90 to 101%+		 - faster than external hashers, depending on the hash+		 - and system. So there is no point forking an external+		 - process unless the file is large. -}+		| filesize < 1048576 = use Nothing hasher+		| otherwise = Right c++skeinHasher :: HashSize -> (L.ByteString -> String)+skeinHasher hashsize +	| hashsize == 256 = show . skein256+	| hashsize == 512 = show . skein512+	| otherwise = error $ "bad skein size " ++ show hashsize

@@ -1,148 +0,0 @@-{- git-annex SHA backends- -- - Copyright 2011-2013 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Backend.SHA (backends) where--import Common.Annex-import qualified Annex-import Types.Backend-import Types.Key-import Types.KeySource-import Utility.Hash-import Utility.ExternalSHA--import qualified Build.SysConfig as SysConfig-import qualified Data.ByteString.Lazy as L-import Data.Char--type SHASize = Int--{- Order is slightly significant; want SHA256 first, and more general- - sizes earlier. -}-sizes :: [Int]-sizes = [256, 1, 512, 224, 384]--{- The SHA256E backend is the default. -}-backends :: [Backend]-backends = catMaybes $ map genBackendE sizes ++ map genBackend sizes--genBackend :: SHASize -> Maybe Backend-genBackend size = Just Backend-	{ name = shaName size-	, getKey = keyValue size-	, fsckKey = Just $ checkKeyChecksum size-	, canUpgradeKey = Just needsUpgrade-	}--genBackendE :: SHASize -> Maybe Backend-genBackendE size = do-	b <- genBackend size-	return $ b -		{ name = shaNameE size-		, getKey = keyValueE size-		}--shaName :: SHASize -> String-shaName size = "SHA" ++ show size--shaNameE :: SHASize -> String-shaNameE size = shaName size ++ "E"--shaN :: SHASize -> FilePath -> Integer -> Annex String-shaN shasize file filesize = do-	showAction "checksum"-	liftIO $ case shaCommand shasize filesize of-		Left sha -> sha <$> L.readFile file-		Right command ->-			either error return -				=<< externalSHA command shasize file--shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String-shaCommand shasize filesize-	| shasize == 1 = use SysConfig.sha1 sha1-	| shasize == 256 = use SysConfig.sha256 sha256-	| shasize == 224 = use SysConfig.sha224 sha224-	| shasize == 384 = use SysConfig.sha384 sha384-	| shasize == 512 = use SysConfig.sha512 sha512-	| otherwise = error $ "bad sha size " ++ show shasize-  where-	use Nothing hasher = Left $ show . hasher-	use (Just c) hasher-		{- Use builtin, but slightly slower hashing for-		 - smallish files. Cryptohash benchmarks 90 to 101%-		 - faster than external hashers, depending on the hash-		 - and system. So there is no point forking an external-		 - process unless the file is large. -}-		| filesize < 1048576 = use Nothing hasher-		| otherwise = Right c--{- A key is a checksum of its contents. -}-keyValue :: SHASize -> KeySource -> Annex (Maybe Key)-keyValue shasize source = do-	let file = contentLocation source-	stat <- liftIO $ getFileStatus file-	let filesize = fromIntegral $ fileSize stat-	s <- shaN shasize file filesize-	return $ Just $ stubKey-		{ keyName = s-		, keyBackendName = shaName shasize-		, keySize = Just filesize-		}--{- Extension preserving keys. -}-keyValueE :: SHASize -> KeySource -> Annex (Maybe Key)-keyValueE size source = keyValue size source >>= maybe (return Nothing) addE-  where-	addE k = return $ Just $ k-		{ keyName = keyName k ++ selectExtension (keyFilename source)-		, keyBackendName = shaNameE size-		}--selectExtension :: FilePath -> String-selectExtension f-	| null es = ""-	| otherwise = intercalate "." ("":es)-  where-	es = filter (not . null) $ reverse $-		take 2 $ takeWhile shortenough $-		reverse $ split "." $ filter validExtension $ takeExtensions f-	shortenough e = length e <= 4 -- long enough for "jpeg"--{- A key's checksum is checked during fsck. -}-checkKeyChecksum :: SHASize -> Key -> FilePath -> Annex Bool-checkKeyChecksum size key file = do-	fast <- Annex.getState Annex.fast-	mstat <- liftIO $ catchMaybeIO $ getFileStatus file-	case (mstat, fast) of-		(Just stat, False) -> do-			let filesize = fromIntegral $ fileSize stat-			check <$> shaN size file filesize-		_ -> return True-  where-	sha = keySha key-	check s-		| s == sha = True-		{- A bug caused checksums to be prefixed with \ in some-		 - cases; still accept these as legal now that the bug has been-		 - fixed. -}-		| '\\' : s == sha = True-		| otherwise = False--keySha :: Key -> String-keySha key = dropExtensions (keyName key)--validExtension :: Char -> Bool-validExtension c-	| isAlphaNum c = True-	| c == '.' = True-	| otherwise = False--{- Upgrade keys that have the \ prefix on their sha due to a bug, or- - that contain non-alphanumeric characters in their extension. -}-needsUpgrade :: Key -> Bool-needsUpgrade key = "\\" `isPrefixOf` keySha key ||-	any (not . validExtension) (takeExtensions $ keyName key)

@@ -1,25 +1,41 @@-git-annex (4.20130921) UNRELEASED; urgency=low+git-annex (4.20131002) unstable; urgency=low    * Note that the layout of gcrypt repositories has changed, and     if you created one you must manually upgrade it.     See http://git-annex.branchable.com/upgrades/gcrypt/+  * webapp: Support setting up and using encrypted git repositories on+    any ssh server, as well as on rsync.net.   * git-annex-shell: Added support for operating inside gcrypt repositories.+  * Disable receive.denyNonFastForwards when setting up a gcrypt special+    remote, since gcrypt needs to be able to fast-forward the master branch.   * import: Preserve top-level directory structure.   * Use cryptohash rather than SHA for hashing when no external hash program     is available. This is a significant speedup for SHA256 on OSX, for     example.+  * Added SKEIN256 and SKEIN512 backends.   * Android build redone from scratch, many dependencies updated,     and entire build can now be done using provided scripts.   * assistant: Clear the list of failed transfers when doing a full transfer     scan. This prevents repeated retries to download files that are not     available, or are not referenced by the current git tree.-  * indirect: Better behavior when a file in direct mode is not owned by+  * indirect, direct: Better behavior when a file is not owned by     the user running the conversion.   * add, import, assistant: Better preserve the mtime of symlinks,     when when adding content that gets deduplicated.-  * webapp: Support storing encrypted git repositories on rsync.net.+  * Send a git-annex user-agent when downloading urls.+    Overridable with --user-agent option.+    (Not yet done for S3 or WebDAV due to limitations of libraries used.)+  * webapp: Fixed a bug where when a new remote is added, one file+    may fail to sync to or from it due to the transferrer process not+    yet knowing about the new remote.+  * OSX: Bundled gpg upgraded, now compatible with config files+    written by MacGPG.+  * assistant: More robust inotify handling; avoid crashing if a directory+    cannot be read.+  * Moved list of backends and remote types from status to version+    command. - -- Joey Hess <joeyh@debian.org>  Sun, 22 Sep 2013 19:42:29 -0400+ -- Joey Hess <joeyh@debian.org>  Wed, 02 Oct 2013 16:00:39 -0400  git-annex (4.20130920) unstable; urgency=low 

@@ -17,8 +17,8 @@ import qualified Command.Add import qualified Annex import qualified Annex.Queue+import qualified Annex.Url as Url import qualified Backend.URL-import qualified Utility.Url as Url import Annex.Content import Logs.Web import qualified Option@@ -123,7 +123,7 @@ 			next $ return True 		| otherwise = do 			headers <- getHttpHeaders-			ifM (liftIO $ Url.check url headers $ keySize key)+			ifM (Url.withUserAgent $ Url.check url headers $ keySize key) 				( do 					setUrlPresent key url 					next $ return True@@ -174,7 +174,7 @@ 		size <- ifM (liftIO $ isJust <$> checkDaemon pidfile) 			( do 				headers <- getHttpHeaders-				liftIO $ snd <$> Url.exists url headers+				snd <$> Url.withUserAgent (Url.exists url headers) 			, return Nothing 			) 		Backend.URL.fromUrl url size@@ -203,7 +203,7 @@ 	headers <- getHttpHeaders 	(exists, size) <- if relaxed 		then pure (True, Nothing)-		else liftIO $ Url.exists url headers+		else Url.withUserAgent $ Url.exists url headers 	if exists 		then do 			key <- Backend.URL.fromUrl url size

@@ -7,6 +7,8 @@  module Command.Direct where +import Control.Exception.Extensible+ import Common.Annex import Command import qualified Git@@ -15,6 +17,7 @@ import Config import Annex.Direct import Annex.Version+import Annex.Exception  def :: [Command] def = [notBareRepo $ noDaemonRunning $@@ -51,9 +54,16 @@ 			Nothing -> noop 			Just a -> do 				showStart "direct" f-				a-				showEndOk+				r <- tryAnnex a+				case r of+					Left e -> warnlocked e+					Right _ -> showEndOk 		return Nothing++	warnlocked :: SomeException -> Annex ()+	warnlocked e = do+		warning $ show e+		warning "leaving this file as-is; correct this problem and run git annex fsck on it"  cleanup :: CommandCleanup cleanup = do

@@ -0,0 +1,35 @@+{- git-annex command+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.GCryptSetup where++import Common.Annex+import Command+import Annex.UUID+import qualified Remote.GCrypt+import qualified Git++def :: [Command]+def = [dontCheck repoExists $ noCommit $+	command "gcryptsetup" paramValue seek+		SectionPlumbing "sets up gcrypt repository"]++seek :: [CommandSeek]+seek = [withStrings start]++start :: String -> CommandStart+start gcryptid = next $ next $ do+	g <- gitRepo+	u <- getUUID+	gu <- Remote.GCrypt.getGCryptUUID True g+	if u == NoUUID && gu == Nothing+		then if Git.repoIsLocalBare g+			then do+				void $ Remote.GCrypt.setupRepo gcryptid g+				return True+			else error "cannot use gcrypt in a non-bare repository"+		else error "gcryptsetup permission denied"

@@ -17,7 +17,7 @@ import Common.Annex import qualified Annex import Command-import qualified Utility.Url as Url+import qualified Annex.Url as Url import Logs.Web import qualified Option import qualified Utility.Format@@ -102,9 +102,10 @@ downloadFeed :: URLString -> Annex (Maybe Feed) downloadFeed url = do 	showOutput+	ua <- Url.getUserAgent 	liftIO $ withTmpFile "feed" $ \f h -> do 		fileEncoding h-		ifM (Url.download url [] [] f)+		ifM (Url.download url [] [] f ua) 			( liftIO $ parseFeedString <$> hGetContentsStrict h 			, return Nothing 			)

@@ -72,7 +72,18 @@ 				return $ size == size' 		if oksize 			then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of-				Nothing -> return False-				Just backend -> maybe (return True) (\a -> a key tmp)+				Nothing -> do+					warning "recvkey: received key from direct mode repository using unknown backend; cannot check; discarding"+					return False+				Just backend -> maybe (return True) runfsck 					(Types.Backend.fsckKey backend)-			else return False+			else do+				warning "recvkey: received key with wrong size; discarding"+				return False+	  where+	  	runfsck check = ifM (check key tmp)+			( return True+			, do+				warning "recvkey: received key from direct mode repository seems to have changed as it was transferred; discarding"+				return False+			)

@@ -17,8 +17,6 @@ import System.PosixCompat.Files  import Common.Annex-import qualified Types.Backend as B-import qualified Types.Remote as R import qualified Remote import qualified Command.Unused import qualified Git@@ -28,7 +26,6 @@ import Utility.DiskFree import Annex.Content import Types.Key-import Backend import Logs.UUID import Logs.Trust import Remote@@ -116,9 +113,7 @@  -} global_fast_stats :: [Stat] global_fast_stats = -	[ supported_backends-	, supported_remote_types-	, repository_mode+	[ repository_mode 	, remote_list Trusted 	, remote_list SemiTrusted 	, remote_list UnTrusted@@ -170,14 +165,6 @@ 	calc (desc, a) = do 		(lift . showHeader) desc 		lift . showRaw =<< a--supported_backends :: Stat-supported_backends = stat "supported backends" $ json unwords $-	return $ map B.name Backend.list--supported_remote_types :: Stat-supported_remote_types = stat "supported remote types" $ json unwords $-	return $ map R.typename Remote.remoteTypes  repository_mode :: Stat repository_mode = stat "repository mode" $ json id $ lift $

@@ -12,6 +12,10 @@ import qualified Build.SysConfig as SysConfig import Annex.Version import BuildFlags+import qualified Types.Backend as B+import qualified Types.Remote as R+import qualified Remote+import qualified Backend  def :: [Command] def = [noCommit $ noRepo showPackageVersion $ dontCheck repoExists $@@ -25,13 +29,20 @@ 	v <- getVersion 	liftIO $ do 		showPackageVersion-		putStrLn $ "local repository version: " ++ fromMaybe "unknown" v-		putStrLn $ "default repository version: " ++ defaultVersion-		putStrLn $ "supported repository versions: " ++ unwords supportedVersions-		putStrLn $ "upgrade supported from repository versions: " ++ unwords upgradableVersions+		info "local repository version" $ fromMaybe "unknown" v+		info "default repository version" defaultVersion+		info "supported repository versions" $+			unwords supportedVersions+		info "upgrade supported from repository versions" $+			unwords upgradableVersions 	stop  showPackageVersion :: IO () showPackageVersion = do-	putStrLn $ "git-annex version: " ++ SysConfig.packageversion-	putStrLn $ "build flags: " ++ unwords buildFlags+	info "git-annex version" SysConfig.packageversion+	info "build flags" $ unwords buildFlags+	info "key/value backends" $ unwords $ map B.name Backend.list+	info "remote types" $ unwords $ map R.typename Remote.remoteTypes++info :: String -> String -> IO ()+info k v = putStrLn $ k ++ ": " ++ v

@@ -177,3 +177,14 @@ 	, File f 	, Param "--list" 	]++{- Changes a git config setting in the specified config file.+ - (Creates the file if it does not already exist.) -}+changeFile :: FilePath -> String -> String -> IO Bool+changeFile f k v = boolSystem "git"+	[ Param "config"+	, Param "--file"+	, File f+	, Param k+	, Param v+	]

@@ -48,6 +48,8 @@ 		"skip files smaller than a size" 	, Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime) 		"stop after the specified amount of time"+	, Option [] ["user-agent"] (ReqArg setuseragent paramName)+		"override default User-Agent" 	, Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) 		"Trust Amazon Glacier inventory" 	] ++ Option.matcher@@ -55,6 +57,7 @@ 	setnumcopies v = maybe noop 		(\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just n }) 		(readish v)+	setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } 	setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v) 	trustArg t = ReqArg (Remote.forceTrust t) paramRemote 

@@ -30,24 +30,26 @@ import qualified Command.SendKey import qualified Command.TransferInfo import qualified Command.Commit+import qualified Command.GCryptSetup  cmds_readonly :: [Command] cmds_readonly = concat-	[ Command.ConfigList.def-	, Command.InAnnex.def-	, Command.SendKey.def-	, Command.TransferInfo.def+	[ gitAnnexShellCheck Command.ConfigList.def+	, gitAnnexShellCheck Command.InAnnex.def+	, gitAnnexShellCheck Command.SendKey.def+	, gitAnnexShellCheck Command.TransferInfo.def 	]  cmds_notreadonly :: [Command] cmds_notreadonly = concat-	[ Command.RecvKey.def-	, Command.DropKey.def-	, Command.Commit.def+	[ gitAnnexShellCheck Command.RecvKey.def+	, gitAnnexShellCheck Command.DropKey.def+	, gitAnnexShellCheck Command.Commit.def+	, Command.GCryptSetup.def 	]  cmds :: [Command]-cmds = map gitAnnexShellCheck $ map adddirparam $ cmds_readonly ++ cmds_notreadonly+cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly   where 	adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } @@ -191,8 +193,8 @@  {- Modifies a Command to check that it is run in either a git-annex  - repository, or a repository with a gcrypt-id set. -}-gitAnnexShellCheck :: Command -> Command-gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists+gitAnnexShellCheck :: [Command] -> [Command]+gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists   where 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ 		error "Not a git-annex or gcrypt repository."

@@ -1,4 +1,4 @@-git-annex (4.20130921) unstable; urgency=low+git-annex (4.20131002) unstable; urgency=low     The layout of gcrypt repositories has changed, and    if you created one you must manually upgrade it.

@@ -168,13 +168,19 @@ prettyUUID :: UUID -> Annex String prettyUUID u = concat <$> prettyListUUIDs [u] -{- Gets the remote associated with a UUID.- - There's no associated remote when this is the UUID of the local repo. -}+{- Gets the remote associated with a UUID. -} remoteFromUUID :: UUID -> Annex (Maybe Remote) remoteFromUUID u = ifM ((==) u <$> getUUID) 	( return Nothing-	, Just . fromMaybe (error "Unknown UUID") . M.lookup u <$> remoteMap id+	, do+		maybe tryharder (return . Just) =<< findinmap 	)+  where+	findinmap = M.lookup u <$> remoteMap id+	{- Re-read remote list in case a new remote has popped up. -}+	tryharder = do+		void remoteListRefresh+		findinmap  {- Filters a list of remotes to ones that have the listed uuids. -} remotesWithUUID :: [Remote] -> [UUID] -> [Remote]

@@ -9,7 +9,8 @@ 	remote, 	gen, 	getGCryptUUID,-	coreGCryptId+	coreGCryptId,+	setupRepo ) where  import qualified Data.Map as M@@ -163,7 +164,7 @@  		{- Run a git fetch and a push to the git repo in order to get 		 - its gcrypt-id set up, so that later git annex commands-		 - will use the remote as a ggcrypt remote. The fetch is+		 - will use the remote as a gcrypt remote. The fetch is 		 - needed if the repo already exists; the push is needed 		 - if the repo has not yet been initialized by gcrypt. -} 		void $ inRepo $ Git.Command.runBool@@ -185,51 +186,50 @@ 						method <- setupRepo gcryptid =<< inRepo (Git.Construct.fromRemoteLocation gitrepo) 						gitConfigSpecialRemote u c' "gcrypt" (fromAccessMethod method) 						return (c', u)-					else error "uuid mismatch"+					else error $ "uuid mismatch " ++ show (u, mu, gcryptid)  {- Sets up the gcrypt repository. The repository is either a local  - repo, or it is accessed via rsync directly, or it is accessed over ssh  - and git-annex-shell is available to manage it.  -- - The gcrypt-id is stored in the gcrypt repository for later- - double-checking and identification. This is always done using rsync.+ - The GCryptID is recorded in the repository's git config for later use.+ - Also, if the git config has receive.denyNonFastForwards set, disable+ - it; gcrypt relies on being able to fast-forward branches.  -} setupRepo :: Git.GCrypt.GCryptId -> Git.Repo -> Annex AccessMethod setupRepo gcryptid r 	| Git.repoIsUrl r = do-		accessmethod <- rsyncsetup+		(_, _, accessmethod) <- rsyncTransport r 		case accessmethod of-			AccessDirect -> return AccessDirect-			AccessShell -> ifM usablegitannexshell+			AccessDirect -> rsyncsetup+			AccessShell -> ifM gitannexshellsetup 				( return AccessShell-				, return AccessDirect+				, rsyncsetup 				) 	| Git.repoIsLocalUnknown r = localsetup =<< liftIO (Git.Config.read r) 	| otherwise = localsetup r   where 	localsetup r' = do-		liftIO $ Git.Command.run [Param "config", Param coreGCryptId, Param gcryptid] r'+		let setconfig k v = liftIO $ Git.Command.run [Param "config", Param k, Param v] r'+		setconfig coreGCryptId gcryptid+		setconfig denyNonFastForwards (Git.Config.boolConfig False) 		return AccessDirect -	{- Download any git config file from the remote,-	 - add the gcryptid to it, and send it back.-	 --	 - At the same time, create the objectDir on the remote,-	 - which is needed for direct rsync to work.+	{- As well as modifying the remote's git config, +	 - create the objectDir on the remote,+	 - which is needed for direct rsync of objects to work. 	 -}   	rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do 		liftIO $ createDirectoryIfMissing True $ tmp </> objectDir-		(rsynctransport, rsyncurl, accessmethod) <- rsyncTransport r+		(rsynctransport, rsyncurl, _) <- rsyncTransport r 		let tmpconfig = tmp </> "config" 		void $ liftIO $ rsync $ rsynctransport ++ 			[ Param $ rsyncurl ++ "/config" 			, Param tmpconfig 			]-		liftIO $ appendFile tmpconfig $ unlines-			[ ""-			, "[core]"-			, "\tgcrypt-id = " ++ gcryptid-			]+		liftIO $ do+			void $ Git.Config.changeFile tmpconfig coreGCryptId gcryptid+			void $ Git.Config.changeFile tmpconfig denyNonFastForwards (Git.Config.boolConfig False) 		ok <- liftIO $ rsync $ rsynctransport ++ 			[ Params "--recursive" 			, Param $ tmp ++ "/"@@ -237,13 +237,15 @@ 			] 		unless ok $ 			error "Failed to connect to remote to set it up."-		return accessmethod+		return AccessDirect -	{-  Check if git-annex shell is installed, and is a new enough-	 -  version to work in a gcrypt repo. -}-	usablegitannexshell = either (const False) (const True)-		<$> Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []+	{-  Ask git-annex-shell to configure the repository as a gcrypt+	 -  repository. May fail if it is too old. -}+	gitannexshellsetup = Ssh.onRemote r (boolSystem, False)+		"gcryptsetup" [ Param gcryptid ] [] +	denyNonFastForwards = "receive.denyNonFastForwards"+ shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a shellOrRsync r ashell arsync = case method of 	AccessShell -> ashell@@ -290,7 +292,7 @@ 	storeshell = withTmp enck $ \tmp -> 		ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True) 			( Ssh.rsyncHelper (Just p)-				=<< Ssh.rsyncParamsRemote r Upload enck tmp Nothing+				=<< Ssh.rsyncParamsRemote False r Upload enck tmp Nothing 			, return False 			) 	spoolencrypted a = Annex.Content.sendAnnex k noop $ \src ->@@ -312,7 +314,7 @@ 				(readBytes $ meteredWriteFile meterupdate d) 	retrieversync = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p 	retrieveshell = withTmp enck $ \tmp ->-		ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote r Download enck tmp Nothing)+		ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download enck tmp Nothing) 			( liftIO $ catchBoolIO $ do 				decrypt cipher (feedFile tmp) $ 					readBytes $ L.writeFile d@@ -375,7 +377,7 @@  - (Also returns a version of input repo with its config read.) -} getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo) getGCryptId fast r-	| Git.repoIsLocal r = extract <$>+	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> 		liftIO (catchMaybeIO $ Git.Config.read r) 	| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) 		[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []

@@ -30,7 +30,7 @@ import qualified Annex.Content import qualified Annex.BranchState import qualified Annex.Branch-import qualified Utility.Url as Url+import qualified Annex.Url as Url import Utility.Tmp import Config import Config.Cost@@ -177,9 +177,10 @@ 			Left l -> return $ Left l  	geturlconfig headers = do+		ua <- Url.getUserAgent 		v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do 			hClose h-			ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile)+			ifM (Url.downloadQuiet (Git.repoLocation r ++ "/config") headers [] tmpfile ua) 				( pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] 				, return $ Left undefined 				)@@ -240,7 +241,7 @@   where 	checkhttp headers = do 		showChecking r-		liftIO $ ifM (anyM (\u -> Url.check u headers (keySize key)) (keyUrls r key))+		ifM (anyM (\u -> Url.withUserAgent $ Url.check u headers (keySize key)) (keyUrls r key)) 			( return $ Right True 			, return $ Left "not found" 			)@@ -295,9 +296,10 @@ 					upload u key file noRetry 						(rsyncOrCopyFile params object dest) 						<&&> checksuccess-	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> +	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do+		direct <- isDirect 		Ssh.rsyncHelper (Just feeder) -			=<< Ssh.rsyncParamsRemote r Download key dest file+			=<< Ssh.rsyncParamsRemote direct r Download key dest file 	| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest 	| otherwise = error "copying from non-ssh, non-http remote not supported"   where@@ -369,9 +371,10 @@ 		guardUsable (repo r) False $ commitOnCleanup r $ 			copylocal =<< Annex.Content.prepSendAnnex key 	| Git.repoIsSsh (repo r) = commitOnCleanup r $-		Annex.Content.sendAnnex key noop $ \object ->+		Annex.Content.sendAnnex key noop $ \object -> do+			direct <- isDirect 			Ssh.rsyncHelper (Just p)-				=<< Ssh.rsyncParamsRemote r Upload key object file+				=<< Ssh.rsyncParamsRemote direct r Upload key object file 	| otherwise = error "copying to non-ssh repo not supported"   where 	copylocal Nothing = return False

@@ -19,7 +19,6 @@ import Remote.Helper.Messages import Utility.Metered import Utility.Rsync-import Config import Types.Remote import Logs.Transfer @@ -111,10 +110,9 @@  {- Generates rsync parameters that ssh to the remote and asks it  - to either receive or send the key's content. -}-rsyncParamsRemote :: Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]-rsyncParamsRemote r direction key file afile = do+rsyncParamsRemote :: Bool -> Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]+rsyncParamsRemote direct r direction key file afile = do 	u <- getUUID-	direct <- isDirect 	let fields = (Fields.remoteUUID, fromUUID u) 		: (Fields.direct, if direct then "1" else "") 		: maybe [] (\f -> [(Fields.associatedFile, f)]) afile

@@ -19,7 +19,7 @@ import Logs.Web import Types.Key import Utility.Metered-import qualified Utility.Url as Url+import qualified Annex.Url as Url #ifdef WITH_QUVI import Annex.Quvi import qualified Utility.Quvi as Quvi@@ -118,7 +118,7 @@ #endif 		DefaultDownloader -> do 			headers <- getHttpHeaders-			liftIO $ Right <$> Url.check u' headers (keySize key)+			Right <$> Url.withUserAgent (Url.check u' headers $ keySize key)   where   	firsthit [] miss _ = return miss 	firsthit (u:rest) _ a = do

@@ -58,6 +58,7 @@ import qualified Utility.Env import qualified Utility.Matcher import qualified Utility.Exception+import qualified Utility.Hash #ifndef mingw32_HOST_OS import qualified GitAnnex import qualified Remote.Helper.Encryptable@@ -136,6 +137,7 @@ 	, check "prop_parse_show_log" Logs.Presence.prop_parse_show_log 	, check "prop_read_show_TrustLevel" Types.TrustLevel.prop_read_show_TrustLevel 	, check "prop_parse_show_TrustLog" Logs.Trust.prop_parse_show_TrustLog+	, check "prop_hashes_stable" Utility.Hash.prop_hashes_stable 	]   where 	check desc prop = do

@@ -6,6 +6,7 @@  import Crypto.Hash import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as C8  sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy@@ -26,4 +27,22 @@ --sha3 :: L.ByteString -> Digest SHA3 --sha3 = hashlazy +skein256 :: L.ByteString -> Digest Skein256_256+skein256 = hashlazy +skein512 :: L.ByteString -> Digest Skein512_512+skein512 = hashlazy++{- Check that all the hashes continue to hash the same. -}+prop_hashes_stable :: Bool+prop_hashes_stable = all (\(hasher, result) -> hasher foo == result)+	[ (show . sha1, "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33")+	, (show . sha224, "0808f64e60d58979fcb676c96ec938270dea42445aeefcd3a4e6f8db")+	, (show . sha256, "2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae")+	, (show . sha384, "98c11ffdfdd540676b1a137cb1a22b2a70350c9a44171d6b1180c6be5cbb2ee3f79d532c8a1dd9ef2e8e08e752a3babb")+	, (show . sha512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7")+	, (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33")+	, (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")+	]+  where+	foo = L.fromChunks [C8.pack "foo"]

@@ -54,11 +54,12 @@ 		-- scan come before real inotify events. 		lock <- newLock 		let handler event = withLock lock (void $ go event)-		void (addWatch i watchevents dir handler)-			`catchIO` failedaddwatch-		withLock lock $-			mapM_ scan =<< filter (not . dirCruft) <$>-				getDirectoryContents dir+		flip catchNonAsync failedwatch $ do+			void (addWatch i watchevents dir handler)+				`catchIO` failedaddwatch+			withLock lock $+				mapM_ scan =<< filter (not . dirCruft) <$>+					getDirectoryContents dir   where 	recurse d = watchDir i d ignored hooks @@ -149,11 +150,13 @@ 		-- disk full error. 		| isFullError e = 			case errHook hooks of-				Nothing -> throw e+				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")" 				Just hook -> tooManyWatches hook dir 		-- The directory could have been deleted. 		| isDoesNotExistError e = return () 		| otherwise = throw e++	failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"  tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () tooManyWatches hook dir = do

@@ -9,6 +9,7 @@  module Utility.Url ( 	URLString,+	UserAgent, 	check, 	exists, 	download,@@ -27,10 +28,12 @@  type Headers = [String] +type UserAgent = String+ {- Checks that an url exists and could be successfully downloaded,  - also checking that its size, if available, matches a specified size. -}-check :: URLString -> Headers -> Maybe Integer -> IO Bool-check url headers expected_size = handle <$> exists url headers+check :: URLString -> Headers -> Maybe Integer -> Maybe UserAgent -> IO Bool+check url headers expected_size = handle <$$> exists url headers   where 	handle (False, _) = False 	handle (True, Nothing) = True@@ -44,8 +47,8 @@  - Uses curl otherwise, when available, since curl handles https better  - than does Haskell's Network.Browser.  -}-exists :: URLString -> Headers -> IO (Bool, Maybe Integer)-exists url headers = case parseURIRelaxed url of+exists :: URLString -> Headers -> Maybe UserAgent -> IO (Bool, Maybe Integer)+exists url headers ua = case parseURIRelaxed url of 	Just u 		| uriScheme u == "file:" -> do 			s <- catchMaybeIO $ getFileStatus (unEscapeString $ uriPath u)@@ -54,12 +57,12 @@ 				Nothing -> dne 		| otherwise -> if Build.SysConfig.curl 			then do-				output <- readProcess "curl" curlparams+				output <- readProcess "curl" $ toCommand curlparams 				case lastMaybe (lines output) of 					Just ('2':_:_) -> return (True, extractsize output) 					_ -> dne 			else do-				r <- request u headers HEAD+				r <- request u headers HEAD ua 				case rspCode r of 					(2,_,_) -> return (True, size r) 					_ -> return (False, Nothing)@@ -67,13 +70,12 @@   where 	dne = return (False, Nothing) -	curlparams = -		[ "-s"-		, "--head"-		, "-L"-		, url-		, "-w", "%{http_code}"-		] ++ concatMap (\h -> ["-H", h]) headers+	curlparams = addUserAgent ua $+		[ Param "-s"+		, Param "--head"+		, Param "-L", Param url+		, Param "-w", Param "%{http_code}"+		] ++ concatMap (\h -> [Param "-H", Param h]) headers  	extractsize s = case lastMaybe $ filter ("Content-Length:" `isPrefixOf`) (lines s) of 		Just l -> case lastMaybe $ words l of@@ -83,6 +85,11 @@  	size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders +-- works for both wget and curl commands+addUserAgent :: Maybe UserAgent -> [CommandParam] -> [CommandParam]+addUserAgent Nothing ps = ps+addUserAgent (Just ua) ps = ps ++ [Param "--user-agent", Param ua] + {- Used to download large files, such as the contents of keys.  -  - Uses wget or curl program for its progress bar. (Wget has a better one,@@ -90,15 +97,15 @@  - would not be appropriate to test at configure time and build support  - for only one in.  -}-download :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool+download :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool download = download' False  {- No output, even on error. -}-downloadQuiet :: URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool+downloadQuiet :: URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool downloadQuiet = download' True -download' :: Bool -> URLString -> Headers -> [CommandParam] -> FilePath -> IO Bool-download' quiet url headers options file = +download' :: Bool -> URLString -> Headers -> [CommandParam] -> FilePath -> Maybe UserAgent -> IO Bool+download' quiet url headers options file ua =  	case parseURIRelaxed url of 		Just u 			| uriScheme u == "file:" -> do@@ -119,7 +126,7 @@ 	curl = go "curl" $ headerparams ++ quietopt "-s" ++ 		[Params "-f -L -C - -# -o"] 	go cmd opts = boolSystem cmd $-		options++opts++[File file, File url]+		addUserAgent ua $ options++opts++[File file, File url] 	quietopt s 		| quiet = [Param s] 		| otherwise = []@@ -134,13 +141,14 @@  - Unfortunately, does not handle https, so should only be used  - when curl is not available.  -}-request :: URI -> Headers -> RequestMethod -> IO (Response String)-request url headers requesttype = go 5 url+request :: URI -> Headers -> RequestMethod -> Maybe UserAgent -> IO (Response String)+request url headers requesttype ua = go 5 url   where 	go :: Int -> URI -> IO (Response String) 	go 0 _ = error "Too many redirects " 	go n u = do 		rsp <- Browser.browse $ do+			maybe noop Browser.setUserAgent ua 			Browser.setErrHandler ignore 			Browser.setOutHandler ignore 			Browser.setAllowRedirects False

@@ -1,4 +1,4 @@-git-annex (4.20130921) unstable; urgency=low+git-annex (4.20131002) unstable; urgency=low     The layout of gcrypt repositories has changed, and    if you created one you must manually upgrade it.

@@ -1,25 +1,41 @@-git-annex (4.20130921) UNRELEASED; urgency=low+git-annex (4.20131002) unstable; urgency=low    * Note that the layout of gcrypt repositories has changed, and     if you created one you must manually upgrade it.     See http://git-annex.branchable.com/upgrades/gcrypt/+  * webapp: Support setting up and using encrypted git repositories on+    any ssh server, as well as on rsync.net.   * git-annex-shell: Added support for operating inside gcrypt repositories.+  * Disable receive.denyNonFastForwards when setting up a gcrypt special+    remote, since gcrypt needs to be able to fast-forward the master branch.   * import: Preserve top-level directory structure.   * Use cryptohash rather than SHA for hashing when no external hash program     is available. This is a significant speedup for SHA256 on OSX, for     example.+  * Added SKEIN256 and SKEIN512 backends.   * Android build redone from scratch, many dependencies updated,     and entire build can now be done using provided scripts.   * assistant: Clear the list of failed transfers when doing a full transfer     scan. This prevents repeated retries to download files that are not     available, or are not referenced by the current git tree.-  * indirect: Better behavior when a file in direct mode is not owned by+  * indirect, direct: Better behavior when a file is not owned by     the user running the conversion.   * add, import, assistant: Better preserve the mtime of symlinks,     when when adding content that gets deduplicated.-  * webapp: Support storing encrypted git repositories on rsync.net.+  * Send a git-annex user-agent when downloading urls.+    Overridable with --user-agent option.+    (Not yet done for S3 or WebDAV due to limitations of libraries used.)+  * webapp: Fixed a bug where when a new remote is added, one file+    may fail to sync to or from it due to the transferrer process not+    yet knowing about the new remote.+  * OSX: Bundled gpg upgraded, now compatible with config files+    written by MacGPG.+  * assistant: More robust inotify handling; avoid crashing if a directory+    cannot be read.+  * Moved list of backends and remote types from status to version+    command. - -- Joey Hess <joeyh@debian.org>  Sun, 22 Sep 2013 19:42:29 -0400+ -- Joey Hess <joeyh@debian.org>  Wed, 02 Oct 2013 16:00:39 -0400  git-annex (4.20130920) unstable; urgency=low 

@@ -50,6 +50,9 @@ This commits any staged changes to the git\-annex branch. It also runs the annex\-content hook. .IP+.IP "gcryptsetup gcryptid"+Sets up a repository as a gcrypt repository.+.IP .SH OPTIONS Most options are the same as in git\-annex. The ones specific to git\-annex\-shell are:

@@ -745,6 +745,9 @@ .IP Also, '\\n' is a newline, '\\000' is a NULL, etc. .IP+.IP "\fB\-\-user\-agent=value\fP"+Overrides the User\-Agent to use when downloading files from the web.+.IP .IP "\fB\-c name=value\fP" Used to override git configuration settings. May be specified multiple times. .IP

@@ -1,5 +1,5 @@ Name: git-annex-Version: 4.20130927+Version: 4.20131002 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <joey@kitenet.net>

@@ -26,11 +26,11 @@   <p>     $forall (keyid, name) <- secretkeys       <p>-        <a .btn onclick="$('#setupmodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}">+        <a .btn href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}" onclick="$('#setupmodal').modal('show');">           <i .icon-lock></i> Encrypt repository #         to ^{gpgKeyDisplay keyid (Just name)}   <p>-    <a .btn onclick="$('#genkeymodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}">+    <a .btn href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}" onclick="$('#genkeymodal').modal('show');">       <i .icon-plus-sign></i> Encrypt repository #     with a new encryption key ^{genKeyModal}

@@ -0,0 +1,19 @@+<div .span9 .hero-unit>+  <h2>+    Combine repositories?+  <p>+    A repository already exists on #{sshHostName sshdata} in the #+    <tt>#{sshDirectory sshdata}</tt> directory.+  <p>+    Do you want to merge this repository's contents into your repository?+  <p>+    <a .btn onclick="$('#setupmodal').modal('show');" href="@{CombineSshR sshdata}">+      <i .icon-resize-small></i> Combine the repositories #+    The combined repositories will sync and share their files.+  <p>+  <p>+    <a .btn href="@{AddSshR}">+      <i .icon-resize-full></i> Go back #+    Use a different directory than <tt>#{sshDirectory sshdata}</tt> to #+    avoid combining the repositories.+^{sshSetupModal sshdata}

@@ -3,54 +3,67 @@     Ready to add remote server   <div .row-fluid>     <div .span9>-      <p>-        The server #{sshHostName sshdata} has been verified to be usable.-      <p>-        You have two options for how to use the server:-      <p>-        $if not (rsyncOnly sshdata)-          <a .btn .btn-primary href="@{MakeSshGitR sshdata}" onclick="$('#setupmodal').modal('show');">-            Use a git repository on the server-        $else-          <a .btn .disabled .btn-warning href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">-            Use a git repository on the server (not available) #-          <a .btn .btn-primary href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">-            Retry-          <br>+      $if not (hasCapability sshdata GitAnnexShellCapable)+        <p>           <i .icon-warning-sign></i> #-          <i>-            The server needs git and git-annex installed to use this option.-        <br>-        All your data will be uploaded to the server, including the full #-        git repository. This is a great choice if you want to set up #-        other devices to use the same server, or share the repository with #-        others.-      <p style="text-align: center">-        -or-+          The server #{sshHostName sshdata} can be used as is, but #+          installing #+          $if not (hasCapability sshdata GitCapable)+            git and git-annex #+          $else+            git-annex #+          on it would make it work better, and provide more options below. #+        <p>+          If you're able to install software on the server, do so and click+          <a .btn href="@{RetrySshR sshdata}" onclick="$('#testmodal').modal('show');">+            Retry+      $else+        <p>+          The server #{sshHostName sshdata} has been verified to be usable. #+          Depending on whether you trust this server, you can choose between #+          storing your data on it encrypted, or unencrypted.+        <h3>+          Unencrypted repository+        <p>+          All your data will be uploaded to the server, including a clone of #+          the git repository. This is a good choice if you want to set up #+          other devices to use the same server, or share the repository with #+          others.+        <p>+          <a .btn href="@{MakeSshGitR sshdata}" onclick="$('#setupmodal').modal('show');">+            Make an unencrypted git repository on the server+        <p style="text-align: center">+          -or-+      <h3>+        Simple shared encryption       <p>-        <a .btn .btn-primary href="@{MakeSshRsyncR sshdata}" onclick="$('#setupmodal').modal('show');">-          Use an encrypted rsync repository on the server-        <br>-        The contents of your files will be stored, fully encrypted, on the #-        server. The server will not store other information about your #-        git repository. This is the best choice if you don't run the server #-        yourself, or have sensitive data.-    <div .span4>-      $if needsPubKey sshdata-        <div .alert .alert-info>-          <i .icon-info-sign></i> #-          A ssh key will be installed on the server, allowing git-annex to #-          access it securely without a password.-^{sshTestModal}-<div .modal .fade #setupmodal>-  <div .modal-header>-    <h3>-      Making repository ...-  <div .modal-body>-    <p>-      Setting up repository on the remote server. This could take a minute.-    $if needsPubKey sshdata+        This allows everyone who has a clone of this repository to #+        decrypt the files stored on #{sshHostName sshdata}. That makes #+        it good for sharing. And it's easy to set up and use.       <p>-        You will be prompted once more for your ssh password. A ssh key #-        is being installed on the server, allowing git-annex to access it #-        securely without a password.+        <a .btn href="@{MakeSshRsyncR sshdata}" onclick="$('#setupmodal').modal('show');">+          <i .icon-lock></i> Use shared encryption+      $if hasCapability sshdata GitCapable+        <p style="text-align: center">+          -or-+        <h3>+          Encrypt with GnuPG key+        <p>+          This stores an encrypted clone of your repository on #+          #{sshHostName sshdata}, unlike shared encryption which only #+          stores file contents there. So it's good for backups. But the #+          encryption will prevent you from sharing the repository with #+          friends, or easily accessing its contents on another computer.+        <p>+          $forall (keyid, name) <- secretkeys+            <p>+              <a .btn href="@{MakeSshGCryptR sshdata (RepoKey keyid)}" onclick="$('#setupmodal').modal('show');" >+                <i .icon-lock></i> Encrypt repository #+              to ^{gpgKeyDisplay keyid (Just name)}+        <p>+          <a .btn href="@{MakeSshGCryptR sshdata NoRepoKey}" onclick="$('#genkeymodal').modal('show');">+            <i .icon-plus-sign></i> Encrypt repository #+          with a new encryption key+^{sshTestModal}+^{sshSetupModal sshdata}+^{genKeyModal}

@@ -0,0 +1,12 @@+<div .modal .fade #setupmodal>+  <div .modal-header>+    <h3>+      Setting up repository ...+  <div .modal-body>+    <p>+      Setting up repository on the remote server. This could take a minute.+    $if needsPubKey sshdata+      <p>+        You will be prompted once more for your ssh password. A ssh key #+        is being installed on the server, allowing git-annex to access it #+        securely without a password.