diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2013 Hamish Mackenzie + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- Stability : Experimental +-- Portability : Unknown +-- +-- | Lets you quickly run ssh on a machine that you have an sshfs connection +-- to. It works out the username, host and the directory on the host based +-- on the current directory and the output of 'mount' +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import System.IO (hPutStrLn, stderr) +import System.Directory (getCurrentDirectory) +import System.Environment (getArgs) +import Data.List (isPrefixOf) +import System.Exit (exitWith, ExitCode(..)) +import System.Process (rawSystem) +import System.Process.Vado (getMountPoint, vado, readSettings, defMountSettings) + +-- | Main function for vado +main = do + args <- getArgs + case span ("-" `isPrefixOf`) args of + (sshopts,cmd:rest) -> do + currentDir <- getCurrentDirectory + mbMountPoint <- getMountPoint currentDir + ms <- readSettings + case mbMountPoint of + Left mp -> vado mp ms currentDir sshopts cmd rest + >>= rawSystem "ssh" >>= exitWith + Right err -> hPutStrLn stderr err >> (exitWith $ ExitFailure 1) + _ -> do + defSettings <- defMountSettings + hPutStrLn stderr $ + "Usage vado [ssh options] command [args]\n\n" + + ++ "The command will be run in the directoy on the remote\n" + ++ "machine that corrisponds to the current directory locally.\n\n" + + ++ "The ssh options must start with a dash '-'.\n" + ++ "You can specify port and key location settings\n" + ++ "in the ~/.vadosettings file.\nExample contents:\n" + ++ show [defSettings] + exitWith $ ExitFailure 1 + diff --git a/src/System/Process/Vado.hs b/src/System/Process/Vado.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Vado.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Module : System.Process.Vado +-- Copyright : Hamish Mackenzie +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- Stability : Experimental +-- Portability : Unknown +-- +-- | Lets you quickly run ssh on a machine that you have an sshfs connection +-- to. It works out the username, host and the directory on the host based +-- on the current directory and the output of 'mount' +-- +----------------------------------------------------------------------------- + +module System.Process.Vado ( + MountPoint(..) + , parseMountPoint + , getMountPoint + , MountSettings(..) + , readSettings + , defMountSettings + , vado + , vamount +) where + +import Prelude hiding (null) +import Control.Applicative ((<$>), (<*), (*>), (<|>)) +import Data.Text (pack, unpack, Text, null) +import Data.List (isPrefixOf, find) +import Data.Monoid (mconcat, mappend) +import Data.Attoparsec.Text (parseOnly, string, Parser, IResult(..), option) +import qualified Data.Attoparsec.Text as P (takeWhile1) +import Data.Text.IO (hPutStrLn) +import System.FilePath (addTrailingPathSeparator, makeRelative, ()) +import Data.Maybe (mapMaybe, fromMaybe) +#if MIN_VERSION_base(4,6,0) +import Text.Read (readMaybe) +#else +import Text.Read (reads) +#endif +import System.Exit (ExitCode) +import System.Process (readProcess) +import System.Directory (getHomeDirectory, getCurrentDirectory, doesFileExist) + +#if !MIN_VERSION_base(4,6,0) +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing +#endif + +-- | Remote file system mount point +data MountPoint = MountPoint { + remoteUser :: Text -- ^ Account used on remote machine + , remoteHost :: Text -- ^ Host name or address of the remote machine + , remoteDir :: FilePath -- ^ Directory on remote machine + , localDir :: FilePath -- ^ Where it is mounted on this machine + } deriving (Ord, Eq) + +instance Show MountPoint where + show MountPoint {..} = unpack (mconcat [remoteUser, "@", remoteHost, ":"]) + ++ remoteDir ++ " on " ++ localDir ++ " " + +-- | Mount point settings +data MountSettings = MountSettings { + sshfsUser :: Text + , sshfsHost :: Text + , sshfsPort :: Int + , idFile :: FilePath + } deriving (Show, Read) + +-- | Default mount settings for vagrant +defMountSettings :: IO MountSettings +defMountSettings = do + homeDir <- getHomeDirectory + return MountSettings { + sshfsUser = "vagrant" + , sshfsHost = "127.0.0.1" + , sshfsPort = 2222 + , idFile = homeDir ".vagrant.d/insecure_private_key" + } + + +-- | Parser for a line of output from the 'mount' command +mountPointParser :: Parser MountPoint +mountPointParser = do + remoteUser <- option "" (P.takeWhile1 (/= '@') <* string "@") + remoteHost <- (string "[" *> P.takeWhile1 (/= ']') <* string "]") <|> P.takeWhile1 (/= ':') + string ":" + remoteDir <- unpack <$> P.takeWhile1 (/= ' ') + string " on " + localDir <- unpack <$> P.takeWhile1 (/= ' ') + return MountPoint{..} + +-- | Parses a line looking for a remote mount point +parseMountPoint :: String -- ^ line of output fromt he 'mount' command + -> Maybe MountPoint +parseMountPoint = done . parseOnly mountPointParser . pack + where + done (Right x) = Just x + done _ = Nothing + +-- | Run 'mount' and look up the mount point relating to the +-- directory in the output +getMountPoint :: FilePath -- ^ Local directory to find the mount point + -> IO (Either MountPoint String) -- ^ Details of the mount point or an error string +getMountPoint dir = do + let dir' = addTrailingPathSeparator dir + -- Run 'mount' and find the remote mount points + mountPoints <- mapMaybe parseMountPoint . lines <$> + readProcess "mount" [] "" + -- Find mount point that matches the current directory + case filter ((`isPrefixOf` dir') + . addTrailingPathSeparator + . localDir) mountPoints of + [mp] -> return $ Left mp + _ -> return . Right $ "Mount point not found for the current directory (" + ++ dir ++ ")\n\n" + ++ case mountPoints of + [] -> "No remote mount points found in output of 'mount'" + _ -> "The following remote mount points were not suitable\n" + ++ concatMap (\mp -> " " ++ show mp ++ "\n") mountPoints + + +-- | Read a list of predefined mount points from the +-- ~/.vadosettings files +readSettings :: IO [MountSettings] +readSettings = do + homeDir <- getHomeDirectory + settings :: Maybe [MountSettings] <- do + let settingsFile = homeDir ".vadosettings" + exists <- doesFileExist settingsFile + if exists + then readMaybe <$> readFile settingsFile + else return Nothing + defaultSettings <- defMountSettings + return $ fromMaybe [defaultSettings] settings + +-- | Get a list of arguments to pass to ssh to run command on a remote machine +-- in the directory that is mounted locally +vado :: MountPoint -- ^ Mount point found using 'getMountPoint' + -> [MountSettings] -- ^ SSH settings from the '.vadosettings' files + -> FilePath -- ^ Local directory you want the command to run in. + -- Normally this will be the same directory + -- you passed to 'getMountPoint'. + -- The vado will run the command in the remote + -- directory that maps to this one. + -> [String] -- ^ Options to pass to ssh. If the mount point is 'vagrant@127.0.0.1' + -- then the most common vagrant connection options + -- ('-p2222' and '-i~/.vagrant.d/insecure_private_key') + -- are included automatically + -> FilePath -- ^ Command to run + -> [String] -- ^ Arguments to pass to the command + -> IO [String] -- ^ Full list of arguments that should be passed to ssh +vado MountPoint{..} settings cwd sshopts cmd args = do + homeDir <- getHomeDirectory + -- Work out where the current directory is on the remote machine + let destinationDir = remoteDir makeRelative localDir cwd + -- Run ssh with + return $ + [unpack $ (if null remoteUser then "" else remoteUser `mappend` "@") + `mappend` remoteHost] + ++ case find (\MountSettings{..} -> + remoteUser == sshfsUser + && remoteHost == sshfsHost) settings of + Just MountSettings{..} -> + [ "-p" ++ show sshfsPort + , "-i" ++ idFile ] + Nothing -> [] + ++ sshopts + ++ ["cd", translate destinationDir, "&&", cmd] + ++ args + where + translate str = '\'' : foldr escape "'" str + where escape '\'' = showString "'\\''" + escape c = showChar c + +-- | Get a list of arguments to pass to sshfs to +-- mount a remote filesystem in the given directory +vamount :: MountSettings -- ^ Mount settings to use + -> FilePath -- ^ Remote directory to mount + -> FilePath -- ^ Local directory (where to mount) + -> [String] -- ^ Other options to pass to sshfs + -> [String] -- ^ Resulting list of arguments +vamount MountSettings{..} remoteDir localDir opts = + [ unpack $ mconcat + [ sshfsUser, "@", sshfsHost + , ":", pack remoteDir] + , localDir + , "-p" ++ show sshfsPort + , "-oIdentityFile=" ++ idFile ] ++ opts diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- +-- Module : Main (for tests) +-- Copyright : Hamish Mackenzie +-- License : BSD +-- +-- Maintainer : Hamish Mackenzie +-- Stability : Experimental +-- Portability : Unknown +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import Control.Monad (unless) +import Control.Applicative ((<$>)) +import System.Exit (exitFailure) +import Test.QuickCheck (Arbitrary(..), elements, listOf1) +import Test.QuickCheck.All (quickCheckAll) +import Data.Text (pack) +import System.Process.Vado (MountPoint(..), parseMountPoint) + +instance Arbitrary MountPoint where + arbitrary = do + let nameChars = ['A'..'Z'] ++ ['a' .. 'z'] ++ ['0'..'1'] ++ "_." + remoteUser <- pack <$> listOf1 (elements nameChars) + remoteHost <- pack <$> listOf1 (elements nameChars) + remoteDir <- listOf1 (elements $ '/':nameChars) + localDir <- listOf1 (elements $ '/':nameChars) + return MountPoint{..} + +prop_MountPointParses mp = parseMountPoint (show mp) == Just mp + +-- | Entry point for unit tests. +main = do + allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions + unless allPass exitFailure + diff --git a/src/Vamount.hs b/src/Vamount.hs new file mode 100644 --- /dev/null +++ b/src/Vamount.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : Hamish Mackenzie & Dan Frumin +-- License : MIT +-- +-- Maintainer : Hamish Mackenzie +-- Stability : Experimental +-- Portability : Unknown +-- +-- | Lets you quickly mount sshfs file systems based on .vadosettings files, +-- for future use with 'vado' +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import Control.Monad (when) +import System.IO (hPutStrLn, stderr) +import System.Directory (getCurrentDirectory) +import System.Environment (getArgs) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import System.Exit (exitWith, ExitCode(..)) +import System.Process (rawSystem) +import System.Process.Vado (getMountPoint, vado, + readSettings, defMountSettings, vamount) +#if MIN_VERSION_base(4,6,0) +import Text.Read (readMaybe) +#else +import Text.Read (reads) +#endif + +#if !MIN_VERSION_base(4,6,0) +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing +#endif + +-- | Main function for vamount +main = do + args <- getArgs + case span ("-" `isPrefixOf`) args of + (sshfsopts,path:rest) -> do + currentDir <- getCurrentDirectory + ms <- readSettings + defSettings <- defMountSettings + let profileNum + | null rest = 0 + | otherwise = fromMaybe 0 (readMaybe (head rest)) + when (length ms < profileNum || profileNum < 0) printUsage + let profile = if profileNum == 0 + then defSettings + else ms !! (profileNum - 1) + rawSystem "sshfs" (vamount profile path currentDir sshfsopts) + >>= exitWith + _ -> printUsage + +printUsage :: IO () +printUsage = do + defSettings <- defMountSettings + hPutStrLn stderr $ + "Usage vamount [ssh options] remote_path [profile #]\n\n" + ++ "The remote_path from the remote server specified\n" + ++ "in the ~/.vadosettings file under number [profile #]\n" + ++ "will be mounted in the current directory using sshfs\n\n" + ++ "The ssh options must start with a dash '-'.\n" + ++ "The profile number count starts from 1.\n" + ++ "If the [profile #] is absent or is 0 then \n" + ++ "the default configuration will be used:\n" + ++ show [defSettings] + exitWith $ ExitFailure 1 + diff --git a/vado.cabal b/vado.cabal new file mode 100644 --- /dev/null +++ b/vado.cabal @@ -0,0 +1,54 @@ +name: vado +version: 0.0.1 +cabal-version: >=1.8 +build-type: Simple +license: MIT +license-file: LICENSE +maintainer: Hamish Mackenzie +homepage: https://github.com/hamishmack/vado +package-url: https://github.com/hamishmack/vado +synopsis: Runs commands on remote machines using ssh +description: Lets you quickly run ssh on a machine that you have an sshfs connection to. + It works out the username, host and the directory on the host based on the current directory and the output of 'mount'. +category: Development +author: Hamish Mackenzie + +Source-Repository head + type: git + location: https://github.com/hamishmack/vado.git + +library + build-depends: base >=4.0.0.0 && <4.8, attoparsec >=0.10.4.0 && <0.12, + directory >=1.1.0.0 && <1.3, filepath >=1.2.0.0 && <1.4, + process >=1.0.1.5 && <1.3, text >=0.11.3.1 && <1.2 + exposed-modules: System.Process.Vado + exposed: True + buildable: True + hs-source-dirs: src + +executable vado + build-depends: base >=4.0.0.0 && <4.8, attoparsec >=0.10.4.0 && <0.12, + directory >=1.1.0.0 && <1.3, filepath >=1.2.0.0 && <1.4, + process >=1.0.1.5 && <1.3, text >=0.11.3.1 && <1.2 + main-is: Main.hs + buildable: True + hs-source-dirs: src + other-modules: System.Process.Vado + +executable vamount + build-depends: base >=4.0.0.0 && <4.8, attoparsec >=0.10.4.0 && <0.12, + directory >=1.1.0.0 && <1.3, filepath >=1.2.0.0 && <1.4, + process >=1.0.1.5 && <1.3, text >=0.11.3.1 && <1.2 + main-is: Vamount.hs + buildable: True + hs-source-dirs: src + other-modules: System.Process.Vado + +test-suite test-vado + build-depends: base >=4.0.0.0 && <4.8, QuickCheck -any, attoparsec >=0.10.4.0 && <0.12, + directory >=1.1.0.0 && <1.3, filepath >=1.2.0.0 && <1.4, + process >=1.0.1.5 && <1.3, text >=0.11.3.1 && <1.2 + type: exitcode-stdio-1.0 + main-is: Test.hs + buildable: True + hs-source-dirs: src