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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Validates an uploaded scenario
module Swarm.Web.Tournament.Validate where

import Control.Arrow (left)
import Control.Carrier.Accum.FixedStrict (evalAccum)
import Control.Carrier.Throw.Either (runThrow)
import Control.Lens
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (evalStateT)
import Control.Monad.Trans.Except
import Data.ByteString.Lazy qualified as LBS
import Data.Either.Extra (maybeToEither)
import Data.Sequence (Seq)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8')
import Data.Yaml (decodeEither', parseEither)
import Servant.Multipart
import Swarm.Game.CESK (continue)
import Swarm.Game.Failure (SystemFailure)
import Swarm.Game.Robot.Concrete (machine)
import Swarm.Game.Scenario
import Swarm.Game.Scenario.Scoring.CodeSize (codeMetricsFromSyntax)
import Swarm.Game.Scenario.Status (emptyLaunchParams)
import Swarm.Game.State
import Swarm.Game.State.Initialize (scenarioToGameState)
import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs)
import Swarm.Game.State.Substate (initState, seed)
import Swarm.Game.Step.Validate (playUntilWin)
import Swarm.Language.Pipeline
import Swarm.Language.Syntax (TSyntax)
import Swarm.Util.Yaml
import Swarm.Web.Tournament.Database.Query
import Swarm.Web.Tournament.Type
import Swarm.Web.Tournament.Validate.FailureMode
import Swarm.Web.Tournament.Validate.Upload
import System.Time.Extra

newtype SolutionTimeout = SolutionTimeout Seconds

data CommonValidationArgs m a
  = CommonValidationArgs
      SolutionTimeout
      (PersistenceArgs m a)

validateScenarioUpload ::
  CommonValidationArgs IO ScenarioUploadResponsePayload ->
  -- | Game version
  Sha1 ->
  IO (Either ScenarioUploadValidationFailure ScenarioCharacterization)
validateScenarioUpload :: CommonValidationArgs IO ScenarioUploadResponsePayload
-> Sha1
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
validateScenarioUpload (CommonValidationArgs SolutionTimeout
solnTimeout PersistenceArgs IO ScenarioUploadResponsePayload
persistenceArgs) Sha1
gameVersion =
  ExceptT ScenarioUploadValidationFailure IO ScenarioCharacterization
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   ScenarioUploadValidationFailure IO ScenarioCharacterization
 -> IO
      (Either ScenarioUploadValidationFailure ScenarioCharacterization))
-> ExceptT
     ScenarioUploadValidationFailure IO ScenarioCharacterization
-> IO
     (Either ScenarioUploadValidationFailure ScenarioCharacterization)
forall a b. (a -> b) -> a -> b
$ do
    (FileMetadata
fileMeta, AssociatedSolutionCharacterization
solnMetrics) <-
      PersistenceArgs IO ScenarioUploadResponsePayload
-> (GenericUploadFailure -> ScenarioUploadValidationFailure)
-> (FileUpload
    -> ExceptT
         ScenarioUploadValidationFailure
         IO
         (AssociatedSolutionCharacterization,
          ScenarioUploadResponsePayload))
-> ExceptT
     ScenarioUploadValidationFailure
     IO
     (FileMetadata, AssociatedSolutionCharacterization)
forall a e.
PersistenceArgs IO a
-> (GenericUploadFailure -> e)
-> (FileUpload
    -> ExceptT e IO (AssociatedSolutionCharacterization, a))
-> ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
withFileCache
        PersistenceArgs IO ScenarioUploadResponsePayload
persistenceArgs
        GenericUploadFailure -> ScenarioUploadValidationFailure
ScenarioUploadFailure
        FileUpload
-> ExceptT
     ScenarioUploadValidationFailure
     IO
     (AssociatedSolutionCharacterization, ScenarioUploadResponsePayload)
computeMetrics

    ScenarioCharacterization
-> ExceptT
     ScenarioUploadValidationFailure IO ScenarioCharacterization
forall a. a -> ExceptT ScenarioUploadValidationFailure IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScenarioCharacterization
 -> ExceptT
      ScenarioUploadValidationFailure IO ScenarioCharacterization)
-> ScenarioCharacterization
-> ExceptT
     ScenarioUploadValidationFailure IO ScenarioCharacterization
forall a b. (a -> b) -> a -> b
$
      FileMetadata
-> SolutionCharacterization -> ScenarioCharacterization
ScenarioCharacterization
        FileMetadata
fileMeta
        (AssociatedSolutionCharacterization -> SolutionCharacterization
characterization AssociatedSolutionCharacterization
solnMetrics)
 where
  computeMetrics :: FileUpload
-> ExceptT
     ScenarioUploadValidationFailure
     IO
     (AssociatedSolutionCharacterization, ScenarioUploadResponsePayload)
