blob: ddf81af4375d82e3c6db63a949725a5908263529 (
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
101
102
103
104
105
106
|
{- git-annex command
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Command.Smudge where
import Common.Annex
import Command
import Types.Key
import Annex.Content
import Annex.MetaData
import Annex.FileMatcher
import Types.KeySource
import Backend
import Logs.Location
import qualified Data.ByteString.Lazy as B
cmd :: Command
cmd = noCommit $ noMessages $
command "smudge" SectionPlumbing
"git smudge filter"
paramFile (seek <$$> optParser)
data SmudgeOptions = SmudgeOptions
{ smudgeFile :: FilePath
, cleanOption :: Bool
}
optParser :: CmdParamsDesc -> Parser SmudgeOptions
optParser desc = SmudgeOptions
<$> argument str ( metavar desc )
<*> switch ( long "clean" <> help "clean filter" )
seek :: SmudgeOptions -> CommandSeek
seek o = commandAction $
(if cleanOption o then clean else smudge) (smudgeFile o)
-- Smudge filter is fed git file content, and if it's a pointer, should
-- emit the annex object content.
smudge :: FilePath -> CommandStart
smudge _file = do
liftIO $ fileEncoding stdin
s <- liftIO $ hGetContents stdin
case parsePointer s of
Nothing -> liftIO $ putStr s
Just k -> do
content <- calcRepo (gitAnnexLocation k)
liftIO $ maybe
(putStr s)
(B.hPut stdout)
=<< catchMaybeIO (B.readFile content)
stop
-- Clean filter decides if a file should be stored in the annex, and
-- outputs a pointer to its injested content.
clean :: FilePath -> CommandStart
clean file = do
ifM (shouldAnnex file)
( do
k <- ingest file
liftIO $ emitPointer k
, liftIO $ B.hGetContents stdin >>= B.hPut stdout -- cat file
)
stop
shouldAnnex :: FilePath -> Annex Bool
shouldAnnex file = do
matcher <- largeFilesMatcher
checkFileMatcher matcher file
ingest :: FilePath -> Annex Key
ingest file = do
backend <- chooseBackend file
let source = KeySource
{ keyFilename = file
, contentLocation = file
, inodeCache = Nothing
}
k <- fst . fromMaybe (error "failed to generate a key")
<$> genKey source backend
-- Hard link (or copy) file content to annex
-- to prevent it from being lost when git checks out
-- a branch not containing this file.
r <- linkAnnex k file
case r of
LinkAnnexFailed -> error "Problem adding file to the annex"
LinkAnnexOk -> logStatus k InfoPresent
LinkAnnexNoop -> noop
genMetaData k file
=<< liftIO (getFileStatus file)
return k
emitPointer :: Key -> IO ()
emitPointer = putStrLn . key2file
parsePointer :: String -> Maybe Key
parsePointer s
| length s' >= maxsz = Nothing -- too long to be a key pointer
| otherwise = headMaybe (lines s') >>= file2key
where
s' = take maxsz s
maxsz = 81920
|
