blob: e08afed6bb3a69faff7744c9ea91c527f0894251 (
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
107
108
109
110
111
112
113
114
115
116
|
{- 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.CatFile
import Annex.MetaData
import Annex.FileMatcher
import Types.KeySource
import Backend
import Logs.Location
import qualified Database.AssociatedFiles as AssociatedFiles
import Git.FilePath
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 to an
-- available annex object, should output its 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
updateAssociatedFiles k file
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
updateAssociatedFiles k file
liftIO $ emitPointer k
, liftIO cat
)
stop
cat :: IO ()
cat = B.hGetContents stdin >>= B.hPut stdout
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
-- Could add a newline and some text explaining this file is a pointer.
-- parsePointer only looks at the first line.
emitPointer :: Key -> IO ()
emitPointer k = putStrLn $ toInternalGitPath $
pathSeparator:objectDir </> key2file k
updateAssociatedFiles :: Key -> FilePath -> Annex ()
updateAssociatedFiles k f = do
h <- AssociatedFiles.openDb
liftIO $ do
AssociatedFiles.addDb h k f
AssociatedFiles.closeDb h
|