computeMetrics FileUpload
file = do
    (GameState
gs, Scenario
scenarioObject) <-
      (ScenarioInstantiationFailure -> ScenarioUploadValidationFailure)
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
-> ExceptT ScenarioUploadValidationFailure IO (GameState, Scenario)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioInstantiationFailure -> ScenarioUploadValidationFailure
ScenarioUploadInstantiationFailure (ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
 -> ExceptT
      ScenarioUploadValidationFailure IO (GameState, Scenario))
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
-> ExceptT ScenarioUploadValidationFailure IO (GameState, Scenario)
forall a b. (a -> b) -> a -> b
$
        ByteString
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
gamestateFromScenarioText (ByteString
 -> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario))
-> ByteString
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
forall a b. (a -> b) -> a -> b
$
          FileUpload -> ByteString
fileContent FileUpload
file

    TSyntax
soln <- Either ScenarioUploadValidationFailure TSyntax
-> ExceptT ScenarioUploadValidationFailure IO TSyntax
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either ScenarioUploadValidationFailure TSyntax
 -> ExceptT ScenarioUploadValidationFailure IO TSyntax)
-> Either ScenarioUploadValidationFailure TSyntax
-> ExceptT ScenarioUploadValidationFailure IO TSyntax
forall a b. (a -> b) -> a -> b
$ ScenarioUploadValidationFailure
-> Maybe TSyntax -> Either ScenarioUploadValidationFailure TSyntax
forall a b. a -> Maybe b -> Either a b
maybeToEither ScenarioUploadValidationFailure
NoSolutionProvided (Maybe TSyntax -> Either ScenarioUploadValidationFailure TSyntax)
-> Maybe TSyntax -> Either ScenarioUploadValidationFailure TSyntax
forall a b. (a -> b) -> a -> b
$ GameState
gs GameState
-> Getting (Maybe TSyntax) GameState (Maybe TSyntax)
-> Maybe TSyntax
forall s a. s -> Getting a s a -> a
^. Getting (Maybe TSyntax) GameState (Maybe TSyntax)
Lens' GameState (Maybe TSyntax)
winSolution

    SolutionCharacterization
solnMetrics <-
      (SolutionEvaluationFailure -> ScenarioUploadValidationFailure)
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
-> ExceptT
     ScenarioUploadValidationFailure IO SolutionCharacterization
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SolutionEvaluationFailure -> ScenarioUploadValidationFailure
ScenarioSolutionEvaluationFailure (ExceptT SolutionEvaluationFailure IO SolutionCharacterization
 -> ExceptT
      ScenarioUploadValidationFailure IO SolutionCharacterization)
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
-> ExceptT
     ScenarioUploadValidationFailure IO SolutionCharacterization
forall a b. (a -> b) -> a -> b
$
        SolutionTimeout
-> TSyntax
-> GameState
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
verifySolution SolutionTimeout
solnTimeout TSyntax
soln GameState
gs

    (AssociatedSolutionCharacterization, ScenarioUploadResponsePayload)
-> ExceptT
     ScenarioUploadValidationFailure
     IO
     (AssociatedSolutionCharacterization, ScenarioUploadResponsePayload)
forall a. a -> ExceptT ScenarioUploadValidationFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( Sha1
-> SolutionCharacterization -> AssociatedSolutionCharacterization
AssociatedSolutionCharacterization (FileMetadata -> Sha1
fileHash (FileMetadata -> Sha1) -> FileMetadata -> Sha1
forall a b. (a -> b) -> a -> b
$ FileUpload -> FileMetadata
fileMetadata FileUpload
file) SolutionCharacterization
solnMetrics
      , Sha1 -> Text -> ScenarioUploadResponsePayload
ScenarioUploadResponsePayload Sha1
gameVersion (Text -> ScenarioUploadResponsePayload)
-> Text -> ScenarioUploadResponsePayload
forall a b. (a -> b) -> a -> b
$
          Scenario
scenarioObject Scenario -> Getting Text Scenario Text -> Text
forall s a. s -> Getting a s a -> a
^. (ScenarioMetadata -> Const Text ScenarioMetadata)
-> Scenario -> Const Text Scenario
Lens' Scenario ScenarioMetadata
scenarioMetadata ((ScenarioMetadata -> Const Text ScenarioMetadata)
 -> Scenario -> Const Text Scenario)
-> ((Text -> Const Text Text)
    -> ScenarioMetadata -> Const Text ScenarioMetadata)
-> Getting Text Scenario Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ScenarioMetadata -> Const Text ScenarioMetadata
Lens' ScenarioMetadata Text
scenarioName
      )

validateSubmittedSolution ::
  CommonValidationArgs IO SolutionUploadResponsePayload ->
  -- | Scenario lookup function
  (Sha1 -> IO (Maybe LBS.ByteString)) ->
  IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
validateSubmittedSolution :: CommonValidationArgs IO SolutionUploadResponsePayload
-> (Sha1 -> IO (Maybe ByteString))
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
validateSubmittedSolution (CommonValidationArgs SolutionTimeout
solnTimeout PersistenceArgs IO SolutionUploadResponsePayload
persistenceArgs) Sha1 -> IO (Maybe ByteString)
scenarioLookupFunc =
  ExceptT SolutionSubmissionFailure IO SolutionFileCharacterization
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SolutionSubmissionFailure IO SolutionFileCharacterization
 -> IO
      (Either SolutionSubmissionFailure SolutionFileCharacterization))
-> ExceptT
     SolutionSubmissionFailure IO SolutionFileCharacterization
-> IO
     (Either SolutionSubmissionFailure SolutionFileCharacterization)
forall a b. (a -> b) -> a -> b
$ do
    Sha1
userSuppliedScenarioSha1 <-
      (String -> SolutionSubmissionFailure)
-> ExceptT String IO Sha1
-> ExceptT SolutionSubmissionFailure IO Sha1
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT String -> SolutionSubmissionFailure
MissingScenarioParameter
        (ExceptT String IO Sha1
 -> ExceptT SolutionSubmissionFailure IO Sha1)
-> (Either String Text -> ExceptT String IO Sha1)
-> Either String Text
-> ExceptT SolutionSubmissionFailure IO Sha1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Sha1 -> ExceptT String IO Sha1
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
        (Either String Sha1 -> ExceptT String IO Sha1)
-> (Either String Text -> Either String Sha1)
-> Either String Text
-> ExceptT String IO Sha1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Sha1) -> Either String Text -> Either String Sha1
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Sha1
Sha1 (String -> Sha1) -> (Text -> String) -> Text -> Sha1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
        (Either String Text -> ExceptT SolutionSubmissionFailure IO Sha1)
-> Either String Text -> ExceptT SolutionSubmissionFailure IO Sha1
forall a b. (a -> b) -> a -> b
$ Text -> MultipartData Mem -> Either String Text
forall tag. Text -> MultipartData tag -> Either String Text
lookupInput Text
"scenario" MultipartData Mem
multipartData

    (FileMetadata
fileMeta, AssociatedSolutionCharacterization
solnMetrics) <-
      PersistenceArgs IO SolutionUploadResponsePayload
-> (GenericUploadFailure -> SolutionSubmissionFailure)
-> (FileUpload
    -> ExceptT
         SolutionSubmissionFailure
         IO
         (AssociatedSolutionCharacterization,
          SolutionUploadResponsePayload))
-> ExceptT
     SolutionSubmissionFailure
     IO
     (FileMetadata, AssociatedSolutionCharacterization)
forall a e.
PersistenceArgs IO a
-> (GenericUploadFailure -> e)
-> (FileUpload
    -> ExceptT e IO (AssociatedSolutionCharacterization, a))
-> ExceptT e IO (FileMetadata, AssociatedSolutionCharacterization)
withFileCache
        PersistenceArgs IO SolutionUploadResponsePayload
persistenceArgs
        GenericUploadFailure -> SolutionSubmissionFailure
SolutionUploadFailure
        (Sha1
-> FileUpload
-> ExceptT
     SolutionSubmissionFailure
     IO
     (AssociatedSolutionCharacterization, SolutionUploadResponsePayload)
computeMetrics Sha1
userSuppliedScenarioSha1)

    let retrievedScenarioHash :: Sha1
retrievedScenarioHash = AssociatedSolutionCharacterization -> Sha1
forScenario AssociatedSolutionCharacterization
solnMetrics

    -- We validate that the uploaded solution, if retrieved from the
    -- cache, actually is for the scenario with the hash they
    -- supplied in the upload metadata.
    -- If someone re-uploads a solution file that already happens to be
    -- stored in the database, but specifies a different scenario hash,
    -- we should alert about this mistake with an error.
    Bool
-> ExceptT SolutionSubmissionFailure IO ()
-> ExceptT SolutionSubmissionFailure IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Sha1
userSuppliedScenarioSha1 Sha1 -> Sha1 -> Bool
forall a. Eq a => a -> a -> Bool
== Sha1
retrievedScenarioHash)
      (ExceptT SolutionSubmissionFailure IO ()
 -> ExceptT SolutionSubmissionFailure IO ())
-> (SolutionSubmissionFailure
    -> ExceptT SolutionSubmissionFailure IO ())
-> SolutionSubmissionFailure
-> ExceptT SolutionSubmissionFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either SolutionSubmissionFailure ()
-> ExceptT SolutionSubmissionFailure IO ()
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
      (Either SolutionSubmissionFailure ()
 -> ExceptT SolutionSubmissionFailure IO ())
-> (SolutionSubmissionFailure
    -> Either SolutionSubmissionFailure ())
