module Arion.Nix
  ( evaluateComposition,
    withEvaluatedComposition,
    buildComposition,
    withBuiltComposition,
    replForComposition,
    EvaluationArgs (..),
    EvaluationMode (..),
  )
where

import Arion.Aeson (pretty)
import Control.Arrow ((>>>))
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.String
import qualified Data.Text.IO as T
import Paths_arion_compose
import Protolude
import qualified System.Directory as Directory
import System.IO (hClose)
import System.IO.Temp (withTempFile)
import System.Process
import Prelude ()

data EvaluationMode
  = ReadWrite
  | ReadOnly

data EvaluationArgs = EvaluationArgs
  { EvaluationArgs -> Int
posixUID :: Int,
    EvaluationArgs -> NonEmpty [Char]
evalModulesFile :: NonEmpty FilePath,
    EvaluationArgs -> Text
pkgsExpr :: Text,
    EvaluationArgs -> Maybe [Char]
workDir :: Maybe FilePath,
    EvaluationArgs -> EvaluationMode
mode :: EvaluationMode,
    EvaluationArgs -> [Text]
extraNixArgs :: [Text]
  }

evaluateComposition :: EvaluationArgs -> IO Value
evaluateComposition :: EvaluationArgs -> IO Value
evaluateComposition EvaluationArgs
ea = do
  [Char]
evalComposition <- IO [Char]
getEvalCompositionFile
  let commandArgs :: [[Char]]
commandArgs =
        [ [Char]
"--eval",
          [Char]
"--strict",
          [Char]
"--json",
          [Char]
"--attr",
          [Char]
"config.out.dockerComposeYamlAttrs"
        ]
      args :: [[Char]]
args =
        [[Char]
evalComposition]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
commandArgs
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ EvaluationMode -> [[Char]]
modeArguments EvaluationArgs
ea.mode
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Text -> [Char]) -> [Text] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> [Char]
forall a b. ConvertText a b => a -> b
toS EvaluationArgs
ea.extraNixArgs
      procSpec :: CreateProcess
procSpec =
        ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix-instantiate" [[Char]]
args)
          { cwd = ea.workDir,
            std_out = CreatePipe
          }

  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Value)
-> IO Value
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
procSpec ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Value)
 -> IO Value)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Value)
-> IO Value
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_in Maybe Handle
outHM Maybe Handle
_err ProcessHandle
procHandle -> do
    let outHandle :: Handle
outHandle = Handle -> Maybe Handle -> Handle
forall a. a -> Maybe a -> a
fromMaybe (Text -> Handle
forall a. HasCallStack => Text -> a
panic Text
"stdout missing") Maybe Handle
outHM

    ByteString
out <- Handle -> IO ByteString
BL.hGetContents Handle
outHandle

    Either [Char] Value
v <- Either [Char] Value -> IO (Either [Char] Value)
forall a. a -> IO a
Protolude.evaluate (ByteString -> Either [Char] Value
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
out)

    ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle

    case ExitCode
exitCode of
      ExitCode
ExitSuccess -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
      ExitFailure Int
1 -> IO ()
forall a. IO a
exitFailure
      ExitFailure {} -> do
        FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text -> FatalError) -> Text -> FatalError
forall a b. (a -> b) -> a -> b
$ Text
"evaluation failed with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExitCode -> Text
forall a b. (Show a, StringConv [Char] b) => a -> b
show ExitCode
exitCode

    case Either [Char] Value
v of
      Right Value
r -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
r
      Left [Char]
e -> FatalError -> IO Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO Value) -> FatalError -> IO Value
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Couldn't parse nix-instantiate output" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a b. (Show a, StringConv [Char] b) => a -> b
show [Char]
e)

-- | Run with docker-compose.yaml tmpfile
withEvaluatedComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withEvaluatedComposition :: forall r. EvaluationArgs -> ([Char] -> IO r) -> IO r
withEvaluatedComposition EvaluationArgs
ea [Char] -> IO r
f = do
  Value
v <- EvaluationArgs -> IO Value
evaluateComposition EvaluationArgs
ea
  [Char] -> [Char] -> ([Char] -> Handle -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFile [Char]
"." [Char]
".tmp-arion-docker-compose.yaml" (([Char] -> Handle -> IO r) -> IO r)
-> ([Char] -> Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \[Char]
path Handle
yamlHandle -> do
    Handle -> Text -> IO ()
T.hPutStrLn Handle
yamlHandle (Value -> Text
forall a. ToJSON a => a -> Text
pretty Value
v)
    Handle -> IO ()
hClose Handle
yamlHandle
    [Char] -> IO r
f [Char]
path

buildComposition :: FilePath -> EvaluationArgs -> IO ()
buildComposition :: [Char] -> EvaluationArgs -> IO ()
buildComposition [Char]
outLink EvaluationArgs
ea = do
  [Char]
evalComposition <- IO [Char]
getEvalCompositionFile
  let commandArgs :: [[Char]]
commandArgs =
        [ [Char]
"--attr",
          [Char]
"config.out.dockerComposeYaml",
          [Char]
"--out-link",
          [Char]
outLink
        ]
      args :: [[Char]]
args =
        [[Char]
evalComposition]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
commandArgs
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Text -> [Char]) -> [Text] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> [Char]
forall a b. ConvertText a b => a -> b
toS EvaluationArgs
ea.extraNixArgs
      procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix-build" [[Char]]
args) {cwd = ea.workDir}

  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
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
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle

    case ExitCode
