{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
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)
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
#endif
data MountPoint = MountPoint {
MountPoint -> Text
remoteUser :: Text
, MountPoint -> Text
remoteHost :: Text
, MountPoint -> [Char]
remoteDir :: FilePath
, MountPoint -> [Char]
localDir :: FilePath
} 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]
" "
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)
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"
}
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
..}
parseMountPoint :: String
-> 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
getMountPoint :: FilePath
-> IO (Either MountPoint String)
getMountPoint :: [Char] -> IO (Either MountPoint [Char])
getMountPoint [Char]
dir = do
let dir' :: [Char]
dir' = ShowS
addTrailingPathSeparator [Char]
dir
[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]
""
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
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
vado :: MountPoint
-> [MountSettings]
-> FilePath
-> [String]
-> FilePath
-> [String]
-> IO [String]
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
let destinationDir :: [Char]
destinationDir = [Char]
remoteDir [Char] -> ShowS
</> [Char] -> ShowS
makeRelative [Char]
localDir [Char]
cwd
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
vamount :: MountSettings
-> FilePath
-> FilePath
-> [String]
-> [String]
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