-> SolutionSubmissionFailure
-> ExceptT SolutionSubmissionFailure IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolutionSubmissionFailure -> Either SolutionSubmissionFailure ()
forall a b. a -> Either a b
Left
      (SolutionSubmissionFailure
 -> ExceptT SolutionSubmissionFailure IO ())
-> SolutionSubmissionFailure
-> ExceptT SolutionSubmissionFailure IO ()
forall a b. (a -> b) -> a -> b
$ Sha1 -> Sha1 -> SolutionSubmissionFailure
CachedSolutionScenarioMismatch Sha1
userSuppliedScenarioSha1 Sha1
retrievedScenarioHash

    SolutionFileCharacterization
-> ExceptT
     SolutionSubmissionFailure IO SolutionFileCharacterization
forall a. a -> ExceptT SolutionSubmissionFailure IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SolutionFileCharacterization
 -> ExceptT
      SolutionSubmissionFailure IO SolutionFileCharacterization)
-> SolutionFileCharacterization
-> ExceptT
     SolutionSubmissionFailure IO SolutionFileCharacterization
forall a b. (a -> b) -> a -> b
$ Sha1 -> SolutionCharacterization -> SolutionFileCharacterization
SolutionFileCharacterization (FileMetadata -> Sha1
fileHash FileMetadata
fileMeta) (SolutionCharacterization -> SolutionFileCharacterization)
-> SolutionCharacterization -> SolutionFileCharacterization
forall a b. (a -> b) -> a -> b
$ AssociatedSolutionCharacterization -> SolutionCharacterization
characterization AssociatedSolutionCharacterization
solnMetrics
 where
  PersistenceArgs UserAlias
_ MultipartData Mem
multipartData ScenarioPersistence IO SolutionUploadResponsePayload
_ = PersistenceArgs IO SolutionUploadResponsePayload
persistenceArgs

  computeMetrics :: Sha1
-> FileUpload
-> ExceptT
     SolutionSubmissionFailure
     IO
     (AssociatedSolutionCharacterization, SolutionUploadResponsePayload)
computeMetrics Sha1
scenarioSha1 FileUpload
file = do
    Text
solText <-
      (UnicodeException -> SolutionSubmissionFailure)
-> ExceptT UnicodeException IO Text
-> ExceptT SolutionSubmissionFailure IO Text
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT UnicodeException -> SolutionSubmissionFailure
SolutionUnicodeError
        (ExceptT UnicodeException IO Text
 -> ExceptT SolutionSubmissionFailure IO Text)
