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

-- | Run with docker-compose.yaml tmpfile
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

-- | Do something with a docker-compose.yaml.
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
    -- 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.
    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 -- FIXME: custom escaping including '$'