Skip to content

Commit e04766a

Browse files
borsboomborsboom
committed
Simplify docker repo/image options (commercialhaskell#66)
Removed repo-owner, repo-prefix, repo-suffix. Just use repo.
1 parent f1e315f commit e04766a

2 files changed

Lines changed: 47 additions & 101 deletions

File tree

‎src/Stack/Docker.hs‎

Lines changed: 32 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ import Data.Aeson (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
3838
import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
3939
import qualified Data.ByteString.Lazy.Char8 as LBS
4040
import Data.Char (isSpace,toUpper,isAscii)
41-
import Data.List (dropWhileEnd,intersperse,isPrefixOf,isInfixOf,foldl',sortBy)
41+
import Data.List (dropWhileEnd,find,intersperse,isPrefixOf,isInfixOf,foldl',sortBy)
4242
import Data.Map.Strict (Map)
4343
import qualified Data.Map.Strict as Map
4444
import Data.Maybe
@@ -683,37 +683,19 @@ checkVersions =
683683
-- | Options parser configuration for Docker.
684684
dockerOptsParser :: Parser DockerOptsMonoid
685685
dockerOptsParser =
686-
--EKB FIXME: remove some of these options that would be uncommon to use from command-line?
687686
DockerOptsMonoid
688687
<$> maybeBoolFlags dockerCmdName
689688
"using a Docker container"
690-
<*> maybeStrOption (long (dockerOptName dockerRepoOwnerArgName) <>
691-
metavar "REGISTRY/OWNER" <>
692-
help "Docker repository owner")
693-
<*> maybeStrOption (long (dockerOptName dockerRepoPrefixArgName) <>
694-
metavar "PREFIX" <>
695-
help "Prefix to add to Docker repository names")
696-
<*> maybeStrOption (long (dockerOptName dockerRepoArgName) <>
697-
metavar "NAME" <>
698-
help "Docker repository name")
699-
<*> maybeStrOption (long (dockerOptName dockerRepoSuffixArgName) <>
700-
metavar "SUFFIX" <>
701-
help "Suffix to add to Docker repository names")
702-
<*> (optional . option (fmap Just str))
703-
(long (dockerOptName dockerImageTagArgName) <>
704-
metavar "TAG" <>
705-
help "Docker image tag")
706-
<*> maybeStrOption (long (dockerOptName dockerImageArgName) <>
707-
metavar "IMAGE" <>
708-
help "Exact Docker image tag or ID (overrides docker-repo-*/tag)")
709-
<*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)
710-
"registry requires login"
711-
<*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>
712-
metavar "USERNAME" <>
713-
help "Docker registry username")
714-
<*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>
715-
metavar "PASSWORD" <>
716-
help "Docker registry password")
689+
<*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>
690+
metavar "NAME" <>
691+
help "Docker repository name") <|>
692+
(Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>
693+
metavar "IMAGE" <>
694+
help "Exact Docker image ID (overrides docker-repo)") <|>
695+
pure Nothing)
696+
<*> pure Nothing
697+
<*> pure Nothing
698+
<*> pure Nothing
717699
<*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)
718700
"automatic pulling latest version of image"
719701
<*> maybeBoolFlags (dockerOptName dockerDetachArgName)
@@ -743,29 +725,27 @@ dockerOptsFromMonoid :: Maybe Project -> DockerOptsMonoid -> DockerOpts
743725
dockerOptsFromMonoid mproject DockerOptsMonoid{..} = DockerOpts
744726
{dockerEnable = fromMaybe False dockerMonoidEnable
745727
,dockerImage =
746-
let owner = fromMaybe "fpco" dockerMonoidRepoOwner
747-
tag = case dockerMonoidImageTag of
748-
Just t -> emptyToNothing t
749-
Nothing ->
750-
case mproject of
751-
Nothing -> Nothing
752-
Just proj ->
753-
case projectResolver proj of
754-
ResolverSnapshot n@(LTS _ _) -> Just (T.unpack (renderSnapName n))
755-
_ -> error (concat ["Resolver not supported for Docker images:\n "
756-
,show (projectResolver proj)
757-
,"\nUse an LTS resolver, or set the '"
758-
,T.unpack dockerImageTagArgName
759-
,"' explicitly, in "
760-
,toFilePath stackDotYaml
761-
,"."])
762-
in concat [owner
763-
,if null owner then "" else "/"
764-
,fromMaybe "" dockerMonoidRepoPrefix
765-
,fromMaybe "dev" dockerMonoidRepo
766-
,fromMaybe "" dockerMonoidRepoSuffix
767-
,maybe "" (const ":") tag
768-
,fromMaybe "" tag]
728+
let defaultTag =
729+
case mproject of
730+
Nothing -> ""
731+
Just proj ->
732+
case projectResolver proj of
733+
ResolverSnapshot n@(LTS _ _) -> ":" ++ (T.unpack (renderSnapName n))
734+
_ -> error (concat ["Resolver not supported for Docker images:\n "
735+
,show (projectResolver proj)
736+
,"\nUse an LTS resolver, or set the '"
737+
,T.unpack dockerImageArgName
738+
,"' explicitly, in "
739+
,toFilePath stackDotYaml
740+
,"."])
741+
in case dockerMonoidRepoOrImage of
742+
Nothing -> "fpco/dev" ++ defaultTag
743+
Just (DockerMonoidImage image) -> image
744+
Just (DockerMonoidRepo repo) ->
745+
case find (`elem` ":@") repo of
746+
Just _ -> -- Repo already specified a tag or digest, so don't append default
747+
repo
748+
Nothing -> repo ++ defaultTag
769749
,dockerRegistryLogin = fromMaybe (isJust (emptyToNothing dockerMonoidRegistryUsername))
770750
dockerMonoidRegistryLogin
771751
,dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername

‎src/Stack/Types/Docker.hs‎

Lines changed: 15 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44

55
module Stack.Types.Docker where
66

7-
import Control.Applicative ((<|>))
7+
import Control.Applicative
88
import Data.Aeson
99
import Data.Monoid
1010
import Data.Text (Text)
@@ -40,24 +40,13 @@ data DockerOpts = DockerOpts
4040
}
4141
deriving (Show)
4242