-> (ByteString -> ExceptT UnicodeException IO Text)
-> ByteString
-> ExceptT SolutionSubmissionFailure IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either UnicodeException Text -> ExceptT UnicodeException IO Text
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except
        (Either UnicodeException Text -> ExceptT UnicodeException IO Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> ExceptT UnicodeException IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8'
        (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict
        (ByteString -> ExceptT SolutionSubmissionFailure IO Text)
-> ByteString -> ExceptT SolutionSubmissionFailure IO Text
forall a b. (a -> b) -> a -> b
$ FileUpload -> ByteString
fileContent FileUpload
file
    TSyntax
soln <- (Text -> SolutionSubmissionFailure)
-> ExceptT Text IO TSyntax
-> ExceptT SolutionSubmissionFailure IO TSyntax
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> SolutionSubmissionFailure
SolutionParseError (ExceptT Text IO TSyntax
 -> ExceptT SolutionSubmissionFailure IO TSyntax)
-> (Either Text TSyntax -> ExceptT Text IO TSyntax)
-> Either Text TSyntax
-> ExceptT SolutionSubmissionFailure IO TSyntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text TSyntax -> ExceptT Text IO TSyntax
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either Text TSyntax
 -> ExceptT SolutionSubmissionFailure IO TSyntax)
-> Either Text TSyntax
-> ExceptT SolutionSubmissionFailure IO TSyntax
forall a b. (a -> b) -> a -> b
$ Text -> Either Text TSyntax
processTermEither Text
solText

    GameState
gs <- (ScenarioRetrievalFailure -> SolutionSubmissionFailure)
-> ExceptT ScenarioRetrievalFailure IO GameState
-> ExceptT SolutionSubmissionFailure IO GameState
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioRetrievalFailure -> SolutionSubmissionFailure
ScenarioRetrievalFailure (ExceptT ScenarioRetrievalFailure IO GameState
 -> ExceptT SolutionSubmissionFailure IO GameState)
-> ExceptT ScenarioRetrievalFailure IO GameState
-> ExceptT SolutionSubmissionFailure IO GameState
forall a b. (a -> b) -> a -> b
$ do
      ByteString
scenarioContent <-
        (Sha1 -> ScenarioRetrievalFailure)
-> ExceptT Sha1 IO ByteString
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Sha1 -> ScenarioRetrievalFailure
DatabaseRetrievalFailure (ExceptT Sha1 IO ByteString
 -> ExceptT ScenarioRetrievalFailure IO ByteString)
-> ExceptT Sha1 IO ByteString
-> ExceptT ScenarioRetrievalFailure IO ByteString
forall a b. (a -> b) -> a -> b
$
          IO (Either Sha1 ByteString) -> ExceptT Sha1 IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
            ( Sha1 -> Maybe ByteString -> Either Sha1 ByteString
forall a b. a -> Maybe b -> Either a b
maybeToEither Sha1
scenarioSha1
                (Maybe ByteString -> Either Sha1 ByteString)
-> IO (Maybe ByteString) -> IO (Either Sha1 ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sha1 -> IO (Maybe ByteString)
scenarioLookupFunc Sha1
scenarioSha1
            )

      ((GameState, Scenario) -> GameState)
-> ExceptT ScenarioRetrievalFailure IO (GameState, Scenario)
-> ExceptT ScenarioRetrievalFailure IO GameState
forall a b.
(a -> b)
-> ExceptT ScenarioRetrievalFailure IO a
-> ExceptT ScenarioRetrievalFailure IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GameState, Scenario) -> GameState
forall a b. (a, b) -> a
fst (ExceptT ScenarioRetrievalFailure IO (GameState, Scenario)
 -> ExceptT ScenarioRetrievalFailure IO GameState)
-> ExceptT ScenarioRetrievalFailure IO (GameState, Scenario)
-> ExceptT ScenarioRetrievalFailure IO GameState
forall a b. (a -> b) -> a -> b
$
        (ScenarioInstantiationFailure -> ScenarioRetrievalFailure)
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
-> ExceptT ScenarioRetrievalFailure IO (GameState, Scenario)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ScenarioInstantiationFailure -> ScenarioRetrievalFailure
RetrievedInstantiationFailure (ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
 -> ExceptT ScenarioRetrievalFailure IO (GameState, Scenario))
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
-> ExceptT ScenarioRetrievalFailure IO (GameState, Scenario)
forall a b. (a -> b) -> a -> b
$
          ByteString
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
gamestateFromScenarioText ByteString
scenarioContent

    SolutionCharacterization
solnMetrics <-
      (SolutionEvaluationFailure -> SolutionSubmissionFailure)
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
-> ExceptT SolutionSubmissionFailure IO SolutionCharacterization
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT SolutionEvaluationFailure -> SolutionSubmissionFailure
SubmittedSolutionEvaluationFailure (ExceptT SolutionEvaluationFailure IO SolutionCharacterization
 -> ExceptT SolutionSubmissionFailure IO SolutionCharacterization)
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
-> ExceptT SolutionSubmissionFailure IO SolutionCharacterization
forall a b. (a -> b) -> a -> b
$
        SolutionTimeout
-> TSyntax
-> GameState
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
verifySolution SolutionTimeout
solnTimeout TSyntax
soln GameState
gs

    (AssociatedSolutionCharacterization, SolutionUploadResponsePayload)
-> ExceptT
     SolutionSubmissionFailure
     IO
     (AssociatedSolutionCharacterization, SolutionUploadResponsePayload)
forall a. a -> ExceptT SolutionSubmissionFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( Sha1
-> SolutionCharacterization -> AssociatedSolutionCharacterization
AssociatedSolutionCharacterization Sha1
scenarioSha1 SolutionCharacterization
solnMetrics
      , Sha1 -> SolutionUploadResponsePayload
SolutionUploadResponsePayload Sha1
scenarioSha1
      )

-- * Utils

initScenarioObjectWithEnv ::
  LBS.ByteString ->
  ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObjectWithEnv :: ByteString -> ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObjectWithEnv ByteString
content = do
  ScenarioInputs
scenarioInputs <-
    (SystemFailure -> ScenarioInstantiationFailure)
-> ExceptT SystemFailure IO ScenarioInputs
-> ExceptT ScenarioInstantiationFailure IO ScenarioInputs
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ContextInitializationFailure -> ScenarioInstantiationFailure
ScenarioEnvironmentFailure (ContextInitializationFailure -> ScenarioInstantiationFailure)
-> (SystemFailure -> ContextInitializationFailure)
-> SystemFailure
-> ScenarioInstantiationFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> ContextInitializationFailure
ContextInitializationFailure)
      (ExceptT SystemFailure IO ScenarioInputs
 -> ExceptT ScenarioInstantiationFailure IO ScenarioInputs)
-> (ThrowC SystemFailure IO ScenarioInputs
    -> ExceptT SystemFailure IO ScenarioInputs)
