diff options
34 files changed, 875 insertions, 838 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 73edb5eaa..7fa7cb3a8 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -32,20 +32,20 @@ seek = [withFilesNotInGit start, withFilesUnlocked start] - to its content. -} start :: FilePath -> CommandStart start file = notBareRepo $ ifAnnexed file fixup add - where - add = do - s <- liftIO $ getSymbolicLinkStatus file - if isSymbolicLink s || not (isRegularFile s) - then stop - else do - showStart "add" file - next $ perform file - fixup (key, _) = do - -- fixup from an interrupted add; the symlink - -- is present but not yet added to git - showStart "add" file - liftIO $ removeFile file - next $ next $ cleanup file key =<< inAnnex key + where + add = do + s <- liftIO $ getSymbolicLinkStatus file + if isSymbolicLink s || not (isRegularFile s) + then stop + else do + showStart "add" file + next $ perform file + fixup (key, _) = do + -- fixup from an interrupted add; the symlink + -- is present but not yet added to git + showStart "add" file + liftIO $ removeFile file + next $ next $ cleanup file key =<< inAnnex key {- The file that's being added is locked down before a key is generated, - to prevent it from being modified in between. It's hard linked into a @@ -67,15 +67,15 @@ ingest :: KeySource -> Annex (Maybe Key) ingest source = do backend <- chooseBackend $ keyFilename source genKey source backend >>= go - where - go Nothing = do - liftIO $ nukeFile $ contentLocation source - return Nothing - go (Just (key, _)) = do - handle (undo (keyFilename source) key) $ - moveAnnex key $ contentLocation source - liftIO $ nukeFile $ keyFilename source - return $ Just key + where + go Nothing = do + liftIO $ nukeFile $ contentLocation source + return Nothing + go (Just (key, _)) = do + handle (undo (keyFilename source) key) $ + moveAnnex key $ contentLocation source + liftIO $ nukeFile $ keyFilename source + return $ Just key perform :: FilePath -> CommandPerform perform file = @@ -91,12 +91,12 @@ undo file key e = do handle tryharder $ fromAnnex key file logStatus key InfoMissing throw e - where - -- fromAnnex could fail if the file ownership is weird - tryharder :: IOException -> Annex () - tryharder _ = do - src <- inRepo $ gitAnnexLocation key - liftIO $ moveFile src file + where + -- fromAnnex could fail if the file ownership is weird + tryharder :: IOException -> Annex () + tryharder _ = do + src <- inRepo $ gitAnnexLocation key + liftIO $ moveFile src file {- Creates the symlink to the annexed content, returns the link target. -} link :: FilePath -> Key -> Bool -> Annex String diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index f70500354..519c67e1b 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -25,8 +25,8 @@ start = startUnused "addunused" perform (performOther "bad") (performOther "tmp" perform :: Key -> CommandPerform perform key = next $ Command.Add.cleanup file key True - where - file = "unused." ++ key2file key + where + file = "unused." ++ key2file key {- The content is not in the annex, but in another directory, and - it seems better to error out, rather than moving bad/tmp content into diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index bef1d6875..0003237eb 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -40,31 +40,31 @@ seek = [withField fileOption return $ \f -> start :: Maybe FilePath -> Maybe Int -> String -> CommandStart start optfile pathdepth s = notBareRepo $ go $ fromMaybe bad $ parseURI s - where - bad = fromMaybe (error $ "bad url " ++ s) $ - parseURI $ escapeURIString isUnescapedInURI s - go url = do - let file = fromMaybe (url2file url pathdepth) optfile - showStart "addurl" file - next $ perform s file + where + bad = fromMaybe (error $ "bad url " ++ s) $ + parseURI $ escapeURIString isUnescapedInURI s + go url = do + let file = fromMaybe (url2file url pathdepth) optfile + showStart "addurl" file + next $ perform s file perform :: String -> FilePath -> CommandPerform perform url file = ifAnnexed file addurl geturl - where - geturl = do - liftIO $ createDirectoryIfMissing True (parentDir file) - ifM (Annex.getState Annex.fast) - ( nodownload url file , download url file ) - addurl (key, _backend) = do - headers <- getHttpHeaders - ifM (liftIO $ Url.check url headers $ keySize key) - ( do - setUrlPresent key url - next $ return True - , do - warning $ "failed to verify url: " ++ url - stop - ) + where + geturl = do + liftIO $ createDirectoryIfMissing True (parentDir file) + ifM (Annex.getState Annex.fast) + ( nodownload url file , download url file ) + addurl (key, _backend) = do + headers <- getHttpHeaders + ifM (liftIO $ Url.check url headers $ keySize key) + ( do + setUrlPresent key url + next $ return True + , do + warning $ "failed to verify url: " ++ url + stop + ) download :: String -> FilePath -> CommandPerform download url file = do @@ -103,10 +103,10 @@ url2file url pathdepth = case pathdepth of | depth > 0 -> frombits $ drop depth | depth < 0 -> frombits $ reverse . take (negate depth) . reverse | otherwise -> error "bad --pathdepth" - where - fullurl = uriRegName auth ++ uriPath url ++ uriQuery url - frombits a = join "/" $ a urlbits - urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl - auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url - filesize = take 255 - escape = replace "/" "_" . replace "?" "_" + where + fullurl = uriRegName auth ++ uriPath url ++ uriQuery url + frombits a = join "/" $ a urlbits + urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl + auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url + filesize = take 255 + escape = replace "/" "_" . replace "?" "_" diff --git a/Command/Assistant.hs b/Command/Assistant.hs index b039e2731..ea8a87a3d 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -65,7 +65,7 @@ autoStart = do ) , nothing ) - where - go program dir = do - changeWorkingDirectory dir - boolSystem program [Param "assistant"] + where + go program dir = do + changeWorkingDirectory dir + boolSystem program [Param "assistant"] diff --git a/Command/Commit.hs b/Command/Commit.hs index d3ce3d7bb..165906139 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -24,6 +24,6 @@ start = next $ next $ do Annex.Branch.commit "update" _ <- runhook <=< inRepo $ Git.hookPath "annex-content" return True - where - runhook (Just hook) = liftIO $ boolSystem hook [] - runhook Nothing = return True + where + runhook (Just hook) = liftIO $ boolSystem hook [] + runhook Nothing = return True diff --git a/Command/Copy.hs b/Command/Copy.hs index 4352aaa31..dd5599264 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -29,7 +29,7 @@ start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandSt start to from file (key, backend) = autoCopies file key (<) $ stopUnless shouldCopy $ Command.Move.start to from False file (key, backend) - where - shouldCopy = case to of - Nothing -> checkAuto $ wantGet (Just file) - Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r) + where + shouldCopy = case to of + Nothing -> checkAuto $ wantGet (Just file) + Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r) diff --git a/Command/Drop.hs b/Command/Drop.hs index 9e58701db..6c210b1e1 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -76,8 +76,8 @@ performRemote key numcopies remote = lockContent key $ do stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok - where - uuid = Remote.uuid remote + where + uuid = Remote.uuid remote cleanupLocal :: Key -> CommandCleanup cleanupLocal key = do @@ -106,20 +106,20 @@ canDropKey key numcopiesM have check skip = do findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool findCopies key need skip = helper [] - where - helper bad have [] - | length have >= need = return True - | otherwise = notEnoughCopies key need have skip bad - helper bad have (r:rs) - | length have >= need = return True - | otherwise = do - let u = Remote.uuid r - let duplicate = u `elem` have - haskey <- Remote.hasKey r key - case (duplicate, haskey) of - (False, Right True) -> helper bad (u:have) rs - (False, Left _) -> helper (r:bad) have rs - _ -> helper bad have rs + where + helper bad have [] + | length have >= need = return True + | otherwise = notEnoughCopies key need have skip bad + helper bad have (r:rs) + | length have >= need = return True + | otherwise = do + let u = Remote.uuid r + let duplicate = u `elem` have + haskey <- Remote.hasKey r key + case (duplicate, haskey) of + (False, Right True) -> helper bad (u:have) rs + (False, Left _) -> helper (r:bad) have rs + _ -> helper bad have rs notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool notEnoughCopies key need have skip bad = do @@ -132,6 +132,6 @@ notEnoughCopies key need have skip bad = do Remote.showLocations key (have++skip) hint return False - where - unsafe = showNote "unsafe" - hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)" + where + unsafe = showNote "unsafe" + hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)" diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 597a4eec0..00c0eec12 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -29,13 +29,13 @@ start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (per perform :: Key -> CommandPerform perform key = maybe droplocal dropremote =<< Remote.byName =<< from - where - dropremote r = do - showAction $ "from " ++ Remote.name r - ok <- Remote.removeKey r key - next $ Command.Drop.cleanupRemote key r ok - droplocal = Command.Drop.performLocal key (Just 0) -- force drop - from = Annex.getField $ Option.name Command.Drop.fromOption + where + dropremote r = do + showAction $ "from " ++ Remote.name r + ok <- Remote.removeKey r key + next $ Command.Drop.cleanupRemote key r ok + droplocal = Command.Drop.performLocal key (Just 0) -- force drop + from = Annex.getField $ Option.name Command.Drop.fromOption performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/Find.hs b/Command/Find.hs index 177b794cd..1e509d1dd 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -29,14 +29,14 @@ formatOption = Option.field [] "format" paramFormat "control format of output" print0Option :: Option print0Option = Option.Option [] ["print0"] (Option.NoArg set) "terminate output with null" - where - set = Annex.setField (Option.name formatOption) "${file}\0" + where + set = Annex.setField (Option.name formatOption) "${file}\0" seek :: [CommandSeek] seek = [withField formatOption formatconverter $ \f -> withFilesInGit $ whenAnnexed $ start f] - where - formatconverter = return . fmap Utility.Format.gen + where + formatconverter = return . fmap Utility.Format.gen start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart start format file (key, _) = do @@ -50,12 +50,12 @@ start format file (key, _) = do Utility.Format.format formatter $ M.fromList vars stop - where - vars = - [ ("file", file) - , ("key", key2file key) - , ("backend", keyBackendName key) - , ("bytesize", size show) - , ("humansize", size $ roughSize storageUnits True) - ] - size c = maybe "unknown" c $ keySize key + where + vars = + [ ("file", file) + , ("key", key2file key) + , ("backend", keyBackendName key) + , ("bytesize", size show) + , ("humansize", size $ roughSize storageUnits True) + ] + size c = maybe "unknown" c $ keySize key diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 5e130c948..deb3a5c81 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -78,22 +78,22 @@ withIncremental = withValue $ do (True, _, _) -> maybe startIncremental (return . ContIncremental . Just) =<< getStartTime - where - startIncremental = do - recordStartTime - return StartIncremental - - checkschedule Nothing = error "bad --incremental-schedule value" - checkschedule (Just delta) = do - Annex.addCleanup "" $ do - v <- getStartTime - case v of - Nothing -> noop - Just started -> do - now <- liftIO getPOSIXTime - when (now - realToFrac started >= delta) $ - resetStartTime - return True + where + startIncremental = do + recordStartTime + return StartIncremental + + checkschedule Nothing = error "bad --incremental-schedule value" + checkschedule (Just delta) = do + Annex.addCleanup "" $ do + v <- getStartTime + case v of + Nothing -> noop + Just started -> do + now <- liftIO getPOSIXTime + when (now - realToFrac started >= delta) $ + resetStartTime + return True start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart start from inc file (key, backend) = do @@ -101,8 +101,8 @@ start from inc file (key, backend) = do case from of Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key file backend numcopies r - where - go = runFsck inc file key + where + go = runFsck inc file key perform :: Key -> FilePath -> Backend -> Maybe Int -> Annex Bool perform key file backend numcopies = check @@ -119,48 +119,48 @@ perform key file backend numcopies = check performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> Annex Bool performRemote key file backend numcopies remote = dispatch =<< Remote.hasKey remote key - where - dispatch (Left err) = do - showNote err - return False - dispatch (Right True) = withtmp $ \tmpfile -> - ifM (getfile tmpfile) - ( go True (Just tmpfile) - , go True Nothing - ) - dispatch (Right False) = go False Nothing - go present localcopy = check - [ verifyLocationLogRemote key file remote present - , checkKeySizeRemote key remote localcopy - , checkBackendRemote backend key remote localcopy - , checkKeyNumCopies key file numcopies - ] - withtmp a = do - pid <- liftIO getProcessID - t <- fromRepo gitAnnexTmpDir - createAnnexDirectory t - let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key - let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) - cleanup - cleanup `after` a tmp - getfile tmp = - ifM (Remote.retrieveKeyFileCheap remote key tmp) - ( return True - , ifM (Annex.getState Annex.fast) - ( return False - , Remote.retrieveKeyFile remote key Nothing tmp - ) + where + dispatch (Left err) = do + showNote err + return False + dispatch (Right True) = withtmp $ \tmpfile -> + ifM (getfile tmpfile) + ( go True (Just tmpfile) + , go True Nothing + ) + dispatch (Right False) = go False Nothing + go present localcopy = check + [ verifyLocationLogRemote key file remote present + , checkKeySizeRemote key remote localcopy + , checkBackendRemote backend key remote localcopy + , checkKeyNumCopies key file numcopies + ] + withtmp a = do + pid <- liftIO getProcessID + t <- fromRepo gitAnnexTmpDir + createAnnexDirectory t + let tmp = t </> "fsck" ++ show pid ++ "." ++ keyFile key + let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) + cleanup + cleanup `after` a tmp + getfile tmp = + ifM (Remote.retrieveKeyFileCheap remote key tmp) + ( return True + , ifM (Annex.getState Annex.fast) + ( return False + , Remote.retrieveKeyFile remote key Nothing tmp ) + ) {- To fsck a bare repository, fsck each key in the location log. -} withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek withBarePresentKeys a params = isBareRepo >>= go - where - go False = return [] - go True = do - unless (null params) $ - error "fsck should be run without parameters in a bare repository" - map a <$> loggedKeys + where + go False = return [] + go True = do + unless (null params) $ + error "fsck should be run without parameters in a bare repository" + map a <$> loggedKeys startBare :: Incremental -> Key -> CommandStart startBare inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of @@ -242,10 +242,10 @@ verifyLocationLog' key desc present u bad = do "but its content is missing." return False _ -> return True - where - fix s = do - showNote "fixing location log" - bad s + where + fix s = do + showNote "fixing location log" + bad s {- The size of the data for a key is checked against the size encoded in - the key's metadata, if available. -} @@ -269,19 +269,19 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of size' <- fromIntegral . fileSize <$> liftIO (getFileStatus file) comparesizes size size' - where - comparesizes a b = do - let same = a == b - unless same $ badsize a b - return same - badsize a b = do - msg <- bad key - warning $ concat - [ "Bad file size (" - , compareSizes storageUnits True a b - , "); " - , msg - ] + where + comparesizes a b = do + let same = a == b + unless same $ badsize a b + return same + badsize a b = do + msg <- bad key + warning $ concat + [ "Bad file size (" + , compareSizes storageUnits True a b + , "); " + , msg + ] checkBackend :: Backend -> Key -> Annex Bool checkBackend backend key = do @@ -290,8 +290,8 @@ checkBackend backend key = do checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool checkBackendRemote backend key remote = maybe (return True) go - where - go = checkBackendOr (badContentRemote remote) backend key + where + go = checkBackendOr (badContentRemote remote) backend key checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool checkBackendOr bad backend key file = @@ -414,9 +414,9 @@ recordStartTime = do t <- modificationTime <$> getFileStatus f hPutStr h $ showTime $ realToFrac t hClose h - where - showTime :: POSIXTime -> String - showTime = show + where + showTime :: POSIXTime -> String + showTime = show resetStartTime :: Annex () resetStartTime = liftIO . nukeFile =<< fromRepo gitAnnexFsckState @@ -431,7 +431,7 @@ getStartTime = do return $ if Just (realToFrac timestamp) == t then Just timestamp else Nothing - where - readishTime :: String -> Maybe POSIXTime - readishTime s = utcTimeToPOSIXSeconds <$> - parseTime defaultTimeLocale "%s%Qs" s + where + readishTime :: String -> Maybe POSIXTime + readishTime s = utcTimeToPOSIXSeconds <$> + parseTime defaultTimeLocale "%s%Qs" s diff --git a/Command/Get.hs b/Command/Get.hs index c95e4eb94..7f02e7935 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -32,10 +32,10 @@ start from file (key, _) = stopUnless ((not <$> inAnnex key) <&&> checkAuto (wan -- get --from = copy --from stopUnless (Command.Move.fromOk src key) $ go $ Command.Move.fromPerform src False key file - where - go a = do - showStart "get" file - next a + where + go a = do + showStart "get" file + next a perform :: Key -> FilePath -> CommandPerform perform key file = stopUnless (getViaTmp key $ getKeyFile key file) $ @@ -45,29 +45,29 @@ perform key file = stopUnless (getViaTmp key $ getKeyFile key file) $ - and copy it to here. -} getKeyFile :: Key -> FilePath -> FilePath -> Annex Bool getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key - where - dispatch [] = do - showNote "not available" - Remote.showLocations key [] - return False - dispatch remotes = trycopy remotes remotes - trycopy full [] = do - Remote.showTriedRemotes full - Remote.showLocations key [] - return False - trycopy full (r:rs) = - ifM (probablyPresent r) - ( docopy r (trycopy full rs) - , trycopy full rs - ) - -- This check is to avoid an ugly message if a remote is a - -- drive that is not mounted. - probablyPresent r - | Remote.hasKeyCheap r = - either (const False) id <$> Remote.hasKey r key - | otherwise = return True - docopy r continue = do - ok <- download (Remote.uuid r) key (Just file) noRetry $ do - showAction $ "from " ++ Remote.name r - Remote.retrieveKeyFile r key (Just file) dest - if ok then return ok else continue + where + dispatch [] = do + showNote "not available" + Remote.showLocations key [] + return False + dispatch remotes = trycopy remotes remotes + trycopy full [] = do + Remote.showTriedRemotes full + Remote.showLocations key [] + return False + trycopy full (r:rs) = + ifM (probablyPresent r) + ( docopy r (trycopy full rs) + , trycopy full rs + ) + -- This check is to avoid an ugly message if a remote is a + -- drive that is not mounted. + probablyPresent r + | Remote.hasKeyCheap r = + either (const False) id <$> Remote.hasKey r key + | otherwise = return True + docopy r continue = do + ok <- download (Remote.uuid r) key (Just file) noRetry $ do + showAction $ "from " ++ Remote.name r + Remote.retrieveKeyFile r key (Just file) dest + if ok then return ok else continue diff --git a/Command/Help.hs b/Command/Help.hs index 80a7b9520..95033eb7f 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -47,5 +47,5 @@ showHelp = liftIO $ putStrLn $ unlines ] , "Run git-annex without any options for a complete command and option list." ] - where - cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c + where + cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index ac4af8d0b..cd4bff2c6 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -20,8 +20,8 @@ seek = [withKeys start] start :: Key -> CommandStart start key = inAnnexSafe key >>= dispatch - where - dispatch (Just True) = stop - dispatch (Just False) = exit 1 - dispatch Nothing = exit 100 - exit n = liftIO $ exitWith $ ExitFailure n + where + dispatch (Just True) = stop + dispatch (Just False) = exit 1 + dispatch Nothing = exit 100 + exit n = liftIO $ exitWith $ ExitFailure n diff --git a/Command/Init.hs b/Command/Init.hs index bbabdc4c2..342ef84e1 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -22,8 +22,8 @@ start :: [String] -> CommandStart start ws = do showStart "init" description next $ perform description - where - description = unwords ws + where + description = unwords ws perform :: String -> CommandPerform perform description = do diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index ad93529cc..720fdddf5 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -40,8 +40,8 @@ start (name:ws) = do showStart "initremote" name next $ perform t u name $ M.union config c - where - config = Logs.Remote.keyValToConfig ws + where + config = Logs.Remote.keyValToConfig ws perform :: RemoteType -> UUID -> String -> R.RemoteConfig -> CommandPerform perform t u name c = do @@ -59,19 +59,19 @@ findByName :: String -> Annex (UUID, R.RemoteConfig) findByName name = do m <- Logs.Remote.readRemoteLog maybe generate return $ findByName' name m - where - generate = do - uuid <- liftIO genUUID - return (uuid, M.insert nameKey name M.empty) + where + generate = do + uuid <- liftIO genUUID + return (uuid, M.insert nameKey name M.empty) findByName' :: String -> M.Map UUID R.RemoteConfig -> Maybe (UUID, R.RemoteConfig) findByName' n = headMaybe . filter (matching . snd) . M.toList - where - matching c = case M.lookup nameKey c of - Nothing -> False - Just n' - | n' == n -> True - | otherwise -> False + where + matching c = case M.lookup nameKey c of + Nothing -> False + Just n' + | n' == n -> True + | otherwise -> False remoteNames :: Annex [String] remoteNames = do @@ -81,12 +81,12 @@ remoteNames = do {- find the specified remote type -} findType :: R.RemoteConfig -> Annex RemoteType findType config = maybe unspecified specified $ M.lookup typeKey config - where - unspecified = error "Specify the type of remote with type=" - specified s = case filter (findtype s) Remote.remoteTypes of - [] -> error $ "Unknown remote type " ++ s - (t:_) -> return t - findtype s i = R.typename i == s + where + unspecified = error "Specify the type of remote with type=" + specified s = case filter (findtype s) Remote.remoteTypes of + [] -> error $ "Unknown remote type " ++ s + (t:_) -> return t + findtype s i = R.typename i == s {- The name of a configured remote is stored in its config using this key. -} nameKey :: String diff --git a/Command/Log.hs b/Command/Log.hs index 90d3d9490..6608a9906 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -47,9 +47,8 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++ [ Option.field ['n'] "max-count" paramNumber "limit number of logs displayed" ] - where - odate n = Option.field [] n paramDate $ - "show log " ++ n ++ " date" + where + odate n = Option.field [] n paramDate $ "show log " ++ n ++ " date" gourceOption :: Option gourceOption = Option.flag [] "gource" "format output for gource" @@ -60,10 +59,10 @@ seek = [withValue Remote.uuidDescriptions $ \m -> withValue (concat <$> mapM getoption passthruOptions) $ \os -> withFlag gourceOption $ \gource -> withFilesInGit $ whenAnnexed $ start m zone os gource] - where - getoption o = maybe [] (use o) <$> - Annex.getField (Option.name o) - use o v = [Param ("--" ++ Option.name o), Param v] + where + getoption o = maybe [] (use o) <$> + Annex.getField (Option.name o) + use o v = [Param ("--" ++ Option.name o), Param v] start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool -> FilePath -> (Key, Backend) -> CommandStart @@ -72,41 +71,41 @@ start m zone os gource file (key, _) = do -- getLog produces a zombie; reap it liftIO reapZombies stop - where - output - | gource = gourceOutput lookupdescription file - | otherwise = normalOutput lookupdescription file zone - lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m + where + output + | gource = gourceOutput lookupdescription file + | otherwise = normalOutput lookupdescription file zone + lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m showLog :: Outputter -> [RefChange] -> Annex () showLog outputter ps = do sets <- mapM (getset newref) ps previous <- maybe (return genesis) (getset oldref) (lastMaybe ps) sequence_ $ compareChanges outputter $ sets ++ [previous] - where - genesis = (0, S.empty) - getset select change = do - s <- S.fromList <$> get (select change) - return (changetime change, s) - get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> - catObject ref + where + genesis = (0, S.empty) + getset select change = do + s <- S.fromList <$> get (select change) + return (changetime change, s) + get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> + catObject ref normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter normalOutput lookupdescription file zone present ts us = liftIO $ mapM_ (putStrLn . format) us - where - time = showTimeStamp zone ts - addel = if present then "+" else "-" - format u = unwords [ addel, time, file, "|", - fromUUID u ++ " -- " ++ lookupdescription u ] + where + time = showTimeStamp zone ts + addel = if present then "+" else "-" + format u = unwords [ addel, time, file, "|", + fromUUID u ++ " -- " ++ lookupdescription u ] gourceOutput :: (UUID -> String) -> FilePath -> Outputter gourceOutput lookupdescription file present ts us = liftIO $ mapM_ (putStrLn . intercalate "|" . format) us - where - time = takeWhile isDigit $ show ts - addel = if present then "A" else "M" - format u = [ time, lookupdescription u, addel, file ] + where + time = takeWhile isDigit $ show ts + addel = if present then "A" else "M" + format u = [ time, lookupdescription u, addel, file ] {- Generates a display of the changes (which are ordered with newest first), - by comparing each change with the previous change. @@ -114,12 +113,12 @@ gourceOutput lookupdescription file present ts us = - removed. -} compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b] compareChanges format changes = concatMap diff $ zip changes (drop 1 changes) - where - diff ((ts, new), (_, old)) = - [format True ts added, format False ts removed] - where - added = S.toList $ S.difference new old - removed = S.toList $ S.difference old new + where + diff ((ts, new), (_, old)) = + [format True ts added, format False ts removed] + where + added = S.toList $ S.difference new old + removed = S.toList $ S.difference old new {- Gets the git log for a given location log file. - @@ -148,21 +147,21 @@ getLog key os = do readLog :: [String] -> [RefChange] readLog = mapMaybe (parse . lines) - where - parse (ts:raw:[]) = let (old, new) = parseRaw raw in - Just RefChange - { changetime = parseTimeStamp ts - , oldref = old - , newref = new - } - parse _ = Nothing + where + parse (ts:raw:[]) = let (old, new) = parseRaw raw in + Just RefChange + { changetime = parseTimeStamp ts + , oldref = old + , newref = new + } + parse _ = Nothing -- Parses something like ":100644 100644 oldsha newsha M" parseRaw :: String -> (Git.Ref, Git.Ref) parseRaw l = go $ words l - where - go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha) - go _ = error $ "unable to parse git log output: " ++ l + where + go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha) + go _ = error $ "unable to parse git log output: " ++ l parseTimeStamp :: String -> POSIXTime parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") . diff --git a/Command/Map.hs b/Command/Map.hs index 3dbdadbd6..94b1289dc 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -63,14 +63,13 @@ start = do -} drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others - where - repos = map (node umap rs) rs - ruuids = ts ++ map getUncachedUUID rs - others = map (unreachable . uuidnode) $ - filter (`notElem` ruuids) (M.keys umap) - trusted = map (trustworthy . uuidnode) ts - uuidnode u = Dot.graphNode (fromUUID u) $ - M.findWithDefault "" u umap + where + repos = map (node umap rs) rs + ruuids = ts ++ map getUncachedUUID rs + others = map (unreachable . uuidnode) $ + filter (`notElem` ruuids) (M.keys umap) + trusted = map (trustworthy . uuidnode) ts + uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap hostname :: Git.Repo -> String hostname r @@ -86,9 +85,9 @@ repoName :: M.Map UUID String -> Git.Repo -> String repoName umap r | repouuid == NoUUID = fallback | otherwise = M.findWithDefault fallback repouuid umap - where - repouuid = getUncachedUUID r - fallback = fromMaybe "unknown" $ Git.remoteName r + where + repouuid = getUncachedUUID r + fallback = fromMaybe "unknown" $ Git.remoteName r {- A unique id for the node for a repo. Uses the annex.uuid if available. -} nodeId :: Git.Repo -> String @@ -100,32 +99,32 @@ nodeId r = {- A node representing a repo. -} node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String node umap fullinfo r = unlines $ n:edges - where - n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ - decorate $ Dot.graphNode (nodeId r) (repoName umap r) - edges = map (edge umap fullinfo r) (Git.remotes r) - decorate - | Git.config r == M.empty = unreachable - | otherwise = reachable + where + n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ + decorate $ Dot.graphNode (nodeId r) (repoName umap r) + edges = map (edge umap fullinfo r) (Git.remotes r) + decorate + | Git.config r == M.empty = unreachable + | otherwise = reachable {- An edge between two repos. The second repo is a remote of the first. -} edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String edge umap fullinfo from to = Dot.graphEdge (nodeId from) (nodeId fullto) edgename - where - -- get the full info for the remote, to get its UUID - fullto = findfullinfo to - findfullinfo n = - case filter (same n) fullinfo of - [] -> n - (n':_) -> n' - {- Only name an edge if the name is different than the name - - that will be used for the destination node, and is - - different from its hostname. (This reduces visual clutter.) -} - edgename = maybe Nothing calcname $ Git.remoteName to - calcname n - | n `elem` [repoName umap fullto, hostname fullto] = Nothing - | otherwise = Just n + where + -- get the full info for the remote, to get its UUID + fullto = findfullinfo to + findfullinfo n = + case filter (same n) fullinfo of + [] -> n + (n':_) -> n' + {- Only name an edge if the name is different than the name + - that will be used for the destination node, and is + - different from its hostname. (This reduces visual clutter.) -} + edgename = maybe Nothing calcname $ Git.remoteName to + calcname n + | n `elem` [repoName umap fullto, hostname fullto] = Nothing + | otherwise = Just n unreachable :: String -> String unreachable = Dot.fillColor "red" @@ -165,11 +164,10 @@ same a b | both Git.repoIsUrl && neither Git.repoIsSsh = matching show | neither Git.repoIsSsh = matching Git.repoPath | otherwise = False - - where - matching t = t a == t b - both t = t a && t b - neither t = not (t a) && not (t b) + where + matching t = t a == t b + both t = t a && t b + neither t = not (t a) && not (t b) {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo @@ -192,50 +190,49 @@ tryScan r | Git.repoIsSsh r = sshscan | Git.repoIsUrl r = return Nothing | otherwise = safely $ Git.Config.read r - where - safely a = do - result <- liftIO (try a :: IO (Either SomeException Git.Repo)) - case result of - Left _ -> return Nothing - Right r' -> return $ Just r' - pipedconfig cmd params = safely $ - withHandle StdoutHandle createProcessSuccess p $ - Git.Config.hRead r - where - p = proc cmd $ toCommand params - - configlist = - onRemote r (pipedconfig, Nothing) "configlist" [] [] - manualconfiglist = do - sshparams <- sshToRepo r [Param sshcmd] - liftIO $ pipedconfig "ssh" sshparams - where - sshcmd = cddir ++ " && " ++ - "git config --null --list" - dir = Git.repoPath r - cddir - | "/~" `isPrefixOf` dir = - let (userhome, reldir) = span (/= '/') (drop 1 dir) - in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir) - | otherwise = "cd " ++ shellEscape dir - - -- First, try sshing and running git config manually, - -- only fall back to git-annex-shell configlist if that - -- fails. - -- - -- This is done for two reasons, first I'd like this - -- subcommand to be usable on non-git-annex repos. - -- Secondly, configlist doesn't include information about - -- the remote's remotes. - sshscan = do - sshnote - v <- manualconfiglist - case v of - Nothing -> do - sshnote - configlist - ok -> return ok - - sshnote = do - showAction "sshing" - showOutput + where + safely a = do + result <- liftIO (try a :: IO (Either SomeException Git.Repo)) + case result of + Left _ -> return Nothing + Right r' -> return $ Just r' + pipedconfig cmd params = safely $ + withHandle StdoutHandle createProcessSuccess p $ + Git.Config.hRead r + where + p = proc cmd $ toCommand params + + configlist = onRemote r (pipedconfig, Nothing) "configlist" [] [] + manualconfiglist = do + sshparams <- sshToRepo r [Param sshcmd] + liftIO $ pipedconfig "ssh" sshparams + where + sshcmd = cddir ++ " && " ++ + "git config --null --list" + dir = Git.repoPath r + cddir + | "/~" `isPrefixOf` dir = + let (userhome, reldir) = span (/= '/') (drop 1 dir) + in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir) + | otherwise = "cd " ++ shellEscape dir + + -- First, try sshing and running git config manually, + -- only fall back to git-annex-shell configlist if that + -- fails. + -- + -- This is done for two reasons, first I'd like this + -- subcommand to be usable on non-git-annex repos. + -- Secondly, configlist doesn't include information about + -- the remote's remotes. + sshscan = do + sshnote + v <- manualconfiglist + case v of + Nothing -> do + sshnote + configlist + ok -> return ok + + sshnote = do + showAction "sshing" + showOutput diff --git a/Command/Migrate.hs b/Command/Migrate.hs index d3b29eeca..0b23c2a40 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -31,9 +31,9 @@ start file (key, oldbackend) = do showStart "migrate" file next $ perform file key oldbackend newbackend else stop - where - choosebackend Nothing = Prelude.head <$> orderedList - choosebackend (Just backend) = return backend + where + choosebackend Nothing = Prelude.head <$> orderedList + choosebackend (Just backend) = return backend {- Checks if a key is upgradable to a newer representation. -} {- Ideally, all keys have file size metadata. Old keys may not. -} @@ -49,10 +49,10 @@ perform file oldkey oldbackend newbackend = do ( maybe stop go =<< genkey , stop ) - where - go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $ - next $ Command.ReKey.cleanup file oldkey newkey - genkey = do - content <- inRepo $ gitAnnexLocation oldkey - let source = KeySource { keyFilename = file, contentLocation = content } - liftM fst <$> genKey source (Just newbackend) + where + go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $ + next $ Command.ReKey.cleanup file oldkey newkey + genkey = do + content <- inRepo $ gitAnnexLocation oldkey + let source = KeySource { keyFilename = file, contentLocation = content } + liftM fst <$> genKey source (Just newbackend) diff --git a/Command/Move.hs b/Command/Move.hs index 41daab4b2..316e4192e 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -44,9 +44,9 @@ start to from move file (key, _) = do (Nothing, Just dest) -> toStart dest move file key (Just src, Nothing) -> fromStart src move file key (_ , _) -> error "only one of --from or --to can be specified" - where - noAuto = when move $ whenM (Annex.getState Annex.auto) $ error - "--auto is not supported for move" + where + noAuto = when move $ whenM (Annex.getState Annex.auto) $ error + "--auto is not supported for move" showMoveAction :: Bool -> FilePath -> Annex () showMoveAction True file = showStart "move" file @@ -98,15 +98,15 @@ toPerform dest move key file = moveLock move key $ do warning "This could have failed because --fast is enabled." stop Right True -> finish False - where - finish remotechanged = do - when remotechanged $ - Remote.logStatus dest key InfoPresent - if move - then do - whenM (inAnnex key) $ removeAnnex key - next $ Command.Drop.cleanupLocal key - else next $ return True + where + finish remotechanged = do + when remotechanged $ + Remote.logStatus dest key InfoPresent + if move + then do + whenM (inAnnex key) $ removeAnnex key + next $ Command.Drop.cleanupLocal key + else next $ return True {- Moves (or copies) the content of an annexed file from a remote - to the current repository. @@ -118,35 +118,37 @@ fromStart :: Remote -> Bool -> FilePath -> Key -> CommandStart fromStart src move file key | move = go | otherwise = stopUnless (not <$> inAnnex key) go - where - go = stopUnless (fromOk src key) $ do - showMoveAction move file - next $ fromPerform src move key file + where + go = stopUnless (fromOk src key) $ do + showMoveAction move file + next $ fromPerform src move key file + fromOk :: Remote -> Key -> Annex Bool fromOk src key | Remote.hasKeyCheap src = either (const expensive) return =<< Remote.hasKey src key | otherwise = expensive - where - expensive = do - u <- getUUID - remotes <- Remote.keyPossibilities key - return $ u /= Remote.uuid src && elem src remotes + where + expensive = do + u <- getUUID + remotes <- Remote.keyPossibilities key + return $ u /= Remote.uuid src && elem src remotes + fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform fromPerform src move key file = moveLock move key $ ifM (inAnnex key) ( handle move True , handle move =<< go ) - where - go = download (Remote.uuid src) key (Just file) noRetry $ do - showAction $ "from " ++ Remote.name src - getViaTmp key $ Remote.retrieveKeyFile src key (Just file) - handle _ False = stop -- failed - handle False True = next $ return True -- copy complete - handle True True = do -- finish moving - ok <- Remote.removeKey src key - next $ Command.Drop.cleanupRemote key src ok + where + go = download (Remote.uuid src) key (Just file) noRetry $ do + showAction $ "from " ++ Remote.name src + getViaTmp key $ Remote.retrieveKeyFile src key (Just file) + handle _ False = stop -- failed + handle False True = next $ return True -- copy complete + handle True True = do -- finish moving + ok <- Remote.removeKey src key + next $ Command.Drop.cleanupRemote key src ok {- Locks a key in order for it to be moved. - No lock is needed when a key is being copied. -} diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 5bd419ca3..ea06873c4 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -25,13 +25,13 @@ seek = [withPairs start] start :: (FilePath, String) -> CommandStart start (file, keyname) = ifAnnexed file go stop - where - newkey = fromMaybe (error "bad key") $ file2key keyname - go (oldkey, _) - | oldkey == newkey = stop - | otherwise = do - showStart "rekey" file - next $ perform file oldkey newkey + where + newkey = fromMaybe (error "bad key") $ file2key keyname + go (oldkey, _) + | oldkey == newkey = stop + | otherwise = do + showStart "rekey" file + next $ perform file oldkey newkey perform :: FilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 112b7fadf..d346925fa 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -27,10 +27,10 @@ start (src:dest:[]) ifAnnexed src (error $ "cannot used annexed file as src: " ++ src) go - where - go = do - showStart "reinject" dest - next $ whenAnnexed (perform src) dest + where + go = do + showStart "reinject" dest + next $ whenAnnexed (perform src) dest start _ = error "specify a src file and a dest file" perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform @@ -43,14 +43,14 @@ perform src _dest (key, backend) = do next $ cleanup key , error "not reinjecting" ) - where - -- the file might be on a different filesystem, - -- so mv is used rather than simply calling - -- moveToObjectDir; disk space is also - -- checked this way. - move = getViaTmp key $ \tmp -> - liftIO $ boolSystem "mv" [File src, File tmp] - reject = const $ return "wrong file?" + where + -- the file might be on a different filesystem, + -- so mv is used rather than simply calling + -- moveToObjectDir; disk space is also + -- checked this way. + move = getViaTmp key $ \tmp -> + liftIO $ boolSystem "mv" [File src, File tmp] + reject = const $ return "wrong file?" cleanup :: Key -> CommandCleanup cleanup key = do diff --git a/Command/Status.hs b/Command/Status.hs index a16e14317..593e8a025 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -114,10 +114,10 @@ nojson a _ = a showStat :: Stat -> StatState () showStat s = maybe noop calc =<< s - where - calc (desc, a) = do - (lift . showHeader) desc - lift . showRaw =<< a + where + calc (desc, a) = do + (lift . showHeader) desc + lift . showRaw =<< a supported_backends :: Stat supported_backends = stat "supported backends" $ json unwords $ @@ -133,8 +133,8 @@ remote_list level = stat n $ nojson $ lift $ do rs <- fst <$> trustPartition level us s <- prettyPrintUUIDs n rs return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s - where - n = showTrustLevel level ++ " repositories" + where + n = showTrustLevel level ++ " repositories" local_annex_size :: Stat local_annex_size = stat "local annex size" $ json id $ @@ -182,42 +182,42 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do then return "none" else return $ multiLine $ map (\(t, i) -> line uuidmap t i) $ sort ts - where - line uuidmap t i = unwords - [ showLcDirection (transferDirection t) ++ "ing" - , fromMaybe (key2file $ transferKey t) (associatedFile i) - , if transferDirection t == Upload then "to" else "from" - , maybe (fromUUID $ transferUUID t) Remote.name $ - M.lookup (transferUUID t) uuidmap - ] + where + line uuidmap t i = unwords + [ showLcDirection (transferDirection t) ++ "ing" + , fromMaybe (key2file $ transferKey t) (associatedFile i) + , if transferDirection t == Upload then "to" else "from" + , maybe (fromUUID $ transferUUID t) Remote.name $ + M.lookup (transferUUID t) uuidmap + ] disk_size :: Stat disk_size = stat "available local disk space" $ json id $ lift $ calcfree <$> getDiskReserve <*> inRepo (getDiskFree . gitAnnexDir) - where - calcfree reserve (Just have) = unwords - [ roughSize storageUnits False $ nonneg $ have - reserve - , "(+" ++ roughSize storageUnits False reserve - , "reserved)" - ] - - calcfree _ _ = "unknown" - nonneg x - | x >= 0 = x - | otherwise = 0 + where + calcfree reserve (Just have) = unwords + [ roughSize storageUnits False $ nonneg $ have - reserve + , "(+" ++ roughSize storageUnits False reserve + , "reserved)" + ] + calcfree _ _ = "unknown" + + nonneg x + | x >= 0 = x + | otherwise = 0 backend_usage :: Stat backend_usage = stat "backend usage" $ nojson $ calc <$> (backendsKeys <$> cachedReferencedData) <*> (backendsKeys <$> cachedPresentData) - where - calc x y = multiLine $ - map (\(n, b) -> b ++ ": " ++ show n) $ - reverse $ sort $ map swap $ M.toList $ - M.unionWith (+) x y + where + calc x y = multiLine $ + map (\(n, b) -> b ++ ": " ++ show n) $ + reverse $ sort $ map swap $ M.toList $ + M.unionWith (+) x y cachedPresentData :: StatState KeyData cachedPresentData = do @@ -249,39 +249,38 @@ foldKeys = foldl' (flip addKey) emptyKeyData addKey :: Key -> KeyData -> KeyData addKey key (KeyData count size unknownsize backends) = KeyData count' size' unknownsize' backends' - where - {- All calculations strict to avoid thunks when repeatedly - - applied to many keys. -} - !count' = count + 1 - !backends' = M.insertWith' (+) (keyBackendName key) 1 backends - !size' = maybe size (+ size) ks - !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks - ks = keySize key + where + {- All calculations strict to avoid thunks when repeatedly + - applied to many keys. -} + !count' = count + 1 + !backends' = M.insertWith' (+) (keyBackendName key) 1 backends + !size' = maybe size (+ size) ks + !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks + ks = keySize key showSizeKeys :: KeyData -> String showSizeKeys d = total ++ missingnote - where - total = roughSize storageUnits False $ sizeKeys d - missingnote - | unknownSizeKeys d == 0 = "" - | otherwise = aside $ - "+ " ++ show (unknownSizeKeys d) ++ - " keys of unknown size" + where + total = roughSize storageUnits False $ sizeKeys d + missingnote + | unknownSizeKeys d == 0 = "" + | otherwise = aside $ + "+ " ++ show (unknownSizeKeys d) ++ + " keys of unknown size" staleSize :: String -> (Git.Repo -> FilePath) -> Stat staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec) - where - go [] = nostat - go keys = onsize =<< sum <$> keysizes keys - onsize 0 = nostat - onsize size = stat label $ - json (++ aside "clean up with git-annex unused") $ - return $ roughSize storageUnits False size - keysizes keys = map (fromIntegral . fileSize) <$> stats keys - stats keys = do - dir <- lift $ fromRepo dirspec - liftIO $ forM keys $ \k -> - getFileStatus (dir </> keyFile k) + where + go [] = nostat + go keys = onsize =<< sum <$> keysizes keys + onsize 0 = nostat + onsize size = stat label $ + json (++ aside "clean up with git-annex unused") $ + return $ roughSize storageUnits False size + keysizes keys = map (fromIntegral . fileSize) <$> stats keys + stats keys = do + dir <- lift $ fromRepo dirspec + liftIO $ forM keys $ \k -> getFileStatus (dir </> keyFile k) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/Sync.hs b/Command/Sync.hs index 1795a6104..f7410112e 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -48,8 +48,8 @@ seek rs = do , [ pushLocal branch ] , [ pushRemote remote branch | remote <- remotes ] ] - where - nobranch = error "no branch is checked out" + where + nobranch = error "no branch is checked out" syncBranch :: Git.Ref -> Git.Ref syncBranch = Git.Ref.under "refs/heads/synced/" @@ -59,23 +59,23 @@ remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote syncRemotes :: [String] -> Annex [Remote] syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) - where - pickfast = (++) <$> listed <*> (good =<< fastest <$> available) - wanted - | null rs = good =<< concat . Remote.byCost <$> available - | otherwise = listed - listed = do - l <- catMaybes <$> mapM (Remote.byName . Just) rs - let s = filter Remote.specialRemote l - unless (null s) $ - error $ "cannot sync special remotes: " ++ - unwords (map Types.Remote.name s) - return l - available = filter (not . Remote.specialRemote) - <$> (filterM (repoSyncable . Types.Remote.repo) - =<< Remote.enabledRemoteList) - good = filterM $ Remote.Git.repoAvail . Types.Remote.repo - fastest = fromMaybe [] . headMaybe . Remote.byCost + where + pickfast = (++) <$> listed <*> (good =<< fastest <$> available) + wanted + | null rs = good =<< concat . Remote.byCost <$> available + | otherwise = listed + listed = do + l <- catMaybes <$> mapM (Remote.byName . Just) rs + let s = filter Remote.specialRemote l + unless (null s) $ + error $ "cannot sync special remotes: " ++ + unwords (map Types.Remote.name s) + return l + available = filter (not . Remote.specialRemote) + <$> (filterM (repoSyncable . Types.Remote.repo) + =<< Remote.enabledRemoteList) + good = filterM $ Remote.Git.repoAvail . Types.Remote.repo + fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: CommandStart commit = do @@ -90,16 +90,16 @@ commit = do mergeLocal :: Git.Ref -> CommandStart mergeLocal branch = go =<< needmerge - where - syncbranch = syncBranch branch - needmerge = do - unlessM (inRepo $ Git.Ref.exists syncbranch) $ - inRepo $ updateBranch syncbranch - inRepo $ Git.Branch.changed branch syncbranch - go False = stop - go True = do - showStart "merge" $ Git.Ref.describe syncbranch - next $ next $ mergeFrom syncbranch + where + syncbranch = syncBranch branch + needmerge = do + unlessM (inRepo $ Git.Ref.exists syncbranch) $ + inRepo $ updateBranch syncbranch + inRepo $ Git.Branch.changed branch syncbranch + go False = stop + go True = do + showStart "merge" $ Git.Ref.describe syncbranch + next $ next $ mergeFrom syncbranch pushLocal :: Git.Ref -> CommandStart pushLocal branch = do @@ -109,11 +109,11 @@ pushLocal branch = do updateBranch :: Git.Ref -> Git.Repo -> IO () updateBranch syncbranch g = unlessM go $ error $ "failed to update " ++ show syncbranch - where - go = Git.Command.runBool "branch" - [ Param "-f" - , Param $ show $ Git.Ref.base syncbranch - ] g + where + go = Git.Command.runBool "branch" + [ Param "-f" + , Param $ show $ Git.Ref.base syncbranch + ] g pullRemote :: Remote -> Git.Ref -> CommandStart pullRemote remote branch = do @@ -122,9 +122,9 @@ pullRemote remote branch = do showOutput stopUnless fetch $ next $ mergeRemote remote (Just branch) - where - fetch = inRepo $ Git.Command.runBool "fetch" - [Param $ Remote.name remote] + where + fetch = inRepo $ Git.Command.runBool "fetch" + [Param $ Remote.name remote] {- The remote probably has both a master and a synced/master branch. - Which to merge from? Well, the master has whatever latest changes @@ -136,22 +136,22 @@ mergeRemote remote b = case b of branch <- inRepo Git.Branch.currentUnsafe all id <$> (mapM merge $ branchlist branch) Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b)) - where - merge = mergeFrom . remoteBranch remote - tomerge branches = filterM (changed remote) branches - branchlist Nothing = [] - branchlist (Just branch) = [branch, syncBranch branch] + where + merge = mergeFrom . remoteBranch remote + tomerge branches = filterM (changed remote) branches + branchlist Nothing = [] + branchlist (Just branch) = [branch, syncBranch branch] pushRemote :: Remote -> Git.Ref -> CommandStart pushRemote remote branch = go =<< needpush - where - needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name] - go False = stop - go True = do - showStart "push" (Remote.name remote) - next $ next $ do - showOutput - inRepo $ pushBranch remote branch + where + needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name] + go False = stop + go True = do + showStart "push" (Remote.name remote) + next $ next $ do + showOutput + inRepo $ pushBranch remote branch pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool pushBranch remote branch g = @@ -160,12 +160,12 @@ pushBranch remote branch g = , Param $ refspec Annex.Branch.name , Param $ refspec branch ] g - where - refspec b = concat - [ show $ Git.Ref.base b - , ":" - , show $ Git.Ref.base $ syncBranch b - ] + where + refspec b = concat + [ show $ Git.Ref.base b + , ":" + , show $ Git.Ref.base $ syncBranch b + ] mergeAnnex :: CommandStart mergeAnnex = do @@ -213,37 +213,37 @@ resolveMerge' u withKey LsFiles.valUs $ \keyUs -> withKey LsFiles.valThem $ \keyThem -> go keyUs keyThem | otherwise = return False - where - go keyUs keyThem - | keyUs == keyThem = do - makelink keyUs - return True - | otherwise = do - liftIO $ nukeFile file - Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] - makelink keyUs - makelink keyThem - return True - file = LsFiles.unmergedFile u - issymlink select = any (select (LsFiles.unmergedBlobType u) ==) - [Just SymlinkBlob, Nothing] - makelink (Just key) = do - let dest = mergeFile file key - l <- calcGitLink dest key - liftIO $ do - nukeFile dest - createSymbolicLink l dest - Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest] - makelink _ = noop - withKey select a = do - let msha = select $ LsFiles.unmergedSha u - case msha of - Nothing -> a Nothing - Just sha -> do - key <- fileKey . takeFileName - . encodeW8 . L.unpack - <$> catObject sha - maybe (return False) (a . Just) key + where + go keyUs keyThem + | keyUs == keyThem = do + makelink keyUs + return True + | otherwise = do + liftIO $ nukeFile file + Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] + makelink keyUs + makelink keyThem + return True + file = LsFiles.unmergedFile u + issymlink select = any (select (LsFiles.unmergedBlobType u) ==) + [Just SymlinkBlob, Nothing] + makelink (Just key) = do + let dest = mergeFile file key + l <- calcGitLink dest key + liftIO $ do + nukeFile dest + createSymbolicLink l dest + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest] + makelink _ = noop + withKey select a = do + let msha = select $ LsFiles.unmergedSha u + case msha of + Nothing -> a Nothing + Just sha -> do + key <- fileKey . takeFileName + . encodeW8 . L.unpack + <$> catObject sha + maybe (return False) (a . Just) key {- The filename to use when resolving a conflicted merge of a file, - that points to a key. @@ -262,13 +262,13 @@ mergeFile :: FilePath -> Key -> FilePath mergeFile file key | doubleconflict = go $ key2file key | otherwise = go $ shortHash $ key2file key - where - varmarker = ".variant-" - doubleconflict = varmarker `isSuffixOf` (dropExtension file) - go v = takeDirectory file - </> dropExtension (takeFileName file) - ++ varmarker ++ v - ++ takeExtension file + where + varmarker = ".variant-" + doubleconflict = varmarker `isSuffixOf` (dropExtension file) + go v = takeDirectory file + </> dropExtension (takeFileName file) + ++ varmarker ++ v + ++ takeExtension file shortHash :: String -> String shortHash = take 4 . md5s . md5FilePath diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 8b653da7d..b365e8c20 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -30,10 +30,10 @@ check = do cwd <- liftIO getCurrentDirectory whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ error "can only run uninit from the top of the git repository" - where - current_branch = Git.Ref . Prelude.head . lines <$> revhead - revhead = inRepo $ Git.Command.pipeReadStrict - [Params "rev-parse --abbrev-ref HEAD"] + where + current_branch = Git.Ref . Prelude.head . lines <$> revhead + revhead = inRepo $ Git.Command.pipeReadStrict + [Params "rev-parse --abbrev-ref HEAD"] seek :: [CommandSeek] seek = [ diff --git a/Command/Unlock.hs b/Command/Unlock.hs index f3ffd31ba..6489fc333 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -17,8 +17,8 @@ def = [ c "unlock" "unlock files for modification" , c "edit" "same as unlock" ] - where - c n = command n paramPaths seek + where + c n = command n paramPaths seek seek :: [CommandSeek] seek = [withFilesInGit $ whenAnnexed start] diff --git a/Command/Unused.hs b/Command/Unused.hs index 79285f7d1..c0551ddea 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -64,27 +64,26 @@ checkUnused = chain 0 , check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir , check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpDir ] - where - findunused True = do - showNote "fast mode enabled; only finding stale files" - return [] - findunused False = do - showAction "checking for unused data" - excludeReferenced =<< getKeysPresent - chain _ [] = next $ return True - chain v (a:as) = do - v' <- a v - chain v' as + where + findunused True = do + showNote "fast mode enabled; only finding stale files" + return [] + findunused False = do + showAction "checking for unused data" + excludeReferenced =<< getKeysPresent + chain _ [] = next $ return True + chain v (a:as) = do + v' <- a v + chain v' as checkRemoteUnused :: String -> CommandPerform checkRemoteUnused name = go =<< fromJust <$> Remote.byName (Just name) - where - go r = do - showAction "checking for unused data" - _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 - next $ return True - remoteunused r = - excludeReferenced <=< loggedKeysFor $ Remote.uuid r + where + go r = do + showAction "checking for unused data" + _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 + next $ return True + remoteunused r = excludeReferenced <=< loggedKeysFor $ Remote.uuid r check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do @@ -100,9 +99,9 @@ number n (x:xs) = (n+1, x) : number (n+1) xs table :: [(Int, Key)] -> [String] table l = " NUMBER KEY" : map cols l - where - cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k - pad n s = s ++ replicate (n - length s) ' ' + where + cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k + pad n s = s ++ replicate (n - length s) ' ' staleTmpMsg :: [(Int, Key)] -> String staleTmpMsg t = unlines $ @@ -129,8 +128,8 @@ remoteUnusedMsg :: Remote -> [(Int, Key)] -> String remoteUnusedMsg r u = unusedMsg' u ["Some annexed data on " ++ name ++ " is not used by any files:"] [dropMsg $ Just r] - where - name = Remote.name r + where + name = Remote.name r dropMsg :: Maybe Remote -> String dropMsg Nothing = dropMsg' "" @@ -159,11 +158,11 @@ dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\ -} excludeReferenced :: [Key] -> Annex [Key] excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel - where - runfilter _ [] = return [] -- optimisation - runfilter a l = bloomFilter show l <$> genBloomFilter show a - firstlevel = withKeysReferencedM - secondlevel = withKeysReferencedInGit + where + runfilter _ [] = return [] -- optimisation + runfilter a l = bloomFilter show l <$> genBloomFilter show a + firstlevel = withKeysReferencedM + secondlevel = withKeysReferencedInGit {- Finds items in the first, smaller list, that are not - present in the second, larger list. @@ -174,8 +173,8 @@ excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel exclude :: Ord a => [a] -> [a] -> [a] exclude [] _ = [] -- optimisation exclude smaller larger = S.toList $ remove larger $ S.fromList smaller - where - remove a b = foldl (flip S.delete) b a + where + remove a b = foldl (flip S.delete) b a {- A bloom filter capable of holding half a million keys with a - false positive rate of 1 in 1000 uses around 8 mb of memory, @@ -208,8 +207,8 @@ genBloomFilter convert populate = do bloom <- lift $ newMB (cheapHashes numhashes) numbits _ <- populate $ \v -> lift $ insertMB bloom (convert v) lift $ unsafeFreezeMB bloom - where - lift = liftIO . stToIO + where + lift = liftIO . stToIO bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v] bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l @@ -218,14 +217,14 @@ bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l - symlinks in the git repo. -} withKeysReferenced :: v -> (Key -> v -> v) -> Annex v withKeysReferenced initial a = withKeysReferenced' initial folda - where - folda k v = return $ a k v + where + folda k v = return $ a k v {- Runs an action on each referenced key in the git repo. -} withKeysReferencedM :: (Key -> Annex ()) -> Annex () withKeysReferencedM a = withKeysReferenced' () calla - where - calla k _ = a k + where + calla k _ = a k withKeysReferenced' :: v -> (Key -> v -> Annex v) -> Annex v withKeysReferenced' initial a = do @@ -233,54 +232,53 @@ withKeysReferenced' initial a = do r <- go initial files liftIO $ void clean return r - where - getfiles = ifM isBareRepo - ( return ([], return True) - , do - top <- fromRepo Git.repoPath - inRepo $ LsFiles.inRepo [top] - ) - go v [] = return v - go v (f:fs) = do - x <- Backend.lookupFile f - case x of - Nothing -> go v fs - Just (k, _) -> do - !v' <- a k v - go v' fs - + where + getfiles = ifM isBareRepo + ( return ([], return True) + , do + top <- fromRepo Git.repoPath + inRepo $ LsFiles.inRepo [top] + ) + go v [] = return v + go v (f:fs) = do + x <- Backend.lookupFile f + case x of + Nothing -> go v fs + Just (k, _) -> do + !v' <- a k v + go v' fs withKeysReferencedInGit :: (Key -> Annex ()) -> Annex () withKeysReferencedInGit a = do rs <- relevantrefs <$> showref forM_ rs (withKeysReferencedInGitRef a) - where - showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"] - relevantrefs = map (Git.Ref . snd) . - nubBy uniqref . - filter ourbranches . - map (separate (== ' ')) . lines - uniqref (x, _) (y, _) = x == y - ourbranchend = '/' : show Annex.Branch.name - ourbranches (_, b) = not (ourbranchend `isSuffixOf` b) - && not ("refs/synced/" `isPrefixOf` b) + where + showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"] + relevantrefs = map (Git.Ref . snd) . + nubBy uniqref . + filter ourbranches . + map (separate (== ' ')) . lines + uniqref (x, _) (y, _) = x == y + ourbranchend = '/' : show Annex.Branch.name + ourbranches (_, b) = not (ourbranchend `isSuffixOf` b) + && not ("refs/synced/" `isPrefixOf` b) withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedInGitRef a ref = do showAction $ "checking " ++ Git.Ref.describe ref go <=< inRepo $ LsTree.lsTree ref - where - go [] = noop - go (l:ls) - | isSymLink (LsTree.mode l) = do - content <- encodeW8 . L.unpack - <$> catFile ref (LsTree.file l) - case fileKey (takeFileName content) of - Nothing -> go ls - Just k -> do - a k - go ls - | otherwise = go ls + where + go [] = noop + go (l:ls) + | isSymLink (LsTree.mode l) = do + content <- encodeW8 . L.unpack + <$> catFile ref (LsTree.file l) + case fileKey (takeFileName content) of + Nothing -> go ls + Just k -> do + a k + go ls + | otherwise = go ls {- Looks in the specified directory for bad/tmp keys, and returns a list - of those that might still have value, or might be stale and removable. diff --git a/Command/Version.hs b/Command/Version.hs index 4cc5cb4ae..907811e75 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -29,8 +29,8 @@ start = do putStrLn $ "supported repository versions: " ++ vs supportedVersions putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions stop - where - vs = join " " + where + vs = join " " showPackageVersion :: IO () showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 0466c0c31..cfe051c4e 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -75,119 +75,116 @@ setCfg curcfg newcfg = do diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String) diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap) - where - diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) - (f newcfg) (f curcfg) + where + diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) + (f newcfg) (f curcfg) genCfg :: Cfg -> M.Map UUID String -> String genCfg cfg descs = unlines $ concat [intro, trust, groups, preferredcontent] - where - intro = - [ com "git-annex configuration" - , com "" - , com "Changes saved to this file will be recorded in the git-annex branch." - , com "" - , com "Lines in this file have the format:" - , com " setting uuid = value" - ] - - trust = settings cfgTrustMap - [ "" - , com "Repository trust configuration" - , com "(Valid trust levels: " ++ - unwords (map showTrustLevel [Trusted .. DeadTrusted]) ++ - ")" - ] - (\(t, u) -> line "trust" u $ showTrustLevel t) - (\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted) - - groups = settings cfgGroupMap - [ "" - , com "Repository groups" - , com "(Separate group names with spaces)" - ] - (\(s, u) -> line "group" u $ unwords $ S.toList s) - (\u -> lcom $ line "group" u "") - - preferredcontent = settings cfgPreferredContentMap - [ "" - , com "Repository preferred contents" - ] - (\(s, u) -> line "preferred-content" u s) - (\u -> line "preferred-content" u "") - - settings field desc showvals showdefaults = concat - [ desc - , concatMap showvals $ - sort $ map swap $ M.toList $ field cfg - , concatMap (\u -> lcom $ showdefaults u) $ - missing field - ] - - line setting u value = - [ com $ "(for " ++ (fromMaybe "" $ M.lookup u descs) ++ ")" - , unwords [setting, fromUUID u, "=", value] - ] - lcom = map (\l -> if "#" `isPrefixOf` l then l else "#" ++ l) - missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg) + where + intro = + [ com "git-annex configuration" + , com "" + , com "Changes saved to this file will be recorded in the git-annex branch." + , com "" + , com "Lines in this file have the format:" + , com " setting uuid = value" + ] + + trust = settings cfgTrustMap + [ "" + , com "Repository trust configuration" + , com "(Valid trust levels: " ++ + unwords (map showTrustLevel [Trusted .. DeadTrusted]) ++ + ")" + ] + (\(t, u) -> line "trust" u $ showTrustLevel t) + (\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted) + + groups = settings cfgGroupMap + [ "" + , com "Repository groups" + , com "(Separate group names with spaces)" + ] + (\(s, u) -> line "group" u $ unwords $ S.toList s) + (\u -> lcom $ line "group" u "") + + preferredcontent = settings cfgPreferredContentMap + [ "" + , com "Repository preferred contents" + ] + (\(s, u) -> line "preferred-content" u s) + (\u -> line "preferred-content" u "") + + settings field desc showvals showdefaults = concat + [ desc + , concatMap showvals $ sort $ map swap $ M.toList $ field cfg + , concatMap (\u -> lcom $ showdefaults u) $ missing field + ] + + line setting u value = + [ com $ "(for " ++ (fromMaybe "" $ M.lookup u descs) ++ ")" + , unwords [setting, fromUUID u, "=", value] + ] + lcom = map (\l -> if "#" `isPrefixOf` l then l else "#" ++ l) + missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg) {- If there's a parse error, returns a new version of the file, - with the problem lines noted. -} parseCfg :: Cfg -> String -> Either String Cfg parseCfg curcfg = go [] curcfg . lines - where - go c cfg [] - | null (catMaybes $ map fst c) = Right cfg - | otherwise = Left $ unlines $ - badheader ++ concatMap showerr (reverse c) - go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of - Left msg -> go ((Just msg, l):c) cfg ls - Right cfg' -> go ((Nothing, l):c) cfg' ls - - parse l cfg - | null l = Right cfg - | "#" `isPrefixOf` l = Right cfg - | null setting || null u = Left "missing repository uuid" - | otherwise = handle cfg (toUUID u) setting value' - where - (setting, rest) = separate isSpace l - (r, value) = separate (== '=') rest - value' = trimspace value - u = reverse $ trimspace $ - reverse $ trimspace r - trimspace = dropWhile isSpace - - handle cfg u setting value - | setting == "trust" = case readTrustLevel value of - Nothing -> badval "trust value" value - Just t -> - let m = M.insert u t (cfgTrustMap cfg) - in Right $ cfg { cfgTrustMap = m } - | setting == "group" = - let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg) - in Right $ cfg { cfgGroupMap = m } - | setting == "preferred-content" = - case checkPreferredContentExpression value of - Just e -> Left e - Nothing -> - let m = M.insert u value (cfgPreferredContentMap cfg) - in Right $ cfg { cfgPreferredContentMap = m } - | otherwise = badval "setting" setting - - showerr (Just msg, l) = [parseerr ++ msg, l] - showerr (Nothing, l) - -- filter out the header and parse error lines - -- from any previous parse failure - | any (`isPrefixOf` l) (parseerr:badheader) = [] - | otherwise = [l] - - badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\"" - badheader = - [ com "There was a problem parsing your input." - , com "Search for \"Parse error\" to find the bad lines." - , com "Either fix the bad lines, or delete them (to discard your changes)." - ] - parseerr = com "Parse error in next line: " + where + go c cfg [] + | null (catMaybes $ map fst c) = Right cfg + | otherwise = Left $ unlines $ + badheader ++ concatMap showerr (reverse c) + go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of + Left msg -> go ((Just msg, l):c) cfg ls + Right cfg' -> go ((Nothing, l):c) cfg' ls + + parse l cfg + | null l = Right cfg + | "#" `isPrefixOf` l = Right cfg + | null setting || null u = Left "missing repository uuid" + | otherwise = handle cfg (toUUID u) setting value' + where + (setting, rest) = separate isSpace l + (r, value) = separate (== '=') rest + value' = trimspace value + u = reverse $ trimspace $ reverse $ trimspace r + trimspace = dropWhile isSpace + + handle cfg u setting value + | setting == "trust" = case readTrustLevel value of + Nothing -> badval "trust value" value + Just t -> + let m = M.insert u t (cfgTrustMap cfg) + in Right $ cfg { cfgTrustMap = m } + | setting == "group" = + let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg) + in Right $ cfg { cfgGroupMap = m } + | setting == "preferred-content" = + case checkPreferredContentExpression value of + Just e -> Left e + Nothing -> + let m = M.insert u value (cfgPreferredContentMap cfg) + in Right $ cfg { cfgPreferredContentMap = m } + | otherwise = badval "setting" setting + + showerr (Just msg, l) = [parseerr ++ msg, l] + showerr (Nothing, l) + -- filter out the header and parse error lines + -- from any previous parse failure + | any (`isPrefixOf` l) (parseerr:badheader) = [] + | otherwise = [l] + + badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\"" + badheader = + [ com "There was a problem parsing your input." + , com "Search for \"Parse error\" to find the bad lines." + , com "Either fix the bad lines, or delete them (to discard your changes)." + ] + parseerr = com "Parse error in next line: " com :: String -> String com s = "# " ++ s diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 43b090fc8..a0bd2e7f7 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -43,24 +43,24 @@ start' allowauto = notBareRepo $ do liftIO $ ensureInstalled ifM isInitialized ( go , auto ) stop - where - go = do - browser <- fromRepo webBrowser - f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim - ifM (checkpid <&&> checkshim f) - ( liftIO $ openBrowser browser f - , startDaemon True True $ Just $ - const $ openBrowser browser - ) - auto - | allowauto = liftIO startNoRepo - | otherwise = do - d <- liftIO getCurrentDirectory - error $ "no git repository in " ++ d - checkpid = do - pidfile <- fromRepo gitAnnexPidFile - liftIO $ isJust <$> checkDaemon pidfile - checkshim f = liftIO $ doesFileExist f + where + go = do + browser <- fromRepo webBrowser + f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim + ifM (checkpid <&&> checkshim f) + ( liftIO $ openBrowser browser f + , startDaemon True True $ Just $ + const $ openBrowser browser + ) + auto + | allowauto = liftIO startNoRepo + | otherwise = do + d <- liftIO getCurrentDirectory + error $ "no git repository in " ++ d + checkpid = do + pidfile <- fromRepo gitAnnexPidFile + liftIO $ isJust <$> checkDaemon pidfile + checkshim f = liftIO $ doesFileExist f {- When run without a repo, see if there is an autoStartFile, - and if so, start the first available listed repository. @@ -111,35 +111,35 @@ firstRun = do webAppThread d urlrenderer True (callback signaler) (callback mainthread) - where - signaler v = do - putMVar v "" - takeMVar v - mainthread v _url htmlshim = do - browser <- maybe Nothing webBrowser <$> Git.Config.global - openBrowser browser htmlshim + where + signaler v = do + putMVar v "" + takeMVar v + mainthread v _url htmlshim = do + browser <- maybe Nothing webBrowser <$> Git.Config.global + openBrowser browser htmlshim - _wait <- takeMVar v + _wait <- takeMVar v - state <- Annex.new =<< Git.CurrentRepo.get - Annex.eval state $ do - dummydaemonize - startAssistant True id $ Just $ sendurlback v - sendurlback v url _htmlshim = putMVar v url - {- Set up the pid file in the new repo. -} - dummydaemonize = - liftIO . lockPidFile =<< fromRepo gitAnnexPidFile + state <- Annex.new =<< Git.CurrentRepo.get + Annex.eval state $ do + dummydaemonize + startAssistant True id $ Just $ sendurlback v + sendurlback v url _htmlshim = putMVar v url + + {- Set up the pid file in the new repo. -} + dummydaemonize = liftIO . lockPidFile =<< fromRepo gitAnnexPidFile openBrowser :: Maybe FilePath -> FilePath -> IO () openBrowser cmd htmlshim = go $ maybe runBrowser runCustomBrowser cmd - where - url = fileUrl htmlshim - go a = do - putStrLn "" - putStrLn $ "Launching web browser on " ++ url - unlessM (a url) $ - error $ "failed to start web browser" - runCustomBrowser c u = boolSystem c [Param u] + where + url = fileUrl htmlshim + go a = do + putStrLn "" + putStrLn $ "Launching web browser on " ++ url + unlessM (a url) $ + error $ "failed to start web browser" + runCustomBrowser c u = boolSystem c [Param u] {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath diff --git a/Command/Whereis.hs b/Command/Whereis.hs index c77b3a02c..251c4ec7a 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -40,15 +40,15 @@ perform remotemap key = do forM_ (mapMaybe (`M.lookup` remotemap) locations) $ performRemote key if null safelocations then stop else next $ return True - where - copiesplural 1 = "copy" - copiesplural _ = "copies" - untrustedheader = "The following untrusted locations may also have copies:\n" + where + copiesplural 1 = "copy" + copiesplural _ = "copies" + untrustedheader = "The following untrusted locations may also have copies:\n" performRemote :: Key -> Remote -> Annex () performRemote key remote = maybe noop go $ whereisKey remote - where - go a = do - ls <- a key - unless (null ls) $ showLongNote $ unlines $ - map (\l -> name remote ++ ": " ++ l) ls + where + go a = do + ls <- a key + unless (null ls) $ showLongNote $ unlines $ + map (\l -> name remote ++ ": " ++ l) ls diff --git a/GitAnnex.hs b/GitAnnex.hs index dcde2644c..81667ee76 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -124,7 +124,6 @@ cmds = concat #ifdef WITH_ASSISTANT , Command.Watch.def , Command.Assistant.def - , Command.XMPPGit.def #ifdef WITH_WEBAPP , Command.WebApp.def #endif diff --git a/debian/changelog b/debian/changelog index cd9fb3b6a..f571eaa06 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,12 +1,13 @@ git-annex (3.20121018) UNRELEASED; urgency=low - * assistant: Can use XMPP to notify other nodes about pushes, as well - as pushing to them over XMPP. - * webapp: Now supports pairing over XMPP. - * assistant: Now drops non-preferred content. - * assistant: Now notices, and applies config changes - as they are made to the git-annex branch, including config changes - pushed in from remotes. + * assistant: Can use XMPP to notify other nodes about pushes made to other + repositories, as well as pushing to them directly over XMPP. + * wepapp: Added an XMPP configuration interface. + * webapp: Supports pairing over XMPP, with both friends, and other repos + using the same account. + * assistant: Drops non-preferred content when possible. + * assistant: Notices, and applies config changes as they are made to + the git-annex branch, including config changes pushed in from remotes. * git-annex-shell: GIT_ANNEX_SHELL_DIRECTORY can be set to limit it to operating on a specified directory. * webapp: When setting up authorized_keys, use GIT_ANNEX_SHELL_DIRECTORY. diff --git a/doc/assistant.mdwn b/doc/assistant.mdwn index c793be59f..c451d4573 100644 --- a/doc/assistant.mdwn +++ b/doc/assistant.mdwn @@ -3,14 +3,13 @@ removable drives, and cloud services, which it keeps synchronised, so its contents are the same everywhere. It's very easy to use, and has all the power of git and git-annex. -Note that the git-annex assistant is still beta quality code. See -[[the_errata|errata]] for known infelicities. - ## installation The git-annex assistant comes as part of git-annex, starting with version -3.20120924. It is still under heavy development, but the basics work well. -See [[install]] to get it installed. +3.20120924. See [[install]] to get it installed. + +Note that the git-annex assistant is still beta quality code. See +the [[release_notes]] for known infelicities and upgrade instructions. ## quick start diff --git a/doc/assistant/errata.mdwn b/doc/assistant/release_notes.mdwn index 03d0d4772..270897fa0 100644 --- a/doc/assistant/errata.mdwn +++ b/doc/assistant/release_notes.mdwn @@ -1,3 +1,49 @@ +## version 3.20121012 + +This is a major upgrade of the git-annex assistant, which is still in beta. + +In general, anything you can configure with the assistant's web app +will work. Some examples of use cases supported by this release include: + +* [[Sharing repositories with friends|share_with_a_friend_walkthrough]] + contacted through a Jabber server (such as Google Talk). +* Setting up cloud repositories, that are used as backups, archives, + or transfer points between repositories that cannot directly contact + one-another. +* [[Pairing|pairing_walkthrough]] two computers that are on the same local + network (or VPN) and automatically keeping the files in the annex in + sync as changes are made to them. +* Cloning your repository to removable drives, USB keys, etc. The assistant + will notice when the drive is mounted and keep it in sync. + Such a drive can be stored as an offline backup, or transported between + computers to keep them in sync. + +The following upgrade notes apply if you're upgrading from a previous version: + +* For best results, edit the configuration of repositories you set + up with older versions, and place them in a repository group. + This lets the assistant know how you want to use the repository; for backup, + archival, as a transfer point for clients, etc. Go to Configuration -> + Manage Repositories, and click in the "configure" link to edit a repository's + configuration. +* If you set up a cloud repository with an older version, and have multiple + clients using it, you are recommended to configure an Jabber account, + so that clients can use it to communicate when sending data to the + cloud repository. Configure Jabber by opening the webapp, and going to + Configuration -> Configure jabber account +* When setting up local pairing, the assistant did not limit the paired + computer to accessing a single git repository. This new version does, + by setting GIT_ANNEX_SHELL_DIRECTORY in `~/.ssh/authorized_keys`. + +The following are known limitations of this release of the git-annex +assistant: + +* On Mac OSX and BSD operating systems, the assistant uses kqueue to watch + files. Kqueue has to open every directory it watches, so too many + directories will run it out of the max number of open files (typically + 1024), and fail. See [[bugs/Issue_on_OSX_with_some_system_limits]] + for a workaround. + ## version 3.20121009 This is a maintenance release of the git-annex assistant, which is still in |