diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs new file mode 100644 index 0000000000..a55a0cab73 --- /dev/null +++ b/Assistant/Gpg.hs @@ -0,0 +1,36 @@ +{- git-annex assistant gpg stuff + - + - Copyright 2013 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} + +module Assistant.Gpg where + +import Utility.Gpg +import Utility.UserInfo +import Types.Remote (RemoteConfigKey) + +import qualified Data.Map as M + +{- Generates a gpg user id that is not used by any existing secret key -} +newUserId :: IO UserId +newUserId = do + oldkeys <- secretKeys + username <- myUserName + let basekeyname = username ++ "'s git-annex encryption key" + return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) + ( basekeyname + : map (\n -> basekeyname ++ show n) ([2..] :: [Int]) + ) + +data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption + deriving (Eq) + +{- Generates Remote configuration for encryption. -} +configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) +configureEncryption SharedEncryption = ("encryption", "shared") +configureEncryption NoEncryption = ("encryption", "none") +configureEncryption HybridEncryption = ("encryption", "hybrid") diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 4b0a4c7d9f..8a93e359bd 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -14,6 +14,7 @@ import qualified Types.Remote as R import qualified Remote import Remote.List import qualified Remote.Rsync as Rsync +import qualified Remote.GCrypt as GCrypt import qualified Git import qualified Git.Command import qualified Command.InitRemote @@ -23,6 +24,8 @@ 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 @@ -31,7 +34,8 @@ import qualified Data.Map as M makeSshRemote :: Bool -> SshData -> Maybe Cost -> Assistant Remote makeSshRemote forcersync sshdata mcost = do r <- liftAnnex $ - addRemote $ maker (sshRepoName sshdata) sshurl + addRemote $ maker (sshRepoName sshdata) + (sshUrl forcersync sshdata) liftAnnex $ maybe noop (setRemoteCost r) mcost syncRemote r return r @@ -40,17 +44,20 @@ makeSshRemote forcersync sshdata mcost = do maker | rsync = makeRsyncRemote | otherwise = makeGitRemote - sshurl = T.unpack $ T.concat $ - if rsync - then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"] - else [T.pack "ssh://", u, h, d, T.pack "/"] - 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] + +{- Generates a ssh or rsync url from a SshData. -} +sshUrl :: Bool -> SshData -> String +sshUrl forcersync sshdata = 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 "/"] + 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] {- Runs an action that returns a name of the remote, and finishes adding it. -} addRemote :: Annex RemoteName -> Annex Remote @@ -74,6 +81,16 @@ makeRsyncRemote name location = makeRemote name location $ const $ void $ , ("type", "rsync") ] +{- Inits a gcrypt special remote, and returns its name. -} +makeGCryptRemote :: RemoteName -> String -> KeyId -> Annex RemoteName +makeGCryptRemote remotename location keyid = + initSpecialRemote remotename GCrypt.remote $ M.fromList + [ ("type", "gcrypt") + , ("gitrepo", location) + , configureEncryption HybridEncryption + , ("keyid", keyid) + ] + type SpecialRemoteMaker = RemoteName -> RemoteType -> R.RemoteConfig -> Annex RemoteName {- Inits a new special remote. The name is used as a suggestion, but diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs index bf39419527..de59240b45 100644 --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -24,6 +24,7 @@ import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.PreferredContent import Creds +import Assistant.Gpg import qualified Data.Text as T import qualified Data.Map as M diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index d0d60e25ae..a3120e01a1 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -24,6 +24,7 @@ import Logs.PreferredContent import Logs.Remote import qualified Utility.Url as Url import Creds +import Assistant.Gpg import qualified Data.Text as T import qualified Data.Map as M diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs index 413f1242d8..316e64bb4f 100644 --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -276,17 +276,14 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir) setupDriveModal :: Widget setupDriveModal = $(widgetFile "configurators/adddrive/setupmodal") -genKeyModal :: Widget -genKeyModal = $(widgetFile "configurators/genkeymodal") - getGenKeyForDriveR :: RemovableDrive -> Handler Html -getGenKeyForDriveR drive = withNewSecretKey $ \key -> do +getGenKeyForDriveR drive = withNewSecretKey $ \keyid -> do {- Generating a key takes a long time, and - the removable drive may have been disconnected - in the meantime. Check that it is still mounted - before finishing. -} ifM (liftIO $ any (\d -> mountPoint d == mountPoint drive) <$> driveList) - ( getFinishAddDriveR drive (RepoKey key) + ( getFinishAddDriveR drive (RepoKey keyid) , getAddDriveR ) @@ -295,13 +292,8 @@ getFinishAddDriveR drive = go where {- Set up new gcrypt special remote. -} go (RepoKey keyid) = whenGcryptInstalled $ makewith $ const $ do - r <- liftAnnex $ addRemote $ - initSpecialRemote remotename GCrypt.remote $ M.fromList - [ ("type", "gcrypt") - , ("gitrepo", dir) - , configureEncryption HybridEncryption - , ("keyid", keyid) - ] + r <- liftAnnex $ addRemote $ + makeGCryptRemote remotename dir keyid return (Types.Remote.uuid r, r) go NoRepoKey = do pr <- liftAnnex $ inRepo $ Git.GCrypt.probeRepo dir diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 945e2b55c6..1587d0c4cb 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Ssh where import Assistant.WebApp.Common +import Assistant.WebApp.Gpg import Assistant.Ssh import Assistant.MakeRemote import Utility.Rsync (rsyncUrlIsShell) @@ -19,10 +20,13 @@ import Remote import Logs.PreferredContent import Types.StandardGroups import Utility.UserInfo +import Utility.Gpg +import Assistant.Sync import qualified Data.Text as T import qualified Data.Map as M import Network.Socket +import Data.Ord sshConfigurator :: Widget -> Handler Html sshConfigurator = page "Add a remote server" (Just Configuration) @@ -147,7 +151,7 @@ postEnableRsyncR u = do case result of FormSuccess sshinput' | isRsyncNet (inputHostname sshinput') -> - void $ liftH $ makeRsyncNet sshinput' reponame (const noop) + void $ liftH $ enableRsyncNet sshinput' reponame (const noop) | otherwise -> do s <- liftIO $ testServer sshinput' case s of @@ -320,19 +324,17 @@ postAddRsyncNetR = do ((result, form), enctype) <- runFormPost $ renderBootstrap $ sshInputAForm hostnamefield $ SshInput Nothing Nothing Nothing 22 - let showform status = page "Add a Rsync.net repository" (Just Configuration) $ - $(widgetFile "configurators/addrsync.net") + let showform status = inpage $ + $(widgetFile "configurators/rsync.net/add") case result of FormSuccess sshinput - | isRsyncNet (inputHostname sshinput) -> do - let reponame = genSshRepoName "rsync.net" - (maybe "" T.unpack $ inputDirectory sshinput) - makeRsyncNet sshinput reponame setupGroup + | isRsyncNet (inputHostname sshinput) -> prep sshinput | otherwise -> showform $ UnusableServer "That is not a rsync.net host name." _ -> showform UntestedServer where + inpage = page "Add a Rsync.net repository" (Just Configuration) hostnamefield = textField `withExpandableNote` ("Help", help) help = [whamlet|
@@ -342,9 +344,41 @@ postAddRsyncNetR = do The host name will be something like "usw-s001.rsync.net", and the # user name something like "7491" |] + prep sshinput = do + let reponame = genSshRepoName "rsync.net" + (maybe "" T.unpack $ inputDirectory sshinput) + prepRsyncNet sshinput reponame $ \sshdata -> inpage $ do + secretkeys <- sortBy (comparing snd) . M.toList + <$> liftIO secretKeys + $(widgetFile "configurators/rsync.net/encrypt") -makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html -makeRsyncNet sshinput reponame setup = do +getMakeRsyncNetSharedR :: SshData -> Handler Html +getMakeRsyncNetSharedR sshdata = makeSshRepo True setupGroup sshdata + +{- Make a gcrypt special remote on rsync.net. -} +getMakeRsyncNetGCryptR :: SshData -> RepoKey -> Handler Html +getMakeRsyncNetGCryptR sshdata NoRepoKey = withNewSecretKey $ \keyid -> + getMakeRsyncNetGCryptR sshdata (RepoKey keyid) +getMakeRsyncNetGCryptR sshdata (RepoKey keyid) = do + sshSetup [sshhost, gitinit] [] $ do + r <- liftAnnex $ addRemote $ + makeGCryptRemote (sshRepoName sshdata) (sshUrl True sshdata) keyid + setupGroup r + liftAssistant $ syncRemote r + redirect $ EditNewCloudRepositoryR $ Remote.uuid r + where + 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 = + prepRsyncNet sshinput reponame $ \sshdata -> + makeSshRepo True setup 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 sshdata <- liftIO $ setupSshKeyPair keypair $ @@ -371,8 +405,7 @@ makeRsyncNet sshinput reponame setup = do , genSshHost (sshHostName sshdata) (sshUserName sshdata) , remotecommand ] - sshSetup sshopts (sshPubKey keypair) $ - makeSshRepo True setup sshdata + sshSetup sshopts (sshPubKey keypair) $ a sshdata isRsyncNet :: Maybe Text -> Bool isRsyncNet Nothing = False diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs index 027abdf78d..cf367bb315 100644 --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -20,6 +20,7 @@ import Types.Remote (RemoteConfig) import Types.StandardGroups import Logs.PreferredContent import Logs.Remote +import Assistant.Gpg import qualified Data.Map as M #endif diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs index 31f7339f22..3446e4fdee 100644 --- a/Assistant/WebApp/Form.hs +++ b/Assistant/WebApp/Form.hs @@ -12,8 +12,8 @@ module Assistant.WebApp.Form where -import Types.Remote (RemoteConfigKey) import Assistant.WebApp.Types +import Assistant.Gpg import Yesod hiding (textField, passwordField) import Yesod.Form.Fields as F @@ -75,9 +75,6 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet| where ident = "toggle_" ++ toggle -data EnableEncryption = HybridEncryption | SharedEncryption | NoEncryption - deriving (Eq) - {- Adds a check box to an AForm to control encryption. -} #if MIN_VERSION_yesod(1,2,0) enableEncryptionField :: (RenderMessage site FormMessage) => AForm (HandlerT site IO) EnableEncryption @@ -91,9 +88,3 @@ enableEncryptionField = areq (selectFieldList choices) "Encryption" (Just Shared [ ("Encrypt all data", SharedEncryption) , ("Disable encryption", NoEncryption) ] - -{- Generates Remote configuration for encryption. -} -configureEncryption :: EnableEncryption -> (RemoteConfigKey, String) -configureEncryption SharedEncryption = ("encryption", "shared") -configureEncryption NoEncryption = ("encryption", "none") -configureEncryption HybridEncryption = ("encryption", "hybrid") diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs index b64bfee6b9..cc733fdebc 100644 --- a/Assistant/WebApp/Gpg.hs +++ b/Assistant/WebApp/Gpg.hs @@ -10,8 +10,8 @@ module Assistant.WebApp.Gpg where import Assistant.WebApp.Common +import Assistant.Gpg import Utility.Gpg -import Utility.UserInfo import qualified Git.Command import qualified Git.Remote import qualified Annex.Branch @@ -31,16 +31,15 @@ gpgKeyDisplay keyid userid = [whamlet| key id #{keyid} |] -{- Generates a gpg user id that is not used by any existing secret key -} -newUserId :: IO UserId -newUserId = do - oldkeys <- secretKeys - username <- myUserName - let basekeyname = username ++ "'s git-annex encryption key" - return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys) - ( basekeyname - : map (\n -> basekeyname ++ show n) ([2..] :: [Int]) - ) +genKeyModal :: Widget +genKeyModal = $(widgetFile "configurators/genkeymodal") + +whenGcryptInstalled :: Handler Html -> Handler Html +whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt") + ( a + , page "Need git-remote-gcrypt" (Just Configuration) $ + $(widgetFile "configurators/needgcrypt") + ) withNewSecretKey :: (KeyId -> Handler Html) -> Handler Html withNewSecretKey use = do @@ -73,9 +72,3 @@ getGCryptRemoteName u repoloc = do void $ inRepo $ Git.Remote.remove tmpremote return mname -whenGcryptInstalled :: Handler Html -> Handler Html -whenGcryptInstalled a = ifM (liftIO $ inPath "git-remote-gcrypt") - ( a - , page "Need git-remote-gcrypt" (Just Configuration) $ - $(widgetFile "configurators/needgcrypt") - ) diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 0b78e4f623..cab76ab6cc 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -45,6 +45,8 @@ /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR 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 /config/repository/add/cloud/S3 AddS3R GET POST /config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST diff --git a/debian/changelog b/debian/changelog index 5588923c26..7c05434e48 100644 --- a/debian/changelog +++ b/debian/changelog @@ -17,6 +17,7 @@ git-annex (4.20130921) UNRELEASED; urgency=low 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. -- Joey Hess Sun, 22 Sep 2013 19:42:29 -0400 diff --git a/doc/assistant/rsync.net.encryption.png b/doc/assistant/rsync.net.encryption.png new file mode 100644 index 0000000000..ec751d10d2 Binary files /dev/null and b/doc/assistant/rsync.net.encryption.png differ diff --git a/templates/configurators/addrsync.net.hamlet b/templates/configurators/rsync.net/add.hamlet similarity index 82% rename from templates/configurators/addrsync.net.hamlet rename to templates/configurators/rsync.net/add.hamlet index d190441179..5a3459187e 100644 --- a/templates/configurators/addrsync.net.hamlet +++ b/templates/configurators/rsync.net/add.hamlet @@ -27,14 +27,14 @@ ^{form} ^{webAppFormAuthToken}
-