{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Failure modes for validating an uploaded scenario
module Swarm.Web.Tournament.Validate.FailureMode where

import Control.Exception.Base (displayException)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Encoding.Error (UnicodeException)
import Data.Yaml (ParseException)
import Swarm.Game.Failure (SystemFailure)
import Swarm.Game.State (Sha1 (..))
import Swarm.Util (parens, showT)
import System.Time.Extra (Seconds, showDuration)

class Describable a where
  describeText :: a -> T.Text

newtype GenericUploadFailure = GenericUploadFailure FileUploadFailure

instance Describable GenericUploadFailure where
  describeText :: GenericUploadFailure -> Text
describeText (GenericUploadFailure FileUploadFailure
x) = FileUploadFailure -> Text
forall a. Describable a => a -> Text
describeText FileUploadFailure
x

data FileUploadFailure
  = NoFileSupplied
  | MultipleFiles Int

instance Describable FileUploadFailure where
  describeText :: FileUploadFailure -> Text
describeText FileUploadFailure
NoFileSupplied = Text
"Must supply a file!"
  describeText (MultipleFiles Int
count) =
    [Text] -> Text
T.unwords
      [ Text
"Only one file is allowed! Provided"
      , Int -> Text
forall a. Show a => a -> Text
showT Int
count
      ]

newtype ContextInitializationFailure = ContextInitializationFailure SystemFailure

instance Describable ContextInitializationFailure where
  describeText :: ContextInitializationFailure -> Text
describeText (ContextInitializationFailure SystemFailure
x) = SystemFailure -> Text
forall a. Show a => a -> Text
showT SystemFailure
x

data SolutionEvaluationFailure
  = SolutionGameStateInitializationFailure ContextInitializationFailure
  | SolutionExecutionTimeout Seconds
  | ErrorsDuringExecution (NE.NonEmpty T.Text)

instance Describable SolutionEvaluationFailure where
  describeText :: SolutionEvaluationFailure -> Text
describeText (SolutionGameStateInitializationFailure ContextInitializationFailure
x) = ContextInitializationFailure -> Text
forall a. Describable a => a -> Text
describeText ContextInitializationFailure
x
  describeText (SolutionExecutionTimeout Seconds
s) =
    [Text] -> Text
T.unwords
      [ Text
"Timed out - this likely means that the solution did not work."
      , Text
"Limit is"
      , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Seconds -> String
showDuration Seconds
s
      ]
  describeText (ErrorsDuringExecution NonEmpty Text
x) = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
x

data ScenarioInstantiationFailure
  = ScenarioEnvironmentFailure ContextInitializationFailure
  | YamlDecodeError ParseException
  | ScenarioParseFailure String

instance Describable ScenarioInstantiationFailure where
  describeText :: ScenarioInstantiationFailure -> Text
describeText (ScenarioEnvironmentFailure ContextInitializationFailure
x) = ContextInitializationFailure -> Text
forall a. Describable a => a -> Text
describeText ContextInitializationFailure
x
  describeText (YamlDecodeError ParseException
x) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseException -> String
forall e. Exception e => e -> String
displayException ParseException
x
  describeText (ScenarioParseFailure String
x) = String -> Text
T.pack String
x

data ScenarioUploadValidationFailure
  = ScenarioUploadFailure GenericUploadFailure
  | NoSolutionProvided
  | ScenarioUploadInstantiationFailure ScenarioInstantiationFailure
  | ScenarioSolutionEvaluationFailure SolutionEvaluationFailure

instance Describable ScenarioUploadValidationFailure where
  describeText :: ScenarioUploadValidationFailure -> Text
describeText (ScenarioUploadFailure GenericUploadFailure
x) = GenericUploadFailure -> Text
forall a. Describable a => a -> Text
describeText GenericUploadFailure
x
  describeText ScenarioUploadValidationFailure
NoSolutionProvided = Text
"No solution to test!"
  describeText (ScenarioUploadInstantiationFailure ScenarioInstantiationFailure
x) = ScenarioInstantiationFailure -> Text
forall a. Describable a => a -> Text
describeText ScenarioInstantiationFailure
x
  describeText (ScenarioSolutionEvaluationFailure SolutionEvaluationFailure
x) = SolutionEvaluationFailure -> Text
forall a. Describable a => a -> Text
describeText SolutionEvaluationFailure
x

data ScenarioRetrievalFailure
  = DatabaseRetrievalFailure Sha1
  | RetrievedInstantiationFailure ScenarioInstantiationFailure
  | DecodingFailure UnicodeException
  | YamlParseFailure ParseException

instance Describable ScenarioRetrievalFailure where
  describeText :: ScenarioRetrievalFailure -> Text
describeText (DatabaseRetrievalFailure (Sha1 String
h)) =
    [Text] -> Text
T.unwords
      [ Text
"Scenario with hash"
      , String -> Text
T.pack String
h
      , Text
"not found"
      ]
  describeText (RetrievedInstantiationFailure ScenarioInstantiationFailure
x) = ScenarioInstantiationFailure -> Text
forall a. Describable a => a -> Text
describeText ScenarioInstantiationFailure
x
  describeText (DecodingFailure UnicodeException
x) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
x
  describeText (YamlParseFailure ParseException
x) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseException -> String
forall e. Exception e => e -> String
displayException ParseException
x

data SolutionSubmissionFailure
  = SolutionUploadFailure GenericUploadFailure
  | MissingScenarioParameter String
  | SubmittedSolutionEvaluationFailure SolutionEvaluationFailure
  | SolutionUnicodeError UnicodeException
  | SolutionParseError T.Text
  | ScenarioRetrievalFailure ScenarioRetrievalFailure
  | CachedSolutionScenarioMismatch Sha1 Sha1

instance Describable SolutionSubmissionFailure where
  describeText :: SolutionSubmissionFailure -> Text
describeText (SolutionUploadFailure GenericUploadFailure
x) = GenericUploadFailure -> Text
forall a. Describable a => a -> Text
describeText GenericUploadFailure
x
  describeText (MissingScenarioParameter String
x) = String -> Text
T.pack String
x
  describeText (SubmittedSolutionEvaluationFailure SolutionEvaluationFailure
x) = SolutionEvaluationFailure -> Text
forall a. Describable a => a -> Text
describeText SolutionEvaluationFailure
x
  describeText (SolutionUnicodeError UnicodeException
x) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
x
  describeText (SolutionParseError Text
x) = Text
x
  describeText (ScenarioRetrievalFailure ScenarioRetrievalFailure
x) = ScenarioRetrievalFailure -> Text
forall a. Describable a => a -> Text
describeText ScenarioRetrievalFailure
x
  describeText (CachedSolutionScenarioMismatch (Sha1 String
userSuppliedScenarioSha1) (Sha1 String
retrievedScenarioHash)) =
    [Text] -> Text
T.unwords
      [ Text
"User-supplied scenario hash"
      , Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
userSuppliedScenarioSha1
      , Text
"did not match scenario hash for previously computed solution"
      , Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
retrievedScenarioHash
      ]