hlinted a few files
This commit is contained in:
parent
016b6a59e7
commit
a3519c365f
5 changed files with 32 additions and 34 deletions
4
Annex.hs
4
Annex.hs
|
@ -50,9 +50,9 @@ new gitrepo allbackends = do
|
||||||
|
|
||||||
{- performs an action in the Annex monad -}
|
{- performs an action in the Annex monad -}
|
||||||
run :: AnnexState -> StateT AnnexState IO a -> IO (a, AnnexState)
|
run :: AnnexState -> StateT AnnexState IO a -> IO (a, AnnexState)
|
||||||
run state action = runStateT (action) state
|
run state action = runStateT action state
|
||||||
eval :: AnnexState -> StateT AnnexState IO a -> IO a
|
eval :: AnnexState -> StateT AnnexState IO a -> IO a
|
||||||
eval state action = evalStateT (action) state
|
eval state action = evalStateT action state
|
||||||
|
|
||||||
{- Returns the git repository being acted on -}
|
{- Returns the git repository being acted on -}
|
||||||
gitRepo :: Annex Git.Repo
|
gitRepo :: Annex Git.Repo
|
||||||
|
|
13
Backend.hs
13
Backend.hs
|
@ -53,7 +53,7 @@ list = do
|
||||||
let l' = if (not $ null backendflag)
|
let l' = if (not $ null backendflag)
|
||||||
then (lookupBackendName bs backendflag):defaults
|
then (lookupBackendName bs backendflag):defaults
|
||||||
else defaults
|
else defaults
|
||||||
Annex.backendsChange $ l'
|
Annex.backendsChange l'
|
||||||
return l'
|
return l'
|
||||||
where
|
where
|
||||||
parseBackendList bs s =
|
parseBackendList bs s =
|
||||||
|
@ -71,7 +71,7 @@ maybeLookupBackendName :: [Backend] -> String -> Maybe Backend
|
||||||
maybeLookupBackendName bs s =
|
maybeLookupBackendName bs s =
|
||||||
if ((length matches) /= 1)
|
if ((length matches) /= 1)
|
||||||
then Nothing
|
then Nothing
|
||||||
else Just $ matches !! 0
|
else Just $ head matches
|
||||||
where matches = filter (\b -> s == Internals.name b) bs
|
where matches = filter (\b -> s == Internals.name b) bs
|
||||||
|
|
||||||
{- Attempts to store a file in one of the backends. -}
|
{- Attempts to store a file in one of the backends. -}
|
||||||
|
@ -88,14 +88,13 @@ storeFileKey' :: [Backend] -> FilePath -> FilePath -> Annex (Maybe (Key, Backend
|
||||||
storeFileKey' [] _ _ = return Nothing
|
storeFileKey' [] _ _ = return Nothing
|
||||||
storeFileKey' (b:bs) file relfile = do
|
storeFileKey' (b:bs) file relfile = do
|
||||||
result <- (Internals.getKey b) relfile
|
result <- (Internals.getKey b) relfile
|
||||||
case (result) of
|
case result of
|
||||||
Nothing -> nextbackend
|
Nothing -> nextbackend
|
||||||
Just key -> do
|
Just key -> do
|
||||||
stored <- (Internals.storeFileKey b) file key
|
stored <- (Internals.storeFileKey b) file key
|
||||||
if (not stored)
|
if (not stored)
|
||||||
then nextbackend
|
then nextbackend
|
||||||
else do
|
else return $ Just (key, b)
|
||||||
return $ Just (key, b)
|
|
||||||
where
|
where
|
||||||
nextbackend = storeFileKey' bs file relfile
|
nextbackend = storeFileKey' bs file relfile
|
||||||
|
|
||||||
|
@ -127,8 +126,8 @@ lookupFile file = do
|
||||||
getsymlink = do
|
getsymlink = do
|
||||||
l <- readSymbolicLink file
|
l <- readSymbolicLink file
|
||||||
return $ takeFileName l
|
return $ takeFileName l
|
||||||
makekey bs l = do
|
makekey bs l =
|
||||||
case maybeLookupBackendName bs $ bname of
|
case maybeLookupBackendName bs bname of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
unless (null kname || null bname) $
|
unless (null kname || null bname) $
|
||||||
warning skip
|
warning skip
|
||||||
|
|
14
Core.hs
14
Core.hs
|
@ -13,7 +13,7 @@ import System.Directory
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
import System.Path
|
import System.Path
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
import Monad (when, unless)
|
import Control.Monad (when, unless)
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Locations
|
import Locations
|
||||||
|
@ -40,7 +40,7 @@ tryRun' state errnum (a:as) = do
|
||||||
Right (True,state') -> tryRun' state' errnum as
|
Right (True,state') -> tryRun' state' errnum as
|
||||||
Right (False,state') -> tryRun' state' (errnum + 1) as
|
Right (False,state') -> tryRun' state' (errnum + 1) as
|
||||||
tryRun' _ errnum [] =
|
tryRun' _ errnum [] =
|
||||||
when (errnum > 0) $ error $ (show errnum) ++ " failed"
|
when (errnum > 0) $ error $ show errnum ++ " failed"
|
||||||
|
|
||||||
{- Sets up a git repo for git-annex. -}
|
{- Sets up a git repo for git-annex. -}
|
||||||
startup :: Annex Bool
|
startup :: Annex Bool
|
||||||
|
@ -63,7 +63,7 @@ shutdown = do
|
||||||
-- the tmp directory itself
|
-- the tmp directory itself
|
||||||
let tmp = annexTmpLocation g
|
let tmp = annexTmpLocation g
|
||||||
exists <- liftIO $ doesDirectoryExist tmp
|
exists <- liftIO $ doesDirectoryExist tmp
|
||||||
when (exists) $ liftIO $ removeDirectoryRecursive $ tmp
|
when (exists) $ liftIO $ removeDirectoryRecursive tmp
|
||||||
liftIO $ createDirectoryIfMissing True tmp
|
liftIO $ createDirectoryIfMissing True tmp
|
||||||
|
|
||||||
return True
|
return True
|
||||||
|
@ -93,7 +93,7 @@ gitAttributes repo = do
|
||||||
{- set up a git pre-commit hook, if one is not already present -}
|
{- set up a git pre-commit hook, if one is not already present -}
|
||||||
gitPreCommitHook :: Git.Repo -> IO ()
|
gitPreCommitHook :: Git.Repo -> IO ()
|
||||||
gitPreCommitHook repo = do
|
gitPreCommitHook repo = do
|
||||||
let hook = (Git.workTree repo) ++ "/" ++ (Git.gitDir repo) ++
|
let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++
|
||||||
"/hooks/pre-commit"
|
"/hooks/pre-commit"
|
||||||
exists <- doesFileExist hook
|
exists <- doesFileExist hook
|
||||||
if (exists)
|
if (exists)
|
||||||
|
@ -120,7 +120,7 @@ calcGitLink file key = do
|
||||||
let absfile = case (absNormPath cwd file) of
|
let absfile = case (absNormPath cwd file) of
|
||||||
Just f -> f
|
Just f -> f
|
||||||
Nothing -> error $ "unable to normalize " ++ file
|
Nothing -> error $ "unable to normalize " ++ file
|
||||||
return $ (relPathDirToDir (parentDir absfile) (Git.workTree g)) ++
|
return $ relPathDirToDir (parentDir absfile) (Git.workTree g) ++
|
||||||
annexLocationRelative key
|
annexLocationRelative key
|
||||||
|
|
||||||
{- Updates the LocationLog when a key's presence changes. -}
|
{- Updates the LocationLog when a key's presence changes. -}
|
||||||
|
@ -138,7 +138,7 @@ getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
|
||||||
getViaTmp key action = do
|
getViaTmp key action = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
let dest = annexLocation g key
|
let dest = annexLocation g key
|
||||||
let tmp = (annexTmpLocation g) ++ (keyFile key)
|
let tmp = annexTmpLocation g ++ keyFile key
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
||||||
success <- action tmp
|
success <- action tmp
|
||||||
if (success)
|
if (success)
|
||||||
|
@ -165,7 +165,7 @@ showNote s = verbose $ do
|
||||||
liftIO $ putStr $ "(" ++ s ++ ") "
|
liftIO $ putStr $ "(" ++ s ++ ") "
|
||||||
liftIO $ hFlush stdout
|
liftIO $ hFlush stdout
|
||||||
showProgress :: Annex ()
|
showProgress :: Annex ()
|
||||||
showProgress = verbose $ liftIO $ putStr $ "\n"
|
showProgress = verbose $ liftIO $ putStr "\n"
|
||||||
showLongNote :: String -> Annex ()
|
showLongNote :: String -> Annex ()
|
||||||
showLongNote s = verbose $ do
|
showLongNote s = verbose $ do
|
||||||
liftIO $ putStr $ "\n" ++ indented
|
liftIO $ putStr $ "\n" ++ indented
|
||||||
|
|
|
@ -16,7 +16,7 @@ import qualified Data.Map as M
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Cmd.Utils
|
import System.Cmd.Utils
|
||||||
import Data.String.Utils
|
import Data.String.Utils
|
||||||
import Monad (unless)
|
import Control.Monad (unless)
|
||||||
|
|
||||||
import qualified GitRepo as Git
|
import qualified GitRepo as Git
|
||||||
|
|
||||||
|
@ -57,5 +57,5 @@ runAction repo action files = do
|
||||||
where
|
where
|
||||||
runxargs = pOpen WriteToPipe "xargs" ("-0":gitcmd) feedxargs
|
runxargs = pOpen WriteToPipe "xargs" ("-0":gitcmd) feedxargs
|
||||||
gitcmd = ["git"] ++ Git.gitCommandLine repo
|
gitcmd = ["git"] ++ Git.gitCommandLine repo
|
||||||
((getSubcommand action):(getParams action))
|
(getSubcommand action:getParams action)
|
||||||
feedxargs h = hPutStr h $ join "\0" files
|
feedxargs h = hPutStr h $ join "\0" files
|
||||||
|
|
31
GitRepo.hs
31
GitRepo.hs
|
@ -43,8 +43,8 @@ module GitRepo (
|
||||||
prop_idempotent_deencode
|
prop_idempotent_deencode
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Monad (unless)
|
import Control.Monad (unless)
|
||||||
import Directory
|
import System.Directory
|
||||||
import System.Posix.Directory
|
import System.Posix.Directory
|
||||||
import System.Path
|
import System.Path
|
||||||
import System.Cmd.Utils
|
import System.Cmd.Utils
|
||||||
|
@ -53,11 +53,11 @@ import Data.String.Utils
|
||||||
import System.IO
|
import System.IO
|
||||||
import qualified Data.Map as Map hiding (map, split)
|
import qualified Data.Map as Map hiding (map, split)
|
||||||
import Network.URI
|
import Network.URI
|
||||||
import Maybe
|
import Data.Maybe
|
||||||
import Char
|
import Data.Char
|
||||||
import Text.Printf
|
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Codec.Binary.UTF8.String (encode)
|
import Codec.Binary.UTF8.String (encode)
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
|
@ -127,31 +127,31 @@ assertLocal :: Repo -> a -> a
|
||||||
assertLocal repo action =
|
assertLocal repo action =
|
||||||
if (not $ repoIsUrl repo)
|
if (not $ repoIsUrl repo)
|
||||||
then action
|
then action
|
||||||
else error $ "acting on URL git repo " ++ (repoDescribe repo) ++
|
else error $ "acting on URL git repo " ++ repoDescribe repo ++
|
||||||
" not supported"
|
" not supported"
|
||||||
assertUrl :: Repo -> a -> a
|
assertUrl :: Repo -> a -> a
|
||||||
assertUrl repo action =
|
assertUrl repo action =
|
||||||
if (repoIsUrl repo)
|
if (repoIsUrl repo)
|
||||||
then action
|
then action
|
||||||
else error $ "acting on local git repo " ++ (repoDescribe repo) ++
|
else error $ "acting on local git repo " ++ repoDescribe repo ++
|
||||||
" not supported"
|
" not supported"
|
||||||
assertSsh :: Repo -> a -> a
|
assertSsh :: Repo -> a -> a
|
||||||
assertSsh repo action =
|
assertSsh repo action =
|
||||||
if (repoIsSsh repo)
|
if (repoIsSsh repo)
|
||||||
then action
|
then action
|
||||||
else error $ "unsupported url in repo " ++ (repoDescribe repo)
|
else error $ "unsupported url in repo " ++ repoDescribe repo
|
||||||
bare :: Repo -> Bool
|
bare :: Repo -> Bool
|
||||||
bare repo = case Map.lookup "core.bare" $ config repo of
|
bare repo = case Map.lookup "core.bare" $ config repo of
|
||||||
Just v -> configTrue v
|
Just v -> configTrue v
|
||||||
Nothing -> error $ "it is not known if git repo " ++
|
Nothing -> error $ "it is not known if git repo " ++
|
||||||
(repoDescribe repo) ++
|
repoDescribe repo ++
|
||||||
" is a bare repository; config not read"
|
" is a bare repository; config not read"
|
||||||
|
|
||||||
{- Path to a repository's gitattributes file. -}
|
{- Path to a repository's gitattributes file. -}
|
||||||
attributes :: Repo -> String
|
attributes :: Repo -> String
|
||||||
attributes repo
|
attributes repo
|
||||||
| bare repo = (workTree repo) ++ "/info/.gitattributes"
|
| bare repo = workTree repo ++ "/info/.gitattributes"
|
||||||
| otherwise = (workTree repo) ++ "/.gitattributes"
|
| otherwise = workTree repo ++ "/.gitattributes"
|
||||||
|
|
||||||
{- Path to a repository's .git directory, relative to its workTree. -}
|
{- Path to a repository's .git directory, relative to its workTree. -}
|
||||||
gitDir :: Repo -> String
|
gitDir :: Repo -> String
|
||||||
|
@ -176,7 +176,7 @@ relative repo@(Repo { location = Dir d }) file = drop (length absrepo) absfile
|
||||||
-- will be substring of file
|
-- will be substring of file
|
||||||
absrepo = case (absNormPath "/" d) of
|
absrepo = case (absNormPath "/" d) of
|
||||||
Just f -> f ++ "/"
|
Just f -> f ++ "/"
|
||||||
Nothing -> error $ "bad repo" ++ (repoDescribe repo)
|
Nothing -> error $ "bad repo" ++ repoDescribe repo
|
||||||
absfile = case (secureAbsNormPath absrepo file) of
|
absfile = case (secureAbsNormPath absrepo file) of
|
||||||
Just f -> f
|
Just f -> f
|
||||||
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
|
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
|
||||||
|
@ -185,7 +185,7 @@ relative repo _ = assertLocal repo $ error "internal"
|
||||||
{- Hostname of an URL repo. (May include a username and/or port too.) -}
|
{- Hostname of an URL repo. (May include a username and/or port too.) -}
|
||||||
urlHost :: Repo -> String
|
urlHost :: Repo -> String
|
||||||
urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
|
urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
|
||||||
where a = fromJust $ uriAuthority $ u
|
where a = fromJust $ uriAuthority u
|
||||||
urlHost repo = assertUrl repo $ error "internal"
|
urlHost repo = assertUrl repo $ error "internal"
|
||||||
|
|
||||||
{- Path of an URL repo. -}
|
{- Path of an URL repo. -}
|
||||||
|
@ -204,14 +204,13 @@ gitCommandLine repo _ = assertLocal repo $ error "internal"
|
||||||
run :: Repo -> [String] -> IO ()
|
run :: Repo -> [String] -> IO ()
|
||||||
run repo params = assertLocal repo $ do
|
run repo params = assertLocal repo $ do
|
||||||
ok <- boolSystem "git" (gitCommandLine repo params)
|
ok <- boolSystem "git" (gitCommandLine repo params)
|
||||||
unless (ok) $ error $ "git " ++ (show params) ++ " failed"
|
unless (ok) $ error $ "git " ++ show params ++ " failed"
|
||||||
|
|
||||||
{- Runs a git subcommand and returns its output. -}
|
{- Runs a git subcommand and returns its output. -}
|
||||||
pipeRead :: Repo -> [String] -> IO String
|
pipeRead :: Repo -> [String] -> IO String
|
||||||
pipeRead repo params = assertLocal repo $ do
|
pipeRead repo params = assertLocal repo $ do
|
||||||
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
|
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
|
||||||
ret <- hGetContentsStrict h
|
hGetContentsStrict h
|
||||||
return ret
|
|
||||||
|
|
||||||
{- Like pipeRead, but does not read output strictly; recommended
|
{- Like pipeRead, but does not read output strictly; recommended
|
||||||
- for git commands that produce a lot of output that will be processed
|
- for git commands that produce a lot of output that will be processed
|
||||||
|
|
Loading…
Reference in a new issue