43-
-- An uninterpreted representation of xidocker options.
43+
-- An uninterpreted representation of docker options.
4444
-- Configurations may be "cascaded" using mappend (left-biased).
4545
data DockerOptsMonoid = DockerOptsMonoid
4646
{dockerMonoidEnable :: !(Maybe Bool)
4747
-- ^ Is using Docker enabled?
48-
,dockerMonoidRepoOwner :: !(Maybe String)
49-
-- ^ Docker repository (registry and) owner
50-
--EKB FIXME: rethink this prefix/repo/suffix business. Improve naming?
51-
,dockerMonoidRepoPrefix :: !(Maybe String)
52-
-- ^ Docker repository name's prefix (e.g. variant)
53-
,dockerMonoidRepo :: !(Maybe String)
54-
-- ^ Docker repository name (e.g. @dev@)
55-
,dockerMonoidRepoSuffix :: !(Maybe String)
56-
-- ^ Docker repository name's suffix (e.g. GHC version)
57-
,dockerMonoidImageTag :: !(Maybe (Maybe String))
58-
-- ^ Optional Docker image tag (e.g. the date)
59-
,dockerMonoidImage :: !(Maybe String)
60-
-- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag.
48+
,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)
49+
-- ^ Docker repository name (e.g. @fpco/dev@ or @fpco/dev:lts-2.8@)
6150
,dockerMonoidRegistryLogin :: !(Maybe Bool)
6251
-- ^ Does registry require login for pulls?
6352
,dockerMonoidRegistryUsername :: !(Maybe String)
@@ -86,12 +75,9 @@ data DockerOptsMonoid = DockerOptsMonoid
8675
instance FromJSON DockerOptsMonoid where
8776
parseJSON = withObject "DockerOptsMonoid"
8877
(\o -> do dockerMonoidEnable <- o .:? dockerEnableArgName .!= Just True
89-
dockerMonoidRepoOwner <- o .:? dockerRepoOwnerArgName
90-
dockerMonoidRepoPrefix <- o .:? dockerRepoPrefixArgName
91-
dockerMonoidRepo <- o .:? dockerRepoArgName
92-
dockerMonoidRepoSuffix <- o .:? dockerRepoSuffixArgName
93-
dockerMonoidImageTag <- o .:? dockerImageTagArgName
94-
dockerMonoidImage <- o .:? dockerImageArgName
78+
dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o .: dockerImageArgName) <|>
79+
((Just . DockerMonoidRepo) <$> o .: dockerRepoArgName) <|>
80+
pure Nothing
9581
dockerMonoidRegistryLogin <- o .:? dockerRegistryLoginArgName
9682
dockerMonoidRegistryUsername <- o .:? dockerRegistryUsernameArgName
9783
dockerMonoidRegistryPassword <- o .:? dockerRegistryPasswordArgName
@@ -107,12 +93,7 @@ instance FromJSON DockerOptsMonoid where
10793
instance Monoid DockerOptsMonoid where
10894
mempty = DockerOptsMonoid
10995
{dockerMonoidEnable = Nothing
110-
,dockerMonoidRepoOwner = Nothing
111-
,dockerMonoidRepoPrefix = Nothing
112-
,dockerMonoidRepo = Nothing
113-
,dockerMonoidRepoSuffix = Nothing
114-
,dockerMonoidImageTag = Nothing
115-
,dockerMonoidImage = Nothing
96+
,dockerMonoidRepoOrImage = Nothing
11697
,dockerMonoidRegistryLogin = Nothing
11798
,dockerMonoidRegistryUsername = Nothing
11899
,dockerMonoidRegistryPassword = Nothing
@@ -126,12 +107,7 @@ instance Monoid DockerOptsMonoid where
126107
}
127108
mappend l r = DockerOptsMonoid
128109
{dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r
129-
,dockerMonoidRepoOwner = dockerMonoidRepoOwner l <|> dockerMonoidRepoOwner r
130-
,dockerMonoidRepoPrefix = dockerMonoidRepoPrefix l <|> dockerMonoidRepoPrefix r
131-
,dockerMonoidRepo = dockerMonoidRepo l <|> dockerMonoidRepo r
132-
,dockerMonoidRepoSuffix = dockerMonoidRepoSuffix l <|> dockerMonoidRepoSuffix r
133-
,dockerMonoidImageTag = dockerMonoidImageTag l <|> dockerMonoidImageTag r
134-
,dockerMonoidImage = dockerMonoidImage l <|> dockerMonoidImage r
110+
,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r
135111
,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r
136112
,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r
137113
,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r
@@ -144,30 +120,20 @@ instance Monoid DockerOptsMonoid where
144120
,dockerMonoidPassHost = dockerMonoidPassHost l <|> dockerMonoidPassHost r
145121
}
146122

