summaryrefslogtreecommitdiff
path: root/Command
diff options
context:
space:
mode:
Diffstat (limited to 'Command')
-rw-r--r--Command/Add.hs58
-rw-r--r--Command/AddUnused.hs4
-rw-r--r--Command/AddUrl.hs58
-rw-r--r--Command/Assistant.hs8
-rw-r--r--Command/Commit.hs6
-rw-r--r--Command/Copy.hs8
-rw-r--r--Command/Drop.hs38
-rw-r--r--Command/DropUnused.hs14
-rw-r--r--Command/Find.hs26
-rw-r--r--Command/Fsck.hs162
-rw-r--r--Command/Get.hs60
-rw-r--r--Command/Help.hs4
-rw-r--r--Command/InAnnex.hs10
-rw-r--r--Command/Init.hs4
-rw-r--r--Command/InitRemote.hs36
-rw-r--r--Command/Log.hs89
-rw-r--r--Command/Map.hs165
-rw-r--r--Command/Migrate.hs20
-rw-r--r--Command/Move.hs62
-rw-r--r--Command/ReKey.hs14
-rw-r--r--Command/Reinject.hs24
-rw-r--r--Command/Status.hs113
-rw-r--r--Command/Sync.hs188
-rw-r--r--Command/Uninit.hs8
-rw-r--r--Command/Unlock.hs4
-rw-r--r--Command/Unused.hs146
-rw-r--r--Command/Version.hs4
-rw-r--r--Command/Vicfg.hs207
-rw-r--r--Command/WebApp.hs84
-rw-r--r--Command/Whereis.hs18
30 files changed, 817 insertions, 825 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 02:59:37 +0000