{-# 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 FilePath
evalModules :: NonEmpty FilePath
, EvaluationArgs -> Text
evalPkgs :: Text
, EvaluationArgs -> Maybe FilePath
evalWorkDir :: Maybe FilePath
, EvaluationArgs -> EvaluationMode
evalMode :: EvaluationMode
, EvaluationArgs -> [Text]
evalUserArgs :: [Text]
}
evaluateComposition :: EvaluationArgs -> IO Value
evaluateComposition :: EvaluationArgs -> IO Value
evaluateComposition EvaluationArgs
ea = do
FilePath
evalComposition <- IO FilePath
getEvalCompositionFile
let commandArgs :: [FilePath]
commandArgs =
[ FilePath
"--eval"
, FilePath
"--strict"
, FilePath
"--json"
, FilePath
"--attr"
, FilePath
"config.out.dockerComposeYamlAttrs"
]
args :: [FilePath]
args =
[ FilePath
evalComposition ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
commandArgs
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ EvaluationMode -> [FilePath]
modeArguments (EvaluationArgs -> EvaluationMode
evalMode EvaluationArgs
ea)
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [FilePath]
argArgs EvaluationArgs
ea
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"nix-instantiate" [FilePath]
args)
{ cwd :: Maybe FilePath
cwd = EvaluationArgs -> Maybe FilePath
evalWorkDir EvaluationArgs
ea
, std_out :: StdStream
std_out = StdStream
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 FilePath Value
v <- Either FilePath Value -> IO (Either FilePath Value)
forall a. a -> IO a
Protolude.evaluate (ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath 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, ConvertText FilePath b) => a -> b
show ExitCode
exitCode
case Either FilePath Value
v of
Right Value
r -> Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
r
Left FilePath
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
<> FilePath -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show FilePath
e)
withEvaluatedComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withEvaluatedComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withEvaluatedComposition EvaluationArgs
ea FilePath -> IO r
f = do
Value
v <- EvaluationArgs -> IO Value
evaluateComposition EvaluationArgs
ea
FilePath -> FilePath -> (FilePath -> Handle -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile FilePath
"." FilePath
".tmp-arion-docker-compose.yaml" ((FilePath -> Handle -> IO r) -> IO r)
-> (FilePath -> Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \FilePath
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
FilePath -> IO r
f FilePath
path
buildComposition :: FilePath -> EvaluationArgs -> IO ()
buildComposition :: FilePath -> EvaluationArgs -> IO ()
buildComposition FilePath
outLink EvaluationArgs
ea = do
FilePath
evalComposition <- IO FilePath
getEvalCompositionFile
let commandArgs :: [FilePath]
commandArgs =
[ FilePath
"--attr"
, FilePath
"config.out.dockerComposeYaml"
, FilePath
"--out-link"
, FilePath
outLink
]
args :: [FilePath]
args =
[ FilePath
evalComposition ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
commandArgs
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [FilePath]
argArgs EvaluationArgs
ea
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"nix-build" [FilePath]
args) { cwd :: Maybe FilePath
cwd = EvaluationArgs -> Maybe FilePath
evalWorkDir EvaluationArgs
ea }
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, ConvertText FilePath b) => a -> b
show ExitCode
exitCode
withBuiltComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withBuiltComposition :: EvaluationArgs -> (FilePath -> IO r) -> IO r
withBuiltComposition EvaluationArgs
ea FilePath -> IO r
f = do
FilePath -> FilePath -> (FilePath -> Handle -> IO r) -> IO r
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile FilePath
"." FilePath
".tmp-arion-docker-compose.yaml" ((FilePath -> Handle -> IO r) -> IO r)
-> (FilePath -> Handle -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \FilePath
path Handle
emptyYamlHandle -> do
Handle -> IO ()
hClose Handle
emptyYamlHandle
FilePath -> IO ()
Directory.removeFile FilePath
path
FilePath -> EvaluationArgs -> IO ()
buildComposition FilePath
path EvaluationArgs
ea
FilePath -> IO r
f FilePath
path
replForComposition :: EvaluationArgs -> IO ()
replForComposition :: EvaluationArgs -> IO ()
replForComposition EvaluationArgs
ea = do
FilePath
evalComposition <- IO FilePath
getEvalCompositionFile
let args :: [FilePath]
args =
[ FilePath
"repl", FilePath
evalComposition ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ EvaluationArgs -> [FilePath]
argArgs EvaluationArgs
ea
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (EvaluationArgs -> [Text]
evalUserArgs EvaluationArgs
ea)
procSpec :: CreateProcess
procSpec = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"nix" [FilePath]
args) { cwd :: Maybe FilePath
cwd = EvaluationArgs -> Maybe FilePath
evalWorkDir EvaluationArgs
ea }
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, ConvertText FilePath b) => a -> b
show ExitCode
exitCode
argArgs :: EvaluationArgs -> [[Char]]
argArgs :: EvaluationArgs -> [FilePath]
argArgs EvaluationArgs
ea =
[ FilePath
"--argstr"
, FilePath
"uid"
, Int -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> Int
evalUid EvaluationArgs
ea
, FilePath
"--arg"
, FilePath
"modules"
, NonEmpty FilePath -> FilePath
modulesNixExpr (NonEmpty FilePath -> FilePath) -> NonEmpty FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> NonEmpty FilePath
evalModules EvaluationArgs
ea
, FilePath
"--arg"
, FilePath
"pkgs"
, Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ EvaluationArgs -> Text
evalPkgs EvaluationArgs
ea
]
getEvalCompositionFile :: IO FilePath
getEvalCompositionFile :: IO FilePath
getEvalCompositionFile = FilePath -> IO FilePath
getDataFileName FilePath
"nix/eval-composition.nix"
modeArguments :: EvaluationMode -> [[Char]]
modeArguments :: EvaluationMode -> [FilePath]
modeArguments EvaluationMode
ReadWrite = [ FilePath
"--read-write-mode" ]
modeArguments EvaluationMode
ReadOnly = [ FilePath
"--readonly-mode" ]
modulesNixExpr :: NonEmpty FilePath -> [Char]
modulesNixExpr :: NonEmpty FilePath -> FilePath
modulesNixExpr =
NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty FilePath -> [FilePath])
-> ([FilePath] -> FilePath) -> NonEmpty FilePath -> FilePath
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
pathExpr ([FilePath] -> [FilePath])
-> ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [FilePath] -> FilePath
Data.String.unwords ([FilePath] -> FilePath)
-> (FilePath -> FilePath) -> [FilePath] -> FilePath
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FilePath -> FilePath
forall a. (Semigroup a, IsString a) => a -> a
wrapList
where
pathExpr :: FilePath -> [Char]
pathExpr :: FilePath -> FilePath
pathExpr FilePath
path | FilePath -> Bool
isAbsolute FilePath
path = FilePath
"(/. + \"/${" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
toNixStringLiteral FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"}\")"
| Bool
otherwise = FilePath
"(./. + \"/${" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
toNixStringLiteral FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"}\")"
isAbsolute :: FilePath -> Bool
isAbsolute (Char
'/' : FilePath
_) = Bool
True
isAbsolute FilePath
_ = 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 :: FilePath -> FilePath
toNixStringLiteral = FilePath -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show