module Control.SSH.Tunnel(
SshTunnelConfig(..)
, openSshTunnel
, addFingerprints
, SshTunnel
, makeSshTunnel
, makeSshTunnelSimple
, closeSshTunnel
, saveSshTunnel
, loadSshTunnel
) where
import Control.Concurrent
import Control.Monad.IO.Class
import Control.Monad.Managed
import Data.Monoid
import Data.Text (Text, pack, unpack)
import Data.UUID as UUID
import Data.UUID.V4 as UUID
import GHC.Generics
import Network.HTTP.Client as C
import Turtle
import Prelude hiding (FilePath)
import qualified Control.Foldl as L
import qualified Data.Text as T
import qualified Data.Text.IO as T
data SshTunnelConfig = SshTunnelConfig {
sshTunnelKey :: Text
, sshTunnelPort :: Int
, sshTunnelRemotePort :: Int
, sshTunnelRemoteUser :: Text
, sshTunnelRemoteNode :: Text
, sshTunnelTempFolder :: Text
} deriving (Generic, Show, Read)
openSshTunnel :: MonadManaged m => SshTunnelConfig
-> ManagerSettings
-> m ManagerSettings
openSshTunnel cfg settings = fmap fst $ openSshTunnel' cfg settings
openSshTunnel' :: MonadManaged m => SshTunnelConfig
-> ManagerSettings
-> m (ManagerSettings, Text)
openSshTunnel' cfg mngSettings = using $ do
masterSocketName <- genTempName (sshTunnelTempFolder cfg) "ssh_tunnel_master"
isExists <- testfile $ Turtle.fromText masterSocketName
when isExists $ rm $ Turtle.fromText masterSocketName
res <- liftIO $ shell (sshCommand masterSocketName) empty
case res of
ExitSuccess -> return ()
excode -> fail $ "Failed to open SSH tunnel: " <> show excode
let proxySettings = useProxy $ C.Proxy "127.0.0.1" (sshTunnelPort cfg)
let mngSettings' = managerSetProxy proxySettings mngSettings
managed $ \k -> do
r <- k (mngSettings', masterSocketName)
ExitSuccess <- shell (closeTunnelCmd masterSocketName) empty
return r
where
sshCommand :: Text -> Text
sshCommand masterSocketName = "ssh -f -N -M "
<> "-S \"" <> masterSocketName <> "\" "
<> "-i \"" <> sshTunnelKey cfg <> "\" "
<> "-L "
<> showl (sshTunnelPort cfg) <> ":127.0.0.1:" <> showl (sshTunnelRemotePort cfg) <> " "
<> sshTunnelRemoteUser cfg <> "@" <> sshTunnelRemoteNode cfg
closeTunnelCmd :: Text -> Text
closeTunnelCmd masterSocketName = "ssh "
<> "-S \"" <> masterSocketName <> "\" "
<> " -O exit 127.0.0.1"
genTempName :: MonadIO m => Text -> Text -> m Text
genTempName folder template = do
uuid <- liftIO UUID.nextRandom
return $ folder <> "/" <> template <> "-" <> UUID.toText uuid
showl :: Show a => a -> Text
showl = pack . show
data SshTunnel = SshTunnel {
sshTunnelCloseMutex :: MVar ()
, sshTunnelSocketName :: Text
}
makeSshTunnel :: MonadIO m => SshTunnelConfig
-> ManagerSettings
-> m (ManagerSettings, SshTunnel)
makeSshTunnel cfg settings = do
mvar <- liftIO newEmptyMVar
settVar <- liftIO newEmptyMVar
_ <- liftIO . forkIO $ with (openSshTunnel' cfg settings) $ \tunnelArgs -> do
putMVar settVar tunnelArgs
takeMVar mvar
(settings', socketName) <- liftIO $ takeMVar settVar
return (settings', SshTunnel mvar socketName)
makeSshTunnelSimple :: MonadIO m => SshTunnelConfig -> m SshTunnel
makeSshTunnelSimple cfg = fmap snd $ makeSshTunnel cfg defaultManagerSettings
closeSshTunnel :: MonadIO m => SshTunnel -> m ()
closeSshTunnel = liftIO . flip putMVar () . sshTunnelCloseMutex
saveSshTunnel :: MonadIO m => FilePath -> SshTunnel -> m ()
saveSshTunnel path SshTunnel{..} = do
path' <- case Turtle.toText path of
Left e -> fail $ "saveSshTunnel: cannot convert path to Text " ++ show e
Right path' -> return $ unpack path'
liftIO $ T.writeFile path' sshTunnelSocketName
loadSshTunnel :: MonadIO m => FilePath -> m SshTunnel
loadSshTunnel path = liftIO $ do
path' <- case Turtle.toText path of
Left e -> fail $ "saveSshTunnel: cannot convert path to Text " ++ show e
Right path' -> return $ unpack path'
name <- T.readFile path'
mvar <- liftIO newEmptyMVar
_ <- liftIO . forkIO $ do
takeMVar mvar
ExitSuccess <- shell (closeTunnelCmd name) empty
return ()
return $ SshTunnel mvar name
getFingerprints :: MonadIO m => SshTunnelConfig -> m (ExitCode, Text)
getFingerprints SshTunnelConfig{..} = shellStrict ("ssh-keyscan -t rsa " <> sshTunnelRemoteNode) empty
addFingerprints :: MonadIO m => SshTunnelConfig -> FilePath -> m ()
addFingerprints cfg path = liftIO $ do
(res, fingers) <- getFingerprints cfg
case res of
ExitSuccess -> return ()
_ -> fail $ "Failed to read fingerprints: " <> show res
cnt <- readTextFile path
writeTextFile path $ cnt <> fingers