mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

don't set up authorized_keys during probe

Browse source
This commit is contained in:
Joey Hess 2012-09-01 21:10:40 -04:00
parent e6d55ae49c
commit 53043999ac
1 changed files with 23 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -28,6 +28,8 @@ data SshServer = SshServer
} }
deriving Show deriving Show
type PubKey = String
sshServerAForm :: Text -> AForm WebApp WebApp SshServer sshServerAForm :: Text -> AForm WebApp WebApp SshServer
sshServerAForm localusername = SshServer sshServerAForm localusername = SshServer
<$> aopt check_hostname "Host name" Nothing <$> aopt check_hostname "Host name" Nothing
@ -73,7 +75,7 @@ getAddSshR = bootstrap (Just Config) $ do
runFormGet $ renderBootstrap $ sshServerAForm u runFormGet $ renderBootstrap $ sshServerAForm u
case result of case result of
FormSuccess sshserver -> do FormSuccess sshserver -> do
(status, sshserver') <- liftIO $ testServer sshserver (status, sshserver', pubkey) <- liftIO $ testServer sshserver
if usable status if usable status
then error $ "TODO " ++ show sshserver' then error $ "TODO " ++ show sshserver'
else showform form enctype status else showform form enctype status
@ -95,46 +97,34 @@ getAddSshR = bootstrap (Just Config) $ do
{- Test if we can ssh into the server. {- Test if we can ssh into the server.
- -
- Two probe attempts are made. First, try sshing in using the existing - Two probe attempts are made. First, try sshing in using the existing
- condfiguration, but don't let ssh prompt for any password. If - configuration, but don't let ssh prompt for any password. If
- passwordless login is already enabled, use it. Otherwise, - passwordless login is already enabled, use it. Otherwise,
- a special ssh key is generated just for this server, and the server - a special ssh key is generated just for this server.
- is configured to allow it.
- -
- If we can ssh in, check that git-annex-shell is installed. If not, this - Once logged into the server, probe to see if git-annex-shell is
- will need to be a rsync special remote, rather than a git remote, so - available, or rsync.
- check that rsync is installed.
-
- When ssh asks for a passphrase, we rely on ssh-askpass
- or an equivilant being used by ssh. Or, if the assistant is
- running in the foreground, the password will be asked there.
-} -}
testServer :: SshServer -> IO (ServerStatus, SshServer) testServer :: SshServer -> IO (ServerStatus, SshServer, Maybe PubKey)
testServer sshserver@(SshServer { hostname = Nothing }) = return testServer sshserver@(SshServer { hostname = Nothing }) = return
(UnusableServer "Please enter a host name.", sshserver) (UnusableServer "Please enter a host name.", sshserver, Nothing)
testServer sshserver = do testServer sshserver = do
home <- myHomeDir home <- myHomeDir
let sshdir = home </> ".ssh" let sshdir = home </> ".ssh"
status <- probe sshdir sshserver [sshopt "NumberOfPasswordPrompts" "0"] Nothing status <- probe sshdir sshserver [sshopt "NumberOfPasswordPrompts" "0"]
if usable status if usable status
then return (status, sshserver) then return (status, sshserver, Nothing)
else do else do
(pubkey, sshserver') <- genSshKey sshdir sshserver (pubkey, sshserver') <- genSshKey sshdir sshserver
status' <- probe sshdir sshserver' [] $ Just $ join ";" status' <- probe sshdir sshserver' []
[ "mkdir -p ~/.ssh" return (status', sshserver', Just pubkey)
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
]
return (status', sshserver')
where where
probe sshdir s extraopts setupcommand = do probe sshdir s extraopts = do
{- This checks the unmangled server name in sshserver. -} {- This checks the unmangled server name in sshserver. -}
knownhost <- knownHost sshdir sshserver knownhost <- knownHost sshdir sshserver
let remotecommand = join ";" $ nonempty let remotecommand = join ";" $
[ report "loggedin" [ report "loggedin"
, checkcommand "git-annex-shell" , checkcommand "git-annex-shell"
, checkcommand "rsync" , checkcommand "rsync"
, fromMaybe "" setupcommand
] ]
let user = maybe "" (\u -> T.unpack u ++ "@") $ username s let user = maybe "" (\u -> T.unpack u ++ "@") $ username s
let host = user ++ T.unpack (fromJust $ hostname s) let host = user ++ T.unpack (fromJust $ hostname s)
@ -183,7 +173,7 @@ sshTranscript opts = do
{- Returns the public key content, and SshServer with a mangled hostname {- Returns the public key content, and SshServer with a mangled hostname
- to use that will enable use of the key. This way we avoid changing the - to use that will enable use of the key. This way we avoid changing the
- user's regular ssh experience at all. -} - user's regular ssh experience at all. -}
genSshKey :: FilePath -> SshServer -> IO (String, SshServer) genSshKey :: FilePath -> SshServer -> IO (PubKey, SshServer)
genSshKey _ (SshServer { hostname = Nothing }) = undefined genSshKey _ (SshServer { hostname = Nothing }) = undefined
genSshKey sshdir sshserver@(SshServer { hostname = Just h }) = do genSshKey sshdir sshserver@(SshServer { hostname = Just h }) = do
createDirectoryIfMissing True sshdir createDirectoryIfMissing True sshdir
@ -219,3 +209,10 @@ knownHost sshdir (SshServer { hostname = Just h }) =
( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h] ( not . null <$> readProcess "ssh-keygen" ["-F", T.unpack h]
, return False , return False
) )
makeAuthorizedKeys pubkey = Just $ join ";"
[ "mkdir -p ~/.ssh"
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
, "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
]