webapp: Support storing encrypted git repositories on rsync.net.

Does not yet support re-enabling such a repository though.

This commit was sponsored by Jan Pieper.
This commit is contained in:
Joey Hess 2013-09-26 16:09:45 -04:00
parent e0b99f3960
commit 588494cbce
14 changed files with 177 additions and 66 deletions

36
Assistant/Gpg.hs Normal file
View file

@ -0,0 +1,36 @@
{- git-annex assistant gpg stuff
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- 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")

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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|
<div>
@ -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

View file

@ -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

View file

@ -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")

View file

@ -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")
)

View file

@ -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

1
debian/changelog vendored
View file

@ -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 <joeyh@debian.org> Sun, 22 Sep 2013 19:42:29 -0400

Binary file not shown.

After

Width:  |  Height:  |  Size: 40 KiB

View file

@ -27,14 +27,14 @@
^{form}
^{webAppFormAuthToken}
<div .form-actions>
<button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">
<button .btn .btn-primary type=submit onclick="$('#setupmodal').modal('show');">
Use this rsync.net repository
<div .modal .fade #testmodal>
<div .modal .fade #setupmodal>
<div .modal-header>
<h3>
Making repository ...
Checking access to rsync.net ...
<div .modal-body>
<p>
Setting up your rsync.net repository. This could take a minute.
This could take a minute.
<p>
You may be prompted for your rsync.net ssh password.

View file

@ -0,0 +1,43 @@
<div .span9 .hero-unit>
<h2>
Ready to use rsync.net
<p>
All data will be encrypted before it is sent to rsync.net. #
There are two options for how to encrypt your data.
<h3>
Simple shared encryption
<p>
This allows everyone who has a clone of this repository to decrypt the #
files stored on rsync.net. That makes it good for sharing. #
And it's easy to set up and use.
<p>
<a .btn href="@{MakeRsyncNetSharedR sshdata}" onclick="$('#setupmodal').modal('show');">
<i .icon-lock></i> Use shared encryption
<p style="text-align: center">
-or-
<h3>
Encrypt with GnuPG key
<p>
This stores an encrypted clone of your repository on rsync.net, #
unlike shared encryption which only stores file contents on rsync.net. #
So it's good for backups. But the encryption will prevent you from #
sharing the rsync.net repository with friends, or easily accessing #
its contents on another computer.
<p>
$forall (keyid, name) <- secretkeys
<p>
<a .btn onclick="$('#setupmodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata (RepoKey keyid)}">
<i .icon-lock></i> Encrypt repository #
to ^{gpgKeyDisplay keyid (Just name)}
<p>
<a .btn onclick="$('#genkeymodal').modal('show');" href="@{MakeRsyncNetGCryptR sshdata NoRepoKey}">
<i .icon-plus-sign></i> Encrypt repository #
with a new encryption key
^{genKeyModal}
<div .modal .fade #setupmodal>
<div .modal-header>
<h3>
Making repository ...
<div .modal-body>
<p>
Setting up your rsync.net repository. This could take a minute.