finished hlinting
This commit is contained in:
parent
57adb0347b
commit
eeae910242
23 changed files with 144 additions and 159 deletions
|
@ -30,7 +30,7 @@ module Backend (
|
|||
) where
|
||||
|
||||
import Control.Monad.State
|
||||
import IO (try)
|
||||
import System.IO.Error (try)
|
||||
import System.FilePath
|
||||
import System.Posix.Files
|
||||
|
||||
|
|
|
@ -34,7 +34,7 @@ backend = Backend {
|
|||
storeFileKey = dummyStore,
|
||||
retrieveKeyFile = copyKeyFile,
|
||||
removeKey = checkRemoveKey,
|
||||
hasKey = checkKeyFile,
|
||||
hasKey = inAnnex,
|
||||
fsckKey = mustProvide
|
||||
}
|
||||
|
||||
|
@ -42,19 +42,15 @@ mustProvide :: a
|
|||
mustProvide = error "must provide this field"
|
||||
|
||||
{- Storing a key is a no-op. -}
|
||||
dummyStore :: FilePath -> Key -> Annex (Bool)
|
||||
dummyStore :: FilePath -> Key -> Annex Bool
|
||||
dummyStore _ _ = return True
|
||||
|
||||
{- Just check if the .git/annex/ file for the key exists. -}
|
||||
checkKeyFile :: Key -> Annex Bool
|
||||
checkKeyFile k = inAnnex k
|
||||
|
||||
{- Try to find a copy of the file in one of the remotes,
|
||||
- and copy it over to this one. -}
|
||||
copyKeyFile :: Key -> FilePath -> Annex (Bool)
|
||||
copyKeyFile :: Key -> FilePath -> Annex Bool
|
||||
copyKeyFile key file = do
|
||||
remotes <- Remotes.keyPossibilities key
|
||||
if (null remotes)
|
||||
if null remotes
|
||||
then do
|
||||
showNote "not available"
|
||||
showLocations key
|
||||
|
@ -68,76 +64,72 @@ copyKeyFile key file = do
|
|||
return False
|
||||
trycopy full (r:rs) = do
|
||||
probablythere <- probablyPresent r
|
||||
if (probablythere)
|
||||
if probablythere
|
||||
then do
|
||||
showNote $ "copying from " ++ (Git.repoDescribe r) ++ "..."
|
||||
showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
|
||||
copied <- Remotes.copyFromRemote r key file
|
||||
if (copied)
|
||||
if copied
|
||||
then return True
|
||||
else trycopy full rs
|
||||
else trycopy full rs
|
||||
probablyPresent r = do
|
||||
-- This check is to avoid an ugly message if a
|
||||
-- remote is a drive that is not mounted.
|
||||
-- Avoid checking inAnnex for ssh remotes because
|
||||
-- that is unnecessarily slow, and the locationlog
|
||||
-- should be trusted. (If the ssh remote is down
|
||||
-- or really lacks the file, it's ok to show
|
||||
-- an ugly message before going on to the next
|
||||
-- remote.)
|
||||
if (not $ Git.repoIsUrl r)
|
||||
-- This check is to avoid an ugly message if a remote is a
|
||||
-- drive that is not mounted. Avoid checking inAnnex for ssh
|
||||
-- remotes because that is unnecessarily slow, and the
|
||||
-- locationlog should be trusted. (If the ssh remote is down
|
||||
-- or really lacks the file, it's ok to show an ugly message
|
||||
-- before going on to the next remote.)
|
||||
probablyPresent r =
|
||||
if not $ Git.repoIsUrl r
|
||||
then liftIO $ doesFileExist $ annexLocation r key
|
||||
else return True
|
||||
|
||||
{- Checks remotes to verify that enough copies of a key exist to allow
|
||||
- for a key to be safely removed (with no data loss), and fails with an
|
||||
- error if not. -}
|
||||
checkRemoveKey :: Key -> Annex (Bool)
|
||||
checkRemoveKey :: Key -> Annex Bool
|
||||
checkRemoveKey key = do
|
||||
force <- Annex.flagIsSet "force"
|
||||
if (force)
|
||||
if force
|
||||
then return True
|
||||
else do
|
||||
remotes <- Remotes.keyPossibilities key
|
||||
numcopies <- getNumCopies
|
||||
if (numcopies > length remotes)
|
||||
if numcopies > length remotes
|
||||
then notEnoughCopies numcopies (length remotes) []
|
||||
else findcopies numcopies 0 remotes []
|
||||
where
|
||||
findcopies need have [] bad =
|
||||
if (have >= need)
|
||||
then return True
|
||||
else notEnoughCopies need have bad
|
||||
findcopies need have (r:rs) bad = do
|
||||
if (have >= need)
|
||||
then return True
|
||||
else do
|
||||
haskey <- Remotes.inAnnex r key
|
||||
case (haskey) of
|
||||
Right True -> findcopies need (have+1) rs bad
|
||||
Right False -> findcopies need have rs bad
|
||||
Left _ -> findcopies need have rs (r:bad)
|
||||
findcopies need have [] bad
|
||||
| have >= need = return True
|
||||
| otherwise = notEnoughCopies need have bad
|
||||
findcopies need have (r:rs) bad
|
||||
| have >= need = return True
|
||||
| otherwise = do
|
||||
haskey <- Remotes.inAnnex r key
|
||||
case haskey of
|
||||
Right True -> findcopies need (have+1) rs bad
|
||||
Right False -> findcopies need have rs bad
|
||||
Left _ -> findcopies need have rs (r:bad)
|
||||
notEnoughCopies need have bad = do
|
||||
unsafe
|
||||
showLongNote $
|
||||
"Could only verify the existence of " ++
|
||||
(show have) ++ " out of " ++ (show need) ++
|
||||
show have ++ " out of " ++ show need ++
|
||||
" necessary copies"
|
||||
showTriedRemotes bad
|
||||
showLocations key
|
||||
hint
|
||||
return False
|
||||
unsafe = showNote "unsafe"
|
||||
hint = showLongNote $ "(Use --force to override this check, or adjust annex.numcopies.)"
|
||||
hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
|
||||
|
||||
showLocations :: Key -> Annex ()
|
||||
showLocations key = do
|
||||
g <- Annex.gitRepo
|
||||
u <- getUUID g
|
||||
uuids <- liftIO $ keyLocations g key
|
||||
let uuidsf = filter (\v -> v /= u) uuids
|
||||
let uuidsf = filter (/= u) uuids
|
||||
ppuuids <- prettyPrintUUIDs uuidsf
|
||||
if (null uuidsf)
|
||||
if null uuidsf
|
||||
then showLongNote $ "No other repository is known to contain the file."
|
||||
else showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
|
||||
|
||||
|
@ -145,7 +137,7 @@ showTriedRemotes :: [Git.Repo] -> Annex ()
|
|||
showTriedRemotes [] = return ()
|
||||
showTriedRemotes remotes =
|
||||
showLongNote $ "I was unable to access these remotes: " ++
|
||||
(Remotes.list remotes)
|
||||
Remotes.list remotes
|
||||
|
||||
getNumCopies :: Annex Int
|
||||
getNumCopies = do
|
||||
|
@ -173,7 +165,7 @@ checkKeyNumCopies key = do
|
|||
remotes <- Remotes.keyPossibilities key
|
||||
inannex <- inAnnex key
|
||||
let present = length remotes + if inannex then 1 else 0
|
||||
if (present < needed)
|
||||
if present < needed
|
||||
then do
|
||||
warning $ note present needed
|
||||
return False
|
||||
|
|
|
@ -33,15 +33,15 @@ sha1 file = do
|
|||
liftIO $ pOpen ReadFromPipe "sha1sum" [file] $ \h -> do
|
||||
line <- hGetLine h
|
||||
let bits = split " " line
|
||||
if (null bits)
|
||||
if null bits
|
||||
then error "sha1sum parse error"
|
||||
else return $ bits !! 0
|
||||
else return $ head bits
|
||||
|
||||
-- A key is a sha1 of its contents.
|
||||
keyValue :: FilePath -> Annex (Maybe Key)
|
||||
keyValue file = do
|
||||
s <- sha1 file
|
||||
return $ Just $ Key ((name backend), s)
|
||||
return $ Just $ Key (name backend, s)
|
||||
|
||||
-- A key's sha1 is checked during fsck.
|
||||
checkKeySHA1 :: Key -> Annex Bool
|
||||
|
@ -49,11 +49,11 @@ checkKeySHA1 key = do
|
|||
g <- Annex.gitRepo
|
||||
let file = annexLocation g key
|
||||
present <- liftIO $ doesFileExist file
|
||||
if (not present)
|
||||
if not present
|
||||
then return True
|
||||
else do
|
||||
s <- sha1 file
|
||||
if (s == keyName key)
|
||||
if s == keyName key
|
||||
then return True
|
||||
else do
|
||||
dest <- moveBad key
|
||||
|
|
|
@ -37,11 +37,11 @@ backend = Backend.File.backend {
|
|||
keyValue :: FilePath -> Annex (Maybe Key)
|
||||
keyValue file = do
|
||||
stat <- liftIO $ getFileStatus file
|
||||
return $ Just $ Key ((name backend), key stat)
|
||||
return $ Just $ Key (name backend, key stat)
|
||||
where
|
||||
key stat = uniqueid stat ++ sep ++ base
|
||||
uniqueid stat = (show $ modificationTime stat) ++ sep ++
|
||||
(show $ fileSize stat)
|
||||
uniqueid stat = show (modificationTime stat) ++ sep ++
|
||||
show (fileSize stat)
|
||||
base = takeFileName file
|
||||
sep = ":"
|
||||
|
||||
|
@ -58,11 +58,11 @@ checkKeySize key = do
|
|||
g <- Annex.gitRepo
|
||||
let file = annexLocation g key
|
||||
present <- liftIO $ doesFileExist file
|
||||
if (not present)
|
||||
if not present
|
||||
then return True
|
||||
else do
|
||||
s <- liftIO $ getFileStatus file
|
||||
if (fileSize s == keySize key)
|
||||
if fileSize s == keySize key
|
||||
then return True
|
||||
else do
|
||||
dest <- moveBad key
|
||||
|
|
|
@ -28,7 +28,7 @@ seek = [withFilesNotInGit start, withFilesUnlocked start]
|
|||
start :: SubCmdStartBackendFile
|
||||
start pair@(file, _) = notAnnexed file $ do
|
||||
s <- liftIO $ getSymbolicLinkStatus file
|
||||
if ((isSymbolicLink s) || (not $ isRegularFile s))
|
||||
if (isSymbolicLink s) || (not $ isRegularFile s)
|
||||
then return Nothing
|
||||
else do
|
||||
showStart "add" file
|
||||
|
@ -37,7 +37,7 @@ start pair@(file, _) = notAnnexed file $ do
|
|||
perform :: (FilePath, Maybe Backend) -> SubCmdPerform
|
||||
perform (file, backend) = do
|
||||
stored <- Backend.storeFileKey file backend
|
||||
case (stored) of
|
||||
case stored of
|
||||
Nothing -> return Nothing
|
||||
Just (key, _) -> return $ Just $ cleanup file key
|
||||
|
||||
|
|
|
@ -24,7 +24,7 @@ seek = [withFilesInGit start]
|
|||
start :: SubCmdStartString
|
||||
start file = isAnnexed file $ \(key, backend) -> do
|
||||
inbackend <- Backend.hasKey key
|
||||
if (not inbackend)
|
||||
if not inbackend
|
||||
then return Nothing
|
||||
else do
|
||||
showStart "drop" file
|
||||
|
@ -33,13 +33,13 @@ start file = isAnnexed file $ \(key, backend) -> do
|
|||
perform :: Key -> Backend -> SubCmdPerform
|
||||
perform key backend = do
|
||||
success <- Backend.removeKey backend key
|
||||
if (success)
|
||||
if success
|
||||
then return $ Just $ cleanup key
|
||||
else return Nothing
|
||||
|
||||
cleanup :: Key -> SubCmdCleanup
|
||||
cleanup key = do
|
||||
inannex <- inAnnex key
|
||||
when (inannex) $ removeAnnex key
|
||||
when inannex $ removeAnnex key
|
||||
logStatus key ValueMissing
|
||||
return True
|
||||
|
|
|
@ -22,12 +22,12 @@ seek = [withKeys start]
|
|||
start :: SubCmdStartString
|
||||
start keyname = do
|
||||
backends <- Backend.list
|
||||
let key = genKey (backends !! 0) keyname
|
||||
let key = genKey (head backends) keyname
|
||||
present <- inAnnex key
|
||||
force <- Annex.flagIsSet "force"
|
||||
if (not present)
|
||||
if not present
|
||||
then return Nothing
|
||||
else if (not force)
|
||||
else if not force
|
||||
then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
|
||||
else do
|
||||
showStart "dropkey" keyname
|
||||
|
|
|
@ -20,5 +20,5 @@ seek = [withDefault "." withFilesInGit start]
|
|||
start :: SubCmdStartString
|
||||
start file = isAnnexed file $ \(key, _) -> do
|
||||
exists <- inAnnex key
|
||||
when (exists) $ liftIO $ putStrLn file
|
||||
when exists $ liftIO $ putStrLn file
|
||||
return Nothing
|
||||
|
|
|
@ -25,7 +25,7 @@ start :: SubCmdStartString
|
|||
start file = isAnnexed file $ \(key, _) -> do
|
||||
link <- calcGitLink file key
|
||||
l <- liftIO $ readSymbolicLink file
|
||||
if (link == l)
|
||||
if link == l
|
||||
then return Nothing
|
||||
else do
|
||||
showStart "fix" file
|
||||
|
|
|
@ -29,10 +29,10 @@ start file = do
|
|||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
backends <- Backend.list
|
||||
let key = genKey (backends !! 0) keyname
|
||||
let key = genKey (head backends) keyname
|
||||
|
||||
inbackend <- Backend.hasKey key
|
||||
unless (inbackend) $ error $
|
||||
unless inbackend $ error $
|
||||
"key ("++keyname++") is not present in backend"
|
||||
showStart "fromkey" file
|
||||
return $ Just $ perform file key
|
||||
|
|
|
@ -24,6 +24,6 @@ start file = isAnnexed file $ \(key, backend) -> do
|
|||
perform :: Key -> Backend -> SubCmdPerform
|
||||
perform key backend = do
|
||||
success <- Backend.fsckKey backend key
|
||||
if (success)
|
||||
if success
|
||||
then return $ Just $ return True
|
||||
else return Nothing
|
||||
|
|
|
@ -24,6 +24,6 @@ start file = isAnnexed file $ \(key, backend) -> do
|
|||
perform :: Key -> Backend -> SubCmdPerform
|
||||
perform key backend = do
|
||||
success <- Backend.fsckKey backend key
|
||||
if (success)
|
||||
if success
|
||||
then return $ Just $ return True
|
||||
else return Nothing
|
||||
|
|
|
@ -20,7 +20,7 @@ seek = [withFilesInGit start]
|
|||
start :: SubCmdStartString
|
||||
start file = isAnnexed file $ \(key, backend) -> do
|
||||
inannex <- inAnnex key
|
||||
if (inannex)
|
||||
if inannex
|
||||
then return Nothing
|
||||
else do
|
||||
showStart "get" file
|
||||
|
@ -29,7 +29,7 @@ start file = isAnnexed file $ \(key, backend) -> do
|
|||
perform :: Key -> Backend -> SubCmdPerform
|
||||
perform key backend = do
|
||||
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
|
||||
if (ok)
|
||||
if ok
|
||||
then return $ Just $ return True -- no cleanup needed
|
||||
else return Nothing
|
||||
|
||||
|
|
|
@ -25,8 +25,8 @@ seek = [withString start]
|
|||
{- Stores description for the repository etc. -}
|
||||
start :: SubCmdStartString
|
||||
start description = do
|
||||
when (null description) $ error $
|
||||
"please specify a description of this repository\n"
|
||||
when (null description) $
|
||||
error "please specify a description of this repository\n"
|
||||
showStart "init" description
|
||||
return $ Just $ perform description
|
||||
|
||||
|
@ -38,7 +38,7 @@ perform description = do
|
|||
setVersion
|
||||
liftIO $ gitAttributes g
|
||||
liftIO $ gitPreCommitHook g
|
||||
return $ Just $ cleanup
|
||||
return $ Just cleanup
|
||||
|
||||
cleanup :: SubCmdCleanup
|
||||
cleanup = do
|
||||
|
@ -53,7 +53,7 @@ cleanup = do
|
|||
gitAttributes :: Git.Repo -> IO ()
|
||||
gitAttributes repo = do
|
||||
exists <- doesFileExist attributes
|
||||
if (not exists)
|
||||
if not exists
|
||||
then do
|
||||
writeFile attributes $ attrLine ++ "\n"
|
||||
commit
|
||||
|
@ -76,7 +76,7 @@ gitPreCommitHook repo = do
|
|||
let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++
|
||||
"/hooks/pre-commit"
|
||||
exists <- doesFileExist hook
|
||||
if (exists)
|
||||
if exists
|
||||
then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
|
||||
else do
|
||||
writeFile hook $ "#!/bin/sh\n" ++
|
||||
|
|
|
@ -7,8 +7,7 @@
|
|||
|
||||
module Command.Move where
|
||||
|
||||
import Control.Monad.State (liftIO)
|
||||
import Monad (when)
|
||||
import Control.Monad.State (liftIO, when)
|
||||
|
||||
import Command
|
||||
import qualified Command.Drop
|
||||
|
@ -53,7 +52,7 @@ start file = do
|
|||
moveToStart :: SubCmdStartString
|
||||
moveToStart file = isAnnexed file $ \(key, _) -> do
|
||||
ishere <- inAnnex key
|
||||
if (not ishere)
|
||||
if not ishere
|
||||
then return Nothing -- not here, so nothing to do
|
||||
else do
|
||||
showStart "move" file
|
||||
|
@ -68,10 +67,10 @@ moveToPerform key = do
|
|||
showNote $ show err
|
||||
return Nothing
|
||||
Right False -> do
|
||||
showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..."
|
||||
let tmpfile = (annexTmpLocation remote) ++ (keyFile key)
|
||||
showNote $ "moving to " ++ Git.repoDescribe remote ++ "..."
|
||||
let tmpfile = annexTmpLocation remote ++ keyFile key
|
||||
ok <- Remotes.copyToRemote remote key tmpfile
|
||||
if (ok)
|
||||
if ok
|
||||
then return $ Just $ moveToCleanup remote key tmpfile
|
||||
else return Nothing -- failed
|
||||
Right True -> return $ Just $ Command.Drop.cleanup key
|
||||
|
@ -79,7 +78,7 @@ moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
|
|||
moveToCleanup remote key tmpfile = do
|
||||
-- Tell remote to use the transferred content.
|
||||
ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
|
||||
"--backend=" ++ (backendName key),
|
||||
"--backend=" ++ backendName key,
|
||||
"--key=" ++ keyName key,
|
||||
tmpfile]
|
||||
if ok
|
||||
|
@ -104,7 +103,7 @@ moveFromStart :: SubCmdStartString
|
|||
moveFromStart file = isAnnexed file $ \(key, _) -> do
|
||||
remote <- Remotes.commandLineRemote
|
||||
l <- Remotes.keyPossibilities key
|
||||
if (null $ filter (\r -> Remotes.same r remote) l)
|
||||
if null $ filter (\r -> Remotes.same r remote) l
|
||||
then return Nothing
|
||||
else do
|
||||
showStart "move" file
|
||||
|
@ -113,18 +112,18 @@ moveFromPerform :: Key -> SubCmdPerform
|
|||
moveFromPerform key = do
|
||||
remote <- Remotes.commandLineRemote
|
||||
ishere <- inAnnex key
|
||||
if (ishere)
|
||||
if ishere
|
||||
then return $ Just $ moveFromCleanup remote key
|
||||
else do
|
||||
showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..."
|
||||
ok <- getViaTmp key (Remotes.copyFromRemote remote key)
|
||||
if (ok)
|
||||
showNote $ "moving from " ++ Git.repoDescribe remote ++ "..."
|
||||
ok <- getViaTmp key $ Remotes.copyFromRemote remote key
|
||||
if ok
|
||||
then return $ Just $ moveFromCleanup remote key
|
||||
else return Nothing -- fail
|
||||
moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
|
||||
moveFromCleanup remote key = do
|
||||
ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
|
||||
"--backend=" ++ (backendName key),
|
||||
"--backend=" ++ backendName key,
|
||||
keyName key]
|
||||
when ok $ do
|
||||
-- Record locally that the key is not on the remote.
|
||||
|
|
|
@ -28,7 +28,7 @@ start file = return $ Just $ perform file
|
|||
perform :: FilePath -> SubCmdPerform
|
||||
perform file = do
|
||||
pairs <- Backend.chooseBackends [file]
|
||||
ok <- doSubCmd $ Command.Add.start $ pairs !! 0
|
||||
ok <- doSubCmd $ Command.Add.start $ head pairs
|
||||
if ok
|
||||
then return $ Just $ cleanup file
|
||||
else error $ "failed to add " ++ file ++ "; canceling commit"
|
||||
|
|
|
@ -28,7 +28,7 @@ start file = do
|
|||
keyname <- Annex.flagGet "key"
|
||||
when (null keyname) $ error "please specify the key with --key"
|
||||
backends <- Backend.list
|
||||
let key = genKey (backends !! 0) keyname
|
||||
let key = genKey (head backends) keyname
|
||||
showStart "setkey" file
|
||||
return $ Just $ perform file key
|
||||
perform :: FilePath -> Key -> SubCmdPerform
|
||||
|
|
|
@ -34,7 +34,7 @@ perform file key backend = do
|
|||
-- force backend to always remove
|
||||
Annex.flagChange "force" $ FlagBool True
|
||||
ok <- Backend.removeKey backend key
|
||||
if (ok)
|
||||
if ok
|
||||
then return $ Just $ cleanup file key
|
||||
else return Nothing
|
||||
|
||||
|
|
|
@ -35,7 +35,7 @@ checkUnused :: Annex Bool
|
|||
checkUnused = do
|
||||
showNote "checking for unused data..."
|
||||
unused <- unusedKeys
|
||||
if (null unused)
|
||||
if null unused
|
||||
then return True
|
||||
else do
|
||||
let list = number 1 unused
|
||||
|
@ -48,9 +48,10 @@ checkUnused = do
|
|||
w u = unlines $
|
||||
["Some annexed data is no longer pointed to by any files in the repository:",
|
||||
" NUMBER KEY"]
|
||||
++ (map (\(n, k) -> " " ++ (pad 6 $ show n) ++ " " ++ show k) u) ++
|
||||
++ map cols u ++
|
||||
["(To see where data was previously used, try: git log --stat -S'KEY')",
|
||||
"(To remove unwanted data: git-annex dropunused NUMBER)"]
|
||||
cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ show k
|
||||
pad n s = s ++ replicate (n - length s) ' '
|
||||
|
||||
number :: Integer -> [a] -> [(Integer, a)]
|
||||
|
@ -71,8 +72,7 @@ unusedKeys = do
|
|||
let unused_m = remove referenced present_m
|
||||
return $ M.keys unused_m
|
||||
where
|
||||
remove [] m = m
|
||||
remove (x:xs) m = remove xs $ M.delete x m
|
||||
remove a b = foldl (flip M.delete) b a
|
||||
|
||||
existsMap :: Ord k => [k] -> M.Map k Int
|
||||
existsMap l = M.fromList $ map (\k -> (k, 1)) l
|
||||
|
|
2
Core.hs
2
Core.hs
|
@ -7,7 +7,7 @@
|
|||
|
||||
module Core where
|
||||
|
||||
import IO (try)
|
||||
import System.IO.Error (try)
|
||||
import System.Directory
|
||||
import Control.Monad.State (liftIO)
|
||||
import System.Path
|
||||
|
|
98
Remotes.hs
98
Remotes.hs
|
@ -17,16 +17,14 @@ module Remotes (
|
|||
runCmd
|
||||
) where
|
||||
|
||||
import IO (bracket_)
|
||||
import Control.Exception.Extensible hiding (bracket_)
|
||||
import Control.Exception.Extensible
|
||||
import Control.Monad.State (liftIO)
|
||||
import Control.Monad (filterM)
|
||||
import qualified Data.Map as Map
|
||||
import Data.String.Utils
|
||||
import System.Directory hiding (copyFile)
|
||||
import System.Posix.Directory
|
||||
import List
|
||||
import Monad (when, unless)
|
||||
import Data.List
|
||||
import Control.Monad (when, unless, filterM)
|
||||
|
||||
import Types
|
||||
import qualified GitRepo as Git
|
||||
|
@ -55,7 +53,7 @@ keyPossibilities key = do
|
|||
-- But, reading the config of remotes can be expensive, so make
|
||||
-- sure we only do it once per git-annex run.
|
||||
remotesread <- Annex.flagIsSet "remotesread"
|
||||
if (remotesread)
|
||||
if remotesread
|
||||
then reposByUUID allremotes uuids
|
||||
else do
|
||||
-- We assume that it's cheap to read the config
|
||||
|
@ -65,11 +63,11 @@ keyPossibilities key = do
|
|||
let cheap = filter (not . Git.repoIsUrl) allremotes
|
||||
let expensive = filter Git.repoIsUrl allremotes
|
||||
doexpensive <- filterM cachedUUID expensive
|
||||
unless (null doexpensive) $ do
|
||||
unless (null doexpensive) $
|
||||
showNote $ "getting UUID for " ++
|
||||
(list doexpensive) ++ "..."
|
||||
list doexpensive ++ "..."
|
||||
let todo = cheap ++ doexpensive
|
||||
if (not $ null todo)
|
||||
if not $ null todo
|
||||
then do
|
||||
_ <- mapM tryGitConfigRead todo
|
||||
Annex.flagChange "remotesread" $ FlagBool True
|
||||
|
@ -84,10 +82,9 @@ keyPossibilities key = do
|
|||
- If the remote cannot be accessed, returns a Left error.
|
||||
-}
|
||||
inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
|
||||
inAnnex r key = do
|
||||
if (not $ Git.repoIsUrl r)
|
||||
then liftIO $ ((try checklocal)::IO (Either IOException Bool))
|
||||
else checkremote
|
||||
inAnnex r key = if Git.repoIsUrl r
|
||||
then checkremote
|
||||
else liftIO (try checklocal ::IO (Either IOException Bool))
|
||||
where
|
||||
checklocal = do
|
||||
-- run a local check by making an Annex monad
|
||||
|
@ -112,12 +109,12 @@ reposByCost :: [Git.Repo] -> Annex [Git.Repo]
|
|||
reposByCost l = do
|
||||
notignored <- filterM repoNotIgnored l
|
||||
costpairs <- mapM costpair notignored
|
||||
return $ fst $ unzip $ sortBy bycost $ costpairs
|
||||
return $ fst $ unzip $ sortBy cmpcost costpairs
|
||||
where
|
||||
costpair r = do
|
||||
cost <- repoCost r
|
||||
return (r, cost)
|
||||
bycost (_, c1) (_, c2) = compare c1 c2
|
||||
cmpcost (_, c1) (_, c2) = compare c1 c2
|
||||
|
||||
{- Calculates cost for a repo.
|
||||
-
|
||||
|
@ -127,9 +124,9 @@ reposByCost l = do
|
|||
repoCost :: Git.Repo -> Annex Int
|
||||
repoCost r = do
|
||||
cost <- repoConfig r "cost" ""
|
||||
if (not $ null cost)
|
||||
if not $ null cost
|
||||
then return $ read cost
|
||||
else if (Git.repoIsUrl r)
|
||||
else if Git.repoIsUrl r
|
||||
then return 200
|
||||
else return 100
|
||||
|
||||
|
@ -141,13 +138,12 @@ repoNotIgnored r = do
|
|||
ignored <- repoConfig r "ignore" "false"
|
||||
fromName <- Annex.flagGet "fromrepository"
|
||||
toName <- Annex.flagGet "torepository"
|
||||
let name = if (not $ null fromName) then fromName else toName
|
||||
if (not $ null name)
|
||||
let name = if null fromName then toName else fromName
|
||||
if not $ null name
|
||||
then return $ match name
|
||||
else return $ not $ isIgnored ignored
|
||||
else return $ not $ Git.configTrue ignored
|
||||
where
|
||||
match name = name == Git.repoRemoteName r
|
||||
isIgnored ignored = Git.configTrue ignored
|
||||
|
||||
{- Checks if two repos are the same, by comparing their remote names. -}
|
||||
same :: Git.Repo -> Git.Repo -> Bool
|
||||
|
@ -158,14 +154,14 @@ commandLineRemote :: Annex Git.Repo
|
|||
commandLineRemote = do
|
||||
fromName <- Annex.flagGet "fromrepository"
|
||||
toName <- Annex.flagGet "torepository"
|
||||
let name = if (not $ null fromName) then fromName else toName
|
||||
let name = if null fromName then toName else fromName
|
||||
when (null name) $ error "no remote specified"
|
||||
g <- Annex.gitRepo
|
||||
let match = filter (\r -> name == Git.repoRemoteName r) $
|
||||
Git.remotes g
|
||||
when (null match) $ error $
|
||||
"there is no git remote named \"" ++ name ++ "\""
|
||||
return $ match !! 0
|
||||
return $ head match
|
||||
|
||||
{- The git configs for the git repo's remotes is not read on startup
|
||||
- because reading it may be expensive. This function tries to read the
|
||||
|
@ -174,12 +170,12 @@ commandLineRemote = do
|
|||
tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo)
|
||||
tryGitConfigRead r = do
|
||||
sshoptions <- repoConfig r "ssh-options" ""
|
||||
if (Map.null $ Git.configMap r)
|
||||
if Map.null $ Git.configMap r
|
||||
then do
|
||||
-- configRead can fail due to IO error or
|
||||
-- for other reasons; catch all possible exceptions
|
||||
result <- liftIO $ (try (Git.configRead r $ Just $ words sshoptions)::IO (Either SomeException (Git.Repo)))
|
||||
case (result) of
|
||||
result <- liftIO (try (Git.configRead r $ Just $ words sshoptions)::IO (Either SomeException Git.Repo))
|
||||
case result of
|
||||
Left _ -> return $ Left r
|
||||
Right r' -> do
|
||||
g <- Annex.gitRepo
|
||||
|
@ -192,18 +188,16 @@ tryGitConfigRead r = do
|
|||
where
|
||||
exchange [] _ = []
|
||||
exchange (old:ls) new =
|
||||
if (Git.repoRemoteName old == Git.repoRemoteName new)
|
||||
then new:(exchange ls new)
|
||||
else old:(exchange ls new)
|
||||
if Git.repoRemoteName old == Git.repoRemoteName new
|
||||
then new : exchange ls new
|
||||
else old : exchange ls new
|
||||
|
||||
{- Tries to copy a key's content from a remote to a file. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file = do
|
||||
if (not $ Git.repoIsUrl r)
|
||||
then getlocal
|
||||
else if (Git.repoIsSsh r)
|
||||
then getssh
|
||||
else error "copying from non-ssh repo not supported"
|
||||
copyFromRemote r key file
|
||||
| not $ Git.repoIsUrl r = getlocal
|
||||
| Git.repoIsSsh r = getssh
|
||||
| otherwise = error "copying from non-ssh repo not supported"
|
||||
where
|
||||
getlocal = liftIO $ copyFile keyloc file
|
||||
getssh = scp r [sshLocation r keyloc, file]
|
||||
|
@ -214,9 +208,9 @@ copyToRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
|||
copyToRemote r key file = do
|
||||
g <- Annex.gitRepo
|
||||
let keyloc = annexLocation g key
|
||||
if (not $ Git.repoIsUrl r)
|
||||
if not $ Git.repoIsUrl r
|
||||
then putlocal keyloc
|
||||
else if (Git.repoIsSsh r)
|
||||
else if Git.repoIsSsh r
|
||||
then putssh keyloc
|
||||
else error "copying to non-ssh repo not supported"
|
||||
where
|
||||
|
@ -224,7 +218,7 @@ copyToRemote r key file = do
|
|||
putssh src = scp r [src, sshLocation r file]
|
||||
|
||||
sshLocation :: Git.Repo -> FilePath -> FilePath
|
||||
sshLocation r file = (Git.urlHost r) ++ ":" ++ shellEscape file
|
||||
sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
|
||||
|
||||
{- Runs scp against a specified remote. (Honors annex-scp-options.) -}
|
||||
scp :: Git.Repo -> [String] -> Annex Bool
|
||||
|
@ -238,21 +232,21 @@ scp r params = do
|
|||
runCmd :: Git.Repo -> String -> [String] -> Annex Bool
|
||||
runCmd r command params = do
|
||||
sshoptions <- repoConfig r "ssh-options" ""
|
||||
if (not $ Git.repoIsUrl r)
|
||||
if not $ Git.repoIsUrl r
|
||||
then do
|
||||
cwd <- liftIO $ getCurrentDirectory
|
||||
liftIO $ bracket_ (changeWorkingDirectory (Git.workTree r))
|
||||
(\_ -> changeWorkingDirectory cwd) $
|
||||
boolSystem command params
|
||||
else if (Git.repoIsSsh r)
|
||||
then do
|
||||
liftIO $ boolSystem "ssh" $
|
||||
(words sshoptions) ++
|
||||
[Git.urlHost r, "cd " ++
|
||||
(shellEscape $ Git.workTree r) ++
|
||||
" && " ++ (shellEscape command) ++ " " ++
|
||||
(unwords $ map shellEscape params)]
|
||||
cwd <- liftIO getCurrentDirectory
|
||||
liftIO $ bracket_
|
||||
(changeWorkingDirectory (Git.workTree r))
|
||||
(changeWorkingDirectory cwd)
|
||||
(boolSystem command params)
|
||||
else if Git.repoIsSsh r
|
||||
then liftIO $ boolSystem "ssh" $
|
||||
words sshoptions ++ [Git.urlHost r, sshcmd]
|
||||
else error "running command in non-ssh repo not supported"
|
||||
where
|
||||
sshcmd = "cd " ++ shellEscape (Git.workTree r) ++
|
||||
" && " ++ shellEscape command ++ " " ++
|
||||
unwords (map shellEscape params)
|
||||
|
||||
{- Looks up a per-remote config option in git config.
|
||||
- Failing that, tries looking for a global config option. -}
|
||||
|
@ -262,5 +256,5 @@ repoConfig r key def = do
|
|||
let def' = Git.configGet g global def
|
||||
return $ Git.configGet g local def'
|
||||
where
|
||||
local = "remote." ++ (Git.repoRemoteName r) ++ ".annex-" ++ key
|
||||
local = "remote." ++ Git.repoRemoteName r ++ ".annex-" ++ key
|
||||
global = "annex." ++ key
|
||||
|
|
18
Utility.hs
18
Utility.hs
|
@ -35,12 +35,12 @@ hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
|
|||
{- Returns the parent directory of a path. Parent of / is "" -}
|
||||
parentDir :: String -> String
|
||||
parentDir dir =
|
||||
if (not $ null dirs)
|
||||
then slash ++ (join s $ take ((length dirs) - 1) dirs)
|
||||
if not $ null dirs
|
||||
then slash ++ join s (take (length dirs - 1) dirs)
|
||||
else ""
|
||||
where
|
||||
dirs = filter (\x -> not $ null x) $ split s dir
|
||||
slash = if (not $ isAbsolute dir) then "" else s
|
||||
dirs = filter (not . null) $ split s dir
|
||||
slash = if isAbsolute dir then s else ""
|
||||
s = [pathSeparator]
|
||||
|
||||
{- Constructs a relative path from the CWD to a directory.
|
||||
|
@ -58,7 +58,7 @@ relPathCwdToDir dir = do
|
|||
where
|
||||
-- absolute, normalized form of the directory
|
||||
absnorm cwd =
|
||||
case (absNormPath cwd dir) of
|
||||
case absNormPath cwd dir of
|
||||
Just d -> d
|
||||
Nothing -> error $ "unable to normalize " ++ dir
|
||||
|
||||
|
@ -70,7 +70,7 @@ relPathCwdToDir dir = do
|
|||
-}
|
||||
relPathDirToDir :: FilePath -> FilePath -> FilePath
|
||||
relPathDirToDir from to =
|
||||
if (not $ null path)
|
||||
if not $ null path
|
||||
then addTrailingPathSeparator path
|
||||
else ""
|
||||
where
|
||||
|
@ -80,8 +80,8 @@ relPathDirToDir from to =
|
|||
common = map fst $ filter same $ zip pfrom pto
|
||||
same (c,d) = c == d
|
||||
uncommon = drop numcommon pto
|
||||
dotdots = take ((length pfrom) - numcommon) $ repeat ".."
|
||||
numcommon = length $ common
|
||||
dotdots = replicate (length pfrom - numcommon) ".."
|
||||
numcommon = length common
|
||||
path = join s $ dotdots ++ uncommon
|
||||
|
||||
{- Run a system command, and returns True or False
|
||||
|
@ -124,4 +124,4 @@ shellEscape f = "'" ++ escaped ++ "'"
|
|||
unsetFileMode :: FilePath -> FileMode -> IO ()
|
||||
unsetFileMode f m = do
|
||||
s <- getFileStatus f
|
||||
setFileMode f $ (fileMode s) `intersectFileModes` (complement m)
|
||||
setFileMode f $ fileMode s `intersectFileModes` complement m
|
||||
|
|
|
@ -25,13 +25,13 @@ getVersion :: Annex (Maybe String)
|
|||
getVersion = do
|
||||
g <- Annex.gitRepo
|
||||
let v = Git.configGet g versionField ""
|
||||
if (not $ null v)
|
||||
if not $ null v
|
||||
then return $ Just v
|
||||
else do
|
||||
-- version 0 was not recorded in .git/config;
|
||||
-- such a repo should have an annexDir
|
||||
d <- liftIO $ doesDirectoryExist $ annexDir g
|
||||
if (d)
|
||||
if d
|
||||
then return $ Just "0"
|
||||
else return Nothing -- no version yet
|
||||
|
||||
|
|
Loading…
Reference in a new issue