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:
parent
34a0e09d4b
commit
b573d91aa2
5 changed files with 161 additions and 139 deletions
|
@ -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
145
Assistant/Ssh.hs
Normal 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)
|
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue