diff options
| -rw-r--r-- | Assistant/Pairing.hs | 4 | ||||
| -rw-r--r-- | Assistant/Ssh.hs | 145 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 19 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 121 | ||||
| -rw-r--r-- | Assistant/WebApp/Types.hs | 11 |
5 files changed, 161 insertions, 139 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index c78deace0..399c7e50f 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -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 diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs new file mode 100644 index 000000000..35ef64caa --- /dev/null +++ b/Assistant/Ssh.hs @@ -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) diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index d4301473f..da54e6a88 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 998249f76..eebcdae03 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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 $ diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs index d018cddbf..f12aedee1 100644 --- a/Assistant/WebApp/Types.hs +++ b/Assistant/WebApp/Types.hs @@ -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 |