-> ThrowC SystemFailure IO ScenarioInputs
-> ExceptT ScenarioInstantiationFailure IO ScenarioInputs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SystemFailure ScenarioInputs)
-> ExceptT SystemFailure IO ScenarioInputs
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
      (IO (Either SystemFailure ScenarioInputs)
 -> ExceptT SystemFailure IO ScenarioInputs)
-> (ThrowC SystemFailure IO ScenarioInputs
    -> IO (Either SystemFailure ScenarioInputs))
-> ThrowC SystemFailure IO ScenarioInputs
-> ExceptT SystemFailure IO ScenarioInputs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThrowC SystemFailure IO ScenarioInputs
-> IO (Either SystemFailure ScenarioInputs)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow
      (ThrowC SystemFailure IO ScenarioInputs
 -> ExceptT ScenarioInstantiationFailure IO ScenarioInputs)
-> ThrowC SystemFailure IO ScenarioInputs
-> ExceptT ScenarioInstantiationFailure IO ScenarioInputs
forall a b. (a -> b) -> a -> b
$ Seq SystemFailure
-> AccumC
     (Seq SystemFailure) (ThrowC SystemFailure IO) ScenarioInputs
-> ThrowC SystemFailure IO ScenarioInputs
forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m a
evalAccum (Seq SystemFailure
forall a. Monoid a => a
mempty :: Seq SystemFailure) AccumC (Seq SystemFailure) (ThrowC SystemFailure IO) ScenarioInputs
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m,
 Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
m ScenarioInputs
initScenarioInputs

  ScenarioInputs
-> ByteString -> ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObject ScenarioInputs
scenarioInputs ByteString
content

initScenarioObject ::
  ScenarioInputs ->
  LBS.ByteString ->
  ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObject :: ScenarioInputs
-> ByteString -> ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObject ScenarioInputs
scenarioInputs ByteString
content = do
  Value
rawYaml <- (ParseException -> ScenarioInstantiationFailure)
-> ExceptT ParseException IO Value
-> ExceptT ScenarioInstantiationFailure IO Value
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseException -> ScenarioInstantiationFailure
YamlDecodeError (ExceptT ParseException IO Value
 -> ExceptT ScenarioInstantiationFailure IO Value)
-> (ByteString -> ExceptT ParseException IO Value)
-> ByteString
-> ExceptT ScenarioInstantiationFailure IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseException Value -> ExceptT ParseException IO Value
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either ParseException Value -> ExceptT ParseException IO Value)
-> (ByteString -> Either ParseException Value)
-> ByteString
-> ExceptT ParseException IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' (ByteString -> ExceptT ScenarioInstantiationFailure IO Value)
-> ByteString -> ExceptT ScenarioInstantiationFailure IO Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
content
  (String -> ScenarioInstantiationFailure)
-> ExceptT String IO Scenario
-> ExceptT ScenarioInstantiationFailure IO Scenario
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT String -> ScenarioInstantiationFailure
ScenarioParseFailure (ExceptT String IO Scenario
 -> ExceptT ScenarioInstantiationFailure IO Scenario)
-> ExceptT String IO Scenario
-> ExceptT ScenarioInstantiationFailure IO Scenario
forall a b. (a -> b) -> a -> b
$
    Either String Scenario -> ExceptT String IO Scenario
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String Scenario -> ExceptT String IO Scenario)
-> Either String Scenario -> ExceptT String IO Scenario
forall a b. (a -> b) -> a -> b
$
      (Value -> Parser Scenario) -> Value -> Either String Scenario
forall a b. (a -> Parser b) -> a -> Either String b
parseEither (ScenarioInputs -> Value -> Parser Scenario
forall e a. FromJSONE e a => e -> Value -> Parser a
parseJSONE' ScenarioInputs
scenarioInputs) Value
rawYaml

gamestateFromScenarioText ::
  LBS.ByteString ->
  ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
gamestateFromScenarioText :: ByteString
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
gamestateFromScenarioText ByteString
content = do
  GameStateConfig
gsc <-
    (SystemFailure -> ScenarioInstantiationFailure)
-> ExceptT SystemFailure IO GameStateConfig
-> ExceptT ScenarioInstantiationFailure IO GameStateConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ContextInitializationFailure -> ScenarioInstantiationFailure
ScenarioEnvironmentFailure (ContextInitializationFailure -> ScenarioInstantiationFailure)
-> (SystemFailure -> ContextInitializationFailure)
-> SystemFailure
-> ScenarioInstantiationFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SystemFailure -> ContextInitializationFailure
ContextInitializationFailure)
      (ExceptT SystemFailure IO GameStateConfig
 -> ExceptT ScenarioInstantiationFailure IO GameStateConfig)
-> (ThrowC SystemFailure IO GameStateConfig
    -> ExceptT SystemFailure IO GameStateConfig)
