{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
module Arion.Images
( loadImages
) where
import Prelude()
import Protolude hiding (to)
import qualified System.Process as Process
import qualified Data.Text as T
import Arion.ExtendedInfo (Image(..))
type TaggedImage = Text
loadImages :: [Image] -> IO ()
loadImages :: [Image] -> IO ()
loadImages [Image]
requestedImages = do
[Text]
loaded <- IO [Text]
getDockerImages
let
isNew :: Image -> Bool
isNew Image
i =
(Image -> Text
imageName Image
i forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Image -> Text
imageTag Image
i) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
loaded
Bool -> Bool -> Bool
&& (Text
"localhost/" forall a. Semigroup a => a -> a -> a
<> Image -> Text
imageName Image
i forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Image -> Text
imageTag Image
i) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
loaded
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Image -> IO ()
loadImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Image -> Bool
isNew forall a b. (a -> b) -> a -> b
$ [Image]
requestedImages
loadImage :: Image -> IO ()
loadImage :: Image -> IO ()
loadImage Image { image :: Image -> Maybe Text
image = Just Text
imgPath, imageName :: Image -> Text
imageName = Text
name } =
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (forall a b. ConvertText a b => a -> b
toS Text
imgPath) IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
fileHandle -> do
let procSpec :: CreateProcess
procSpec = (String -> [String] -> CreateProcess
Process.proc String
"docker" [ String
"load" ]) {
std_in :: StdStream
Process.std_in = Handle -> StdStream
Process.UseHandle Handle
fileHandle
}
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
procSpec forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_in Maybe Handle
_out Maybe Handle
_err ProcessHandle
procHandle -> do
ExitCode
e <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
procHandle
case ExitCode
e of
ExitCode
ExitSuccess -> forall (f :: * -> *). Applicative f => f ()
pass
ExitFailure Int
code ->
forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"docker load failed with exit code " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
code forall a. Semigroup a => a -> a -> a
<> Text
" for image " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" from path " forall a. Semigroup a => a -> a -> a
<> Text
imgPath
loadImage Image { imageExe :: Image -> Maybe Text
imageExe = Just Text
imgExe, imageName :: Image -> Text
imageName = Text
name } = do
let loadSpec :: CreateProcess
loadSpec = (String -> [String] -> CreateProcess
Process.proc String
"docker" [ String
"load" ]) { std_in :: StdStream
Process.std_in = StdStream
Process.CreatePipe }
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
loadSpec forall a b. (a -> b) -> a -> b
$ \(Just Handle
inHandle) Maybe Handle
_out Maybe Handle
_err ProcessHandle
loadProcHandle -> do
let streamSpec :: CreateProcess
streamSpec = String -> [String] -> CreateProcess
Process.proc (forall a b. ConvertText a b => a -> b
toS Text
imgExe) []
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
streamSpec { std_out :: StdStream
Process.std_out = Handle -> StdStream
Process.UseHandle Handle
inHandle } forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
streamProcHandle ->
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
loadProcHandle) forall a b. (a -> b) -> a -> b
$ \Async ExitCode
loadExitAsync ->
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
streamProcHandle) forall a b. (a -> b) -> a -> b
$ \Async ExitCode
streamExitAsync -> do
Either ExitCode ExitCode
r <- forall a b. Async a -> Async b -> IO (Either a b)
waitEither Async ExitCode
loadExitAsync Async ExitCode
streamExitAsync
case Either ExitCode ExitCode
r of
Right (ExitFailure Int
code) -> forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"image producer for image " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" failed with exit code " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
code forall a. Semigroup a => a -> a -> a
<> Text
" from executable " forall a. Semigroup a => a -> a -> a
<> Text
imgExe
Right ExitCode
ExitSuccess -> forall (f :: * -> *). Applicative f => f ()
pass
Left ExitCode
_ -> forall (f :: * -> *). Applicative f => f ()
pass
ExitCode
loadExit <- forall a. Async a -> IO a
wait Async ExitCode
loadExitAsync
case ExitCode
loadExit of
ExitFailure Int
code -> forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"docker load failed with exit code " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
code forall a. Semigroup a => a -> a -> a
<> Text
" for image " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" produced by executable " forall a. Semigroup a => a -> a -> a
<> Text
imgExe
ExitCode
_ -> forall (f :: * -> *). Applicative f => f ()
pass
forall (f :: * -> *). Applicative f => f ()
pass
loadImage Image { imageName :: Image -> Text
imageName = Text
name } = do
forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"image " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" doesn't specify an image file or imageExe executable"
getDockerImages :: IO [TaggedImage]
getDockerImages :: IO [Text]
getDockerImages = do
let procSpec :: CreateProcess
procSpec = String -> [String] -> CreateProcess
Process.proc String
"docker" [ String
"images", String
"--filter", String
"dangling=false", String
"--format", String
"{{.Repository}}:{{.Tag}}" ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> String -> IO String
Process.readCreateProcess CreateProcess
procSpec String
""