cc89699457
This is conceptually very simple, just making a 1 that was hard coded be exposed as a config option. The hard part was plumbing all that, and dealing with complexities like reading it from git attributes at the same time that numcopies is read. Behavior change: When numcopies is set to 0, git-annex used to drop content without requiring any copies. Now to get that (highly unsafe) behavior, mincopies also needs to be set to 0. It seemed better to remove that edge case, than complicate mincopies by ignoring it when numcopies is 0. This commit was sponsored by Denis Dzyubenko on Patreon.
101 lines
3 KiB
Haskell
101 lines
3 KiB
Haskell
{- git check-attr interface
|
|
-
|
|
- Copyright 2010-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.CheckAttr where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import qualified Utility.CoProcess as CoProcess
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import System.IO.Error
|
|
import qualified Data.ByteString as B
|
|
|
|
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
|
|
|
|
type Attr = String
|
|
|
|
{- Starts git check-attr running to look up the specified attributes
|
|
- and returns a handle. -}
|
|
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
|
|
checkAttrStart attrs repo = do
|
|
currdir <- R.getCurrentDirectory
|
|
h <- gitCoProcessStart True params repo
|
|
return (h, attrs, currdir)
|
|
where
|
|
params =
|
|
[ Param "check-attr"
|
|
, Param "-z"
|
|
, Param "--stdin"
|
|
] ++ map Param attrs ++
|
|
[ Param "--" ]
|
|
|
|
checkAttrStop :: CheckAttrHandle -> IO ()
|
|
checkAttrStop (h, _, _) = CoProcess.stop h
|
|
|
|
checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
|
|
checkAttr h want file = checkAttrs h [want] file >>= return . \case
|
|
(v:_) -> v
|
|
[] -> ""
|
|
|
|
{- Gets attributes of a file. When an attribute is not specified,
|
|
- returns "" for it. -}
|
|
checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String]
|
|
checkAttrs (h, attrs, currdir) want file = do
|
|
l <- CoProcess.query h send (receive "")
|
|
return (getvals l want)
|
|
where
|
|
getvals _ [] = []
|
|
getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
|
|
["unspecified"] -> "" : getvals l xs
|
|
[v] -> v : getvals l xs
|
|
_ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
|
|
|
|
send to = B.hPutStr to $ file' `B.snoc` 0
|
|
receive c from = do
|
|
s <- hGetSomeString from 1024
|
|
if null s
|
|
then eofError
|
|
else do
|
|
let v = c ++ s
|
|
maybe (receive v from) return (parse v)
|
|
eofError = ioError $ mkIOError userErrorType "git check-attr EOF" Nothing Nothing
|
|
parse s
|
|
-- new null separated output
|
|
| '\0' `elem` s = if "\0" `isSuffixOf` s
|
|
then
|
|
let bits = segment (== '\0') s
|
|
in if length bits == (numattrs * 3) + 1
|
|
then Just $ getattrvalues bits []
|
|
else Nothing -- more attributes to come
|
|
else Nothing -- output incomplete
|
|
-- old one line per value output
|
|
| otherwise = if "\n" `isSuffixOf` s
|
|
then
|
|
let ls = lines s
|
|
in if length ls == numattrs
|
|
then Just $ map (\(attr, val) -> (attr, oldattrvalue attr val))
|
|
(zip attrs ls)
|
|
else Nothing -- more attributes to come
|
|
else Nothing -- line incomplete
|
|
numattrs = length attrs
|
|
|
|
{- git check-attr chokes on some absolute filenames,
|
|
- so make sure the filename is relative. -}
|
|
file' = relPathDirToFileAbs currdir $ absPathFrom currdir file
|
|
oldattrvalue attr l = end bits !! 0
|
|
where
|
|
bits = split sep l
|
|
sep = ": " ++ attr ++ ": "
|
|
getattrvalues (_filename:attr:val:rest) c = getattrvalues rest ((attr,val):c)
|
|
getattrvalues _ c = c
|
|
|
|
{- User may enter this to override a previous attr setting, when they wish
|
|
- to not specify an attr for some files. -}
|
|
unspecifiedAttr :: String
|
|
unspecifiedAttr = "!"
|