Argotest.hs

{-# LANGUAGE
   LambdaCase
 , OverloadedStrings
 , DataKinds
 , FlexibleInstances
 , TypeOperators #-}

module Argotest where

import Data.Default
import Turtle
import Prelude hiding (FilePath)

import System.IO (withFile)
import Debug.Trace
import Filesystem.Path ((</>))
import Control.Concurrent.Async
import System.Console.ANSI
import System.Console.ANSI.Types (Color)
import System.Posix.Signals
import System.Process hiding (shell)
import Data.Text as Text hiding (empty)
import Data.Text.IO as Text

data StackArgs = StackArgs
  { dargs                :: [Text]        --"Daemon arguments. Properly quote this."
  , app                  :: Text        --"Target application call, sh+path valid"
  , manifest             :: FilePath    --"Input file, manifest."
  , cmd_out              :: FilePath    --"Output file, application stdout"
  , cmd_err              :: FilePath    --"Output file, application stderr"
  , daemon_out           :: FilePath    --"Output file, daemon stdout"
  , daemon_err           :: FilePath    --"Output file, daemon stderr"
  , nrm_log              :: FilePath    --"Output file, daemon log"
  , time_file            :: FilePath  } --"Output file, application runtime"

instance Default StackArgs where
  def = StackArgs
    { dargs = []
    , app = "echo \"HelloWorld\""
    , manifest = "manifests/basic.json"
    , cmd_out = "cmd_out.log"
    , cmd_err = "cmd_err.log"
    , daemon_out = "daemon_out.log"
    , daemon_err = "daemon_err.log"
    , nrm_log = "nrm.log"
    , time_file = "time.log"
    }

colorShell :: Color -> Shell ()-> Shell ()
colorShell color s = setC color *> s *> setC White
  where setC c = liftIO $ setSGR [SetColor Foreground Dull c]

printInfo    :: Text -> Shell ()
printError   :: Text -> Shell ()
printWarning :: Text -> Shell ()
printInfo    = printf ("Info:"%s)
printWarning = colorShell Yellow . printf ("Warning:"%s)
printError   = colorShell Red . printf ("Error:"%s)

myWhich str = which str >>= \case
  (Just p) -> printInfo ( format ("Found "%fp%" at "%fp%"\n") str p ) >> return p
  Nothing -> die $ format ("Argo `"%fp%"` not in $PATH.") str

sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
sudoRemoveFile printer desc filePath = do
  foundSocket <- testfile filePath
  when foundSocket $ go False
  printInfo $ format ("OK: "%s%" "%fp%"\n") desc filePath
  where go useSudo = do
          printer $ format ("found stale " %s%" at "%fp%".. ") desc filePath
          shell (format ((if useSudo then "sudo " else "")%"rm -f "%fp) filePath) empty >>= \case
            ExitSuccess   -> colorShell Green $ printf " Successfully removed.\n"
            ExitFailure n -> if useSudo
                             then printer $ format ("Failed to remove stale "%s%", even with sudo.") desc
                             else do
                                printer $ format ("Failed to remove stale "%s%". Trying sudo..\n") desc
                                go True

cleanSocket = sudoRemoveFile printError "socket"
cleanLog    = sudoRemoveFile printWarning "log file"

cleanLeftovers :: FilePath -> FilePath -> FilePath ->
  FilePath -> FilePath -> FilePath -> Shell ()
cleanLeftovers daemon_out daemon_err cmd_out cmd_err time_file nrm_log = do
  printInfo "Cleaning leftovers..\n"
  mapM_ cleanLog [daemon_out, daemon_err, cmd_out, cmd_err, time_file, nrm_log, ".argo_nodeos_config_exit_message"]
  mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]

prepareDaemonShell :: [Text] -> FilePath -> FilePath -> FilePath -> Shell (IO ())
prepareDaemonShell dargs daemon_out daemon_err nrm_log = do
  confPath      <- myWhich "argo_nodeos_config"
  myWhich "daemon"
  tempDirPath   <- mktempdir "/tmp" "argo-expe"
  let confPath' = tempDirPath </> "argo_nodeos_config"
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to "%fp%"\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
  shell (format ("sudo chown root:root "%fp) confPath') empty >>= \case
    ExitSuccess   -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n -> die ("Failed to set argo_nodeos_config permissions " <> repr n)
  shell (format ("sudo chmod u+sw "%fp) confPath') empty >>= \case
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)

  --Cleaning the config, running the daemon
  shell (format (fp%" --clean_config=kill_content:true") confPath') empty >>= \case
    ExitSuccess   -> printInfo "Cleaned the argo config.\n"
    ExitFailure n -> do
      printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n" )
      testfile ".argo_nodeos_config_exit_message" >>= \case
        True -> do printInfo "Contents of .argo_nodeos_config_exit_message: \n"
                   view $ input "./argo_nodeos_config_exit_message"
        False ->  die ("Clean config failed with exit code " <> repr n)
  printInfo $ format ("Running the daemon, main log at "%fp%", stdout at "%fp%", stderr at "%fp%"\n") nrm_log daemon_out daemon_err
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
  return $ twoWayPrint daemon_out daemon_err $ inprocWithErr "daemon"
          (dargs ++ ["--nrm_log", Text.pack $ encodeString nrm_log])
          empty
    --twoWayPrint l
    --case l of
    --  Left out  -> output daemon_out $ return out
    --  Right err -> output daemon_err $ return err

twoWayPrint :: FilePath -> FilePath -> Shell (Either Line Line) -> IO ()
twoWayPrint outPath errPath s = sh $ do
    handleOut <- using (writeonly outPath)
    handleErr <- using (writeonly errPath)
    s >>= \case
      Left out  -> liftIO $ Text.hPutStrLn handleOut (lineToText out)
      Right err  -> liftIO $ Text.hPutStrLn handleOut (lineToText err)

cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()
cmdShell manifest app cmd_out cmd_err =
  shell (format ("cmd run -u toto "%fp%"  "%s%" > "%fp%" 2>"%fp) manifest app cmd_out cmd_err) empty >>= \case
  ExitSuccess   -> printInfo "cmd has exited successfuly.\n"
  ExitFailure n -> die ("cmd failed with exit code " <> repr n <>
    " . The application logs are at " <> repr cmd_out <> " " <> repr cmd_err )