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 2012-09-10 15:20:18 -04:00
parent 34a0e09d4b
commit b573d91aa2
5 changed files with 161 additions and 139 deletions

View file

@ -8,6 +8,7 @@
module Assistant.Pairing where
import Utility.Verifiable
import Assistant.Ssh
import Control.Concurrent
import Network.Socket
@ -40,7 +41,7 @@ data PairData = PairData
, remoteAddress :: SomeAddr
, remoteUserName :: UserName
, remoteDirectory :: FilePath
, sshPubKey :: SshPubKey
, remoteSshPubKey :: SshPubKey
}
deriving (Eq, Read, Show)
@ -52,6 +53,7 @@ type UserName = String
data PairingInProgress = PairingInProgress
{ inProgressSecret :: Secret
, inProgressThreadId :: ThreadId
, inProgressSshKeyPair :: SshKeyPair
}
data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6

145
Assistant/Ssh.hs Normal file
View file

@ -0,0 +1,145 @@
{- git-annex assistant ssh utilities
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Ssh where
import Common
import Utility.TempFile
import Data.Text (Text)
import qualified Data.Text as T
import qualified Control.Exception as E
import System.Process (CreateProcess(..))
import Control.Concurrent
data SshData = SshData
{ sshHostName :: Text
, sshUserName :: Maybe Text
, sshDirectory :: Text
, sshRepoName :: String
, needsPubKey :: Bool
, rsyncOnly :: Bool
}
deriving (Read, Show, Eq)
data SshKeyPair = SshKeyPair
{ sshPubKey :: String
, sshPrivKey :: String
}
{- 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"
{- 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)
{- 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"
]
]
| 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)

View file

@ -29,18 +29,19 @@
module Assistant.WebApp.Configurators.Pairing where
import Assistant.Pairing
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
#ifdef WITH_PAIRING
import Assistant.Pairing.Network
import Assistant.Ssh
import Assistant.Common
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Verifiable
import Utility.Network
#endif
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import Yesod
import Data.Text (Text)
@ -60,15 +61,17 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
dstatus <- daemonStatus <$> lift getYesod
urlrender <- lift getUrlRender
let homeurl = urlrender HomeR
hostname <- liftIO $ getHostname
username <- liftIO $ getUserName
hostname <- liftIO getHostname
username <- liftIO getUserName
reldir <- fromJust . relDir <$> lift getYesod
let sshkey = "" -- TODO generate/read ssh key
keypair <- liftIO genSshKeyPair
let pubkey = sshPubKey keypair ++ "foo"
let mkmsg addr = PairMsg $ mkVerifiable
(PairReq, PairData hostname addr username reldir sshkey) secret
(PairReq, PairData hostname addr username reldir pubkey) secret
liftIO $ do
pip <- PairingInProgress secret
<$> sendrequests mkmsg dstatus homeurl
<*> pure keypair
oldpip <- modifyDaemonStatus dstatus $
\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
maybe noop stopold oldpip

View file

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

View file

@ -11,6 +11,7 @@
module Assistant.WebApp.Types where
import Assistant.Common
import Assistant.Ssh
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
@ -67,16 +68,6 @@ data WebAppState = WebAppState
{ showIntro :: Bool
}
data SshData = SshData
{ sshHostName :: Text
, sshUserName :: Maybe Text
, sshDirectory :: Text
, sshRepoName :: String
, needsPubKey :: Bool
, rsyncOnly :: Bool
}
deriving (Read, Show, Eq)
instance PathPiece SshData where
toPathPiece = pack . show
fromPathPiece = readish . unpack