finished hlinting

This commit is contained in:
Joey Hess 2010-11-22 17:51:55 -04:00
parent 57adb0347b
commit eeae910242
23 changed files with 144 additions and 159 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View 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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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" ++

View file

@ -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.

View file

@ -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"

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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