{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Module      :  System.Process.Vado
-- Copyright   :  Hamish Mackenzie
-- License     :  MIT
--
-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
-- 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 {
    MountPoint -> Text
remoteUser :: Text     -- ^ Account used on remote machine
  , MountPoint -> Text
remoteHost :: Text     -- ^ Host name or address of the remote machine
  , MountPoint -> [Char]
remoteDir  :: FilePath -- ^ Directory on remote machine
  , MountPoint -> [Char]
localDir   :: FilePath -- ^ Where it is mounted on this machine
  } deriving (Eq MountPoint
MountPoint -> MountPoint -> Bool
MountPoint -> MountPoint -> Ordering
MountPoint -> MountPoint -> MountPoint
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MountPoint -> MountPoint -> MountPoint
$cmin :: MountPoint -> MountPoint -> MountPoint
max :: MountPoint -> MountPoint -> MountPoint
$cmax :: MountPoint -> MountPoint -> MountPoint
>= :: MountPoint -> MountPoint -> Bool
$c>= :: MountPoint -> MountPoint -> Bool
> :: MountPoint -> MountPoint -> Bool
$c> :: MountPoint -> MountPoint -> Bool
<= :: MountPoint -> MountPoint -> Bool
$c<= :: MountPoint -> MountPoint -> Bool
< :: MountPoint -> MountPoint -> Bool
$c< :: MountPoint -> MountPoint -> Bool
compare :: MountPoint -> MountPoint -> Ordering
$ccompare :: MountPoint -> MountPoint -> Ordering
Ord, MountPoint -> MountPoint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MountPoint -> MountPoint -> Bool
$c/= :: MountPoint -> MountPoint -> Bool
== :: MountPoint -> MountPoint -> Bool
$c== :: MountPoint -> MountPoint -> Bool
Eq)

instance Show MountPoint where
    show :: MountPoint -> [Char]
show MountPoint {[Char]
Text
localDir :: [Char]
remoteDir :: [Char]
remoteHost :: Text
remoteUser :: Text
localDir :: MountPoint -> [Char]
remoteDir :: MountPoint -> [Char]
remoteHost :: MountPoint -> Text
remoteUser :: MountPoint -> Text
..} = Text -> [Char]
unpack (forall a. Monoid a => [a] -> a
mconcat [Text
remoteUser, Text
"@", Text
remoteHost, Text
":"])
                            forall a. [a] -> [a] -> [a]
++ [Char]
remoteDir forall a. [a] -> [a] -> [a]
++ [Char]
" on " forall a. [a] -> [a] -> [a]
++ [Char]
localDir forall a. [a] -> [a] -> [a]
++ [Char]
" "

-- | Mount point settings
data MountSettings = MountSettings {
    MountSettings -> Text
sshfsUser :: Text
  , MountSettings -> Text
sshfsHost :: Text
  , MountSettings -> Int
sshfsPort :: Int
  , MountSettings -> [Char]
idFile     :: FilePath
  } deriving (Int -> MountSettings -> ShowS
[MountSettings] -> ShowS
MountSettings -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MountSettings] -> ShowS
$cshowList :: [MountSettings] -> ShowS
show :: MountSettings -> [Char]
$cshow :: MountSettings -> [Char]
showsPrec :: Int -> MountSettings -> ShowS
$cshowsPrec :: Int -> MountSettings -> ShowS
Show, ReadPrec [MountSettings]
ReadPrec MountSettings
Int -> ReadS MountSettings
ReadS [MountSettings]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MountSettings]
$creadListPrec :: ReadPrec [MountSettings]
readPrec :: ReadPrec MountSettings
$creadPrec :: ReadPrec MountSettings
readList :: ReadS [MountSettings]
$creadList :: ReadS [MountSettings]
readsPrec :: Int -> ReadS MountSettings
$creadsPrec :: Int -> ReadS MountSettings
Read)

-- | Default mount settings for vagrant
defMountSettings :: IO MountSettings
defMountSettings :: IO MountSettings
defMountSettings = do
  [Char]
