{-# LANGUAGE OverloadedStrings #-}
module Arion.Nix
( evaluateComposition
, withEvaluatedComposition
, buildComposition
, withBuiltComposition
, replForComposition
, EvaluationArgs(..)
, EvaluationMode(..)
) where
import Prelude ( )
import Protolude
import Arion.Aeson ( pretty )
import Data.Aeson
import qualified Data.String
import qualified System.Directory as Directory
import System.Process
import qualified Data.ByteString.Lazy as BL
import Paths_arion_compose
import qualified Data.Text.IO as T
import qualified Data.List.NonEmpty as NE
import Control.Arrow ( (>>>) )
import System.IO.Temp ( withTempFile )
import System.IO ( hClose )
data EvaluationMode =
ReadWrite | ReadOnly
data EvaluationArgs = EvaluationArgs
{ EvaluationArgs -> Int
evalUid :: Int
, EvaluationArgs -> NonEmpty [Char]
evalModules :: NonEmpty FilePath
, EvaluationArgs -> Text
evalPkgs :: Text
, EvaluationArgs -> Maybe [Char]
evalWorkDir :: Maybe FilePath
, EvaluationArgs -> EvaluationMode
evalMode :: EvaluationMode
, EvaluationArgs -> [Text]
evalUserArgs :: [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 ]
forall a. [a] -> [a] -> [a]
++ [[Char]]
commandArgs
forall a. [a] -> [a] -> [a]
++ EvaluationMode -> [[Char]]
modeArguments (EvaluationArgs -> EvaluationMode
evalMode EvaluationArgs
ea)
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix-instantiate" [[Char]]
args)
{ cwd :: Maybe [Char]
cwd = EvaluationArgs -> Maybe [Char]
evalWorkDir EvaluationArgs
ea
, std_out :: StdStream
std_out = StdStream
CreatePipe
}
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
procSpec forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_in Maybe Handle
outHM Maybe Handle
_err ProcessHandle
procHandle -> do
let outHandle :: Handle
outHandle = forall a. a -> Maybe a -> a
fromMaybe (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 <- forall a. a -> IO a
Protolude.evaluate (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 -> forall (f :: * -> *). Applicative f => f ()
pass
ExitFailure Int
1 -> forall a. IO a
exitFailure
ExitFailure {} -> do
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"evaluation failed with " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show ExitCode
exitCode
case Either [Char] Value
v of
Right Value
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
r
Left [Char]
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError (Text
"Couldn't parse nix-instantiate output" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show [Char]
e)
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
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFile [Char]
"." [Char]
".tmp-arion-docker-compose.yaml" forall a b. (a -> b) -> a -> b
$ \[Char]
path Handle
yamlHandle -> do
Handle -> Text -> IO ()
T.hPutStrLn Handle
yamlHandle (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 ]
forall a. [a] -> [a] -> [a]
++ [[Char]]
commandArgs
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix-build" [[Char]]
args) { cwd :: Maybe [Char]
cwd = EvaluationArgs -> Maybe [Char]
evalWorkDir EvaluationArgs
ea }
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
procSpec 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 -> forall (f :: * -> *). Applicative f => f ()
pass
ExitFailure Int
1 -> forall a. IO a
exitFailure
ExitFailure {} -> do
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"nix-build failed with " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show ExitCode
exitCode
withBuiltComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withBuiltComposition :: forall r. EvaluationArgs -> ([Char] -> IO r) -> IO r
withBuiltComposition EvaluationArgs
ea [Char] -> IO r
f = do
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> [Char] -> ([Char] -> Handle -> m a) -> m a
withTempFile [Char]
"." [Char]
".tmp-arion-docker-compose.yaml" forall a b. (a -> b) -> a -> b
$ \[Char]
path Handle
emptyYamlHandle -> do
Handle -> IO ()
hClose Handle
emptyYamlHandle
[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]
evalComposition ]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [[Char]]
argArgs EvaluationArgs
ea
forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
"nix" [[Char]]
args) { cwd :: Maybe [Char]
cwd = EvaluationArgs -> Maybe [Char]
evalWorkDir EvaluationArgs
ea }
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
procSpec 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 -> forall (f :: * -> *). Applicative f => f ()
pass
ExitFailure Int
1 -> forall a. IO a
exitFailure
ExitFailure {} -> do
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"nix repl failed with " forall a. Semigroup a => a -> a -> a
<> 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"
, forall a b. (Show a, StringConv [Char] b) => a -> b
show forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> Int
evalUid EvaluationArgs
ea
, [Char]
"--arg"
, [Char]
"modules"
, NonEmpty [Char] -> [Char]
modulesNixExpr forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> NonEmpty [Char]
evalModules EvaluationArgs
ea
, [Char]
"--arg"
, [Char]
"pkgs"
, forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> Text
evalPkgs EvaluationArgs
ea
]
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 =
forall a. NonEmpty a -> [a]
NE.toList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [Char]
pathExpr 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 forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> 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]
"(/. + \"/${" forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
toNixStringLiteral [Char]
path forall a. Semigroup a => a -> a -> a
<> [Char]
"}\")"
| Bool
otherwise = [Char]
"(./. + \"/${" forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
toNixStringLiteral [Char]
path 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
"[ " forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
" ]"
toNixStringLiteral :: [Char] -> [Char]
toNixStringLiteral :: [Char] -> [Char]
toNixStringLiteral = forall a b. (Show a, StringConv [Char] b) => a -> b
show