123+
-- | Options for Docker repository or image.
124+
data DockerMonoidRepoOrImage
125+
= DockerMonoidRepo String
126+
| DockerMonoidImage String
127+
deriving (Show)
128+
147129
-- | Docker enable argument name.
148130
dockerEnableArgName :: Text
149131
dockerEnableArgName = "enable"
150132

151-
-- | Docker repo owner argument name.
152-
dockerRepoOwnerArgName :: Text
153-
dockerRepoOwnerArgName = "repo-owner"
154-
155-
-- | Docker repo prefix argument name.
156-
dockerRepoPrefixArgName :: Text
157-
dockerRepoPrefixArgName = "repo-prefix"
158-
159133
-- | Docker repo arg argument name.
160134
dockerRepoArgName :: Text
161135
dockerRepoArgName = "repo"
162136

163-
-- | Docker repo suffix argument name.
164-
dockerRepoSuffixArgName :: Text
165-
dockerRepoSuffixArgName = "repo-suffix"
166-
167-
-- | Docker image tag argument name.
168-
dockerImageTagArgName :: Text
169-
dockerImageTagArgName = "image-tag"
170-
171137
-- | Docker image argument name.
172138
dockerImageArgName :: Text
173139
dockerImageArgName = "image"

0 commit comments

Comments
 (0)