{-# 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 {
remoteUser :: Text
, remoteHost :: Text
, remoteDir :: FilePath
, localDir :: FilePath
} deriving (Ord, Eq)
instance Show MountPoint where
show MountPoint {..} = unpack (mconcat [remoteUser, "@", remoteHost, ":"])
++ remoteDir ++ " on " ++ localDir ++ " "
data MountSettings = MountSettings {
sshfsUser :: Text
, sshfsHost :: Text
, sshfsPort :: Int
, idFile :: FilePath
} deriving (Show, Read)
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"
}
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{..}
parseMountPoint :: String
-> Maybe MountPoint
parseMountPoint = done . parseOnly mountPointParser . pack
where
done (Right x) = Just x
done _ = Nothing
getMountPoint :: FilePath
-> IO (Either MountPoint String)
getMountPoint dir = do
let dir' = addTrailingPathSeparator dir
mountPoints <- mapMaybe parseMountPoint . lines <$>
readProcess "mount" [] ""
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
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
vado :: MountPoint
-> [MountSettings]
-> FilePath
-> [String]
-> FilePath
-> [String]
-> IO [String]
vado MountPoint{..} settings cwd sshopts cmd args = do
homeDir <- getHomeDirectory
let destinationDir = remoteDir </> makeRelative localDir cwd
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
vamount :: MountSettings
-> FilePath
-> FilePath
-> [String]
-> [String]
vamount MountSettings{..} remoteDir localDir opts =
[ unpack $ mconcat
[ sshfsUser, "@", sshfsHost
, ":", pack remoteDir]
, localDir
, "-p" ++ show sshfsPort
, "-oIdentityFile=" ++ idFile ] ++ opts