sync.hs

#!/usr/bin/env stack
-- stack --resolver lts-16.4 script --package fsnotify --package directory --package filepath --package process

-- Usage
-- sync.hs <local-path> <remote-host> <remote-path>
--
-- $ ./sync.hs ./path/to 1.2.3.4 /home/joe/path/to
-- Syncing changes from: /Users/joe/path/to/
--                   to: 1.2.3.4:/home/joe/path/to
-- ++ /home/joe/path/to/123/
-- >> /home/joe/path/to/123/1.txt
-- -- /home/joe/path/to/123/1.txt
-- -- /home/joe/path/to/123/

import           Control.Concurrent.Chan (newChan, readChan)
import           Control.Monad           (forever)
import           Data.List               (isPrefixOf)
import           System.Directory        (makeAbsolute)
import           System.Environment      (getArgs)
import           System.Exit             (ExitCode (..))
import           System.FilePath         (makeRelative, splitPath, takeFileName,
                                          (</>))
import           System.FSNotify         (Event (..), eventPath, watchTreeChan,
                                          withManager)
import           System.Process          (readProcessWithExitCode)

main :: IO ()
main = do
    -- TODO migrate to cmdargs
    [localPath_, remoteHost, remotePath] <- getArgs

    localPath <- makeAbsolute localPath_

    events <- newChan

    withManager $ \mgr -> do
        _ <- watchTreeChan mgr localPath
            (\e -> not $ any ("." `isPrefixOf`) (splitPath $ eventPath e)) -- ignore hidden files
            events

        putStrLn $ "Syncing changes from: " ++ localPath ++ "\n" ++
                   "                  to: " ++ remoteHost ++ ":" ++ remotePath

        forever $ do
            e <- readChan events

            let lp = eventPath e
                rp = remotePath </> makeRelative localPath lp

            let maybeCmd = case e of
                    Added    _ _ True  -> Just ["++", "ssh",     remoteHost, "mkdir " ++ rp]
                    Added    _ _ False -> Just [">>", "scp", lp, remoteHost ++ ":" ++ rp]

                    Modified _ _ True  -> Nothing -- TODO sync remote attrs?
                    Modified _ _ False -> Just [">>", "scp", lp, remoteHost ++ ":" ++ rp]

                    Removed  _ _ True  -> Just ["--", "ssh",     remoteHost, "rmdir " ++ rp]
                    Removed  _ _ False -> Just ["--", "ssh",     remoteHost, "rm "    ++ rp]

                    Unknown  {}        -> Nothing

            case maybeCmd of
                Just (m:cmd:args) -> do
                    putStrLn $ m ++ " " ++ rp
                    a@(ec, _, _) <- readProcessWithExitCode cmd args ""

                    case ec of
                        ExitSuccess   -> return ()
                        ExitFailure _ -> putStrLn $ "!!" ++ show a

                Nothing ->
                    putStrLn $ "Unexpected FSNotify event: " ++ show e