-> ThrowC SystemFailure IO GameStateConfig
-> ExceptT ScenarioInstantiationFailure IO GameStateConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either SystemFailure GameStateConfig)
-> ExceptT SystemFailure IO GameStateConfig
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
      (IO (Either SystemFailure GameStateConfig)
 -> ExceptT SystemFailure IO GameStateConfig)
-> (ThrowC SystemFailure IO GameStateConfig
    -> IO (Either SystemFailure GameStateConfig))
-> ThrowC SystemFailure IO GameStateConfig
-> ExceptT SystemFailure IO GameStateConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThrowC SystemFailure IO GameStateConfig
-> IO (Either SystemFailure GameStateConfig)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow
      (ThrowC SystemFailure IO GameStateConfig
 -> ExceptT ScenarioInstantiationFailure IO GameStateConfig)
-> ThrowC SystemFailure IO GameStateConfig
-> ExceptT ScenarioInstantiationFailure IO GameStateConfig
forall a b. (a -> b) -> a -> b
$ Seq SystemFailure
-> AccumC
     (Seq SystemFailure) (ThrowC SystemFailure IO) GameStateConfig
-> ThrowC SystemFailure IO GameStateConfig
forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m a
evalAccum (Seq SystemFailure
forall a. Monoid a => a
mempty :: Seq SystemFailure) AccumC
  (Seq SystemFailure) (ThrowC SystemFailure IO) GameStateConfig
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m,
 Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
m GameStateConfig
initGameStateConfig

  let scenarioInputs :: ScenarioInputs
scenarioInputs = GameStateInputs -> ScenarioInputs
gsiScenarioInputs (GameStateInputs -> ScenarioInputs)
-> GameStateInputs -> ScenarioInputs
forall a b. (a -> b) -> a -> b
$ GameStateConfig -> GameStateInputs
initState GameStateConfig
gsc
  Scenario
scenarioObject <- ScenarioInputs
-> ByteString -> ExceptT ScenarioInstantiationFailure IO Scenario
initScenarioObject ScenarioInputs
scenarioInputs ByteString
content
  GameState
gs <- IO GameState -> ExceptT ScenarioInstantiationFailure IO GameState
forall a. IO a -> ExceptT ScenarioInstantiationFailure IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GameState -> ExceptT ScenarioInstantiationFailure IO GameState)
-> IO GameState
-> ExceptT ScenarioInstantiationFailure IO GameState
forall a b. (a -> b) -> a -> b
$ Scenario
-> ValidatedLaunchParams -> GameStateConfig -> IO GameState
scenarioToGameState Scenario
scenarioObject ValidatedLaunchParams
forall (f :: * -> *) a.
Applicative f =>
ParameterizableLaunchParams a f
emptyLaunchParams GameStateConfig
gsc
  (GameState, Scenario)
-> ExceptT ScenarioInstantiationFailure IO (GameState, Scenario)
forall a. a -> ExceptT ScenarioInstantiationFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GameState
gs, Scenario
scenarioObject)

verifySolution ::
  SolutionTimeout ->
  TSyntax ->
  GameState ->
  ExceptT SolutionEvaluationFailure IO SolutionCharacterization
verifySolution :: SolutionTimeout
-> TSyntax
-> GameState
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
verifySolution (SolutionTimeout Seconds
timeoutSeconds) TSyntax
sol GameState
gs = do
  (Seconds
actualTime, Either (NonEmpty Text) TickNumber
eitherTickCount) <-
    IO
  (Either
     SolutionEvaluationFailure
     (Seconds, Either (NonEmpty Text) TickNumber))
-> ExceptT
     SolutionEvaluationFailure
     IO
     (Seconds, Either (NonEmpty Text) TickNumber)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
      (IO
   (Either
      SolutionEvaluationFailure
      (Seconds, Either (NonEmpty Text) TickNumber))
 -> ExceptT
      SolutionEvaluationFailure
      IO
      (Seconds, Either (NonEmpty Text) TickNumber))
-> (IO (Either (NonEmpty Text) TickNumber)
    -> IO
         (Either
            SolutionEvaluationFailure
            (Seconds, Either (NonEmpty Text) TickNumber)))
-> IO (Either (NonEmpty Text) TickNumber)
-> ExceptT
     SolutionEvaluationFailure
     IO
     (Seconds, Either (NonEmpty Text) TickNumber)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Seconds, Either (NonEmpty Text) TickNumber)
 -> Either
      SolutionEvaluationFailure
      (Seconds, Either (NonEmpty Text) TickNumber))
-> IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber))
-> IO
     (Either
        SolutionEvaluationFailure
        (Seconds, Either (NonEmpty Text) TickNumber))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SolutionEvaluationFailure
-> Maybe (Seconds, Either (NonEmpty Text) TickNumber)
-> Either
     SolutionEvaluationFailure
     (Seconds, Either (NonEmpty Text) TickNumber)
