diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016-2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anton Gushcha nor the names of other-2017 + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +ssh-tunnel +========== + +Small library that allows to create SSH tunnel (SOCKS proxy) from Haskell and proxy +[http-client](http://hackage.haskell.org/package/http-client). + +Tunnel is created with: +``` +ssh -f -N -M -S -i -L :127.0.0.1: @ +``` + +Note: that the tunnel is created in background (-f) without a shell on remote host (-N) +and (-M -S ) defines special socket that is used to terminate the tunnel. + +How to use in your code: +```haskell +import Control.Monad.Managed +import Control.SSH.Tunnel +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +with (openSshTunnel config tlsManagerSettings) $ \settings -> do + manager <- newManager settings + -- do things with manager + -- as soon you live the scope, tunnel will be down +``` + +Also, you can find `addFingerprints` function useful for adding fingerprints to +known hosts on first connect. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Control/SSH/Tunnel.hs b/src/Control/SSH/Tunnel.hs new file mode 100644 --- /dev/null +++ b/src/Control/SSH/Tunnel.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE RecordWildCards #-} +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 + +-- | Configuration of SSH tunnel +data SshTunnelConfig = SshTunnelConfig { + sshTunnelKey :: Text -- ^ Path to ssh pem file +, sshTunnelPort :: Int -- ^ Port that is used for local ssh proxy +, sshTunnelRemotePort :: Int -- ^ Port that is used on remote machine for vpn manager +, sshTunnelRemoteUser :: Text -- ^ Name of SSH user for tunneling +, sshTunnelRemoteNode :: Text -- ^ Host of SSH tunnel +, sshTunnelTempFolder :: Text -- ^ Place where we can place our temp files +} deriving (Generic, Show, Read) + + +-- | Open SSH tunnel and return settings for connection manager +-- +-- Tunnel is created with: +-- @ +-- ssh -f -N -M -S -i -L :127.0.0.1: @ +-- @ +-- +-- Note: that the tunnel is created in background (-f) without a shell on remote host (-N) +-- and (-M -S ) defines special socket that is used to terminate the tunnel. +-- +-- How to use in your code: +-- @ +-- import Control.Monad.Managed +-- import Control.SSH.Tunnel +-- import Network.HTTP.Client +-- import Network.HTTP.Client.TLS +-- +-- with (openSshTunnel config tlsManagerSettings) $ \settings -> do +-- manager <- newManager settings +-- -- do things with manager +-- -- as soon you live the scope, tunnel will be down +-- @ +openSshTunnel :: MonadManaged m => SshTunnelConfig -- ^ Configuration of connection + -> ManagerSettings -- ^ Your manager settings that would be extended with proxy information + -> m ManagerSettings -- ^ Extended client manager settings, tunnel termination action is handled by 'MonadManaged' +openSshTunnel cfg settings = fmap fst $ openSshTunnel' cfg settings + +-- | Internal version that also returns path to master socket +openSshTunnel' :: MonadManaged m => SshTunnelConfig -- ^ Configuration of connection + -> ManagerSettings -- ^ Your manager settings that would be extended with proxy information + -> m (ManagerSettings, Text) -- ^ Extended client manager settings, tunnel termination action is handled by 'MonadManaged' +openSshTunnel' cfg mngSettings = using $ do + -- open ssh tunnel + 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 + + -- configure proxy manager + 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 + -- We open ssh in detached mode with master socket to be able to close the tunnel + 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 + +-- Send exit command over master socket +closeTunnelCmd :: Text -> Text +closeTunnelCmd masterSocketName = "ssh " + <> "-S \"" <> masterSocketName <> "\" " + <> " -O exit 127.0.0.1" + +-- | Generation of temporary name for a file +genTempName :: MonadIO m => Text -> Text -> m Text +genTempName folder template = do + uuid <- liftIO UUID.nextRandom + return $ folder <> "/" <> template <> "-" <> UUID.toText uuid + +-- | Handy way to print into text +showl :: Show a => a -> Text +showl = pack . show + +-- | SSH tunnel ID that can be used to send commands to it +data SshTunnel = SshTunnel { + sshTunnelCloseMutex :: MVar () +, sshTunnelSocketName :: Text +} + +-- | Make a SSH tunnel, same as 'openSshTunnel', but handles all 'Managed' monad +-- stuff internally. As soon as 'SshTunnel' value is garbage collected, internal +-- ssh tunnel will be closed. Also you can use 'closeSshTunnel' to manually free +-- resources. +makeSshTunnel :: MonadIO m => SshTunnelConfig -- ^ Configuration of connection + -> ManagerSettings -- ^ Your manager settings that would be extended with proxy information + -> m (ManagerSettings, SshTunnel) -- ^ Extended client manager settings and id that can be used to shut down the tunnel +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) + +-- | Helper, when you don't need manager in 'makeSshTunnelSimple' +makeSshTunnelSimple :: MonadIO m => SshTunnelConfig -> m SshTunnel +makeSshTunnelSimple cfg = fmap snd $ makeSshTunnel cfg defaultManagerSettings + +-- | Closes given ssh tunnel, see 'makeSshTunnel' +closeSshTunnel :: MonadIO m => SshTunnel -> m () +closeSshTunnel = liftIO . flip putMVar () . sshTunnelCloseMutex + +-- | Write down info about tunnel into file to be able to close it from other +-- haskell program. +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 + +-- | Read saved tunnel from file that was written by 'saveSshTunnel' +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 + +-- | Read remote server fingerprints that can be added to known_hosts +getFingerprints :: MonadIO m => SshTunnelConfig -> m (ExitCode, Text) +getFingerprints SshTunnelConfig{..} = shellStrict ("ssh-keyscan -t rsa " <> sshTunnelRemoteNode) empty + +-- | Add server fingerprints to given path +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 diff --git a/ssh-tunnel.cabal b/ssh-tunnel.cabal new file mode 100644 --- /dev/null +++ b/ssh-tunnel.cabal @@ -0,0 +1,37 @@ +name: ssh-tunnel +version: 1.0.0.0 +synopsis: Proxy http-client via ssh tunnel. +description: Please see README.md +homepage: https://github.com/githubuser/ssh-tunnel#readme +license: BSD3 +license-file: LICENSE +author: Anton Gushcha + , Anatoliy Nardid +maintainer: ncrashed@gmail.com +copyright: 2016-2017 Anton Gushcha +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Control.SSH.Tunnel + build-depends: + base >= 4.7 && < 5 + , foldl >= 1.1 && < 1.3 + , http-client >= 0.4 && < 0.6 + , managed >= 1.0 && < 1.1 + , text >= 1.2 && < 1.3 + , transformers >= 0.4 && < 0.6 + , turtle >= 1.2 && < 1.4 + , uuid >= 1.3 && < 1.4 + default-language: Haskell2010 + default-extensions: + DeriveGeneric + OverloadedStrings + +source-repository head + type: git + location: https://github.com/Teaspot-Studio/ssh-tunnel