Skip to content

Commit 51d8ca8

Browse files
m-ildefonsm-ildefons
authored
Merge pull request #106 from aokellermann/aokellermann/pr
basic support for --keep-git-dir, --unpack, --parents
2 parents e262ffe + 5af3127 commit 51d8ca8

6 files changed

Lines changed: 230 additions & 71 deletions

File tree

‎src/Language/Docker/Parser/Copy.hs‎

Lines changed: 72 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@ data Flag
1414
| FlagChown Chown
1515
| FlagChmod Chmod
1616
| FlagLink Link
17+
| FlagKeepGitDir KeepGitDir
18+
| FlagParents Parents
1719
| FlagUnpack Unpack
1820
| FlagSource CopySource
1921
| FlagExclude Exclude
@@ -26,16 +28,18 @@ parseCopy = do
2628
let chownFlags = [c | FlagChown c <- flags]
2729
let chmodFlags = [c | FlagChmod c <- flags]
2830
let linkFlags = [l | FlagLink l <- flags]
31+
let parentsFlags = [p | FlagParents p <- flags]
2932
let sourceFlags = [f | FlagSource f <- flags]
3033
let excludeFlags = [e | FlagExclude e <- flags]
3134
let invalid = [i | FlagInvalid i <- flags]
3235
-- Let's do some validation on the flags
33-
case (invalid, chownFlags, chmodFlags, linkFlags, sourceFlags, excludeFlags) of
34-
((k, v) : _, _, _, _, _, _) -> unexpectedFlag k v
35-
(_, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--chown"
36-
(_, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--chmod"
37-
(_, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--link"
38-
(_, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--from"
36+
case (invalid, chownFlags, chmodFlags, linkFlags, parentsFlags, sourceFlags, excludeFlags) of
37+
((k, v) : _, _, _, _, _, _, _) -> unexpectedFlag k v
38+
(_, _ : _ : _, _, _, _, _, _) -> customError $ DuplicateFlagError "--chown"
39+
(_, _, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--chmod"
40+
(_, _, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--link"
41+
(_, _, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--parents"
42+
(_, _, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--from"
3943
_ -> do
4044
let cho =
4145
case chownFlags of
@@ -49,12 +53,16 @@ parseCopy = do
4953
case linkFlags of
5054
[] -> NoLink
5155
l : _ -> l
56+
let par =
57+
case parentsFlags of
58+
[] -> NoParents
59+
p : _ -> p
5260
let fr =
5361
case sourceFlags of
5462
[] -> NoSource
5563
f : _ -> f
56-
try (heredocList (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk fr excludeFlags)))
57-
<|> fileList "COPY" (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk fr excludeFlags))
64+
try (heredocList (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk par fr excludeFlags)))
65+
<|> fileList "COPY" (\src dest -> Copy (CopyArgs src dest) (CopyFlags cho chm lnk par fr excludeFlags))
5866

5967
parseAdd :: (?esc :: Char) => Parser (Instruction Text)
6068
parseAdd = do
@@ -64,18 +72,20 @@ parseAdd = do
6472
let chownFlags = [c | FlagChown c <- flags]
6573
let chmodFlags = [c | FlagChmod c <- flags]
6674
let linkFlags = [l | FlagLink l <- flags]
75+
let keepGitDirFlags = [k | FlagKeepGitDir k <- flags]
6776
let unpackFlags = [u | FlagUnpack u <- flags]
6877
let excludeFlags = [e | FlagExclude e <- flags]
6978
let invalidFlags = [i | FlagInvalid i <- flags]
7079
notFollowedBy (string "--") <?>
71-
"only the --checksum, --chown, --chmod, --link, --unpack, --exclude flags or the src and dest paths"
72-
case (invalidFlags, checksumFlags, chownFlags, linkFlags, chmodFlags, unpackFlags, excludeFlags) of
73-
((k, v) : _, _, _, _, _, _, _) -> unexpectedFlag k v
74-
(_, _ : _ : _, _, _, _, _, _) -> customError $ DuplicateFlagError "--checksum"
75-
(_, _, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--chown"
76-
(_, _, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--chmod"
77-
(_, _, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--link"
78-
(_, _, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--unpack"
80+
"only the --checksum, --chown, --chmod, --link, --exclude, --keep-git-dir, --unpack flags or the src and dest paths"
81+
case (invalidFlags, checksumFlags, chownFlags, linkFlags, chmodFlags, keepGitDirFlags, unpackFlags, excludeFlags) of
82+
((k, v) : _, _, _, _, _, _, _, _) -> unexpectedFlag k v
83+
(_, _ : _ : _, _, _, _, _, _, _) -> customError $ DuplicateFlagError "--checksum"
84+
(_, _, _ : _ : _, _, _, _, _, _) -> customError $ DuplicateFlagError "--chown"
85+
(_, _, _, _ : _ : _, _, _, _, _) -> customError $ DuplicateFlagError "--chmod"
86+
(_, _, _, _, _ : _ : _, _, _, _) -> customError $ DuplicateFlagError "--link"
87+
(_, _, _, _, _, _ : _ : _, _, _) -> customError $ DuplicateFlagError "--keep-git-dir"
88+
(_, _, _, _, _, _, _ : _ : _, _) -> customError $ DuplicateFlagError "--unpack"
7989
_ -> do
8090
let chk = case checksumFlags of
8191
[] -> NoChecksum
@@ -89,10 +99,13 @@ parseAdd = do
8999
let lnk = case linkFlags of
90100
[] -> NoLink
91101
l : _ -> l
102+
let kgd = case keepGitDirFlags of
103+
[] -> NoKeepGitDir
104+
k : _ -> k
92105
let unp = case unpackFlags of
93106
[] -> NoUnpack
94107
u : _ -> u
95-
fileList "ADD" (\src dest -> Add (AddArgs src dest) (AddFlags chk cho chm lnk unp excludeFlags))
108+
fileList "ADD" (\src dest -> Add (AddArgs src dest) (AddFlags chk cho chm lnk kgd unp excludeFlags))
96109

97110
heredocList :: (?esc :: Char) =>
98111
(NonEmpty SourcePath -> TargetPath -> Instruction Text) ->
@@ -125,13 +138,20 @@ unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name)
125138
unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name)
126139

127140
copyFlag :: (?esc :: Char) => Parser Flag
128-
copyFlag = (FlagSource <$> try copySource <?> "only one --from") <|> addFlag
141+
copyFlag = (FlagSource <$> try copySource <?> "only one --from")
142+
<|> (FlagChown <$> try chown <?> "--chown")
143+
<|> (FlagChmod <$> try chmod <?> "--chmod")
144+
<|> (FlagLink <$> try link <?> "--link")
145+
<|> (FlagParents <$> try parents <?> "--parents")
146+
<|> (FlagExclude <$> try exclude <?> "--exclude")
147+
<|> (FlagInvalid <$> try anyFlag <?> "other flag")
129148

130149
addFlag :: (?esc :: Char) => Parser Flag
131150
addFlag = (FlagChecksum <$> try checksum <?> "--checksum")
132151
<|> (FlagChown <$> try chown <?> "--chown")
133152
<|> (FlagChmod <$> try chmod <?> "--chmod")
134153
<|> (FlagLink <$> try link <?> "--link")
154+
<|> (FlagKeepGitDir <$> try keepGitDir <?> "--keep-git-dir")
135155
<|> (FlagUnpack <$> try unpack <?> "--unpack")
136156
<|> (FlagExclude <$> try exclude <?> "--exclude")
137157
<|> (FlagInvalid <$> try anyFlag <?> "other flag")
@@ -159,11 +179,41 @@ link = do
159179
void $ string "--link"
160180
return Link
161181

182+
parents :: Parser Parents
183+
parents = ( try parentsExplicit <?> "explicit --parents")
184+
<|> ( try parentsImplicit <?> "implicit --parents")
185+
where
186+
parentsExplicit = do
187+
void $ string "--parents="
188+
val <- string "true" <|> string "false"
189+
return $ Parents (val == "true")
190+
parentsImplicit = do
191+
void $ string "--parents"
192+
return $ Parents True
193+
194+
keepGitDir :: Parser KeepGitDir
195+
keepGitDir = ( try keepGitDirExplicit <?> "explicit --keep-git-dir" )
196+
<|> ( try keepGitDirImplicit <?> "implicit --keep-git-dir" )
197+
where
198+
keepGitDirExplicit = do
199+
void $ string "--keep-git-dir="
200+
val <- string "true" <|> string "false"
201+
return $ KeepGitDir (val == "true")
202+
keepGitDirImplicit = do
203+
void $ string "--keep-git-dir"
204+
return $ KeepGitDir True
205+
162206
unpack :: Parser Unpack
163-
unpack = do
164-
void $ string "--unpack="
165-
val <- string "true" <|> string "false"
166-
return $ Unpack (val == "true")
207+
unpack = ( try unpackExplicit <?> "explicit --unpack" )
208+
<|> ( try unpackImplicit <?> "implicit --unpack" )
209+
where
210+
unpackExplicit = do
211+
void $ string "--unpack="
212+
val <- string "true" <|> string "false"
213+
return $ Unpack (val == "true")
214+
unpackImplicit = do
215+
void $ string "--unpack"
216+
return $ Unpack True
167217

168218
copySource :: (?esc :: Char) => Parser CopySource
169219
copySource = do

‎src/Language/Docker/PrettyPrint.hs‎

Lines changed: 18 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -160,6 +160,20 @@ prettyPrintLink link =
160160
Link -> "--link"
161161
NoLink -> mempty
162162

163+
prettyPrintKeepGitDir :: KeepGitDir -> Doc ann
164+
prettyPrintKeepGitDir keepGitDir =
165+
case keepGitDir of
166+
KeepGitDir True -> "--keep-git-dir=true"
167+
KeepGitDir False -> "--keep-git-dir=false"
168+
NoKeepGitDir -> mempty
169+
170+
prettyPrintParents :: Parents -> Doc ann
171+
prettyPrintParents parents =
172+
case parents of
173+
Parents True -> "--parents=true"
174+
Parents False -> "--parents=false"
175+
NoParents -> mempty
176+
163177
prettyPrintUnpack :: Unpack -> Doc ann
164178
prettyPrintUnpack unpack =
165179
case unpack of
@@ -300,11 +314,12 @@ prettyPrintInstruction i =
300314
prettyPrintArguments c
301315
Copy
302316
CopyArgs {sourcePaths, targetPath}
303-
CopyFlags {chmodFlag, chownFlag, linkFlag, sourceFlag, excludeFlags} -> do
317+
CopyFlags {chmodFlag, chownFlag, linkFlag, parentsFlag, sourceFlag, excludeFlags} -> do
304318
"COPY"
305319
prettyPrintChown chownFlag
306320
prettyPrintChmod chmodFlag
307321
prettyPrintLink linkFlag
322+
prettyPrintParents parentsFlag
308323
prettyPrintCopySource sourceFlag
309324
prettyPrintExcludes excludeFlags
310325
prettyPrintFileList sourcePaths targetPath
@@ -334,12 +349,13 @@ prettyPrintInstruction i =
334349
prettyPrintBaseImage b
335350
Add
336351
AddArgs {sourcePaths, targetPath}
337-
AddFlags {checksumFlag, chownFlag, chmodFlag, linkFlag, unpackFlag, excludeFlags} -> do
352+
AddFlags {checksumFlag, chownFlag, chmodFlag, linkFlag, keepGitDirFlag, unpackFlag, excludeFlags} -> do
338353
"ADD"
339354
prettyPrintChecksum checksumFlag
340355
prettyPrintChown chownFlag
341356
prettyPrintChmod chmodFlag
342357
prettyPrintLink linkFlag
358+
prettyPrintKeepGitDir keepGitDirFlag
343359
prettyPrintUnpack unpackFlag
344360
prettyPrintExcludes excludeFlags
345361
prettyPrintFileList sourcePaths targetPath

‎src/Language/Docker/Syntax.hs‎

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -162,6 +162,16 @@ data Link
162162
| NoLink
163163
deriving (Show, Eq, Ord)
164164

165+
data KeepGitDir
166+
= KeepGitDir !Bool
167+
| NoKeepGitDir
168+
deriving (Show, Eq, Ord)
169+
170+
data Parents
171+
= Parents !Bool
172+
| NoParents
173+
deriving (Show, Eq, Ord)
174+
165175
data Unpack
166176
= Unpack !Bool
167177
| NoUnpack
@@ -202,13 +212,14 @@ data CopyFlags
202212
{ chownFlag :: !Chown,
203213
chmodFlag :: !Chmod,
204214
linkFlag :: !Link,
215+
parentsFlag :: !Parents,
205216
sourceFlag :: !CopySource,
206217
excludeFlags :: ![Exclude]
207218
}
208219
deriving (Show, Eq, Ord)
209220

210221
instance Default CopyFlags where
211-
def = CopyFlags NoChown NoChmod NoLink NoSource []
222+
def = CopyFlags NoChown NoChmod NoLink NoParents NoSource []
212223

213224
data AddArgs
214225
= AddArgs
@@ -223,13 +234,14 @@ data AddFlags
223234
chownFlag :: !Chown,
224235
chmodFlag :: !Chmod,
225236
linkFlag :: !Link,
237+
keepGitDirFlag :: !KeepGitDir,
226238
unpackFlag :: !Unpack,
227239
excludeFlags :: ![Exclude]
228240
}
229241
deriving (Show, Eq, Ord)
230242

231243
instance Default AddFlags where
232-
def = AddFlags NoChecksum NoChown NoChmod NoLink NoUnpack []
244+
def = AddFlags NoChecksum NoChown NoChmod NoLink NoKeepGitDir NoUnpack []
233245

234246
newtype Exclude
235247
= Exclude

0 commit comments

Comments
 (0)