prep for enabling remotre gcrypt repos in webapp

Assistant/WebApp/Configurators/Ssh.hs

@@ -131,6 +131,13 @@ postAddSshR = sshConfigurator $ do
 sshTestModal :: Widget
 sshTestModal = $(widgetFile "configurators/ssh/testmodal")
 
+{- 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 = error "TODO"
+
 {- To enable an existing rsync special remote, parse the SshInput from
  - its rsyncurl, and display a form whose only real purpose is to check
  - if ssh public keys need to be set up. From there, we can proceed with

Assistant/WebApp/RepoList.hs

@@ -24,6 +24,7 @@ import Logs.Trust
 import Logs.Group
 import Config
 import Git.Config
+import Git.Remote
 import Assistant.Sync
 import Config.Cost
 import qualified Git
@@ -156,8 +157,9 @@ repoList reposelector
 				else return l
 	unconfigured = liftAnnex $ do
 		m <- readRemoteLog
+		g <- gitRepo
 		map snd . catMaybes . filter selectedremote 
-			. map (findinfo m)
+			. map (findinfo m g)
 			<$> (trustExclude DeadTrusted $ M.keys m)
 	selectedrepo r
 		| Remote.readonly r = False
@@ -167,7 +169,7 @@ repoList reposelector
 	selectedremote (Just (iscloud, _))
 		| onlyCloud reposelector = iscloud
 		| otherwise = True
-	findinfo m u = case M.lookup "type" =<< M.lookup u m of
+	findinfo m g u = case getconfig "type" of
 		Just "rsync" -> val True EnableRsyncR
 		Just "directory" -> val False EnableDirectoryR
 #ifdef WITH_S3
@@ -177,8 +179,16 @@ repoList reposelector
 #ifdef WITH_WEBDAV
 		Just "webdav" -> val True EnableWebDAVR
 #endif
+		Just "gcrypt" ->
+			-- Skip gcrypt repos on removable drives;
+			-- handled separately.
+			case getconfig "gitrepo" of
+				Just rr	| remoteLocationIsUrl (parseRemoteLocation rr g) ->
+					val True EnableGCryptR
+				_ -> 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

Assistant/WebApp/routes

@@ -65,6 +65,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/directory/#UUID EnableDirectoryR GET
 /config/repository/enable/S3/#UUID EnableS3R GET POST
 /config/repository/enable/IA/#UUID EnableIAR GET POST

Git/Construct.hs

@@ -23,8 +23,6 @@ module Git.Construct (
 	checkForRepo,
 ) where
 
-{-# LANGUAGE CPP #-}
-
 #ifndef mingw32_HOST_OS
 import System.Posix.User
 #else
@@ -36,6 +34,7 @@ import Network.URI
 import Common
 import Git.Types
 import Git
+import Git.Remote
 import qualified Git.Url as Url
 import Utility.UserInfo
 
@@ -143,51 +142,10 @@ remoteNamedFromKey k = remoteNamed basename
 {- Constructs a new Repo for one of a Repo's remotes using a given
  - location (ie, an url). -}
 fromRemoteLocation :: String -> Repo -> IO Repo
-fromRemoteLocation s repo = gen $ calcloc s
+fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
   where
-	gen v	
-#ifdef mingw32_HOST_OS
-		| dosstyle v = fromRemotePath (dospath v) repo
-#endif
-		| scpstyle v = fromUrl $ scptourl v
-		| urlstyle v = fromUrl v
-		| otherwise = fromRemotePath v repo
-	-- insteadof config can rewrite remote location
-	calcloc l
-		| null insteadofs = l
-		| otherwise = replacement ++ drop (length bestvalue) l
-	  where
-		replacement = drop (length prefix) $
-			take (length bestkey - length suffix) bestkey
-		(bestkey, bestvalue) = maximumBy longestvalue insteadofs
-		longestvalue (_, a) (_, b) = compare b a
-		insteadofs = filterconfig $ \(k, v) -> 
-			startswith prefix k &&
-			endswith suffix k &&
-			startswith v l
-		filterconfig f = filter f $
-			concatMap splitconfigs $ M.toList $ fullconfig repo
-		splitconfigs (k, vs) = map (\v -> (k, v)) vs
-		(prefix, suffix) = ("url." , ".insteadof")
-	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
-	-- git remotes can be written scp style -- [user@]host:dir
-	-- but foo::bar is a git-remote-helper location instead
-	scpstyle v = ":" `isInfixOf` v 
-		&& not ("//" `isInfixOf` v)
-		&& not ("::" `isInfixOf` v)
-	scptourl v = "ssh://" ++ host ++ slash dir
-	  where
-		(host, dir) = separate (== ':') v
-		slash d	| d == "" = "/~/" ++ d
-			| "/" `isPrefixOf` d = d
-			| "~" `isPrefixOf` d = '/':d
-			| otherwise = "/~/" ++ d
-#ifdef mingw32_HOST_OS
-	-- git on Windows will write a path to .git/config with "drive:",
-	-- which is not to be confused with a "host:"
-	dosstyle = hasDrive
-	dospath = fromInternalGitPath
-#endif
+	gen (RemotePath p) = fromRemotePath p repo
+	gen (RemoteUrl u) = fromUrl u
 
 {- Constructs a Repo from the path specified in the git remotes of
  - another Repo. -}

Git/Remote.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Git.Remote where
 
 import Common
@@ -13,6 +15,8 @@ import qualified Git.Command
 import qualified Git.BuildVersion
 
 import Data.Char
+import qualified Data.Map as M
+import Network.URI
 
 type RemoteName = String
 
@@ -48,3 +52,58 @@ remove remotename = Git.Command.run
 			else "remove"
 	, Param remotename
 	]
+
+data RemoteLocation = RemoteUrl String | RemotePath FilePath
+
+remoteLocationIsUrl :: RemoteLocation -> Bool
+remoteLocationIsUrl (RemoteUrl _) = True
+remoteLocationIsUrl _ = False
+
+{- Determines if a given remote location is an url, or a local
+ - path. Takes the repository's insteadOf configuration into account. -}
+parseRemoteLocation :: String -> Repo -> RemoteLocation
+parseRemoteLocation s repo = ret $ calcloc s
+  where
+  	ret v
+#ifdef mingw32_HOST_OS
+		| dosstyle v = RemotePath (dospath v)
+#endif
+		| scpstyle v = RemoteUrl (scptourl v)
+		| urlstyle v = RemoteUrl v
+		| otherwise = RemotePath v
+	-- insteadof config can rewrite remote location
+	calcloc l
+		| null insteadofs = l
+		| otherwise = replacement ++ drop (length bestvalue) l
+	  where
+		replacement = drop (length prefix) $
+			take (length bestkey - length suffix) bestkey
+		(bestkey, bestvalue) = maximumBy longestvalue insteadofs
+		longestvalue (_, a) (_, b) = compare b a
+		insteadofs = filterconfig $ \(k, v) -> 
+			startswith prefix k &&
+			endswith suffix k &&
+			startswith v l
+		filterconfig f = filter f $
+			concatMap splitconfigs $ M.toList $ fullconfig repo
+		splitconfigs (k, vs) = map (\v -> (k, v)) vs
+		(prefix, suffix) = ("url." , ".insteadof")
+	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+	-- git remotes can be written scp style -- [user@]host:dir
+	-- but foo::bar is a git-remote-helper location instead
+	scpstyle v = ":" `isInfixOf` v 
+		&& not ("//" `isInfixOf` v)
+		&& not ("::" `isInfixOf` v)
+	scptourl v = "ssh://" ++ host ++ slash dir
+	  where
+		(host, dir) = separate (== ':') v
+		slash d	| d == "" = "/~/" ++ d
+			| "/" `isPrefixOf` d = d
+			| "~" `isPrefixOf` d = '/':d
+			| otherwise = "/~/" ++ d
+#ifdef mingw32_HOST_OS
+	-- git on Windows will write a path to .git/config with "drive:",
+	-- which is not to be confused with a "host:"
+	dosstyle = hasDrive
+	dospath = fromInternalGitPath
+#endif