Throw error on scenario hash mismatch upon solution submission

src/swarm-tournament/Swarm/Web/Tournament/Database/Query.hs

@@ -43,7 +43,7 @@ data PersistenceLayer = PersistenceLayer
   }
 
 data ScenarioPersistence b = ScenarioPersistence
-  { lookupCache :: Sha1 -> IO (Maybe SolutionCharacterization)
+  { lookupCache :: Sha1 -> IO (Maybe AssociatedSolutionSolutionCharacterization)
   -- ^ Looks up by key
   , storeCache :: CharacterizationResponse b -> IO Sha1
   -- ^ Stores and returns key
@@ -56,7 +56,7 @@ data UserAttributedUpload = UserAttributedUpload
 
 data CharacterizationResponse a = CharacterizationResponse
   { upload :: UserAttributedUpload
-  , solnCharacterization :: SolutionCharacterization
+  , associatedCharacterization :: AssociatedSolutionSolutionCharacterization
   , payload :: a
   }
 
@@ -68,6 +68,12 @@ newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload
   { scenariohash :: Sha1
   }
 
+instance FromRow AssociatedSolutionSolutionCharacterization where
+  fromRow =
+    AssociatedSolutionSolutionCharacterization
+      <$> (Sha1 <$> field)
+      <*> fromRow
+
 instance FromRow SolutionCharacterization where
   fromRow =
     SolutionCharacterization
@@ -216,7 +222,7 @@ lookupScenarioContent sha1 = do
   liftIO . fmap (fmap fromOnly . listToMaybe) . withConnect connInfo $ \conn ->
     query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1)
 
-lookupSolutionSubmission :: Sha1 -> ReaderT ConnectInfo IO (Maybe SolutionCharacterization)
+lookupSolutionSubmission :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
 lookupSolutionSubmission contentSha1 = do
   connInfo <- ask
   liftIO $ withConnect connInfo $ \conn -> runMaybeT $ do
@@ -227,14 +233,15 @@ lookupSolutionSubmission contentSha1 = do
 
     MaybeT $
       listToMaybe
-        <$> query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE id = ?;" (Only evaluationId)
+        <$> query conn "SELECT scenario, wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE id = ?;" (Only evaluationId)
 
 -- | There should only be one builtin solution for the scenario.
-lookupScenarioSolution :: Sha1 -> ReaderT ConnectInfo IO (Maybe SolutionCharacterization)
-lookupScenarioSolution sha1 = do
+lookupScenarioSolution :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
+lookupScenarioSolution scenarioSha1 = do
   connInfo <- ask
-  liftIO . fmap listToMaybe . withConnect connInfo $ \conn ->
-    query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only sha1)
+  solnChar <- liftIO . fmap listToMaybe . withConnect connInfo $ \conn ->
+    query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1)
+  return $ AssociatedSolutionSolutionCharacterization scenarioSha1 <$> solnChar
 
 listGames :: ReaderT ConnectInfo IO [TournamentGame]
 listGames = do
@@ -261,7 +268,7 @@ insertScenario s = do
         , uid
         , swarmGameVersion $ payload s
         )
-    _ <- insertSolution conn True scenarioSha $ solnCharacterization s
+    _ <- insertSolution conn True scenarioSha $ characterization $ associatedCharacterization s
 
     return resultList
   return $ Sha1 h
@@ -276,7 +283,7 @@ insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUpl
   liftIO $ withConnect connInfo $ \conn -> do
     uid <- getUserId conn $ uploader solutionUpload
 
-    solutionEvalId <- insertSolution conn False scenarioSha s
+    solutionEvalId <- insertSolution conn False scenarioSha $ characterization s
 
     [Only echoedSha1] <-
       query

src/swarm-tournament/Swarm/Web/Tournament/Type.hs

@@ -49,6 +49,11 @@ data TournamentGame = TournamentGame
   }
   deriving (Generic, ToJSON)
 
