summaryrefslogtreecommitdiff
path: root/Annex/Perms.hs
blob: dc1cb2f8b15fd20284e9d0e0450cd9cca071ce9b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
{- git-annex file permissions
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Annex.Perms (
	setAnnexPerm,
	annexFileMode,
	createAnnexDirectory,
	noUmask,
	createContentDir,
	freezeContentDir,
) where

import Common.Annex
import Utility.FileMode
import Git.SharedRepository
import qualified Annex
import Config

import System.Posix.Types

withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = maybe startup a =<< Annex.getState Annex.shared
  where
	startup = do
		shared <- fromRepo getSharedRepository
		Annex.changeState $ \s -> s { Annex.shared = Just shared }
		a shared

{- Sets appropriate file mode for a file or directory in the annex,
 - other than the content files and content directory. Normally,
 - use the default mode, but with core.sharedRepository set,
 - allow the group to write, etc. -}
setAnnexPerm :: FilePath -> Annex ()
setAnnexPerm file = unlessM crippledFileSystem $
	withShared $ liftIO . go
  where
	go GroupShared = groupWriteRead file
	go AllShared = modifyFileMode file $ addModes $
		[ ownerWriteMode, groupWriteMode ] ++ readModes
	go _ = noop

{- Gets the appropriate mode to use for creating a file in the annex
 - (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode
annexFileMode = withShared $ return . go
  where
	go GroupShared = sharedmode
	go AllShared = combineModes (sharedmode:readModes)
	go _ = stdFileMode
	sharedmode = combineModes
		[ ownerWriteMode, groupWriteMode
		, ownerReadMode, groupReadMode
		]

{- Creates a directory inside the gitAnnexDir, including any parent
 - directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top
  where
	top = parentDir <$> fromRepo gitAnnexDir
	traverse d below stop
		| d `equalFilePath` stop = done
		| otherwise = ifM (liftIO $ doesDirectoryExist d)
			( done
			, traverse (parentDir d) (d:below) stop
			)
	  where
		done = forM_ below $ \p -> do
			liftIO $ createDirectoryIfMissing True p
			setAnnexPerm p

{- Blocks writing to the directory an annexed file is in, to prevent the
 - file accidentially being deleted. However, if core.sharedRepository
 - is set, this is not done, since the group must be allowed to delete the
 - file.
 -}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = unlessM crippledFileSystem $
	liftIO . go =<< fromRepo getSharedRepository
  where
	dir = parentDir file
	go GroupShared = groupWriteRead dir
	go AllShared = groupWriteRead dir
	go _ = preventWrite dir

{- Makes the directory tree to store an annexed file's content,
 - with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir dest = do
	unlessM (liftIO $ doesDirectoryExist dir) $
		createAnnexDirectory dir 
	-- might have already existed with restricted perms
	unlessM crippledFileSystem $
		liftIO $ allowWrite dir
  where
	dir = parentDir dest