{-# 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

-- | Subject to change
loadImages :: [Image] -> IO ()
loadImages :: [Image] -> IO ()
loadImages [Image]
requestedImages = do

  [Text]
loaded <- IO [Text]
getDockerImages

  let
    isNew :: Image -> Bool
isNew Image
i =
      -- On docker, the image name is unmodified
      (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
      -- On podman, you used to automatically get a localhost prefix
      -- however, since NixOS 22.05, this expected to be part of the name instead
        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
""