Main.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Tournament hosting
module Main where

import Data.ByteString.Lazy qualified as LBS
import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.List.NonEmpty qualified as NE
import Data.Map.NonEmpty (NEMap)
import Data.Map.NonEmpty qualified as NEM
import Data.String (fromString)
import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Client.MultipartFormData
import Network.HTTP.Types (ok200)
import Network.Wai.Handler.Warp (testWithApplication)
import Swarm.Game.State (Sha1 (..))
import Swarm.Web.Tournament qualified as Tournament
import Swarm.Web.Tournament.Database.Query
import Swarm.Web.Tournament.Type (UserAlias (..))
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.HUnit (Assertion, assertEqual, testCase)

main :: IO ()
main = do
  scenariosMap <- buildScenariosMap $ pure "data/scenarios/Challenges/arbitrage.yaml"
  let appData = mkAppData scenariosMap
  defaultMain $
    testGroup
      "Test database-agnostic server interactions"
      [ testCase "Test scenario upload" $ testScenarioUpload scenariosMap appData
      , testCase "Test solution upload" $ testSolutionUpload scenariosMap appData
      ]
 where
  noPersistence =
    ScenarioPersistence
      { lookupCache = const $ return Nothing
      , storeCache = const $ return $ Sha1 "bogus"
      , getContent = const $ return Nothing
      }

  mkPersistenceLayer scenariosMap =
    PersistenceLayer
      { scenarioStorage =
          noPersistence
            { getContent = return . fmap content . (`NEM.lookup` scenariosMap)
            }
      , solutionStorage = noPersistence
      , authenticationStorage =
          AuthenticationStorage
            { usernameFromCookie = const $ return $ Just fakeUser
            , cookieFromUsername = const $ return "fake-cookie-value"
            }
      }

  fakeUser = UserAlias "test-user"

  mkAppData scenariosMap =
    Tournament.AppData
      { Tournament.swarmGameGitVersion = Sha1 "abcdef"
      , Tournament.gitHubCredentials = Tournament.GitHubCredentials "" ""
      , Tournament.persistence = mkPersistenceLayer scenariosMap
      , Tournament.developmentMode = Tournament.LocalDevelopment fakeUser
      }

type LocalFileLookup = NEMap Sha1 FilePathAndContent

data FilePathAndContent = FilePathAndContent
  { filePath :: FilePath
  , content :: LBS.ByteString
  }

buildScenariosMap :: NE.NonEmpty FilePath -> IO LocalFileLookup
buildScenariosMap pathList =
  NEM.fromList <$> traverse getWithHash pathList
 where
  getWithHash fp = do
    fileContent <- LBS.readFile fp
    let h = Sha1 $ showDigest $ sha1 fileContent
    return (h, FilePathAndContent fp fileContent)

testScenarioUpload :: LocalFileLookup -> Tournament.AppData -> Assertion
testScenarioUpload fileLookup appData =
  mapM_ f testScenarioPaths
 where
  f x = uploadForm appData "/api/private/upload/scenario" [partFileSource "file" x]
  testScenarioPaths = map filePath $ NE.toList $ NEM.elems fileLookup

testSolutionUpload :: LocalFileLookup -> Tournament.AppData -> Assertion
testSolutionUpload fileLookup appData =
  uploadForm appData "/api/private/upload/solution" form
 where
  solutionFilePath = "data/scenarios/Challenges/_arbitrage/solution.sw"
  Sha1 scenarioSha1 = NE.head $ NEM.keys fileLookup
  form =
    [ partBS "scenario" $ fromString scenarioSha1
    , partFileSource "file" solutionFilePath
    ]

-- * Utils

uploadForm :: Tournament.AppData -> String -> [PartM IO] -> Assertion
uploadForm appData urlPath form =
  testWithApplication (pure tournamentApp) $ \p -> do
    manager <- newManager defaultManagerSettings

    let baseUrl = "http://localhost:" ++ show p
    reqLogin <- parseRequest $ baseUrl ++ "/api/private/login/local"
    respLogin <- httpLbs reqLogin manager

    let apiUrl = baseUrl ++ urlPath
    req <- parseRequest apiUrl
    resp <-
      flip httpLbs manager
        =<< formDataBody form (req {cookieJar = Just $ responseCookieJar respLogin})

    let assertionMsg =
          unwords
            [ "Server response from"
            , apiUrl
            , "should be 200;"
            , "'respLogin' was:"
            , show respLogin
            , "and 'resp' was:"
            , show resp
            ]
    assertEqual assertionMsg ok200 $ responseStatus resp
 where
  tournamentApp = Tournament.app True appData