module Sync.MerkleTree.Run where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Data.List
import System.Console.GetOpt
import System.Exit
import System.IO
import System.IO.Error
import System.Process
import Sync.MerkleTree.CommTypes
import Sync.MerkleTree.Sync
import qualified Data.Text as T
import qualified Data.Text.IO as T
data RemoteCmd
= RemoteCmd String
| Simulate
data SyncOptions
= SyncOptions
{ so_source :: Maybe FilePath
, so_destination :: Maybe FilePath
, so_remote :: Maybe RemoteCmd
, so_ignore :: [String]
, so_boring :: [FilePath]
, so_add :: Bool
, so_update :: Bool
, so_delete :: Bool
, so_help :: Bool
, so_nonOptions :: [String]
, so_compareClocks :: Maybe (Double, Double)
, so_version :: Bool
}
defaultSyncOptions :: SyncOptions
defaultSyncOptions =
SyncOptions
{ so_source = Nothing
, so_destination = Nothing
, so_remote = Nothing
, so_ignore = []
, so_boring = []
, so_add = False
, so_update = False
, so_delete = False
, so_help = False
, so_nonOptions = []
, so_version = False
, so_compareClocks = Nothing
}
toClientServerOptions :: SyncOptions -> IO ClientServerOptions
toClientServerOptions so =
do let parseBoringFile = map T.unpack . filter noComment . map T.strip . T.lines
noComment s = not (T.null s || ("#" `T.isPrefixOf` s))
ignoreFromBoringFiles <-
forM (so_boring so) $ liftM parseBoringFile . T.readFile
return $
ClientServerOptions
{ cs_add = so_add so
, cs_update = so_update so
, cs_delete = so_delete so
, cs_ignore = (concat ignoreFromBoringFiles) ++ (so_ignore so)
, cs_compareClocks = so_compareClocks so
}
optDescriptions :: [OptDescr (SyncOptions -> SyncOptions)]
optDescriptions =
[ Option ['s'] ["source"] (ReqArg (\fp so -> so { so_source = Just fp }) "DIR")
"source directory"
, Option ['d'] ["destination"] (ReqArg (\fp so -> so { so_destination = Just fp }) "DIR")
"destination directory"
, Option ['r'] ["remote-shell"] (ReqArg (\s so -> so { so_remote = Just $ RemoteCmd s }) "CMD")
"synchroize with a remote-site (see below)"
, Option ['i'] ["ignore"] (ReqArg (\fp so -> so { so_ignore = fp:(so_ignore so) }) "REGEX")
"ignore entries matching the given regex"
, Option ['b'] ["boring"] (ReqArg (\fp so -> so { so_boring = fp:(so_boring so) }) "PATH")
"ignore entries matching the regexes in the given file"
, Option ['a'] ["add"] (NoArg (\so -> so { so_add = True }))
"copy additional files from the source directory"
, Option ['u'] ["update"] (NoArg (\so -> so { so_update = True }))
"overwrite existing files"
, Option [] ["delete"] (NoArg (\so -> so { so_delete = True }))
"delete superfluos files in the destination directory"
, Option [] ["compareclocks"]
(OptArg (\x so -> so { so_compareClocks = fmap (flip (,) 0.0 . read) x }) "T")
"check whether there is a clock drift between client and server"
, Option ['v'] ["version"] (NoArg (\so -> so { so_version = True})) "shows version"
, Option ['h'] ["help"] (NoArg (\so -> so { so_help = True })) "shows usage information"
]
parseNonOption :: String -> (SyncOptions -> SyncOptions)
parseNonOption s so = so { so_nonOptions = s:(so_nonOptions so) }
toSyncOptions :: [(SyncOptions -> SyncOptions)] -> SyncOptions
toSyncOptions = foldl (flip id) defaultSyncOptions
putError :: String -> IO ()
putError = hPutStrLn stderr
printUsageInfo :: String -> IO ()
printUsageInfo version =
mapM_ putError ([usageInfo header optDescriptions] ++ [details])
where
header = unlines
[ "Usage: sync-mht [OPTIONS..]"
, ""
, "Fast incremental file transfer using Merkle-Hash-Trees (Version: " ++ version ++ ")"
]
details = unlines
[ "Note: The argument to the --remote-shell option should be a CMD running sync-mht"
, "with a remote command execution tool (like ssh or docker). If given exactly one of"
, "the directories must be prepended with 'remote:' - indicating a folder on the site,"
, "accessible with the provided remote shell command."
]
data Location
= Remote FilePath
| Local FilePath
parseFilePath :: FilePath -> Location
parseFilePath fp
| Just rest <- stripPrefix "remote:" fp = Remote rest
| otherwise = Local fp
main :: String -> [String] -> IO ()
main version args = flip catchIOError (putError . show) $
do let parsedOpts = getOpt (ReturnInOrder parseNonOption) optDescriptions args
exit err = hPutStrLn stderr err >> exitFailure
case () of
() | [] == args -> runChild
| (options,[],[]) <- parsedOpts ->
do mMsg <- run version $ toSyncOptions options
case mMsg of
Just err -> exit $ T.unpack err
Nothing -> return ()
| (_,_,errs) <- parsedOpts -> exit $ concat $ map (++"\n") errs
run :: String -> SyncOptions -> IO (Maybe T.Text)
run version so
| so_help so = usage >> return Nothing
| so_version so = putStrLn version >> return Nothing
| not (null (so_nonOptions so)) =
return $ Just $ T.concat
[ "Unrecognized options: "
, T.intercalate ", " (map T.pack $ so_nonOptions so)
]
| Just source <- so_source so, Just destination <- so_destination so =
do cs <- toClientServerOptions so
case (parseFilePath source, parseFilePath destination) of
(Remote _, Remote _) -> return $ Just doubleRemote
(Local source', Local destination')
| Just _ <- so_remote so -> return $ Just missingRemote
| otherwise -> local cs source' destination'
(Remote source', Local destination')
| Just remoteCmd <- so_remote so ->
runParent cs remoteCmd source' destination' FromRemote
| otherwise -> return $ Just missingRemoteCmd
(Local source', Remote destination')
| Just remoteCmd <- so_remote so ->
runParent cs remoteCmd source' destination' ToRemote
| otherwise -> return $ Just missingRemoteCmd
| otherwise =
do let missingOpts =
T.intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst)
[(so_source, "--source"), (so_destination, "--destination")]
return $ Just $ T.concat [ "The options ", missingOpts, " are required." ]
where
usage = printUsageInfo version
doubleRemote = "Either the directory given in --source or --destination must be local."
missingRemote = T.concat
[ "The --remote-shell options requires that either the directory given at "
, "--source or --destination is at remote site. (Indicated by the prefix: 'remote:')"
]
missingRemoteCmd = "The --remote-shell is required when the prefix 'remote:' is used."
_WAIT_FOR_INPUT_ :: Int
_WAIT_FOR_INPUT_ = 1000 * 1000 * 3
runChild :: IO ()
runChild =
do gotMessage <- newEmptyMVar
streams <- openStreams stdin stdout
_ <- forkIO $
do threadDelay _WAIT_FOR_INPUT_
r <- isEmptyMVar gotMessage
when r $ putError
"Running in server mode. (The command `sync-mht --help` prints usage info.)"
child gotMessage streams
runParent ::
ClientServerOptions
-> RemoteCmd
-> FilePath
-> FilePath
-> Direction
-> IO (Maybe T.Text)
runParent clientServerOpts mRemoteCmd source destination dir =
do (exitAction, parentStreams) <-
case mRemoteCmd of
RemoteCmd remoteCmd ->
do (Just hIn, Just hOut, Nothing, ph) <-
createProcess $ (shell remoteCmd)
{ std_in = CreatePipe
, std_out = CreatePipe
}
parentStreams <- openStreams hOut hIn
let shutdown =
do hClose hIn
hClose hOut
waitForProcess ph
return ()
return (shutdown, parentStreams)
Simulate ->
do (parentInStream, childOutStream) <- mkChanStreams
(childInStream, parentOutStream) <- mkChanStreams
childTerminated <- newEmptyMVar
running <- newEmptyMVar
let childStrs = StreamPair { sp_in = childInStream, sp_out = childOutStream }
let parentStrs = StreamPair { sp_in = parentInStream, sp_out = parentOutStream }
_ <- forkFinally (child running childStrs) (const $ putMVar childTerminated ())
return (takeMVar childTerminated, parentStrs)
exitMsg <- parent parentStreams source destination dir clientServerOpts
exitAction
return exitMsg