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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
{- git-annex links to content
-
- On file systems that support them, symlinks are used.
-
- On other filesystems, git instead stores the symlink target in a regular
- file.
-
- Pointer files are used instead of symlinks for unlocked files.
-
- Copyright 2013-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Link where
import Common.Annex
import qualified Annex
import qualified Git.HashObject
import qualified Git.UpdateIndex
import qualified Annex.Queue
import Git.Types
import Git.FilePath
import Types.Key
import qualified Data.ByteString.Lazy as L
type LinkTarget = String
{- Checks if a file is a link to a key. -}
isAnnexLink :: FilePath -> Annex (Maybe Key)
isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file
{- Gets the link target of a symlink.
-
- On a filesystem that does not support symlinks, fall back to getting the
- link target by looking inside the file.
-
- Returns Nothing if the file is not a symlink, or not a link to annex
- content.
-}
getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
getAnnexLinkTarget f = getAnnexLinkTarget' f
=<< (coreSymlinks <$> Annex.getGitConfig)
{- Pass False to force looking inside file. -}
getAnnexLinkTarget' :: FilePath -> Bool -> Annex (Maybe LinkTarget)
getAnnexLinkTarget' file coresymlinks = if coresymlinks
then check readSymbolicLink $
return Nothing
else check readSymbolicLink $
check probefilecontent $
return Nothing
where
check getlinktarget fallback = do
v <- liftIO $ catchMaybeIO $ getlinktarget file
case v of
Just l
| isLinkToAnnex (fromInternalGitPath l) -> return v
| otherwise -> return Nothing
Nothing -> fallback
probefilecontent f = withFile f ReadMode $ \h -> do
fileEncoding h
-- The first 8k is more than enough to read; link
-- files are small.
s <- take 8192 <$> hGetContents h
-- If we got the full 8k, the file is too large
if length s == 8192
then return ""
else
-- If there are any NUL or newline
-- characters, or whitespace, we
-- certianly don't have a link to a
-- git-annex key.
return $ if any (`elem` s) "\0\n\r \t"
then ""
else s
makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
makeAnnexLink = makeGitLink
{- Creates a link on disk.
-
- On a filesystem that does not support symlinks, writes the link target
- to a file. Note that git will only treat the file as a symlink if
- it's staged as such, so use addAnnexLink when adding a new file or
- modified link to git.
-}
makeGitLink :: LinkTarget -> FilePath -> Annex ()
makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do
void $ tryIO $ removeFile file
createSymbolicLink linktarget file
, liftIO $ writeFile file linktarget
)
{- Creates a link on disk, and additionally stages it in git. -}
addAnnexLink :: LinkTarget -> FilePath -> Annex ()
addAnnexLink linktarget file = do
makeAnnexLink linktarget file
stageSymlink file =<< hashSymlink linktarget
{- Injects a symlink target into git, returning its Sha. -}
hashSymlink :: LinkTarget -> Annex Sha
hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $
toInternalGitPath linktarget
hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
toInternalGitPath linktarget
{- Stages a symlink to an annexed object, using a Sha of its target. -}
stageSymlink :: FilePath -> Sha -> Annex ()
stageSymlink file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file sha)
{- Injects a pointer file content into git, returning its Sha. -}
hashPointerFile :: Key -> Annex Sha
hashPointerFile key = inRepo $ Git.HashObject.hashObject BlobObject $
formatPointer key
{- Stages a pointer file, using a Sha of its content -}
stagePointerFile :: FilePath -> Sha -> Annex ()
stagePointerFile file sha =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageFile sha FileBlob file)
{- Parses a symlink target or a pointer file to a Key.
- Only looks at the first line, as pointer files can have subsequent
- lines. -}
parseLinkOrPointer :: L.ByteString -> Maybe Key
parseLinkOrPointer = parseLinkOrPointer' . decodeBS . L.take maxsz
where
{- Want to avoid buffering really big files in git into
- memory when reading files that may be pointers.
-
- 8192 bytes is plenty for a pointer to a key.
- Pad some more to allow for any pointer files that might have
- lines after the key explaining what the file is used for. -}
maxsz = 81920
parseLinkOrPointer' :: String -> Maybe Key
parseLinkOrPointer' s = headMaybe (lines (fromInternalGitPath s)) >>= go
where
go l
| isLinkToAnnex l = file2key $ takeFileName l
| otherwise = Nothing
formatPointer :: Key -> String
formatPointer k =
toInternalGitPath (pathSeparator:objectDir </> key2file k) ++ "\n"
{- Checks if a file is a pointer to a key. -}
isPointerFile :: FilePath -> Annex (Maybe Key)
isPointerFile f = liftIO $ catchDefaultIO Nothing $
parseLinkOrPointer <$> L.readFile f
|
