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

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

-- | 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
  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
    -- 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]
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 -- FIXME: custom escaping including '$'