responding to pair requests *almost* works

This commit is contained in:
Joey Hess 2012-09-10 17:53:51 -04:00
parent b573d91aa2
commit c20d6f4189
9 changed files with 189 additions and 122 deletions

View file

@ -15,6 +15,7 @@ import qualified Data.Text as T
import qualified Control.Exception as E
import System.Process (CreateProcess(..))
import Control.Concurrent
import Data.Char
data SshData = SshData
{ sshHostName :: Text
@ -31,6 +32,8 @@ data SshKeyPair = SshKeyPair
, sshPrivKey :: String
}
type SshPubKey = String
{- ssh -ofoo=bar command-line option -}
sshOpt :: String -> String -> String
sshOpt k v = concat ["-o", k, "=", v]
@ -40,6 +43,15 @@ sshDir = do
home <- myHomeDir
return $ home </> ".ssh"
{- host_dir, with all / in dir replaced by _, and bad characters removed -}
genSshRepoName :: String -> FilePath -> String
genSshRepoName host dir
| null dir = filter legal host
| otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir
where
legal '_' = True
legal c = isAlphaNum c
{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> String -> IO (String, Bool)
sshTranscript opts input = do
@ -71,27 +83,30 @@ sshTranscript opts input = do
return ()
return (transcript, ok)
makeAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
makeAuthorizedKeys rsynconly pubkey = boolSystem "sh"
[ Param "-c" , Param $ makeAuthorizedKeysCommand rsynconly pubkey ]
{- Implemented as a shell command, so it can be run on remote servers over
- ssh. -}
makeAuthorizedKeys :: SshData -> SshKeyPair -> Maybe String
makeAuthorizedKeys sshdata keypair
| needsPubKey sshdata = Just $ join "&&" $
[ "mkdir -p ~/.ssh"
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
, unwords
[ "echo"
, shellEscape $ authorizedKeysLine sshdata keypair
, ">>~/.ssh/authorized_keys"
]
makeAuthorizedKeysCommand :: Bool -> SshPubKey -> String
makeAuthorizedKeysCommand rsynconly pubkey = join "&&" $
[ "mkdir -p ~/.ssh"
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
, unwords
[ "echo"
, shellEscape $ authorizedKeysLine rsynconly pubkey
, ">>~/.ssh/authorized_keys"
]
| otherwise = Nothing
authorizedKeysLine :: SshData -> SshKeyPair -> String
authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey })
]
authorizedKeysLine :: Bool -> SshPubKey -> String
authorizedKeysLine rsynconly pubkey
{- TODO: Locking down rsync is difficult, requiring a rather
- long perl script. -}
| rsyncOnly sshdata = pubkey
| rsynconly = pubkey
| otherwise = limitcommand "git-annex-shell -c" ++ pubkey
where
limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "