git.iko.soy/typeable/octopod
on master help sign in
check if tag exists
commit07cb7fa935d48405f570fff250ed8fe8ea5eca92 authorAndrei Orlov <aaorlov1@gmail.com> dateSat 20 Jun 2020, 15:20 (6 years ago) parent7e4d6e9
5 files changed+83−3
compare with master
unifiedsplit
default.nix+12 dm-backend/dm-backend.cabal+9 dm-backend/src/DMS.hs+12 dm-backend/src/DMS/AWS.hs+47 nix/sources.json+3−3
default.nix+12
@@ -16,6 +16,18 @@
1616 };
1717
1818 overrides = hself: hsuper: {
19+ amazonka = pkgs.haskell.lib.overrideCabal hsuper.amazonka (old: {
20+ broken = false;
21+ });
22+ amazonka-core = pkgs.haskell.lib.overrideCabal hsuper.amazonka-core (old: {
23+ broken = false;
24+ });
25+ amazonka-ecr = pkgs.haskell.lib.overrideCabal hsuper.amazonka-ecr (old: {
26+ broken = false;
27+ });
28+ amazonka-test = pkgs.haskell.lib.overrideCabal hsuper.amazonka-test (old: {
29+ broken = false;
30+ });
1931 deriving-aeson = hsuper.callCabal2nix "deriving-aeson" sources.deriving-aeson { };
2032 servant-reflex = hsuper.callCabal2nix "servant-reflex" sources.servant-reflex { };
2133 servant = pkgs.haskell.lib.overrideCabal hsuper.servant (old: {
dm-backend/dm-backend.cabal+9
@@ -41,6 +41,7 @@ library
4141 DMC.Args
4242 DMS
4343 DMS.Args
44+ DMS.AWS
4445 Orphans
4546 TLS
4647 Types
@@ -48,6 +49,8 @@ library
4849 src
4950 build-depends:
5051 aeson
52+ , amazonka
53+ , amazonka-ecr
5154 , async
5255 , base >=4.7 && <5
5356 , bytestring
@@ -96,6 +99,8 @@ executable dmc-exe
9699 build-depends:
97100 aeson
98101 , async
102+ , amazonka
103+ , amazonka-ecr
99104 , base >=4.7 && <5
100105 , bytestring
101106 , chronos
@@ -139,6 +144,8 @@ executable dms-exe
139144 build-depends:
140145 aeson
141146 , async
147+ , amazonka
148+ , amazonka-ecr
142149 , base >=4.7 && <5
143150 , bytestring
144151 , chronos
@@ -180,6 +187,8 @@ test-suite dm-test
180187 build-depends:
181188 aeson
182189 , async
190+ , amazonka
191+ , amazonka-ecr
183192 , base >=4.7 && <5
184193 , bytestring
185194 , chronos
dm-backend/src/DMS.hs+12
@@ -31,6 +31,7 @@ import System.Process.Typed
3131
3232import Common.API
3333import DMS.Args
34+import DMS.AWS
3435import Orphans ()
3536import TLS (createTLSOpts)
3637import Types
@@ -159,6 +160,7 @@ createH dep = do
159160 "INSERT INTO deployments (name, tag, envs) VALUES (?, ?, ?)"
160161 -- FIXME: make EnvPairs a newtype and give it ToField instance
161162 (n, t, formatEnvPairs e)
163+ failIfImageNotFound $ tag dep
162164 res :: Either SqlError Int64 <- liftIO . try $ createDep pgPool dep
163165 case res of
164166 Right _ -> pure ()
@@ -338,6 +340,7 @@ updateH dName DeploymentUpdate { newTag = dTag, newEnvs = nEnvs } = do
338340 , "--tag", coerce $ dTag
339341 ] ++ concat [["--env", concatPair e] | e <- envPairs]
340342 cmd = coerce $ updateCommand st
343+ failIfImageNotFound dTag
341344 liftIO $ do
342345 void $ updateDeploymentNameAndTag pgPool dName dTag
343346 log $ "call " <> unwords (cmd : args)
@@ -457,6 +460,7 @@ restoreH dName = do
457460 st <- ask
458461 let pgPool = pool st
459462 dep <- selectDeployment pgPool dName ArchivedOnlyDeployments
463+ failIfImageNotFound $ tag dep
460464 ec <- createDeployment dep st
461465 void $ liftIO $ do
462466 let
@@ -501,6 +505,14 @@ createDeploymentLog pgPool (Deployment dName dTag dEnvs) act ec arch = do
501505 void $ withResource pgPool $ \conn ->
502506 execute conn q (act, dTag, formatEnvPairs dEnvs, exitCode', arch', dName)
503507
508+failIfImageNotFound :: DeploymentTag -> AppM ()
509+failIfImageNotFound dTag = do
510+ foundTag <- liftIO . findImageTag $ dTag
511+ case foundTag of
512+ Just _ -> pure ()
513+ Nothing ->
514+ throwError err400 { errBody = validationError [] ["tag not found"] }
515+
504516appError :: Text -> BSL.ByteString
505517appError = encode . AppError
506518
dm-backend/src/DMS/AWS.hsnew file+47
@@ -0,0 +1,47 @@
1+module DMS.AWS (findImageTag) where
2+
3+import Control.Lens
4+import Data.Coerce
5+import Data.Text
6+import Network.AWS
7+import Network.AWS.ECR
8+
9+import Types
10+
11+repositoryName :: Text
12+repositoryName = "default"
13+
14+findImageTag :: DeploymentTag -> IO (Maybe Text)
15+findImageTag dTag = do
16+ env <- newEnv Discover
17+ let
18+ lImages =
19+ listImages repositoryName
20+ & liFilter .~ Just (listImagesFilter & lifTagStatus .~ Just Tagged)
21+ resp <- runResourceT . runAWS env . send $ lImages
22+ handleResponse dTag env resp
23+
24+handleResponse :: DeploymentTag -> Env -> ListImagesResponse -> IO (Maybe Text)
25+handleResponse dTag env resp = do
26+ let
27+ foundTags =
28+ resp
29+ ^. lirsImageIds
30+ ^.. each . iiImageTag . _Just . filtered (== coerce dTag)
31+ case foundTags of
32+ [foundTag] -> pure . Just $ foundTag
33+ _ -> findImageTagWithNextToken dTag env (resp ^. lirsNextToken)
34+
35+findImageTagWithNextToken
36+ :: DeploymentTag
37+ -> Env -> Maybe Text
38+ -> IO (Maybe Text)
39+findImageTagWithNextToken _ _ Nothing = pure Nothing
40+findImageTagWithNextToken dTag env (Just token) = do
41+ let
42+ lImages =
43+ listImages repositoryName
44+ & liFilter .~ Just (listImagesFilter & lifTagStatus .~ Just Tagged)
45+ & liNextToken .~ Just token
46+ resp <- runResourceT . runAWS env . send $ lImages
47+ handleResponse dTag env resp
nix/sources.json+3−3
@@ -29,10 +29,10 @@
2929 "homepage": "https://github.com/NixOS/nixpkgs",
3030 "owner": "NixOS",
3131 "repo": "nixpkgs",
32− "rev": "1484e1acfeee4c5ec039df93282e78ffc0be2236",
33− "sha256": "060165brkgngwgln2i87qgqbj5kgiwgihm1qcy7apzydbmibz9zz",
32+ "rev": "3eea039a964ecefbc657498b3829dfa19727f069",
33+ "sha256": "14kb40a1v4zdr45dr8rb7zda0qbn3sw4b2k37m7p9q70kyv93rmg",
3434 "type": "tarball",
35− "url": "https://github.com/NixOS/nixpkgs/archive/1484e1acfeee4c5ec039df93282e78ffc0be2236.tar.gz",
35+ "url": "https://github.com/NixOS/nixpkgs/archive/3eea039a964ecefbc657498b3829dfa19727f069.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 },
3838 "servant-reflex": {