exitCode of
      ExitCode
ExitSuccess -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
      ExitFailure Int
1 -> IO ()
forall a. IO a
exitFailure
      ExitFailure {} -> do
        FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text -> FatalError) -> Text -> FatalError
forall a b. (a -> b) -> a -> b
$ Text
"nix-build failed with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExitCode -> Text
forall a b. (Show a, StringConv [Char] b) => a -> b
show ExitCode
exitCode

-- | Do something with a docker-compose.yaml.
withBuiltComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withBuiltComposition :: forall r. EvaluationArgs -> ([Char] -> IO r) -> IO r
withBuiltComposition EvaluationArgs
ea [Char] -> IO r
f = do
  [Char] -> [Char] -> ([Char] -> Handle -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFile [Char]
"." [Char]
".tmp-arion-docker-compose.yaml" (([Char] -> Handle -> IO r) -> IO r)
-> ([Char] -> Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \[Char]
path Handle
emptyYamlHandle -> do
    Handle -> IO ()
hClose Handle
emptyYamlHandle
    -- Known problem: kills atomicity of withTempFile; won't fix because we should manage gc roots,
    -- impl of which will probably avoid this "problem". It seems unlikely to cause issues.
    [Char] -> IO ()
Directory.removeFile [Char]
path
    [Char] -> EvaluationArgs -> IO ()
buildComposition [Char]
path EvaluationArgs
ea
    [Char] -> IO r
f [Char]
path

replForComposition :: EvaluationArgs -> IO ()
replForComposition :: EvaluationArgs -> IO ()
replForComposition EvaluationArgs
ea = do
  [Char]
evalComposition <- IO [Char]
getEvalCompositionFile
  let args :: [[Char]]
args =
        [[Char]
"repl", [Char]
"--file", [Char]
evalComposition]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Text -> [Char]) -> [Text] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> [Char]
forall a b. ConvertText a b => a -> b
toS EvaluationArgs
ea.extraNixArgs
      procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix" [[Char]]
args) {cwd = ea.workDir}

  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
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
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle

    case ExitCode
exitCode of
      ExitCode
ExitSuccess -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
      ExitFailure Int
1 -> IO ()
forall a. IO a
exitFailure
      ExitFailure {} -> do
        FatalError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FatalError -> IO ()) -> FatalError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text -> FatalError) -> Text -> FatalError
forall a b. (a -> b) -> a -> b
$ Text
"nix repl failed with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExitCode -> Text
forall a b. (Show a, StringConv [Char] b) => a -> b
show ExitCode
exitCode

argArgs :: EvaluationArgs -> [[Char]]
argArgs :: EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea =
  [ [Char]
"--argstr",
    [Char]
"uid",
    Int -> [Char]
forall a b. (Show a, StringConv [Char] b) => a -> b
show EvaluationArgs
ea.posixUID,
    [Char]
"--arg",
    [Char]
"modules",
    NonEmpty [Char] -> [Char]
modulesNixExpr EvaluationArgs
ea.evalModulesFile,
    [Char]
"--arg",
    [Char]
"pkgs",
    Text -> [Char]
forall a b. ConvertText a b => a -> b
toS EvaluationArgs
ea.pkgsExpr
  ]

getEvalCompositionFile :: IO FilePath
getEvalCompositionFile :: IO [Char]
getEvalCompositionFile = [Char] -> IO [Char]
getDataFileName [Char]
"nix/eval-composition.nix"

modeArguments :: EvaluationMode -> [[Char]]
modeArguments :: EvaluationMode -> [[Char]]
modeArguments EvaluationMode
ReadWrite = [[Char]
"--read-write-mode"]
modeArguments EvaluationMode
ReadOnly = [[Char]
"--readonly-mode"]

modulesNixExpr :: NonEmpty FilePath -> [Char]
modulesNixExpr :: NonEmpty [Char] -> [Char]
modulesNixExpr =
  NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [Char] -> [[Char]])
-> ([[Char]] -> [Char]) -> NonEmpty [Char] -> [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [Char]
pathExpr ([[Char]] -> [[Char]])
-> ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [[Char]] -> [Char]
Data.String.unwords ([[Char]] -> [Char]) -> ([Char] -> [Char]) -> [[Char]] -> [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Char] -> [Char]
forall {a}. (Semigroup a, IsString a) => a -> a
wrapList
  where
    pathExpr :: FilePath -> [Char]
    pathExpr :: [Char] -> [Char]
pathExpr [Char]
path
      | [Char] -> Bool
isAbsolute [Char]
path = [Char]
"(/. + \"/${" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
toNixStringLiteral [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"}\")"
      | Bool
otherwise = [Char]
"(./. + \"/${" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
toNixStringLiteral [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"}\")"

    isAbsolute :: [Char] -> Bool
isAbsolute (Char
'/' : [Char]
_) = Bool
True
    isAbsolute [Char]
_ = Bool
False

    wrapList :: a -> a
wrapList a
s = a
"[ " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" ]"

toNixStringLiteral :: [Char] -> [Char]
toNixStringLiteral :: [Char] -> [Char]
toNixStringLiteral = [Char] -> [Char]
forall a b. (Show a, StringConv [Char] b) => a -> b
show -- FIXME: custom escaping including '$'