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

  [TaggedImage]
loaded <- IO [TaggedImage]
getDockerImages

  let
    isNew :: Image -> Bool
isNew Image
i =
      -- On docker, the image name is unmodified
      (Image -> TaggedImage
imageName Image
i TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
":" TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Image -> TaggedImage
imageTag Image
i) TaggedImage -> [TaggedImage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TaggedImage]
loaded
      -- -- On podman, you automatically get a localhost prefix
        Bool -> Bool -> Bool
&& (TaggedImage
"localhost/" TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Image -> TaggedImage
imageName Image
i TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
":" TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Image -> TaggedImage
imageTag Image
i) TaggedImage -> [TaggedImage] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TaggedImage]
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 { image :: Image -> Maybe TaggedImage
image = Just TaggedImage
imgPath, imageName :: Image -> TaggedImage
imageName = TaggedImage
name } =
  FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (TaggedImage -> FilePath
forall a b. ConvertText a b => a -> b
toS TaggedImage
imgPath) IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
fileHandle -> do
  let procSpec :: CreateProcess
procSpec = (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
"docker" [ FilePath
"load" ]) {
          std_in :: StdStream
Process.std_in = Handle -> StdStream
Process.UseHandle Handle
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 ->
        TaggedImage -> IO ()
forall a. HasCallStack => TaggedImage -> a
panic (TaggedImage -> IO ()) -> TaggedImage -> IO ()
forall a b. (a -> b) -> a -> b
$ TaggedImage
"docker load failed with exit code " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Int -> TaggedImage
forall a b. (Show a, ConvertText FilePath b) => a -> b
show Int
code TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" for image " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
name TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" from path " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
imgPath

loadImage Image { imageExe :: Image -> Maybe TaggedImage
imageExe = Just TaggedImage
imgExe, imageName :: Image -> TaggedImage
imageName = TaggedImage
name } = do
  let loadSpec :: CreateProcess
loadSpec = (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
"docker" [ FilePath
"load" ]) { std_in :: StdStream
Process.std_in = StdStream
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 = FilePath -> [FilePath] -> CreateProcess
Process.proc (TaggedImage -> FilePath
forall a b. ConvertText a b => a -> b
toS TaggedImage
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 { std_out :: StdStream
Process.std_out = Handle -> StdStream
Process.UseHandle Handle
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) -> TaggedImage -> IO ()
forall a. HasCallStack => TaggedImage -> a
panic (TaggedImage -> IO ()) -> TaggedImage -> IO ()
forall a b. (a -> b) -> a -> b
$ TaggedImage
"image producer for image " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
name TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" failed with exit code " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Int -> TaggedImage
forall a b. (Show a, ConvertText FilePath b) => a -> b
show Int
code TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" from executable " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
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 -> TaggedImage -> IO ()
forall a. HasCallStack => TaggedImage -> a
panic (TaggedImage -> IO ()) -> TaggedImage -> IO ()
forall a b. (a -> b) -> a -> b
$ TaggedImage
"docker load failed with exit code " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> Int -> TaggedImage
forall a b. (Show a, ConvertText FilePath b) => a -> b
show Int
code TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" for image " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
name TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" produced by executable " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
imgExe
            ExitCode
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
          IO ()
forall (f :: * -> *). Applicative f => f ()
pass

loadImage Image { imageName :: Image -> TaggedImage
imageName = TaggedImage
name } = do
  TaggedImage -> IO ()
forall a. HasCallStack => TaggedImage -> a
panic (TaggedImage -> IO ()) -> TaggedImage -> IO ()
forall a b. (a -> b) -> a -> b
$ TaggedImage
"image " TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
name TaggedImage -> TaggedImage -> TaggedImage
forall a. Semigroup a => a -> a -> a
<> TaggedImage
" doesn't specify an image file or imageExe executable"


getDockerImages :: IO [TaggedImage]
getDockerImages :: IO [TaggedImage]
getDockerImages = do
  let procSpec :: CreateProcess
procSpec = FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
"docker" [ FilePath
"images",  FilePath
"--filter", FilePath
"dangling=false", FilePath
"--format", FilePath
"{{.Repository}}:{{.Tag}}" ]
  (TaggedImage -> TaggedImage) -> [TaggedImage] -> [TaggedImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map TaggedImage -> TaggedImage
forall a b. ConvertText a b => a -> b
toS ([TaggedImage] -> [TaggedImage])
-> (FilePath -> [TaggedImage]) -> FilePath -> [TaggedImage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedImage -> [TaggedImage]
T.lines (TaggedImage -> [TaggedImage])
-> (FilePath -> TaggedImage) -> FilePath -> [TaggedImage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> TaggedImage
forall a b. ConvertText a b => a -> b
toS (FilePath -> [TaggedImage]) -> IO FilePath -> IO [TaggedImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> FilePath -> IO FilePath
Process.readCreateProcess CreateProcess
procSpec FilePath
""