forall a b. a -> Maybe b -> Either a b
maybeToEither (Seconds -> SolutionEvaluationFailure
SolutionExecutionTimeout Seconds
timeoutSeconds))
      (IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber))
 -> IO
      (Either
         SolutionEvaluationFailure
         (Seconds, Either (NonEmpty Text) TickNumber)))
-> (IO (Either (NonEmpty Text) TickNumber)
    -> IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber)))
-> IO (Either (NonEmpty Text) TickNumber)
-> IO
     (Either
        SolutionEvaluationFailure
        (Seconds, Either (NonEmpty Text) TickNumber))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds
-> IO (Seconds, Either (NonEmpty Text) TickNumber)
-> IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber))
forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
timeoutSeconds
      (IO (Seconds, Either (NonEmpty Text) TickNumber)
 -> IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber)))
-> (IO (Either (NonEmpty Text) TickNumber)
    -> IO (Seconds, Either (NonEmpty Text) TickNumber))
-> IO (Either (NonEmpty Text) TickNumber)
-> IO (Maybe (Seconds, Either (NonEmpty Text) TickNumber))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (NonEmpty Text) TickNumber)
-> IO (Seconds, Either (NonEmpty Text) TickNumber)
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration
      (IO (Either (NonEmpty Text) TickNumber)
 -> ExceptT
      SolutionEvaluationFailure
      IO
      (Seconds, Either (NonEmpty Text) TickNumber))
-> IO (Either (NonEmpty Text) TickNumber)
-> ExceptT
     SolutionEvaluationFailure
     IO
     (Seconds, Either (NonEmpty Text) TickNumber)
forall a b. (a -> b) -> a -> b
$ StateT GameState IO (Either (NonEmpty Text) TickNumber)
-> GameState -> IO (Either (NonEmpty Text) TickNumber)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT GameState IO (Either (NonEmpty Text) TickNumber)
playUntilWin GameState
gs'

  TickNumber
tickCount <- Either SolutionEvaluationFailure TickNumber
-> ExceptT SolutionEvaluationFailure IO TickNumber
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either SolutionEvaluationFailure TickNumber
 -> ExceptT SolutionEvaluationFailure IO TickNumber)
-> Either SolutionEvaluationFailure TickNumber
-> ExceptT SolutionEvaluationFailure IO TickNumber
forall a b. (a -> b) -> a -> b
$ (NonEmpty Text -> SolutionEvaluationFailure)
-> Either (NonEmpty Text) TickNumber
-> Either SolutionEvaluationFailure TickNumber
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty Text -> SolutionEvaluationFailure
ErrorsDuringExecution Either (NonEmpty Text) TickNumber
eitherTickCount

  SolutionCharacterization
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
forall a. a -> ExceptT SolutionEvaluationFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SolutionCharacterization
 -> ExceptT SolutionEvaluationFailure IO SolutionCharacterization)
-> SolutionCharacterization
-> ExceptT SolutionEvaluationFailure IO SolutionCharacterization
forall a b. (a -> b) -> a -> b
$
    Seconds
-> TickNumber
-> Seed
-> ScenarioCodeMetrics
-> SolutionCharacterization
SolutionCharacterization
      Seconds
actualTime
      TickNumber
tickCount
      (GameState
gs GameState -> Getting Seed GameState Seed -> Seed
forall s a. s -> Getting a s a -> a
^. (Randomness -> Const Seed Randomness)
-> GameState -> Const Seed GameState
Lens' GameState Randomness
randomness ((Randomness -> Const Seed Randomness)
 -> GameState -> Const Seed GameState)
-> ((Seed -> Const Seed Seed)
    -> Randomness -> Const Seed Randomness)
-> Getting Seed GameState Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seed -> Const Seed Seed) -> Randomness -> Const Seed Randomness
Lens' Randomness Seed
seed)
      ScenarioCodeMetrics
codeMetrics
 where
  codeMetrics :: ScenarioCodeMetrics
codeMetrics = TSyntax -> ScenarioCodeMetrics
forall a. Data a => Syntax' a -> ScenarioCodeMetrics
codeMetricsFromSyntax TSyntax
sol
  gs' :: GameState
gs' = GameState
gs GameState -> (GameState -> GameState) -> GameState
forall a b. a -> (a -> b) -> b
& (Robot -> Identity Robot) -> GameState -> Identity GameState
Traversal' GameState Robot
baseRobot ((Robot -> Identity Robot) -> GameState -> Identity GameState)
-> ((CESK -> Identity CESK) -> Robot -> Identity Robot)
-> (CESK -> Identity CESK)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CESK -> Identity CESK) -> Robot -> Identity Robot
Lens' Robot CESK
machine ((CESK -> Identity CESK) -> GameState -> Identity GameState)
-> (CESK -> CESK) -> GameState -> GameState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TSyntax -> CESK -> CESK
continue TSyntax
sol