content: {-# LANGUAGE OverloadedStrings #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
  
  {-# HLINT ignore "Functor law" #-}
  
  -- |
  -- SPDX-License-Identifier: BSD-3-Clause
  --
  -- SQL Queries for Swarm tournaments.
  module Swarm.Web.Tournament.Database.Query where
  
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
  import Control.Monad.Trans.Reader (ReaderT, ask)
  import Data.ByteString.Lazy qualified as LBS
  import Data.Maybe (listToMaybe)
  import Data.Text qualified as T
  import Data.Text.Lazy qualified as TL
  import Data.Time.Clock
  import Database.SQLite.Simple
  import Database.SQLite.Simple.ToField
  import Swarm.Game.Scenario.Scoring.CodeSize
  import Swarm.Game.State (Sha1 (..))
  import Swarm.Game.Tick (TickNumber (..))
  import Swarm.Web.Auth
  import Swarm.Web.Tournament.Type
  
  type ConnectInfo = String
  
  databaseFilename :: ConnectInfo
  databaseFilename = "swarm-games.db"
  
  newtype UserId = UserId Int
  
  instance ToField UserId where
    toField (UserId x) = toField x
  
  data AuthenticationStorage m = AuthenticationStorage
    { usernameFromCookie :: TL.Text -> m (Maybe UserAlias)
    , cookieFromUsername :: UserAlias -> m TL.Text
    }
  
  data PersistenceLayer m = PersistenceLayer
    { scenarioStorage :: ScenarioPersistence m ScenarioUploadResponsePayload
    , solutionStorage :: ScenarioPersistence m SolutionUploadResponsePayload
    , authenticationStorage :: AuthenticationStorage m
    }
  
  data ScenarioPersistence m a = ScenarioPersistence
    { lookupCache :: Sha1 -> m (Maybe AssociatedSolutionCharacterization)
    -- ^ Looks up by key
    , storeCache :: CharacterizationResponse a -> m Sha1
    -- ^ Stores and returns key
    , getContent :: Sha1 -> m (Maybe LBS.ByteString)
    -- ^ Dump file contents
    }
  
  data UserAttributedUpload = UserAttributedUpload
    { uploader :: UserAlias
    , fileUpload :: FileUpload
    }
  
  data CharacterizationResponse a = CharacterizationResponse
    { upload :: UserAttributedUpload
    , associatedCharacterization :: AssociatedSolutionCharacterization
    , payload :: a
    }
  
  data ScenarioUploadResponsePayload = ScenarioUploadResponsePayload
    { swarmGameVersion :: Sha1
    , sTitle :: T.Text
    }
  
  newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload
    { scenariohash :: Sha1
    }
  
  instance FromRow AssociatedSolutionCharacterization where
    fromRow =
      AssociatedSolutionCharacterization
        <$> (Sha1 <$> field)
        <*> fromRow
  
  instance FromRow SolutionCharacterization where
    fromRow =
      SolutionCharacterization
        <$> field
        <*> (TickNumber <$> field)
        <*> field
        <*> (ScenarioCodeMetrics <$> field <*> field)
  
  instance FromRow TournamentGame where
    fromRow =
      TournamentGame
        <$> field
        <*> field
        <*> (Sha1 <$> field)
        <*> field
        <*> (Sha1 <$> field)
        <*> field
  
  instance FromRow TournamentSolution where
    fromRow =
      TournamentSolution
        <$> field
        <*> field
        <*> fromRow
  
  instance FromRow SolutionFileCharacterization where
    fromRow =
      SolutionFileCharacterization
        <$> (Sha1 <$> field)
        <*> fromRow
  
  -- * Authentication
  
  -- | If the username already exists, overwrite the row.
  insertCookie ::
    UserAlias ->
    ReaderT Connection IO TL.Text
  insertCookie gitHubUsername = do
    conn <- ask
    liftIO $ do
      [Only cookieString] <-
        query
          conn
          "REPLACE INTO users (alias) VALUES (?) RETURNING cookie;"
          (Only gitHubUsername)
      return cookieString
  
  -- | If the username already exists, overwrite the row.
  insertGitHubTokens ::
    UserAlias ->
    ReceivedTokens ->
    ReaderT Connection IO ()
  insertGitHubTokens gitHubUsername gitHubTokens = do
    conn <- ask
    currentTime <- liftIO getCurrentTime
    let expirationOf = mkExpirationTime currentTime
    liftIO $ do
      execute
        conn
        "REPLACE INTO github_tokens (alias, github_access_token, github_access_token_expires_at, github_refresh_token, github_refresh_token_expires_at) VALUES (?, ?, ?, ?, ?);"
        ( gitHubUsername
        , token $ accessToken gitHubTokens
        , expirationOf accessToken
        , token $ refreshToken gitHubTokens
        , expirationOf refreshToken
        )
      return ()
   where
    mkExpirationTime currTime accessor =
      addUTCTime (fromIntegral $ expirationSeconds $ accessor gitHubTokens) currTime
  
  getUsernameFromCookie ::
    TL.Text ->
    ReaderT Connection IO (Maybe UserAlias)
  getUsernameFromCookie cookieText = do
    conn <- ask
    liftIO . fmap (fmap (UserAlias . fromOnly) . listToMaybe) $
      query conn "SELECT alias FROM users WHERE cookie = ?;" (Only cookieText)
  
  -- * Retrieval
  
  lookupScenarioContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
  lookupScenarioContent sha1 = do
    conn <- ask
    liftIO . fmap (fmap fromOnly . listToMaybe) $
      query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1)
  
  lookupSolutionContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
  lookupSolutionContent sha1 = do
    conn <- ask
    liftIO . fmap (fmap fromOnly . listToMaybe) $
      query conn "SELECT content FROM solution_submission WHERE content_sha1 = ?;" (Only sha1)
  
  lookupSolutionSubmission :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
  lookupSolutionSubmission contentSha1 = do
    conn <- ask
    liftIO $ runMaybeT $ do
      evaluationId :: Int <-
        MaybeT $
          fmap fromOnly . listToMaybe
            <$> query conn "SELECT solution_evaluation FROM solution_submission WHERE content_sha1 = ?;" (Only contentSha1)
  
      MaybeT $
        listToMaybe
          <$> 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 Connection IO (Maybe AssociatedSolutionCharacterization)
  lookupScenarioSolution scenarioSha1 = do
    conn <- ask
    solnChar <-
      liftIO . fmap listToMaybe $
        query conn "SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Only scenarioSha1)
    return $ AssociatedSolutionCharacterization scenarioSha1 <$> solnChar
  
  listGames :: ReaderT Connection IO [TournamentGame]
  listGames = do
    conn <- ask
    liftIO $
      query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions;"
  
  listSubmissions :: Sha1 -> ReaderT Connection IO GameWithSolutions
  listSubmissions scenarioSha1 = do
    conn <- ask
    liftIO $ do
      [game] <- query conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions WHERE scenario = ?;" (Only scenarioSha1)
      solns <- query conn "SELECT uploaded_at, solution_submitter, solution_sha1, wall_time_seconds, ticks, seed, char_count, ast_size FROM all_solution_submissions WHERE scenario = ?;" (Only scenarioSha1)
      return $ GameWithSolutions game solns
  
  -- * Insertion
  
  insertScenario ::
    CharacterizationResponse ScenarioUploadResponsePayload ->
    ReaderT Connection IO Sha1
  insertScenario s = do
    conn <- ask
    h <- liftIO $ do
      [Only resultList] <-
        query
          conn
          "INSERT INTO scenarios (content_sha1, content, original_filename, title, uploader, swarm_git_sha1) VALUES (?, ?, ?, ?, ?, ?) RETURNING content_sha1;"
          ( scenarioSha
          , fileContent $ fileUpload $ upload s
          , filename . fileMetadata . fileUpload $ upload s
          , sTitle $ payload s
          , uploader $ upload s
          , swarmGameVersion $ payload s
          )
      _ <- insertSolution conn True scenarioSha $ characterization $ associatedCharacterization s
  
      return resultList
    return $ Sha1 h
   where
    scenarioSha = fileHash . fileMetadata . fileUpload $ upload s
  
  insertSolutionSubmission ::
    CharacterizationResponse SolutionUploadResponsePayload ->
    ReaderT Connection IO Sha1
  insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUploadResponsePayload scenarioSha)) = do
    conn <- ask
    liftIO $ do
      solutionEvalId <- insertSolution conn False scenarioSha $ characterization s
      [Only echoedSha1] <-
        query
          conn
          "INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation, content) VALUES (?, ?, ?, ?) RETURNING content_sha1;"
          ( uploader solutionUpload
          , fileHash $ fileMetadata $ fileUpload solutionUpload
          , solutionEvalId
          , fileContent $ fileUpload solutionUpload
          )
      return $ Sha1 echoedSha1
  
  insertSolution ::
    Connection ->
    Bool ->
    Sha1 ->
    SolutionCharacterization ->
    IO Int
  insertSolution conn isBuiltin scenarioSha s = do
    [Only evaluationId] <-
      query
        conn
        "INSERT INTO evaluated_solution (scenario, builtin, wall_time_seconds, ticks, seed, char_count, ast_size) VALUES (?, ?, ?, ?, ?, ?, ?) RETURNING id;"
        insertion_items
    return evaluationId
   where
    insertion_items =
      ( scenarioSha
      , isBuiltin
      , solutionWallTime s
      , getTickNumber $ solutionTicks s
      , scenarioSeed s
      , sourceTextLength $ solutionCodeMetrics s
      , astSize $ solutionCodeMetrics s
      )
  