Merge branch 'sshgcrypt'

This commit is contained in:
Joey Hess 2013-10-01 19:12:25 -04:00
commit cc0e63fac2
21 changed files with 401 additions and 245 deletions

View file

@ -9,7 +9,6 @@ module Assistant.MakeRemote where
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 qualified Command.InitRemote
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 @@ makeRemote basename location a = do
g <- gitRepo
if not (any samelocation $ Git.remotes g)
then do
let name = uniqueRemoteName basename 0 g
a name
return name

View file

@ -12,7 +12,9 @@ import Assistant.Ssh
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 @@ import qualified Data.Text as T
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 @@ finishedLocalPairing msg keypair = do
, "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 @@ pairMsgToSshData msg = do
, 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.

View file

@ -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 Common.Annex
import Utility.Tmp
import Utility.UserInfo
import Utility.Shell
import Utility.Rsync
import Git.Remote
import Data.Text (Text)
@ -25,10 +26,19 @@ data SshData = SshData
, 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 @@ sshDir = do
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 @@ validateSshPubKey pubkey
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 @@ removeAuthorizedKeys rsynconly dir pubkey = do
- 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 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
, "chmod 600 ~/.ssh/authorized_keys"
, unwords
[ "echo"
, shellEscape $ authorizedKeysLine rsynconly dir pubkey
, shellEscape $ authorizedKeysLine gitannexshellonly dir pubkey
, ">>~/.ssh/authorized_keys"
]
]
@ -141,11 +193,11 @@ addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
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 "

View file

@ -205,7 +205,8 @@ enableAWSRemote _ _ = error "S3 not supported by this build"
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. -}

View file

@ -152,7 +152,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
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

View file

@ -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,14 +14,12 @@ import Assistant.WebApp.Common
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
@ -54,7 +52,7 @@ mkSshData s = SshData
(maybe "" T.unpack $ inputDirectory s)
, sshPort = inputPort s
, needsPubKey = False
, rsyncOnly = False
, sshCapabilities = [] -- untested
}
mkSshInput :: SshData -> SshInput
@ -103,15 +101,12 @@ sshInputAForm hostnamefield def = SshInput
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
@ -140,10 +135,11 @@ sshTestModal = $(widgetFile "configurators/ssh/testmodal")
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 }
sshdata { sshCapabilities = [RsyncCapable] }
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. -}
@ -151,19 +147,23 @@ getEnableGCryptR :: UUID -> Handler Html
getEnableGCryptR = postEnableGCryptR
postEnableGCryptR :: UUID -> Handler Html
postEnableGCryptR u = whenGcryptInstalled $
enableSpecialSshRemote "gitrepo" enableRsyncNetGCrypt enablersync u
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 -> 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 +175,19 @@ enableSpecialSshRemote urlkey rsyncnetsetup genericsetup u = do
s <- liftIO $ testServer sshinput'
case s of
Left status -> showform form enctype status
Right sshdata -> liftH $ genericsetup sshdata
Right sshdata -> void $ liftH $ genericsetup sshdata
{ sshRepoName = reponame }
_ -> 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,8 +195,9 @@ parseSshRsyncUrl u
- 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.
-}
testServer :: SshInput -> IO (Either ServerStatus SshData)
@ -223,22 +205,23 @@ 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
case capabilities status of
[] -> do
status' <- probe []
if usable status'
then ret status' True
else return $ Left status'
case capabilities status' of
[] -> return $ Left status'
cs -> ret cs True
cs -> ret cs False
where
ret status needspubkey = return $ Right $ (mkSshData sshinput)
ret cs needspubkey = return $ Right $ (mkSshData sshinput)
{ needsPubKey = needspubkey
, rsyncOnly = status == UsableRsyncServer
, sshCapabilities = cs
}
probe extraopts = do
let remotecommand = shellWrap $ intercalate ";"
[ report "loggedin"
, checkcommand "git-annex-shell"
, checkcommand "git"
, checkcommand "rsync"
, checkcommand shim
]
@ -256,14 +239,19 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
, 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)
]
in if null cs
then if reported "loggedin"
then UnusableServer "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
else UnusableServer $ T.pack $
"Failed to ssh to the server. Transcript: " ++ s
else UsableServer cs
where
reported r = token r `isInfixOf` s
@ -286,7 +274,9 @@ showSshErr msg = sshConfigurator $
$(widgetFile "configurators/ssh/error")
getConfirmSshR :: SshData -> Handler Html
getConfirmSshR sshdata = sshConfigurator $
getConfirmSshR sshdata = sshConfigurator $ do
secretkeys <- sortBy (comparing snd) . M.toList
<$> liftIO secretKeys
$(widgetFile "configurators/ssh/confirm")
getRetrySshR :: SshData -> Handler ()
@ -295,44 +285,81 @@ getRetrySshR sshdata = do
redirect $ either (const $ ConfirmSshR sshdata) 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 -> do
reponame <- liftAnnex $ getGCryptRemoteName u repourl
void $ liftH $ enableGCrypt sshdata reponame
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)]
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
prepSsh gcrypt sshdata a
| needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
makeSsh' rsync sshdata sshdata' (Just keypair)
prepSsh' gcrypt 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' gcrypt sshdata sshdata' Nothing a
| otherwise = prepSsh' gcrypt 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' gcrypt 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 || gcrypt) 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
@ -366,56 +393,35 @@ postAddRsyncNetR = do
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
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. -}
@ -427,7 +433,7 @@ prepRsyncNet sshinput reponame a = do
(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.

View file

@ -126,7 +126,8 @@ postEnableWebDAVR _ = error "WebDAV not supported by this build"
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)

