diff --git a/ConfsolveArgs.hs b/ConfsolveArgs.hs --- a/ConfsolveArgs.hs +++ b/ConfsolveArgs.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, CPP #-} module ConfsolveArgs where import System.Console.CmdArgs +#ifdef CABAL +import Data.Version (showVersion) +import Paths_confsolve (version) +#endif + data Confsolve = Confsolve { dropbox :: Bool, wuala :: Bool, @@ -14,13 +19,18 @@ wuala = def &= help "Resolve Wuala file conflicts", directory = def &= args &= typ "DIRECTORY" } - &= summary summaryInfo + &= summary "" &= help "A command line tool for resolving conflicts of file synchronizers." &= helpArg [explicit, name "help", name "h"] &= versionArg [explicit, name "version", name "v", summary versionInfo ] -versionInfo = "confsolve version 0.4.1" -summaryInfo = "" +versionInfo :: String +versionInfo = +#ifdef CABAL + "confsolve version " ++ showVersion version +#else + "confsolve version unknown (not built with cabal)" +#endif confsolveArgs :: IO Confsolve confsolveArgs = cmdArgs confsolve diff --git a/Dropbox/Conflict.hs b/Dropbox/Conflict.hs --- a/Dropbox/Conflict.hs +++ b/Dropbox/Conflict.hs @@ -3,16 +3,12 @@ module Dropbox.Conflict where import FileConflict import qualified Dropbox.FileNameParser as P -import qualified Data.Text as T - -data Parser = Parser - -(<++>) = T.append +import Data.Monoid ((<>)) -instance ConflictParser Parser where - parseConflict _ baseName = - case P.parse baseName of - Just (P.FileInfo realBaseName host date) -> - Just (realBaseName, "Version " <++> date <++> " from " <++> host) +parse :: ConflictParser +parse baseName = + case P.parse baseName of + Just (P.FileInfo realBaseName host date) -> + Just (realBaseName, "Version " <> date <> " from " <> host) - Nothing -> Nothing + Nothing -> Nothing diff --git a/FileConflict.hs b/FileConflict.hs --- a/FileConflict.hs +++ b/FileConflict.hs @@ -14,8 +14,8 @@ -- conflicting file details displayed to the user type Details = T.Text -class ConflictParser a where - parseConflict :: a -> BaseName -> Maybe (RealBaseName, Details) +-- the conflict file parser +type ConflictParser = BaseName -> Maybe (RealBaseName, Details) -- the details and filePath of a conflicting file data ConflictingFile = ConflictingFile { diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} + +import System.IO +import System.IO.Error (IOErrorType) +import System.Environment +import System.Process +import System.Exit +import Data.Foldable (foldrM, foldlM) +import qualified Data.HashMap.Strict as HM +import qualified Filesystem as FS +import qualified Data.Text as T +import qualified Filesystem.Path.CurrentOS as FP +import Filesystem.Path.CurrentOS (()) +import Control.Monad (mapM_, when, void) +import Control.Applicative ((<$>)) +import qualified FileConflict as FC +import qualified Dropbox.Conflict as DB +import qualified Wuala.Conflict as WU +import Utils +import ConfsolveArgs +import ParseInput + + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + hSetBuffering stdin NoBuffering + args <- confsolveArgs + let dir = FP.fromText $ T.pack (directory args) + when (dropbox args) $ + resolveConflicts DB.parse dir + + when (wuala args) $ + resolveConflicts WU.parse dir + + +printRuntineHelp :: IO () +printRuntineHelp = do + trashDir <- show <$> trashDirectory + putStrLn $ "" + putStrLn $ "Runtime Options:" + putStrLn $ " (T)ake File (NUM) => By pressing 't' and a number (e.g 't1'), the conflicting file with the" + putStrLn $ " number NUM is used as the new version. A copy of the" + putStrLn $ " current file and the other conflicting files is put" + putStrLn $ " into the trash directory '" ++ trashDir ++ "'." + putStrLn $ "" + putStrLn $ " (M)ove to Trash => By pressing 'm', all conflicting files are" + putStrLn $ " moved into the trash directory '" ++ trashDir ++ "'." + putStrLn $ "" + putStrLn $ " Show (D)iff (NUM) => By pressing 'd' and a number (e.g 'd1'), the difference between the" + putStrLn $ " current file and the conflicting file NUM is shown." + putStrLn $ " If there's only one conflicting file, then only pressing" + putStrLn $ " 'd' is sufficient." + putStrLn $ " By pressing 'd' and two numbers (e.g 'd1 2'), the difference between" + putStrLn $ " the two conflicting files is shown." + putStrLn $ " The diff tool can be specified by the user by setting the environment" + putStrLn $ " variable 'CONFSOLVE_DIFF'. The default diff tool is 'gvimdiff -f'." + putStrLn $ "" + putStrLn $ " (S)kip => By pressing 's', the current conflict is skipped" + putStrLn $ " and the next one is shown." + putStrLn $ "" + putStrLn $ " (Q)uit => By pressing 'q', the application is quit." + putStrLn $ "" + putStrLn $ " (H)elp => By pressing 'h', this help is printed." + putStrLn $ "" + +type Conflicts = HM.HashMap T.Text [FC.ConflictingFile] + + +resolveConflicts :: FC.ConflictParser -> FP.FilePath -> IO () +resolveConflicts parse filePath = do + conflicts <- collectConflicts parse filePath HM.empty + mapM_ (handleConflict . conflict) (HM.toList conflicts) + where + conflict (path, files) = FC.Conflict (FP.fromText path) files + + +collectConflicts :: FC.ConflictParser -> FP.FilePath -> Conflicts -> IO Conflicts +collectConflicts parse filePath conflicts = do + isDir <- FS.isDirectory filePath + if isDir + then do + entries <- FS.listDirectory filePath + foldrM (\entry conflicts -> collectConflicts parse entry conflicts) conflicts entries + else do + isFile <- FS.isFile filePath + if isFile + then do + let bname = toText $ FP.basename filePath + case parse bname of + Just (realBaseName, details) -> do + return $ HM.insertWith (++) + (toText $ replaceBaseName filePath (FP.fromText realBaseName)) + [FC.ConflictingFile details filePath] + conflicts + + Nothing -> return conflicts + + else return conflicts + + +handleConflict :: FC.Conflict -> IO () +handleConflict conflict = do + let origFP = FC.origFilePath conflict + exists <- FS.isFile origFP + if not exists + then putStrLn $ "Found conflicts for the file '" ++ show origFP ++ "', but the file itself is missing! Skipping it." + else do + putConflict conflict + askUserTillHandled conflict + where + askUserTillHandled confict = do + reply <- askUser confict + askAgain <- maybe (putStrLn "Invalid input! See Help" >> return True) + (handleUserReply confict) + reply + when askAgain $ do + putConflict confict + askUserTillHandled confict + + +type AskAgain = Bool +handleUserReply :: FC.Conflict -> UserReply -> IO AskAgain +handleUserReply conflict reply = + case reply of + TakeFile num -> do + takeFile num conflict + dontAskAgain + + MoveToTrash -> do + mapM_ (\c -> moveToTrash $ FC.filePath c) confs + dontAskAgain + + ShowDiff -> do + showDiff (FC.origFilePath conflict) (FC.filePath $ confs !! 0) + askAgain + + ShowDiffWith num -> do + showDiff (FC.origFilePath conflict) (FC.filePath $ confs !! (num - 1)) + askAgain + + ShowDiffBetween num1 num2 -> do + showDiff (FC.filePath $ confs !! (num1 - 1)) (FC.filePath $ confs !! (num2 - 1)) + askAgain + + Skip -> dontAskAgain + Quit -> exitSuccess + Help -> printRuntineHelp >> askAgain + where + confs = FC.conflictingFiles conflict + askAgain = return True + dontAskAgain = return False + + moveToTrash filePath = + errorsToStderr $ do + trashDir <- trashDirectory + FS.createTree trashDir + let fileName = FP.filename filePath + FS.copyFile filePath (trashDir fileName) + FS.removeFile filePath + + takeFile num conflict = do + (year, month, day) <- getCurrentDate + let idx = num - 1 + confs = FC.conflictingFiles conflict + file = FC.filePath $ confs !! idx + origFile = FC.origFilePath conflict + backupSpec = T.pack $ "_backup_" ++ show year ++ "-" ++ show month ++ "-" ++ show day + backupBaseName = (toText $ FP.basename origFile) `T.append` backupSpec + backupFile = replaceBaseName origFile (FP.fromText backupBaseName) + + errorsToStderr $ do + FS.copyFile origFile backupFile + moveToTrash backupFile + FS.copyFile file origFile + mapM_ (\c -> moveToTrash (FC.filePath c)) confs + + showDiff file1 file2 = do + putStrLn "" + diff <- getEnvOrDefault "CONFSOLVE_DIFF" defaultDiff + handle <- runCommand $ diff ++ " " ++ (quote $ toString file1) ++ " " ++ (quote $ toString file2) + waitForProcess handle + return () + + quote string = "\"" ++ string ++ "\"" + + +putConflict :: FC.Conflict -> IO () +putConflict conflict = do + putStrLn $ "\nConflicting file: " ++ (show $ FC.origFilePath conflict) + void $ foldlM (\i c -> putConf i c >> (return $ i+1)) 1 (FC.conflictingFiles conflict) + where + putConf fileNum conf = + putStrLn $ " (" ++ show fileNum ++ ") " ++ (show $ FC.details conf) + + +askUser :: FC.Conflict -> IO (Maybe UserReply) +askUser conflict = do + putStr "\n(T)ake File (NUM) | (M)ove to Trash | Show (D)iff (NUM [NUM]) | (S)kip | (Q)uit | (H)elp: " + line <- getLine + return $ parseInput line (length . FC.conflictingFiles $ conflict) diff --git a/Wuala/Conflict.hs b/Wuala/Conflict.hs --- a/Wuala/Conflict.hs +++ b/Wuala/Conflict.hs @@ -3,16 +3,12 @@ module Wuala.Conflict where import FileConflict import qualified Wuala.FileNameParser as P -import qualified Data.Text as T - -data Parser = Parser - -(<++>) = T.append +import Data.Monoid ((<>)) -instance ConflictParser Parser where - parseConflict _ baseName = - case P.parse baseName of - Just (P.FileInfo realBaseName version host) -> - Just (realBaseName, "Version " <++> version <++> " from " <++> host) +parse :: ConflictParser +parse baseName = + case P.parse baseName of + Just (P.FileInfo realBaseName version host) -> + Just (realBaseName, "Version " <> version <> " from " <> host) - Nothing -> Nothing + Nothing -> Nothing diff --git a/confsolve.cabal b/confsolve.cabal --- a/confsolve.cabal +++ b/confsolve.cabal @@ -1,5 +1,5 @@ name: confsolve -version: 0.5.1 +version: 0.5.2 cabal-version: >=1.6 build-type: Simple license: BSD3 @@ -11,7 +11,7 @@ running Dropbox or Wuala. category: Utils author: Daniel Trstenjak -tested-with: GHC ==7.6.2 +tested-with: GHC ==7.6.2, GHC ==7.6.3 source-repository head type: git @@ -28,9 +28,11 @@ system-filepath >=0.4.8 && <0.5, system-fileio >=0.3.13 && <0.4, cmdargs >=0.10.7 && <0.11 - main-is: confsolve.hs + main-is: Main.hs buildable: True + cpp-options: -DCABAL other-modules: + Paths_confsolve FileConflict ParseInput Dropbox.Conflict diff --git a/confsolve.hs b/confsolve.hs deleted file mode 100644 --- a/confsolve.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} - -import System.IO -import System.IO.Error (IOErrorType) -import System.Environment -import System.Process -import System.Exit -import Data.Foldable (foldrM, foldlM) -import qualified Data.HashMap.Strict as HM -import qualified Filesystem as FS -import qualified Data.Text as T -import qualified Filesystem.Path.CurrentOS as FP -import Filesystem.Path.CurrentOS (()) -import Control.Monad (mapM_, when, void) -import Control.Applicative ((<$>)) -import qualified FileConflict as FC -import qualified Dropbox.Conflict as DB -import qualified Wuala.Conflict as WU -import Utils -import ConfsolveArgs -import ParseInput - - -main = do - hSetBuffering stdout NoBuffering - hSetBuffering stdin NoBuffering - args <- confsolveArgs - let dir = FP.fromText $ T.pack (directory args) - when (dropbox args) $ - resolveConflicts DB.Parser dir - - when (wuala args) $ - resolveConflicts WU.Parser dir - - -printRuntineHelp = do - trashDir <- show <$> trashDirectory - putStrLn $ "" - putStrLn $ "Runtime Options:" - putStrLn $ " (T)ake File (NUM) => By pressing 't' and a number (e.g 't1'), the conflicting file with the" - putStrLn $ " number NUM is used as the new version. A copy of the" - putStrLn $ " current file and the other conflicting files is put" - putStrLn $ " into the trash directory '" ++ trashDir ++ "'." - putStrLn $ "" - putStrLn $ " (M)ove to Trash => By pressing 'm', all conflicting files are" - putStrLn $ " moved into the trash directory '" ++ trashDir ++ "'." - putStrLn $ "" - putStrLn $ " Show (D)iff (NUM) => By pressing 'd' and a number (e.g 'd1'), the difference between the" - putStrLn $ " current file and the conflicting file NUM is shown." - putStrLn $ " If there's only one conflicting file, then only pressing" - putStrLn $ " 'd' is sufficient." - putStrLn $ " By pressing 'd' and two numbers (e.g 'd1 2'), the difference between" - putStrLn $ " the two conflicting files is shown." - putStrLn $ " The diff tool can be specified by the user by setting the environment" - putStrLn $ " variable 'CONFSOLVE_DIFF'. The default diff tool is 'gvimdiff -f'." - putStrLn $ "" - putStrLn $ " (S)kip => By pressing 's', the current conflict is skipped" - putStrLn $ " and the next one is shown." - putStrLn $ "" - putStrLn $ " (Q)uit => By pressing 'q', the application is quit." - putStrLn $ "" - putStrLn $ " (H)elp => By pressing 'h', this help is printed." - putStrLn $ "" - -type Conflicts = HM.HashMap T.Text [FC.ConflictingFile] - - -resolveConflicts :: FC.ConflictParser parser => parser -> FP.FilePath -> IO () -resolveConflicts parser filePath = do - conflicts <- collectConflicts parser filePath HM.empty - mapM_ (handleConflict . conflict) (HM.toList conflicts) - where - conflict (path, files) = FC.Conflict (FP.fromText path) files - - -collectConflicts :: FC.ConflictParser parser => parser -> FP.FilePath -> Conflicts -> IO Conflicts -collectConflicts parser filePath conflicts = do - isDir <- FS.isDirectory filePath - if isDir - then do - entries <- FS.listDirectory filePath - foldrM (\entry conflicts -> collectConflicts parser entry conflicts) conflicts entries - else do - isFile <- FS.isFile filePath - if isFile - then do - let bname = toText $ FP.basename filePath - case FC.parseConflict parser bname of - Just (realBaseName, details) -> do - return $ HM.insertWith (++) - (toText $ replaceBaseName filePath (FP.fromText realBaseName)) - [FC.ConflictingFile details filePath] - conflicts - - Nothing -> return conflicts - - else return conflicts - - -handleConflict :: FC.Conflict -> IO () -handleConflict conflict = do - let origFP = FC.origFilePath conflict - exists <- FS.isFile origFP - if not exists - then putStrLn $ "Found conflicts for the file '" ++ show origFP ++ "', but the file itself is missing! Skipping it." - else do - putConflict conflict - askUser conflict - - -putConflict :: FC.Conflict -> IO () -putConflict conflict = do - putStrLn $ "\nConflicting file: " ++ (show $ FC.origFilePath conflict) - void $ foldlM (\i c -> putConf i c >> (return $ i+1)) 1 (FC.conflictingFiles conflict) - where - putConf fileNum conf = - putStrLn $ " (" ++ show fileNum ++ ") " ++ (show $ FC.details conf) - - -askUser conflict = do - putStr "\n(T)ake File (NUM) | (M)ove to Trash | Show (D)iff (NUM [NUM]) | (S)kip | (Q)uit | (H)elp: " - line <- getLine - let confs = FC.conflictingFiles conflict - numConfs = length confs - askAgain = putConflict conflict >> askUser conflict - - case parseInput line numConfs of - Just (TakeFile num) -> - takeFile num conflict - - Just MoveToTrash -> - mapM_ (\c -> moveToTrash $ FC.filePath c) confs - - Just ShowDiff -> do - showDiff (FC.origFilePath conflict) (FC.filePath $ confs !! 0) - askAgain - - Just (ShowDiffWith num) -> do - showDiff (FC.origFilePath conflict) (FC.filePath $ confs !! (num - 1)) - askAgain - - Just (ShowDiffBetween num1 num2) -> do - showDiff (FC.filePath $ confs !! (num1 - 1)) (FC.filePath $ confs !! (num2 - 1)) - askAgain - - Just Skip -> return () - Just Quit -> exitSuccess - Just Help -> printRuntineHelp >> askAgain - - _ -> putStrLn $ "Invalid input! See Help" - - where - moveToTrash filePath = - errorsToStderr $ do - trashDir <- trashDirectory - FS.createTree trashDir - let fileName = FP.filename filePath - FS.copyFile filePath (trashDir fileName) - FS.removeFile filePath - - takeFile num conflict = do - (year, month, day) <- getCurrentDate - let idx = num - 1 - confs = FC.conflictingFiles conflict - file = FC.filePath $ confs !! idx - origFile = FC.origFilePath conflict - backupSpec = T.pack $ "_backup_" ++ show year ++ "-" ++ show month ++ "-" ++ show day - backupBaseName = (toText $ FP.basename origFile) `T.append` backupSpec - backupFile = replaceBaseName origFile (FP.fromText backupBaseName) - - errorsToStderr $ do - FS.copyFile origFile backupFile - moveToTrash backupFile - FS.copyFile file origFile - mapM_ (\c -> moveToTrash (FC.filePath c)) confs - - showDiff file1 file2 = do - putStrLn "" - diff <- getEnvOrDefault "CONFSOLVE_DIFF" defaultDiff - handle <- runCommand $ diff ++ " " ++ (quote $ toString file1) ++ " " ++ (quote $ toString file2) - waitForProcess handle - return () - - quote string = "\"" ++ string ++ "\""