+data AssociatedSolutionSolutionCharacterization = AssociatedSolutionSolutionCharacterization
+  { forScenario :: Sha1
+  , characterization :: SolutionCharacterization
+  }
+
 data SolutionCharacterization = SolutionCharacterization
   { solutionWallTime :: Seconds
   , solutionTicks :: TickNumber

src/swarm-tournament/Swarm/Web/Tournament/Validate.hs

@@ -11,6 +11,7 @@ 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 (StateT, evalStateT, gets)
 import Control.Monad.Trans.Except
@@ -77,7 +78,7 @@ validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVe
     pure $
       ScenarioCharacterization
         fileMeta
-        solnMetrics
+        (characterization solnMetrics)
  where
   computeMetrics file = do
     gs <-
@@ -91,7 +92,10 @@ validateScenarioUpload (CommonValidationArgs solnTimeout persistenceArgs) gameVe
       withExceptT ScenarioSolutionEvaluationFailure $
         verifySolution solnTimeout soln gs
 
-    return (solnMetrics, ScenarioUploadResponsePayload gameVersion)
+    return
+      ( AssociatedSolutionSolutionCharacterization (fileHash $ fileMetadata file) solnMetrics
+      , ScenarioUploadResponsePayload gameVersion
+      )
 
 validateSubmittedSolution ::
   CommonValidationArgs SolutionUploadResponsePayload ->
@@ -100,30 +104,36 @@ validateSubmittedSolution ::
   IO (Either SolutionSubmissionFailure SolutionFileCharacterization)
 validateSubmittedSolution (CommonValidationArgs solnTimeout persistenceArgs) scenarioLookupFunc =
   runExceptT $ do
+    userSuppliedScenarioSha1 <-
+      withExceptT MissingScenarioParameter
+        . except
+        . fmap (Sha1 . T.unpack)
+        $ lookupInput "scenario" multipartData
+
     (fileMeta, solnMetrics) <-
       withFileCache
         persistenceArgs
         SolutionUploadFailure
-        computeMetrics
+        (computeMetrics userSuppliedScenarioSha1)
+
+    let retrievedScenarioHash = forScenario solnMetrics
 
-    -- TODO: Validate that the uploaded solution, if retrieved from the
+    -- 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.
+    unless (userSuppliedScenarioSha1 == retrievedScenarioHash)
+      . except
+      . Left
+      $ CachedSolutionScenarioMismatch userSuppliedScenarioSha1 retrievedScenarioHash
 
-    pure $ SolutionFileCharacterization (fileHash fileMeta) solnMetrics
+    pure $ SolutionFileCharacterization (fileHash fileMeta) $ characterization solnMetrics
  where
   PersistenceArgs _ multipartData _ = persistenceArgs
 
-  computeMetrics file = do
-    scenarioSha1 <-
-      withExceptT MissingScenarioParameter
-        . except
-        . fmap (Sha1 . T.unpack)
-        $ lookupInput "scenario" multipartData
-
+  computeMetrics scenarioSha1 file = do
     solText <-
       withExceptT SolutionUnicodeError
         . except
@@ -147,7 +157,10 @@ validateSubmittedSolution (CommonValidationArgs solnTimeout persistenceArgs) sce
       withExceptT SubmittedSolutionEvaluationFailure $
         verifySolution solnTimeout soln gs
 
-    return (solnMetrics, SolutionUploadResponsePayload scenarioSha1)
+    return
+      ( AssociatedSolutionSolutionCharacterization scenarioSha1 solnMetrics
+      , SolutionUploadResponsePayload scenarioSha1
+      )
 
 -- * Utils
 

src/swarm-tournament/Swarm/Web/Tournament/Validate/FailureMode.hs

@@ -14,7 +14,7 @@ import Data.Text.Encoding.Error (UnicodeException)
 import Data.Yaml (ParseException)
 import Swarm.Game.Failure (SystemFailure)
 import Swarm.Game.State (Sha1 (..))
-import Swarm.Util (showT)
+import Swarm.Util (parens, showT)
 import System.Time.Extra (Seconds, showDuration)
 
 class Describable a where
@@ -103,6 +103,7 @@ data SolutionSubmissionFailure
   | SolutionUnicodeError UnicodeException
   | SolutionParseError T.Text
   | ScenarioRetrievalFailure ScenarioRetrievalFailure
+  | CachedSolutionScenarioMismatch Sha1 Sha1
 
 instance Describable SolutionSubmissionFailure where
   describeText (SolutionUploadFailure x) = describeText x
@@ -111,3 +112,10 @@ instance Describable SolutionSubmissionFailure where
   describeText (SolutionUnicodeError x) = T.pack $ displayException x
   describeText (SolutionParseError x) = x
   describeText (ScenarioRetrievalFailure x) = describeText x
+  describeText (CachedSolutionScenarioMismatch (Sha1 userSuppliedScenarioSha1) (Sha1 retrievedScenarioHash)) =
+    T.unwords
+      [ "User-supplied scenario hash"
+      , parens $ T.pack userSuppliedScenarioSha1
+      , "did not match scenario hash for previously computed solution"
+      , parens $ T.pack retrievedScenarioHash
+      ]

src/swarm-tournament/Swarm/Web/Tournament/Validate/Upload.hs

@@ -47,8 +47,8 @@ obtainFileUpload multipartData =
 withFileCache ::
   PersistenceArgs a ->
   (GenericUploadFailure -> e) ->
-  (FileUpload -> ExceptT e IO (SolutionCharacterization, a)) ->
-  ExceptT e IO (FileMetadata, SolutionCharacterization)
+  (FileUpload -> ExceptT e IO (AssociatedSolutionSolutionCharacterization, a)) ->
+  ExceptT e IO (FileMetadata, AssociatedSolutionSolutionCharacterization)
 withFileCache (PersistenceArgs userAlias multipartData persistenceFunctions) errorWrapper cacheStoreFunction = do
   file <- withExceptT errorWrapper $ obtainFileUpload multipartData
   maybePreexisting <-

tournament/scripts/demo/client/submit.sh

@@ -1,5 +1,17 @@
 #!/bin/bash -ex
 
+# Parameters:
+# $1 = hostname (and optional port)
+# $2 = path to scenario file
+# $3 = path to solution file
+
+HOST=$1
+SCENARIO_FILEPATH=$2
+SOLUTION_FILEPATH=$3
+
+# Example:
+# tournament/scripts/demo/client/submit.sh localhost:8008 data/scenarios/Challenges/dimsum.yaml data/scenarios/Challenges/_arbitrage/solution.sw
+#
 # This exercises the tournament API by:
 #
 # 1. Uploading a scenario file
@@ -10,18 +22,13 @@
 
 cd $(git rev-parse --show-toplevel)
 
-SCENARIO_DATA_DIR=data/scenarios
 PORT=8080
-#HOST=localhost:$PORT
-HOST=swarmgame.net
+HOST=localhost:$PORT
+# HOST=swarmgame.net
 BASE_UPLOAD_URL=http://$HOST/upload
 
 SCENARIO_UPLOAD_URL=$BASE_UPLOAD_URL/scenario
-SCENARIO_FILEPATH=$SCENARIO_DATA_DIR/Challenges/arbitrage.yaml
 SCENARIO_HASH=$(curl --silent -F "my_file=@$SCENARIO_FILEPATH" $SCENARIO_UPLOAD_URL | jq -r .scenarioFileMetadata.fileHash)
 
-echo "Scenario hash: $SCENARIO_HASH"
-
 SOLUTION_UPLOAD_URL=$BASE_UPLOAD_URL/solution
-SOLUTION_FILEPATH=$SCENARIO_DATA_DIR/Challenges/_arbitrage/solution.sw
-curl --silent -F "scenario=$SCENARIO_HASH" -F "my_file=@$SOLUTION_FILEPATH" $SOLUTION_UPLOAD_URL | jq .
+curl --silent -F "scenario=$SCENARIO_HASH" -F "my_file=@$SOLUTION_FILEPATH" $SOLUTION_UPLOAD_URL

tournament/scripts/demo/client/test-cases/local/good-submit.sh

@@ -0,0 +1,8 @@
+#!/bin/bash -ex
+
+cd $(git rev-parse --show-toplevel)
+
+tournament/scripts/demo/client/submit.sh \
+    localhost:8008 \
+    data/scenarios/Challenges/arbitrage.yaml \
+    data/scenarios/Challenges/_arbitrage/solution.sw

tournament/scripts/demo/client/test-cases/local/wrong-scenario-cached-solution.sh

@@ -0,0 +1,13 @@
+#!/bin/bash -ex
+
+# This test cases demonstrates the failure whether or
+# not the solutions to both scenarios have already been submitted.
+
+cd $(git rev-parse --show-toplevel)
+
+tournament/scripts/demo/client/test-cases/local/good-submit.sh
+
+tournament/scripts/demo/client/submit.sh \
+    localhost:8008 \
+    data/scenarios/Challenges/dimsum.yaml \
+    data/scenarios/Challenges/_arbitrage/solution.sw