1{- git-update-index library
2 -
3 - Copyright 2011-2020 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}
9
10module Git.UpdateIndex (
11	Streamer,
12	pureStreamer,
13	streamUpdateIndex,
14	streamUpdateIndex',
15	withUpdateIndex,
16	lsTree,
17	lsSubTree,
18	updateIndexLine,
19	stageFile,
20	unstageFile,
21	stageSymlink,
22	stageDiffTreeItem,
23	refreshIndex,
24) where
25
26import Common
27import Git
28import Git.Types
29import Git.Command
30import Git.FilePath
31import Git.Sha
32import qualified Git.DiffTreeItem as Diff
33
34import qualified Data.ByteString as S
35import qualified Data.ByteString.Lazy as L
36import Control.Monad.IO.Class
37
38{- Streamers are passed a callback and should feed it lines in the form
39 - read by update-index, and generated by ls-tree. -}
40type Streamer = (L.ByteString -> IO ()) -> IO ()
41
42{- A streamer with a precalculated value. -}
43pureStreamer :: L.ByteString -> Streamer
44pureStreamer !s = \streamer -> streamer s
45
46{- Streams content into update-index from a list of Streamers. -}
47streamUpdateIndex :: Repo -> [Streamer] -> IO ()
48streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
49	forM_ as $ streamUpdateIndex' h
50
51data UpdateIndexHandle = UpdateIndexHandle Handle
52
53streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
54streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do
55	L.hPutStr h s
56	L.hPutStr h "\0"
57
58withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
59withUpdateIndex repo a = bracket setup cleanup go
60  where
61	params = map Param ["update-index", "-z", "--index-info"]
62
63	setup = liftIO $ createProcess $
64		(gitCreateProcess params repo)
65			{ std_in = CreatePipe }
66	go p = do
67		r <- a (UpdateIndexHandle (stdinHandle p))
68		liftIO $ do
69			hClose (stdinHandle p)
70			void $ checkSuccessProcess (processHandle p)
71		return r
72
73	cleanup = liftIO . cleanupProcess
74
75{- A streamer that adds the current tree for a ref. Useful for eg, copying
76 - and modifying branches. -}
77lsTree :: Ref -> Repo -> Streamer
78lsTree (Ref x) repo streamer = do
79	(s, cleanup) <- pipeNullSplit params repo
80	mapM_ streamer s
81	void $ cleanup
82  where
83	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
84lsSubTree :: Ref -> FilePath -> Repo -> Streamer
85lsSubTree (Ref x) p repo streamer = do
86	(s, cleanup) <- pipeNullSplit params repo
87	mapM_ streamer s
88	void $ cleanup
89  where
90	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p]
91
92{- Generates a line suitable to be fed into update-index, to add
93 - a given file with a given sha. -}
94updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
95updateIndexLine sha treeitemtype file = L.fromStrict $
96	fmtTreeItemType treeitemtype
97	<> " blob "
98	<> fromRef' sha
99	<> "\t"
100	<> indexPath file
101
102stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer
103stageFile sha treeitemtype file repo = do
104	p <- toTopFilePath (toRawFilePath file) repo
105	return $ pureStreamer $ updateIndexLine sha treeitemtype p
106
107{- A streamer that removes a file from the index. -}
108unstageFile :: FilePath -> Repo -> IO Streamer
109unstageFile file repo = do
110	p <- toTopFilePath (toRawFilePath file) repo
111	return $ unstageFile' p
112
113unstageFile' :: TopFilePath -> Streamer
114unstageFile' p = pureStreamer $ L.fromStrict $
115	"0 "
116	<> fromRef' deleteSha
117	<> "\t"
118	<> indexPath p
119
120{- A streamer that adds a symlink to the index. -}
121stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer
122stageSymlink file sha repo = do
123	!line <- updateIndexLine
124		<$> pure sha
125		<*> pure TreeSymlink
126		<*> toTopFilePath file repo
127	return $ pureStreamer line
128
129{- A streamer that applies a DiffTreeItem to the index. -}
130stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
131stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of
132	Nothing -> unstageFile' (Diff.file d)
133	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
134
135indexPath :: TopFilePath -> InternalGitPath
136indexPath = toInternalGitPath . getTopFilePath
137
138{- Refreshes the index, by checking file stat information.  -}
139refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool
140refreshIndex repo feeder = withCreateProcess p go
141  where
142	params =
143		[ Param "update-index"
144		, Param "-q"
145		, Param "--refresh"
146		, Param "-z"
147		, Param "--stdin"
148		]
149
150	p = (gitCreateProcess params repo)
151		{ std_in = CreatePipe }
152
153	go (Just h) _ _ pid = do
154		feeder $ \f ->
155			S.hPut h (S.snoc f 0)
156		hFlush h
157		hClose h
158		checkSuccessProcess pid
159	go _ _ _ _ = error "internal"
160