broke out fairly generic ssh stuff to Assistant.Ssh so pairing can use it too
I'd rather Utility.Ssh, but the SshData type is not sufficiently clean and generic for Utility.
This commit is contained in:
Joey Hess
parent
34a0e09d4b
commit
b573d91aa2
5 changed files with 161 additions and 139 deletions
|
|
@ -10,11 +10,11 @@
|
|||
module Assistant.WebApp.Configurators.Ssh where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.Ssh
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.SideBar
|
||||
import Utility.Yesod
|
||||
import Utility.TempFile
|
||||
import Assistant.WebApp.Configurators.Local
|
||||
import qualified Types.Remote as R
|
||||
import qualified Remote.Rsync as Rsync
|
||||
|
|
@ -26,11 +26,8 @@ import Yesod
|
|||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import qualified Control.Exception as E
|
||||
import Network.BSD
|
||||
import System.Posix.User
|
||||
import System.Process (CreateProcess(..))
|
||||
import Control.Concurrent
|
||||
|
||||
sshConfigurator :: Widget -> Handler RepHtml
|
||||
sshConfigurator a = bootstrap (Just Config) $ do
|
||||
|
|
@ -45,11 +42,6 @@ data SshServer = SshServer
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
data SshKeyPair = SshKeyPair
|
||||
{ sshPubKey :: String
|
||||
, sshPrivKey :: String
|
||||
}
|
||||
|
||||
{- SshServer is only used for applicative form prompting, this converts
|
||||
- the result of such a form into a SshData. -}
|
||||
mkSshData :: SshServer -> SshData
|
||||
|
|
@ -171,15 +163,6 @@ testServer sshserver = do
|
|||
token r = "git-annex-probe " ++ r
|
||||
report r = "echo " ++ token r
|
||||
|
||||
{- ssh -ofoo=bar command-line option -}
|
||||
sshOpt :: String -> String -> String
|
||||
sshOpt k v = concat ["-o", k, "=", v]
|
||||
|
||||
sshDir :: IO FilePath
|
||||
sshDir = do
|
||||
home <- myHomeDir
|
||||
return $ home </> ".ssh"
|
||||
|
||||
{- user@host or host -}
|
||||
genSshHost :: Text -> Maybe Text -> String
|
||||
genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
|
||||
|
|
@ -189,37 +172,6 @@ genSshRepoName :: SshServer -> String
|
|||
genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++
|
||||
(maybe "" (\d -> '_' : T.unpack d) (directory s))
|
||||
|
||||
{- The output of ssh, including both stdout and stderr. -}
|
||||
sshTranscript :: [String] -> String -> IO (String, Bool)
|
||||
sshTranscript opts input = do
|
||||
(readf, writef) <- createPipe
|
||||
readh <- fdToHandle readf
|
||||
writeh <- fdToHandle writef
|
||||
(Just inh, _, _, pid) <- createProcess $
|
||||
(proc "ssh" opts)
|
||||
{ std_in = CreatePipe
|
||||
, std_out = UseHandle writeh
|
||||
, std_err = UseHandle writeh
|
||||
}
|
||||
hClose writeh
|
||||
|
||||
-- fork off a thread to start consuming the output
|
||||
transcript <- hGetContents readh
|
||||
outMVar <- newEmptyMVar
|
||||
_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
|
||||
|
||||
-- now write and flush any input
|
||||
when (not (null input)) $ do hPutStr inh input; hFlush inh
|
||||
hClose inh -- done with stdin
|
||||
|
||||
-- wait on the output
|
||||
takeMVar outMVar
|
||||
hClose readh
|
||||
|
||||
ok <- checkSuccessProcess pid
|
||||
return ()
|
||||
return (transcript, ok)
|
||||
|
||||
{- Runs a ssh command; if it fails shows the user the transcript,
|
||||
- and if it succeeds, runs an action. -}
|
||||
sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
|
||||
|
|
@ -314,77 +266,6 @@ makeRsyncRemote name location = makeRemote name location $ const $ do
|
|||
, ("type", "rsync")
|
||||
]
|
||||
|
||||
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"
|
||||
]
|
||||
]
|
||||
| otherwise = Nothing
|
||||
|
||||
authorizedKeysLine :: SshData -> SshKeyPair -> String
|
||||
authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey })
|
||||
{- TODO: Locking down rsync is difficult, requiring a rather
|
||||
- long perl script. -}
|
||||
| rsyncOnly sshdata = 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 "
|
||||
|
||||
{- Generates a ssh key pair. -}
|
||||
genSshKeyPair :: IO SshKeyPair
|
||||
genSshKeyPair = withTempDir "git-annex-keygen" $ \dir -> do
|
||||
ok <- boolSystem "ssh-keygen"
|
||||
[ Param "-P", Param "" -- no password
|
||||
, Param "-f", File $ dir </> "key"
|
||||
]
|
||||
unless ok $
|
||||
error "ssh-keygen failed"
|
||||
SshKeyPair
|
||||
<$> readFile (dir </> "key.pub")
|
||||
<*> readFile (dir </> "key")
|
||||
|
||||
{- Installs a ssh key pair, and sets up ssh config with a mangled hostname
|
||||
- that will enable use of the key. This way we avoid changing the user's
|
||||
- regular ssh experience at all. Returns a modified SshData containing the
|
||||
- mangled hostname. -}
|
||||
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData
|
||||
setupSshKeyPair sshkeypair sshdata = do
|
||||
sshdir <- sshDir
|
||||
let configfile = sshdir </> "config"
|
||||
createDirectoryIfMissing True sshdir
|
||||
|
||||
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do
|
||||
h <- fdToHandle =<<
|
||||
createFile (sshdir </> sshprivkeyfile)
|
||||
(unionFileModes ownerWriteMode ownerReadMode)
|
||||
hPutStr h (sshPrivKey sshkeypair)
|
||||
hClose h
|
||||
unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ do
|
||||
writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
|
||||
|
||||
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
|
||||
appendFile configfile $ unlines
|
||||
[ ""
|
||||
, "# Added automatically by git-annex"
|
||||
, "Host " ++ mangledhost
|
||||
, "\tHostname " ++ T.unpack (sshHostName sshdata)
|
||||
, "\tIdentityFile ~/.ssh/" ++ sshprivkeyfile
|
||||
]
|
||||
|
||||
return $ sshdata { sshHostName = T.pack mangledhost }
|
||||
where
|
||||
sshprivkeyfile = "key." ++ mangledhost
|
||||
sshpubkeyfile = sshprivkeyfile ++ ".pub"
|
||||
mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
|
||||
user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
|
||||
|
||||
getAddRsyncNetR :: Handler RepHtml
|
||||
getAddRsyncNetR = do
|
||||
((result, form), enctype) <- runFormGet $
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue