enabling rsync.net gcrypt repos

Still need to detect when the user is trying to create a repo
that already exists, and jump to the enabling code.

Assistant/MakeRemote.hs

@@ -47,10 +47,10 @@ makeSshRemote forcersync sshdata mcost = do
 
 {- Generates a ssh or rsync url from a SshData. -}
 sshUrl :: Bool -> SshData -> String
-sshUrl forcersync sshdata = T.unpack $ T.concat $
+sshUrl forcersync sshdata = addtrailingslash $ T.unpack $ T.concat $
 	if (forcersync || rsyncOnly sshdata)
-		then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
-		else [T.pack "ssh://", u, h, d, T.pack "/"]
+		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
@@ -58,7 +58,10 @@ sshUrl forcersync sshdata = T.unpack $ T.concat $
 		| 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

Assistant/WebApp/Configurators/Ssh.hs

@@ -22,6 +22,10 @@ import Types.StandardGroups
 import Utility.UserInfo
 import Utility.Gpg
 import Assistant.Sync
+import qualified Remote.GCrypt as GCrypt
+import qualified Git.GCrypt
+import Types.Remote (RemoteConfigKey)
+import Git.Remote
 
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -131,39 +135,48 @@ 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
- - the usual repo setup; all that code is idempotent.
- -
- - Note that there's no EnableSshR because ssh remotes are not special
+{- Note that there's no EnableSshR because ssh remotes are not special
  - remotes, and so their configuration is not shared between repositories.
  -}
 getEnableRsyncR :: UUID -> Handler Html
 getEnableRsyncR = postEnableRsyncR
 postEnableRsyncR :: UUID -> Handler Html
-postEnableRsyncR u = do
+postEnableRsyncR = enableSpecialSshRemote "rsyncurl" enableRsyncNet enablersync
+  where
+	enablersync sshdata = redirect $ ConfirmSshR $
+		sshdata { rsyncOnly = True }
+
+{- 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
+  where
+  	enablersync sshdata = error "TODO enable ssh gcrypt remote"
+
+{- To enable an 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
 	m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
-	case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
+	case (parseSshRsyncUrl =<< M.lookup urlkey m, M.lookup "name" m) of
 		(Just sshinput, Just reponame) -> sshConfigurator $ do
 			((result, form), enctype) <- liftH $
 				runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
 			case result of
 				FormSuccess sshinput'
 					| isRsyncNet (inputHostname sshinput') ->
-						void $ liftH $ enableRsyncNet sshinput' reponame (const noop)
+						void $ liftH $ rsyncnetsetup sshinput' reponame
 					| otherwise -> do
 						s <- liftIO $ testServer sshinput'
 						case s of
 							Left status -> showform form enctype status
-							Right sshdata -> enable sshdata
+							Right sshdata -> liftH $ genericsetup sshdata
 								{ sshRepoName = reponame }
 				_ -> showform form enctype UntestedServer
 		_ -> redirect AddSshR
@@ -171,8 +184,6 @@ postEnableRsyncR u = do
 	showform form enctype status = do
 		description <- liftAnnex $ T.pack <$> prettyUUID u
 		$(widgetFile "configurators/ssh/enable")
-	enable sshdata = liftH $ redirect $ ConfirmSshR $
-		sshdata { rsyncOnly = True }
 
 {- 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.
@@ -377,10 +388,28 @@ getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = whenGcryptInstalled $ do
 	sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
 	gitinit = "git init --bare " ++ T.unpack (sshDirectory sshdata)
 
-enableRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
-enableRsyncNet sshinput reponame setup = 
+enableRsyncNet :: SshInput -> String -> Handler Html
+enableRsyncNet sshinput reponame = 
 	prepRsyncNet sshinput reponame $ \sshdata ->
-		makeSshRepo True setup sshdata
+		makeSshRepo True (const noop) sshdata
+
+enableRsyncNetGCrypt :: SshInput -> String -> Handler Html
+enableRsyncNetGCrypt sshinput reponame = 
+	prepRsyncNet sshinput reponame $ \sshdata -> do
+  		let repourl = sshUrl True sshdata
+		pr <- liftAnnex $ inRepo $ Git.GCrypt.probeRepo repourl
+		case pr of
+			Git.GCrypt.Decryptable -> do
+				r <- liftAnnex $ addRemote $
+					enableSpecialRemote reponame GCrypt.remote $ M.fromList
+						[("gitrepo", repourl)]
+				setupGroup r
+				liftAssistant $ syncRemote r
+				redirect $ EditNewCloudRepositoryR $ Remote.uuid r		
+			Git.GCrypt.NotDecryptable ->
+				error "The drive contains a git repository that is encrypted with a GnuPG key that you do not have."
+			Git.GCrypt.NotEncrypted ->
+				error "Unexpectedly found a non-encrypted git repository, instead of the expected encrypted git repository."
 
 {- Prepares rsync.net ssh key, and if successful, runs an action with
  - its SshData. -}

Command/List.hs

@@ -22,6 +22,7 @@ import Logs.UUID
 import Annex.UUID
 import qualified Option
 import qualified Annex
+import Git.Remote
 
 def :: [Command]
 def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
@@ -68,7 +69,6 @@ start l file (key, _) = do
 	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
 	stop
 
-type RemoteName = String
 type Present = Bool
 
 header :: [(RemoteName, TrustLevel)] -> String

Git/GCrypt.hs

@@ -15,6 +15,7 @@ import Git.Construct
 import qualified Git.Config as Config
 import qualified Git.Command as Command
 import Utility.Gpg
+import Git.Remote
 
 urlPrefix :: String
 urlPrefix = "gcrypt::"
@@ -66,7 +67,6 @@ probeRepo loc baserepo = do
 		ExitFailure 1 -> NotDecryptable
 		ExitFailure _ -> NotEncrypted
 
-type RemoteName = String
 type GCryptId = String
 
 {- gcrypt gives each encrypted repository a uique gcrypt-id,

Remote.hs

@@ -56,6 +56,7 @@ import Logs.Trust
 import Logs.Location hiding (logStatus)
 import Remote.List
 import Config
+import Git.Remote
 
 {- Map from UUIDs of Remotes to a calculated value. -}
 remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
@@ -68,7 +69,7 @@ remoteMap c = M.fromList . map (\r -> (uuid r, c r)) .
 uuidDescriptions :: Annex (M.Map UUID String)
 uuidDescriptions = M.unionWith addName <$> uuidMap <*> remoteMap name
 
-addName :: String -> String -> String
+addName :: String -> RemoteName -> String
 addName desc n
 	| desc == n = desc
 	| null desc = n
@@ -76,12 +77,12 @@ addName desc n
 
 {- When a name is specified, looks up the remote matching that name.
  - (Or it can be a UUID.) -}
-byName :: Maybe String -> Annex (Maybe Remote)
+byName :: Maybe RemoteName -> Annex (Maybe Remote)
 byName Nothing = return Nothing
 byName (Just n) = either error Just <$> byName' n
 
 {- Like byName, but the remote must have a configured UUID. -}
-byNameWithUUID :: Maybe String -> Annex (Maybe Remote)
+byNameWithUUID :: Maybe RemoteName -> Annex (Maybe Remote)
 byNameWithUUID = checkuuid <=< byName
   where
   	checkuuid Nothing = return Nothing
@@ -93,7 +94,7 @@ byNameWithUUID = checkuuid <=< byName
 				else error e
 		| otherwise = return $ Just r
 
-byName' :: String -> Annex (Either String Remote)
+byName' :: RemoteName -> Annex (Either String Remote)
 byName' "" = return $ Left "no remote specified"
 byName' n = handle . filter matching <$> remoteList
   where
@@ -104,7 +105,7 @@ byName' n = handle . filter matching <$> remoteList
 {- Looks up a remote by name (or by UUID, or even by description),
  - and returns its UUID. Finds even remotes that are not configured in
  - .git/config. -}
-nameToUUID :: String -> Annex UUID
+nameToUUID :: RemoteName -> Annex UUID
 nameToUUID "." = getUUID -- special case for current repo
 nameToUUID "here" = getUUID
 nameToUUID "" = error "no remote specified"

Types/Remote.hs

@@ -18,6 +18,7 @@ import Types.UUID
 import Types.GitConfig
 import Config.Cost
 import Utility.Metered
+import Git.Remote
 
 type RemoteConfigKey = String
 type RemoteConfig = M.Map RemoteConfigKey String
@@ -42,7 +43,7 @@ data RemoteA a = Remote {
 	-- each Remote has a unique uuid
 	uuid :: UUID,
 	-- each Remote has a human visible name
-	name :: String,
+	name :: RemoteName,
 	-- Remotes have a use cost; higher is more expensive
 	cost :: Cost,
 	-- Transfers a key to the remote.

templates/configurators/editrepository.hamlet

@@ -1,7 +1,7 @@
 <div .span9 .hero-unit>
   <h2>
     $if new
-      Repository created
+      Setup complete
     $else
       Editing repository
   $if new

templates/configurators/ssh/enable.hamlet

@@ -2,9 +2,8 @@
   <h2>
     Enabling #{description}
   <p>
-    Another repository uses this server, but the server is not #
-    yet enabled for use here. The first step to enable it is to check if it's #
-    usable here.
+    To enable this repository, you first need to check that its ssh server #
+    is usable from here.
   <p>
   <p>
     <form method="post" .form-horizontal enctype=#{enctype}>