homeDir <- IO [Char]
getHomeDirectory
  forall (m :: * -> *) a. Monad m => a -> m a
return MountSettings {
    sshfsUser :: Text
sshfsUser = Text
"vagrant"
  , sshfsHost :: Text
sshfsHost = Text
"127.0.0.1"
  , sshfsPort :: Int
sshfsPort = Int
2222
  , idFile :: [Char]
idFile = [Char]
homeDir [Char] -> ShowS
</> [Char]
".vagrant.d/insecure_private_key"
  }


-- | Parser for a line of output from the 'mount' command
mountPointParser :: Parser MountPoint
mountPointParser :: Parser MountPoint
mountPointParser = do
    Text
remoteUser <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Text
"" ((Char -> Bool) -> Parser Text Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'@') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text Text
string Text
"@")
    Text
remoteHost <- (Text -> Parser Text Text
string Text
"[" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
']') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text Text
string Text
"]") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
':')
    Text -> Parser Text Text
string Text
":"
    [Char]
remoteDir <- Text -> [Char]
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')
    Text -> Parser Text Text
string Text
" on "
    [Char]
localDir <- Text -> [Char]
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')
    forall (m :: * -> *) a. Monad m => a -> m a
return MountPoint{[Char]
Text
localDir :: [Char]
remoteDir :: [Char]
remoteHost :: Text
remoteUser :: Text
localDir :: [Char]
remoteDir :: [Char]
remoteHost :: Text
remoteUser :: Text
..}

-- | Parses a line looking for a remote mount point
parseMountPoint :: String           -- ^ line of output fromt he 'mount' command
                -> Maybe MountPoint
parseMountPoint :: [Char] -> Maybe MountPoint
parseMountPoint = forall {a} {a}. Either a a -> Maybe a
done forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser MountPoint
mountPointParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
pack
  where
    done :: Either a a -> Maybe a
done (Right a
x)  = forall a. a -> Maybe a
Just a
x
    done Either a a
_          = forall a. Maybe a
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 :: [Char] -> IO (Either MountPoint [Char])
getMountPoint [Char]
dir = do
    let dir' :: [Char]
dir' = ShowS
addTrailingPathSeparator [Char]
dir
    -- Run 'mount' and find the remote mount points
    [MountPoint]
mountPoints <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe MountPoint
parseMountPoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    [Char] -> [[Char]] -> [Char] -> IO [Char]
readProcess [Char]
"mount" [] [Char]
""
    -- Find mount point that matches the current directory
    case forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
dir')
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
addTrailingPathSeparator
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> [Char]
localDir) [MountPoint]
mountPoints of
        [MountPoint
mp] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MountPoint
mp
        [MountPoint]
_    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char]
"Mount point not found for the current directory ("
                        forall a. [a] -> [a] -> [a]
++ [Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
")\n\n"
                        forall a. [a] -> [a] -> [a]
++ case [MountPoint]
mountPoints of
                            [] -> [Char]
"No remote mount points found in output of 'mount'"
                            [MountPoint]
_  -> [Char]
"The following remote mount points were not suitable\n"
                                    forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\MountPoint
mp -> [Char]
"  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show MountPoint
mp forall a. [a] -> [a] -> [a]
++ [Char]
"\n") [MountPoint]
mountPoints


-- | Read a list of predefined mount points from the
-- ~/.vadosettings files
readSettings :: IO [MountSettings]
readSettings :: IO [MountSettings]
readSettings = do
  [Char]
homeDir <- IO [Char]
getHomeDirectory
  Maybe [MountSettings]
settings :: Maybe [MountSettings] <- do
      let settingsFile :: [Char]
settingsFile = [Char]
homeDir [Char] -> ShowS
</> [Char]
".vadosettings"
      Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
settingsFile
      if Bool
exists
        then forall a. Read a => [Char] -> Maybe a
readMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
settingsFile
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  MountSettings
defaultSettings <- IO MountSettings
defMountSettings
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [MountSettings
defaultSettings] Maybe [MountSettings]
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
-> [MountSettings]
-> [Char]
-> [[Char]]
-> [Char]
-> [[Char]]
-> IO [[Char]]
vado MountPoint{[Char]
Text
localDir :: [Char]
remoteDir :: [Char]
remoteHost :: Text
remoteUser :: Text
localDir :: MountPoint -> [Char]
remoteDir :: MountPoint -> [Char]
remoteHost :: MountPoint -> Text
remoteUser :: MountPoint -> Text
..} [MountSettings]
settings [Char]
cwd [[Char]]
sshopts [Char]
cmd [[Char]]
args = do
    [Char]
homeDir <- IO [Char]
getHomeDirectory
    -- Work out where the current directory is on the remote machine
    let destinationDir :: [Char]
destinationDir = [Char]
remoteDir [Char] -> ShowS
</> [Char] -> ShowS
makeRelative [Char]
localDir [Char]
cwd
    -- Run ssh with
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        [Text -> [Char]
unpack forall a b. (a -> b) -> a -> b
$ (if Text -> Bool
null Text
remoteUser then Text
"" else Text
remoteUser forall a. Monoid a => a -> a -> a
`mappend` Text
"@")
                  forall a. Monoid a => a -> a -> a
`mappend` Text
remoteHost]
        forall a. [a] -> [a] -> [a]
++ case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\MountSettings{Int
[Char]
Text
idFile :: [Char]
sshfsPort :: Int
sshfsHost :: Text
sshfsUser :: Text
idFile :: MountSettings -> [Char]
sshfsPort :: MountSettings -> Int
sshfsHost :: MountSettings -> Text
sshfsUser :: MountSettings -> Text
..} ->
                       Text
remoteUser forall a. Eq a => a -> a -> Bool
== Text
sshfsUser
                       Bool -> Bool -> Bool
&& Text
remoteHost forall a. Eq a => a -> a -> Bool
== Text
sshfsHost) [MountSettings]
settings of
             Just MountSettings{Int
[Char]
Text
idFile :: [Char]
sshfsPort :: Int
sshfsHost :: Text
sshfsUser :: Text
idFile :: MountSettings -> [Char]
sshfsPort :: MountSettings -> Int
sshfsHost :: MountSettings -> Text
sshfsUser :: MountSettings -> Text
..} ->
               [ [Char]
"-p" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
sshfsPort
               , [Char]
"-i" forall a. [a] -> [a] -> [a]
++ [Char]
idFile ]
             Maybe MountSettings
Nothing -> []
        forall a. [a] -> [a] -> [a]
++ [[Char]]
sshopts
        forall a. [a] -> [a] -> [a]
++ [[Char]
"cd", forall {t :: * -> *}. Foldable t => t Char -> [Char]
translate [Char]
destinationDir, [Char]
"&&", [Char]
cmd]
        forall a. [a] -> [a] -> [a]
++ [[Char]]
args
  where
    translate :: t Char -> [Char]
translate t Char
str = Char
'\'' forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
escape [Char]
"'" t Char
str
      where escape :: Char -> ShowS
escape Char
'\'' = [Char] -> ShowS
showString [Char]
"'\\''"
            escape Char
c    = Char -> ShowS
showChar Char
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 -> [Char] -> [Char] -> [[Char]] -> [[Char]]
vamount MountSettings{Int
[Char]
Text
idFile :: [Char]
sshfsPort :: Int
sshfsHost :: Text
sshfsUser :: Text
idFile :: MountSettings -> [Char]
sshfsPort :: MountSettings -> Int
sshfsHost :: MountSettings -> Text
sshfsUser :: MountSettings -> Text
..} [Char]
remoteDir [Char]
localDir [[Char]]
opts =
  [ Text -> [Char]
unpack forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
    [ Text
sshfsUser, Text
"@", Text
sshfsHost
    , Text
":", [Char] -> Text
pack [Char]
remoteDir]
  , [Char]
localDir
  , [Char]
"-p" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
sshfsPort
  , [Char]
"-oIdentityFile=" forall a. [a] -> [a] -> [a]
++ [Char]
idFile ] forall a. [a] -> [a] -> [a]
++ [[Char]]
opts