View file

@ -20,6 +20,7 @@ import qualified Remote.List as Remote
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
@ -125,12 +126,13 @@ getCurrentTransfers :: Handler TransferMap
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

View file

@ -44,6 +44,7 @@
/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/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

35
Command/GCryptSetup.hs Normal file
View file

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

View file

@ -177,3 +177,14 @@ fromFile r f = fromPipe r "git"
, 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
]

View file

@ -30,24 +30,26 @@ import qualified Command.RecvKey
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 @@ checkEnv var = do
{- 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."

View file

@ -9,7 +9,8 @@ module Remote.GCrypt (
remote,
gen,
getGCryptUUID,
coreGCryptId
coreGCryptId,
setupRepo
) where
import qualified Data.Map as M
@ -163,7 +164,7 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
{- 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 @@ gCryptSetup mu c = go $ M.lookup "gitrepo" c
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,12 +237,14 @@ setupRepo gcryptid r
]
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

2
debian/changelog vendored
View file

@ -28,6 +28,8 @@ git-annex (4.20130921) UNRELEASED; urgency=low
written by MacGPG.
* assistant: More robust inotify handling; avoid crashing if a directory
cannot be read.
* Disable receive.denyNonFastForwards when setting up a gcrypt special
remote, since gcrypt needs to be able to fast-forward the master branch.
-- Joey Hess <joeyh@debian.org> Sun, 22 Sep 2013 19:42:29 -0400

View file

@ -3,14 +3,15 @@ using [git-remote-gcrypt](https://github.com/blake2-ppc/git-remote-gcrypt).
There are at least two use cases for this in the assistant:
* Storing an encrypted git repository on a local drive.
* Storing an encrypted git repository on a local drive. **done**
* Or on a remote server. This could even allow using github. But more
likely would be a shell server that has git-annex-shell on it so can
also store file contents, and which is not trusted with unencrypted data.
**done**
git-remote-gcrypt is already usable with git-annex. What's needed is
to make sure it's installed (ie, get it packaged into distros or embedded
into git-annex), and make it easy to set up from the webapp.
into git-annex), and make it easy to set up from the webapp. **done**
Hmm, this will need gpg key creation, so would also be a good opportunity
to make the webapp allow using that for special remotes too.
@ -18,4 +19,4 @@ to make the webapp allow using that for special remotes too.
One change is needed in git-annex core.. It currently does not support
storing encrypted files on git remotes, only on special remotes. Perhaps
the way to deal with this is to make it consider git-remote-grypt remotes
to be a special remote type?
to be a special remote type? **done**

View file

@ -0,0 +1,8 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawmKKg3Vmzk7KwRGRKjHVdtyoj1JfxLX6NM"
nickname="Tom"
subject="comment 1"
date="2013-10-01T17:38:03Z"
content="""
I've had this issue as well. Saw a comment on Joey's blog that implies he knows about it and that a fix will be released soon.
"""]]

View file

@ -0,0 +1,17 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawkeJKC5Sy0stmcTWyePOLEVv0G-x1yaT_w"
nickname="Josef"
subject="Additional Comments"
date="2013-09-30T21:33:31Z"
content="""
Imported several thousand files to annex and would like to add the following comments:
- it would be great to have an option to exclude hidden dot files from import,
- empty directories should be deleted when files located in the directories are deleted,
- \"git annex add\" seems to process directories and files alphabetically, unfortunately import processes files in a different order, which makes it hard to predict which files are deleted when deduplicating,
Cheers,
"""]]

View file

@ -0,0 +1,12 @@
[[!comment format=mdwn
username="https://www.google.com/accounts/o8/id?id=AItOawmKKg3Vmzk7KwRGRKjHVdtyoj1JfxLX6NM"
nickname="Tom"
subject="comment 3"
date="2013-10-01T18:33:05Z"
content="""
I've got the same issue on Xubuntu 13.04. I installed using this script: https://github.com/zerodogg/scriptbucket/blob/master/gitannex-install
`git-annex version` makes no mention of DNS or ADNS
`host` command is installed on my machine. any suggestions on how best to fix for this setup?
"""]]

View file

@ -60,6 +60,10 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
This commits any staged changes to the git-annex branch.
It also runs the annex-content hook.
* gcryptsetup gcryptid
Sets up a repository as a gcrypt repository.
# OPTIONS
Most options are the same as in git-annex. The ones specific

View file

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

View file

@ -3,45 +3,69 @@
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.
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>
<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}
^{genKeyModal}
<div .modal .fade #setupmodal>
<div .modal-header>
<h3>