module Arion.Images
  ( loadImages,
  )
where

import Arion.ExtendedInfo (Image (..))
import qualified Data.Text as T
import Protolude hiding (to)
import qualified System.Process as Process
import Prelude ()

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 -> Bool
isNew Image
i =
        -- On docker, the image name is unmodified
        (Image
i.imageName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Image
i.imageTag) Text -> [Text] -> Bool
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/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Image
i.imageName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Image
i.imageTag) Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
loaded

  (Image -> IO ()) -> [Image] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Image -> IO ()
loadImage ([Image] -> IO ()) -> ([Image] -> [Image]) -> [Image] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image -> Bool) -> [Image] -> [Image]
forall a. (a -> Bool) -> [a] -> [a]
filter Image -> Bool
isNew ([Image] -> IO ()) -> [Image] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Image]
requestedImages

loadImage :: Image -> IO ()
loadImage :: Image -> IO ()
loadImage Image {$sel:image:Image :: Image -> Maybe Text
image = Just Text
imgPath, $sel:imageName:Image :: Image -> Text
imageName = Text
name} =
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
imgPath) IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
fileHandle -> do
    let procSpec :: CreateProcess
procSpec =
          (String -> [String] -> CreateProcess
Process.proc String
"docker" [String
"load"])
            { Process.std_in = Process.UseHandle fileHandle
            }
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
procSpec ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
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 -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        ExitFailure Int
code ->
          Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"docker load failed with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Int
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for image " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imgPath
loadImage Image {$sel:imageExe:Image :: Image -> Maybe Text
imageExe = Just Text
imgExe, $sel:imageName:Image :: Image -> Text
imageName = Text
name} = do
  let loadSpec :: CreateProcess
loadSpec = (String -> [String] -> CreateProcess
Process.proc String
"docker" [String
"load"]) {Process.std_in = Process.CreatePipe}
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
loadSpec ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
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 (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
imgExe) []
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
Process.withCreateProcess CreateProcess
streamSpec {Process.std_out = Process.UseHandle inHandle} ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
streamProcHandle ->
      IO ExitCode -> (Async ExitCode -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
loadProcHandle) ((Async ExitCode -> IO ()) -> IO ())
-> (Async ExitCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ExitCode
loadExitAsync ->
        IO ExitCode -> (Async ExitCode -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
streamProcHandle) ((Async ExitCode -> IO ()) -> IO ())
-> (Async ExitCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ExitCode
streamExitAsync -> do
          Either ExitCode ExitCode
r <- Async ExitCode -> Async ExitCode -> IO (Either ExitCode ExitCode)
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) -> Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"image producer for image " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Int
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from executable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imgExe
            Right ExitCode
ExitSuccess -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
            Left ExitCode
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
          ExitCode
loadExit <- Async ExitCode -> IO ExitCode
forall a. Async a -> IO a
wait Async ExitCode
loadExitAsync
          case ExitCode
loadExit of
            ExitFailure Int
code -> Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"docker load failed with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Int
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for image " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" produced by executable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imgExe
            ExitCode
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
          IO ()
forall (f :: * -> *). Applicative f => f ()
pass
loadImage Image {$sel:imageName:Image :: Image -> Text
imageName = Text
name} = do
  Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"image " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
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}}"]
  (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
forall a b. ConvertText a b => a -> b
toS ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> [Text]) -> IO String -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> String -> IO String
Process.readCreateProcess CreateProcess
procSpec String
""