1{- git check-attr interface
2 -
3 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Git.CheckAttr where
9
10import Common
11import Git
12import Git.Command
13import qualified Utility.CoProcess as CoProcess
14import qualified Utility.RawFilePath as R
15
16import System.IO.Error
17import qualified Data.ByteString as B
18
19type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
20
21type Attr = String
22
23{- Starts git check-attr running to look up the specified attributes
24 - and returns a handle.  -}
25checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
26checkAttrStart attrs repo = do
27	currdir <- R.getCurrentDirectory
28	h <- gitCoProcessStart True params repo
29	return (h, attrs, currdir)
30  where
31	params =
32		[ Param "check-attr"
33		, Param "-z"
34		, Param "--stdin"
35		] ++ map Param attrs ++
36		[ Param "--" ]
37
38checkAttrStop :: CheckAttrHandle -> IO ()
39checkAttrStop (h, _, _) = CoProcess.stop h
40
41checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
42checkAttr h want file = checkAttrs h [want] file >>= return . \case
43	(v:_) -> v
44	[] -> ""
45
46{- Gets attributes of a file. When an attribute is not specified,
47 - returns "" for it. -}
48checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String]
49checkAttrs (h, attrs, currdir) want file = do
50	l <- CoProcess.query h send (receive "")
51	return (getvals l want)
52  where
53	getvals _ [] = []
54	getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
55			["unspecified"] -> "" : getvals l xs
56			[v] -> v : getvals l xs
57			_ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
58
59	send to = B.hPutStr to $ file' `B.snoc` 0
60	receive c from = do
61		s <- hGetSomeString from 1024
62		if null s
63			then eofError
64			else do
65				let v = c ++ s
66				maybe (receive v from) return (parse v)
67	eofError = ioError $ mkIOError userErrorType "git check-attr EOF" Nothing Nothing
68	parse s
69		-- new null separated output
70		| '\0' `elem` s = if "\0" `isSuffixOf` s
71			then
72				let bits = segment (== '\0') s
73				in if length bits == (numattrs * 3) + 1
74					then Just $ getattrvalues bits []
75					else Nothing -- more attributes to come
76			else Nothing -- output incomplete
77		-- old one line per value output
78		| otherwise = if "\n" `isSuffixOf` s
79			then
80				let ls = lines s
81				in if length ls == numattrs
82					then Just $ map (\(attr, val) -> (attr, oldattrvalue attr val))
83						(zip attrs ls)
84					else Nothing -- more attributes to come
85			else Nothing -- line incomplete
86	numattrs = length attrs
87
88	{- git check-attr chokes on some absolute filenames,
89	 - so make sure the filename is relative. -}
90	file' = relPathDirToFileAbs currdir $ absPathFrom currdir file
91	oldattrvalue attr l = end bits !! 0
92	  where
93		bits = split sep l
94		sep = ": " ++ attr ++ ": "
95	getattrvalues (_filename:attr:val:rest) c = getattrvalues rest ((attr,val):c)
96	getattrvalues _ c = c
97
98{- User may enter this to override a previous attr setting, when they wish
99 - to not specify an attr for some files. -}
100unspecifiedAttr :: String
101unspecifiedAttr = "!"
102