confsolve 0.2 → 0.3.1
raw patch · 2 files changed
+96/−90 lines, 2 filesdep +attoparsecdep +cmdargsdep +system-fileiodep −directorydep −filepathdep −hashmap
Dependencies added: attoparsec, cmdargs, system-fileio, system-filepath, text, unordered-containers
Dependencies removed: directory, filepath, hashmap, regex-posix
Files
- confsolve.cabal +4/−4
- confsolve.hs +92/−86
confsolve.cabal view
@@ -1,5 +1,5 @@ Name: confsolve-Version: 0.2+Version: 0.3.1 License: BSD3 License-file: LICENSE Author: Daniel Trstenjak@@ -7,8 +7,8 @@ Build-Type: Simple Category: Utils Cabal-Version: >=1.6-Synopsis: A command line tool for resolving conflicts of file synchronizers. Currently supported are Dropbox and Wuala.-Description: A command line tool for resolving conflicts of file synchronizers. Currently supported are Dropbox and Wuala.+Synopsis: A command line tool for resolving conflicts of file synchronizers.+Description: A command line tool for resolving conflicts of file synchronizers. source-repository head type: git@@ -16,4 +16,4 @@ Executable confsolve Main-is: confsolve.hs- Build-Depends: base >= 3 && < 5, regex-posix >= 0.94 && < 0.95, time >= 1.2 && < 1.3, process >= 1.0 && < 1.1, filepath >= 1.2 && < 1.3, directory >= 1.1 && < 1.2, haskell98 >= 1.1 && < 1.2, hashmap >= 1.2.0.1 && < 1.3+ Build-Depends: base >= 3 && < 5, time >= 1.2 && < 1.3, process >= 1.0 && < 1.1, haskell98 >= 1.1 && < 1.2, unordered-containers >= 0.2.1.0 && < 0.3, text >= 0.11.2.0 && < 0.12, attoparsec >= 0.10.1.1 && < 0.11, system-filepath >= 0.4.6 && < 0.5, system-fileio >= 0.3.7 && < 0.4, cmdargs >= 0.9.5 && < 1.0
confsolve.hs view
@@ -1,48 +1,42 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} import System (getArgs)-import System.Directory import System.IO import System.IO.Error (IOErrorType)-import System.FilePath import System.Environment import System.Process import System.Exit-import Data.List (isInfixOf, isSuffixOf, isPrefixOf, concat, foldr) import Data.Char (intToDigit, digitToInt, isDigit, toUpper) import Data.Foldable (foldrM, foldlM)-import qualified Data.HashSet as HS-import Control.Monad (mapM_)+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)+import Control.Applicative ((<$>)) import Foreign.Marshal.Error (void) import qualified FileConflict as FC-import qualified Dropbox as DB-import qualified Wuala as WU+import qualified Dropbox.Conflict as DB+import qualified Wuala.Conflict as WU import Utils+import ConfsolveArgs + main = do hSetBuffering stdout NoBuffering hSetBuffering stdin NoBuffering- args <- getArgs- case args of- [] -> printHelp- ("-h":[]) -> printHelp >> printRuntineHelp- ("--help":[]) -> printHelp >> printRuntineHelp- ("-d":dir:[]) -> void $ resolve DB.DropboxConflict dir HS.empty- ("-w":dir:[]) -> void $ resolve WU.WualaConflict dir HS.empty- otherwise -> error $ "Invalid Arguments!"+ args <- confsolveArgs+ let dir = FP.fromText $ T.pack (directory args)+ when (dropbox args) $+ resolveConflicts DB.Parser dir -printHelp = do- putStrLn $ ""- putStrLn $ "Usage: confsolve OPTION DIRECTORY"- putStrLn $ ""- putStrLn $ "Options:"- putStrLn $ " -d resolve Dropbox file conflicts"- putStrLn $ " -w resolve Wuala file conflicts"- putStrLn $ " -h print this help message"- putStrLn $ ""+ when (wuala args) $+ resolveConflicts WU.Parser dir + printRuntineHelp = do- trashDir <- trashDirectory+ trashDir <- show <$> trashDirectory putStrLn $ "" putStrLn $ "Runtime Options:" putStrLn $ " (T)ake File (NUM) => By pressing 't' and a digit, the conflicting file with the"@@ -70,73 +64,85 @@ putStrLn $ " (H)elp => By pressing 'h', this help is printed." putStrLn $ "" -type Resolved = HS.Set String+type Conflicts = HM.HashMap T.Text [FC.ConflictingFile] -resolve :: (FC.FileConflict a) => a -> String -> Resolved -> IO Resolved-resolve fileConflict file resolved = do- dirExists <- doesDirectoryExist file- if dirExists++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 <- getDirContents file- foldrM (\e r -> resolve fileConflict (file </> e) r) resolved entries+ entries <- FS.listDirectory filePath+ foldrM (\entry conflicts -> collectConflicts parser entry conflicts) conflicts entries else do- fileExists <- doesFileExist file- let isntResolved = not $ file `HS.member` resolved- if fileExists && isntResolved- then do- maybeConfInfo <- FC.find fileConflict file- case maybeConfInfo of- Nothing -> return resolved- Just confInfo -> do- handleConflict confInfo- return $ foldr (\c r -> HS.insert (FC.filePath c) r) resolved (FC.conflicts confInfo)- else return resolved+ 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 -handleConflict :: FC.ConflictInfo -> IO ()-handleConflict confInfo = do- let origFP = FC.origFilePath confInfo- exists <- doesFileExist origFP+ 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 '" ++ origFP ++ "', but the file itself is missing! Skipping it."+ then putStrLn $ "Found conflicts for the file '" ++ show origFP ++ "', but the file itself is missing! Skipping it." else do- putConfInfo confInfo- askUser confInfo+ putConflict conflict+ askUser conflict -putConfInfo :: FC.ConflictInfo -> IO ()-putConfInfo confInfo = do- putStrLn $ "\nConflicting file: " ++ FC.origFilePath confInfo- void $ foldlM (\i c -> putConf i c >> (return $ i+1)) 1 (FC.conflicts confInfo)+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 idx conf =- putStrLn $ " (" ++ [intToDigit idx] ++ ") " ++ FC.details conf+ putStrLn $ " (" ++ [intToDigit idx] ++ ") " ++ (show $ FC.details conf) -askUser confInfo = do- putStr "\n(T)ake File (NUM) | (M)ove to Trash | Show (D)iff (NUM [NUM]) | (S)kip | (Q)uit | (H)elp: " +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.conflicts confInfo+ let confs = FC.conflictingFiles conflict numConfs = length confs validD = validDigit 1 numConfs invalidTake = putStrLn $ "Invalid input! Use e.g: 't1'" invalidDiff = putStrLn $ "Invalid input! Use e.g: 'd1' or 'd12'" invalidInput = putStrLn $ "Invalid input! See Help"- askAgain = askUser confInfo+ askAgain = askUser conflict case map toUpper line of- ('T':d:[]) | validD d -> takeFile (digitToInt d) confInfo+ ('T':d:[]) | validD d -> takeFile (digitToInt d) conflict | otherwise -> invalidTake >> askAgain - ('M':[]) -> mapM_ (\c -> moveToTrash $ FC.filePath c) confs + ('M':[]) -> mapM_ (\c -> moveToTrash $ FC.filePath c) confs - ('D':[]) | numConfs == 1 -> do showDiff (FC.origFilePath confInfo) - (FC.filePath $ confs !! 0) - askAgain + ('D':[]) | numConfs == 1 -> do showDiff (FC.origFilePath conflict)+ (FC.filePath $ confs !! 0)+ askAgain | otherwise -> invalidInput >> askAgain - ('D':d:[]) | validD d -> do let i = (digitToInt d) - 1 - showDiff (FC.origFilePath confInfo) + ('D':d:[]) | validD d -> do let i = (digitToInt d) - 1+ showDiff (FC.origFilePath conflict) (FC.filePath $ confs !! i) askAgain @@ -144,7 +150,7 @@ ('D':d1:d2:[]) | validD d1 && validD d2 -> do let i1 = (digitToInt d1) - 1 i2 = (digitToInt d2) - 1- showDiff (FC.filePath $ confs !! i1) + showDiff (FC.filePath $ confs !! i1) (FC.filePath $ confs !! i2) askAgain @@ -159,34 +165,34 @@ where validDigit min max d = isDigit d && let i = digitToInt d in i >= min && i <= max - moveToTrash file =- errorsToStderr $ do + moveToTrash filePath =+ errorsToStderr $ do trashDir <- trashDirectory- createDirectoryIfMissing True trashDir- let (dir, fileName) = splitFileName file- copyFile file (trashDir </> fileName) - removeFile file+ FS.createTree trashDir+ let fileName = FP.filename filePath+ FS.copyFile filePath (trashDir </> fileName)+ FS.removeFile filePath - takeFile num confInfo = do+ takeFile num conflict = do (year, month, day) <- getCurrentDate- let idx = num - 1- confs = FC.conflicts confInfo- file = FC.filePath $ confs !! idx- origFile = FC.origFilePath confInfo- origBackup = FC.dir confInfo </> FC.fileName confInfo - ++ "_backup_" ++ show year ++ "-" ++ show month- ++ "-" ++ show day ++ FC.suffix confInfo+ 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- copyFile origFile origBackup- moveToTrash origBackup- copyFile file origFile+ 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 file1 ++ " " ++ quote file2+ handle <- runCommand $ diff ++ " " ++ (quote $ toString file1) ++ " " ++ (quote $ toString file2) waitForProcess handle return ()