{-# LANGUAGE
  TupleSections,
  LambdaCase,
  RecordWildCards,
  OverloadedStrings #-}

module Argo.Stack where
import           Argo.Args

import           Turtle
import           Turtle.Shell
import           Prelude                 hiding ( FilePath )

import           Filesystem.Path                ( (</>) )

import           Control.Concurrent.Async

import           Data.Text                     as T
                                         hiding ( empty )
import           Argo.Utils
import           System.Process                as P
                                         hiding ( shell )
import           Control.Monad                 as CM
import           Data.Maybe
import           Control.Foldl                 as Fold
import           Text.Show.Pretty

cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
  printInfo "Cleaning working(output) directory."
  cleanLog wd
  printInfo "Cleaning sockets."
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]

checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
  let dir = case toText workingDirectory of
        Left  di -> di
        Right di -> di
  let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
  b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length
  when (b > 0) $ dieRed $ format
    ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
    workingDirectory

prepareDaemon
  :: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
prepareDaemon out stdErr test = do
  _        <- myWhich "daemon"
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp) confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config"
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root."
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
    ExitSuccess   -> printInfo "Set the suid bit."
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
  cleanContainers confPath' 1 2
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
  return $ Instrumentation (P.proc "daemon" []) out stdErr test
 where
  nodeOsFailure n = do
    printError ("argo_nodeos_config failed with exit code :" <> repr n)
    testfile ".argo_nodeos_config_exit_message" >>= \case
      True -> do
        printInfo "Contents of .argo_nodeos_config_exit_message: "
        view $ input ".argo_nodeos_config_exit_message"
      False -> die ("argo_nodeos_config failed with exit code " <> repr n)
  cleanContainers :: FilePath -> NominalDiffTime -> Integer -> Shell ()
  cleanContainers argo_nodeos_config retryTime remainingRetries = do
    let showConfig =
          inshell (format (fp % " --show_config") argo_nodeos_config) empty
    verboseShell'
        (format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
        empty
      >>= \case
            (ExitFailure n, _, _) -> do
              when (remainingRetries == 0) $ nodeOsFailure n
              printWarning
                (  "the argo_nodeos_config call failed with exit code "
                <> repr n
                <> ". Retrying.."
                )
              liftIO $ sleep (retryTime * 2)
              cleanContainers argo_nodeos_config
                              (retryTime * 2)
                              (remainingRetries - 1)
            (ExitSuccess, _, _) -> do
              printInfo "Cleaned the argo config."
              len <- liftIO $ Turtle.Shell.fold
                (grep (has "CONTAINER") showConfig)
                Fold.length
              if len > 0
                then do
                  printWarning
                    "the argo_nodeos_config call did not remove containers, \
                \at least not fast enough. Retrying.."
                  liftIO $ sleep retryTime
                  cleanContainers argo_nodeos_config
                                  (retryTime * 2)
                                  (remainingRetries - 1)
                else
                  printInfo
                    "argo_nodeos_config successfully cleaned the container \
                    \config."

cmdRunI
  :: AppName
  -> [AppArg]
  -> ContainerName
  -> ManifestDir
  -> ManifestName
  -> ProcessBehavior
  -> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) args (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
  = Just (Run, )
    <*> processBehaviorToI
          (  P.proc "cmd"
          $  ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
          ++ fmap (T.unpack . argToText) args
          )
          pb
  where argToText (AppArg a) = a

cmdListenI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb =
  Just (Listen, )
    <*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb

cmdListenProgressI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb =
  Just (Progress, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
          pb

cmdListenPerformanceI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
  Just (Performance, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
          )
          pb

cmdListenPowerI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
  Just (Power, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
          pb

data StackOutput =
    FoundMessage Text
  | FoundTracebacks Tracebacks
  | Died StackI ExitCode TracebackScanOut TracebackScanErr Tracebacks deriving (Show)
type Tracebacks = [(StackI, Text, Text)]
newtype TracebackScanOut = TracebackScanOut TracebackScan deriving (Show)
newtype TracebackScanErr = TracebackScanErr TracebackScan deriving (Show)

data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Eq)
instance Show StackI where
  show = \case
    Daemon -> "daemon"
    Run -> "cmd run"
    Listen -> "cmd listen -v"
    Progress -> "cmd listen -f progress"
    Power -> "cmd listen -f power"
    Performance -> "cmd listen -f performance"

runStack :: StackArgs -> Shell StackOutput
runStack sa@StackArgs {..} = do
  when (verbosity == Verbose) $ liftIO $ pPrint sa

  CM.mapM_
    cleanSocket
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]
  let (WorkingDirectory wd) = workingDirectory
  _ <- Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
  mktree wd
  checkFsAttributes wd
  cd wd

  iDaemon <- case daemon of
    DontRun -> return Nothing
    JustRun stdOut stdErr ->
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
    Test t stdOut stdErr ->
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)

  let milist =
        [ iDaemon
        , cmdRunI app args containerName manifestDir manifestName cmdrun
        , cmdListenI containerName cmdlisten
        , cmdListenPerformanceI containerName cmdlistenperformance
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

  if verbosity == Verbose
    then do
      printInfo "Starting the following processes:"
      liftIO $ pPrint ilist
    else liftIO $ pPrint (fmap fst ilist)

  asyncs <- liftIO $ mapM tupleToAsync ilist
  _      <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs

  when (verbosity == Verbose) $ printInfo "Processes started."

  out <- liftIO $ waitAnyCancel asyncs

  printInfo
    (  "Processes cancelled due to termination of: "
    <> repr (fst $ snd out)
    <> " with exit information: "
    <> repr (snd $ snd out)
    )

  tracebackList <- procsWithTracebacks ilist

  r <- case snd out of
    (_, Left (PatternMatched line)) -> case tracebackList of
      [] -> return $ FoundMessage line
      t  -> return $ FoundTracebacks t
    (stacki, Right (errmsg, tracebackOut, tracebackErr)) -> return $ Died
      stacki
      errmsg
      (TracebackScanOut tracebackOut)
      (TracebackScanErr tracebackErr)
      tracebackList

  cd "../"

  return r
 where
  procsWithTracebacks
    :: [(StackI, Instrumentation)] -> Shell [(StackI, Text, Text)]
  procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist

  showOutputs :: (StackI, Instrumentation) -> (StackI, Text, Text)
  showOutputs (si, Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
    (si, outlog, errlog)

  checkI :: Instrumentation -> Shell Bool
  checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) = do
    b <- liftIO $ Turtle.Shell.fold
      (grep (has "Traceback") (input $ fromText outlog))
      Fold.length
    c <- liftIO $ Turtle.Shell.fold
      (grep (has "Traceback") (input $ fromText errlog))
      Fold.length
    return $ (b > 0) || (c > 0)

  tupleToAsync
    :: (StackI, Instrumentation)
    -> IO
         ( Async
             ( StackI
             , Either
                 MonitoringResult
                 (ExitCode, TracebackScan, TracebackScan)
             )
         )
  tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum