Merge branch 'sshgcrypt'
This commit is contained in:
commit
cc0e63fac2
21 changed files with 401 additions and 245 deletions
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 "
|
||||
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
35
Command/GCryptSetup.hs
Normal 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"
|
|
@ -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
|
||||
]
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
2
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
|
@ -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**
|
||||
|
|
|
@ -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.
|
||||
"""]]
|
|
@ -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,
|
||||
|
||||
"""]]
|
|
@ -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?
|
||||
"""]]
|
|
@ -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
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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>
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue