{-# 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 :: String
databaseFilename = String
"swarm-games.db"

newtype UserId = UserId Int

instance ToField UserId where
  toField :: UserId -> SQLData
toField (UserId Seed
x) = Seed -> SQLData
forall a. ToField a => a -> SQLData
toField Seed
x

data AuthenticationStorage m = AuthenticationStorage
  { forall (m :: * -> *).
AuthenticationStorage m -> Text -> m (Maybe UserAlias)
usernameFromCookie :: TL.Text -> m (Maybe UserAlias)
  , forall (m :: * -> *).
AuthenticationStorage m -> UserAlias -> m Text
cookieFromUsername :: UserAlias -> m TL.Text
  }

data PersistenceLayer m = PersistenceLayer
  { forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m ScenarioUploadResponsePayload
scenarioStorage :: ScenarioPersistence m ScenarioUploadResponsePayload
  , forall (m :: * -> *).
PersistenceLayer m
-> ScenarioPersistence m SolutionUploadResponsePayload
solutionStorage :: ScenarioPersistence m SolutionUploadResponsePayload
  , forall (m :: * -> *). PersistenceLayer m -> AuthenticationStorage m
authenticationStorage :: AuthenticationStorage m
  }

data ScenarioPersistence m a = ScenarioPersistence
  { forall (m :: * -> *) a.
ScenarioPersistence m a
-> Sha1 -> m (Maybe AssociatedSolutionCharacterization)
lookupCache :: Sha1 -> m (Maybe AssociatedSolutionCharacterization)
  -- ^ Looks up by key
  , forall (m :: * -> *) a.
ScenarioPersistence m a -> CharacterizationResponse a -> m Sha1
storeCache :: CharacterizationResponse a -> m Sha1
  -- ^ Stores and returns key
  , forall (m :: * -> *) a.
ScenarioPersistence m a -> Sha1 -> m (Maybe ByteString)
getContent :: Sha1 -> m (Maybe LBS.ByteString)
  -- ^ Dump file contents
  }

data UserAttributedUpload = UserAttributedUpload
  { UserAttributedUpload -> UserAlias
uploader :: UserAlias
  , UserAttributedUpload -> FileUpload
fileUpload :: FileUpload
  }

data CharacterizationResponse a = CharacterizationResponse
  { forall a. CharacterizationResponse a -> UserAttributedUpload
upload :: UserAttributedUpload
  , forall a.
CharacterizationResponse a -> AssociatedSolutionCharacterization
associatedCharacterization :: AssociatedSolutionCharacterization
  , forall a. CharacterizationResponse a -> a
payload :: a
  }

data ScenarioUploadResponsePayload = ScenarioUploadResponsePayload
  { ScenarioUploadResponsePayload -> Sha1
swarmGameVersion :: Sha1
  , ScenarioUploadResponsePayload -> Text
sTitle :: T.Text
  }

newtype SolutionUploadResponsePayload = SolutionUploadResponsePayload
  { SolutionUploadResponsePayload -> Sha1
scenariohash :: Sha1
  }

instance FromRow AssociatedSolutionCharacterization where
  fromRow :: RowParser AssociatedSolutionCharacterization
fromRow =
    Sha1
-> SolutionCharacterization -> AssociatedSolutionCharacterization
AssociatedSolutionCharacterization
      (Sha1
 -> SolutionCharacterization -> AssociatedSolutionCharacterization)
-> RowParser Sha1
-> RowParser
     (SolutionCharacterization -> AssociatedSolutionCharacterization)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Sha1
Sha1 (String -> Sha1) -> RowParser String -> RowParser Sha1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser String
forall a. FromField a => RowParser a
field)
      RowParser
  (SolutionCharacterization -> AssociatedSolutionCharacterization)
-> RowParser SolutionCharacterization
-> RowParser AssociatedSolutionCharacterization
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser SolutionCharacterization
forall a. FromRow a => RowParser a
fromRow

instance FromRow SolutionCharacterization where
  fromRow :: RowParser SolutionCharacterization
fromRow =
    Seconds
-> TickNumber
-> Seed
-> ScenarioCodeMetrics
-> SolutionCharacterization
SolutionCharacterization
      (Seconds
 -> TickNumber
 -> Seed
 -> ScenarioCodeMetrics
 -> SolutionCharacterization)
-> RowParser Seconds
-> RowParser
     (TickNumber
      -> Seed -> ScenarioCodeMetrics -> SolutionCharacterization)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Seconds
forall a. FromField a => RowParser a
field
      RowParser
  (TickNumber
   -> Seed -> ScenarioCodeMetrics -> SolutionCharacterization)
-> RowParser TickNumber
-> RowParser
     (Seed -> ScenarioCodeMetrics -> SolutionCharacterization)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int64 -> TickNumber
TickNumber (Int64 -> TickNumber) -> RowParser Int64 -> RowParser TickNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Int64
forall a. FromField a => RowParser a
field)
      RowParser (Seed -> ScenarioCodeMetrics -> SolutionCharacterization)
-> RowParser Seed
-> RowParser (ScenarioCodeMetrics -> SolutionCharacterization)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Seed
forall a. FromField a => RowParser a
field
      RowParser (ScenarioCodeMetrics -> SolutionCharacterization)
-> RowParser ScenarioCodeMetrics
-> RowParser SolutionCharacterization
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Seed -> Seed -> ScenarioCodeMetrics
ScenarioCodeMetrics (Seed -> Seed -> ScenarioCodeMetrics)
-> RowParser Seed -> RowParser (Seed -> ScenarioCodeMetrics)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Seed
forall a. FromField a => RowParser a
field RowParser (Seed -> ScenarioCodeMetrics)
-> RowParser Seed -> RowParser ScenarioCodeMetrics
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Seed
forall a. FromField a => RowParser a
field)

instance FromRow TournamentGame where
  fromRow :: RowParser TournamentGame
fromRow =
    Text -> Text -> Sha1 -> Seed -> Sha1 -> Text -> TournamentGame
TournamentGame
      (Text -> Text -> Sha1 -> Seed -> Sha1 -> Text -> TournamentGame)
-> RowParser Text
-> RowParser
     (Text -> Sha1 -> Seed -> Sha1 -> Text -> TournamentGame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Text
forall a. FromField a => RowParser a
field
      RowParser (Text -> Sha1 -> Seed -> Sha1 -> Text -> TournamentGame)
-> RowParser Text
-> RowParser (Sha1 -> Seed -> Sha1 -> Text -> TournamentGame)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Text
forall a. FromField a => RowParser a
field
      RowParser (Sha1 -> Seed -> Sha1 -> Text -> TournamentGame)
-> RowParser Sha1
-> RowParser (Seed -> Sha1 -> Text -> TournamentGame)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Sha1
Sha1 (String -> Sha1) -> RowParser String -> RowParser Sha1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser String
forall a. FromField a => RowParser a
field)
      RowParser (Seed -> Sha1 -> Text -> TournamentGame)
-> RowParser Seed -> RowParser (Sha1 -> Text -> TournamentGame)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Seed
forall a. FromField a => RowParser a
field
      RowParser (Sha1 -> Text -> TournamentGame)
-> RowParser Sha1 -> RowParser (Text -> TournamentGame)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Sha1
Sha1 (String -> Sha1) -> RowParser String -> RowParser Sha1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser String
forall a. FromField a => RowParser a
field)
      RowParser (Text -> TournamentGame)
-> RowParser Text -> RowParser TournamentGame
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Text
forall a. FromField a => RowParser a
field

instance FromRow TournamentSolution where
  fromRow :: RowParser TournamentSolution
fromRow =
    UTCTime
-> Text -> SolutionFileCharacterization -> TournamentSolution
TournamentSolution
      (UTCTime
 -> Text -> SolutionFileCharacterization -> TournamentSolution)
-> RowParser UTCTime
-> RowParser
     (Text -> SolutionFileCharacterization -> TournamentSolution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser UTCTime
forall a. FromField a => RowParser a
field
      RowParser
  (Text -> SolutionFileCharacterization -> TournamentSolution)
-> RowParser Text
-> RowParser (SolutionFileCharacterization -> TournamentSolution)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Text
forall a. FromField a => RowParser a
field
      RowParser (SolutionFileCharacterization -> TournamentSolution)
-> RowParser SolutionFileCharacterization
-> RowParser TournamentSolution
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser SolutionFileCharacterization
forall a. FromRow a => RowParser a
fromRow

instance FromRow SolutionFileCharacterization where
  fromRow :: RowParser SolutionFileCharacterization
fromRow =
    Sha1 -> SolutionCharacterization -> SolutionFileCharacterization
SolutionFileCharacterization
      (Sha1 -> SolutionCharacterization -> SolutionFileCharacterization)
-> RowParser Sha1
-> RowParser
     (SolutionCharacterization -> SolutionFileCharacterization)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Sha1
Sha1 (String -> Sha1) -> RowParser String -> RowParser Sha1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser String
forall a. FromField a => RowParser a
field)
      RowParser
  (SolutionCharacterization -> SolutionFileCharacterization)
-> RowParser SolutionCharacterization
-> RowParser SolutionFileCharacterization
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser SolutionCharacterization
forall a. FromRow a => RowParser a
fromRow

-- * Authentication

-- | If the username already exists, overwrite the row.
insertCookie ::
  UserAlias ->
  ReaderT Connection IO TL.Text
insertCookie :: UserAlias -> ReaderT Connection IO Text
insertCookie UserAlias
gitHubUsername = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO Text -> ReaderT Connection IO Text
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT Connection IO Text)
-> IO Text -> ReaderT Connection IO Text
forall a b. (a -> b) -> a -> b
$ do
    [Only Text
cookieString] <-
      Connection -> Query -> Only UserAlias -> IO [Only Text]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
        Connection
conn
        Query
"REPLACE INTO users (alias) VALUES (?) RETURNING cookie;"
        (UserAlias -> Only UserAlias
forall a. a -> Only a
Only UserAlias
gitHubUsername)
    Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
cookieString

-- | If the username already exists, overwrite the row.
insertGitHubTokens ::
  UserAlias ->
  ReceivedTokens ->
  ReaderT Connection IO ()
insertGitHubTokens :: UserAlias -> ReceivedTokens -> ReaderT Connection IO ()
insertGitHubTokens UserAlias
gitHubUsername ReceivedTokens
gitHubTokens = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  UTCTime
currentTime <- IO UTCTime -> ReaderT Connection IO UTCTime
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let expirationOf :: (ReceivedTokens -> Expirable a) -> UTCTime
expirationOf = UTCTime -> (ReceivedTokens -> Expirable a) -> UTCTime
forall {a}. UTCTime -> (ReceivedTokens -> Expirable a) -> UTCTime
mkExpirationTime UTCTime
currentTime
  IO () -> ReaderT Connection IO ()
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Connection IO ())
-> IO () -> ReaderT Connection IO ()
forall a b. (a -> b) -> a -> b
$ do
    Connection
-> Query
-> (UserAlias, AccessToken, UTCTime, RefreshToken, UTCTime)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute
      Connection
conn
      Query
"REPLACE INTO github_tokens (alias, github_access_token, github_access_token_expires_at, github_refresh_token, github_refresh_token_expires_at) VALUES (?, ?, ?, ?, ?);"
      ( UserAlias
gitHubUsername
      , Expirable AccessToken -> AccessToken
forall a. Expirable a -> a
token (Expirable AccessToken -> AccessToken)
-> Expirable AccessToken -> AccessToken
forall a b. (a -> b) -> a -> b
$ ReceivedTokens -> Expirable AccessToken
accessToken ReceivedTokens
gitHubTokens
      , (ReceivedTokens -> Expirable AccessToken) -> UTCTime
forall {a}. (ReceivedTokens -> Expirable a) -> UTCTime
expirationOf ReceivedTokens -> Expirable AccessToken
accessToken
      , Expirable RefreshToken -> RefreshToken
forall a. Expirable a -> a
token (Expirable RefreshToken -> RefreshToken)
-> Expirable RefreshToken -> RefreshToken
forall a b. (a -> b) -> a -> b
$ ReceivedTokens -> Expirable RefreshToken
refreshToken ReceivedTokens
gitHubTokens
      , (ReceivedTokens -> Expirable RefreshToken) -> UTCTime
forall {a}. (ReceivedTokens -> Expirable a) -> UTCTime
expirationOf ReceivedTokens -> Expirable RefreshToken
refreshToken
      )
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  mkExpirationTime :: UTCTime -> (ReceivedTokens -> Expirable a) -> UTCTime
mkExpirationTime UTCTime
currTime ReceivedTokens -> Expirable a
accessor =
    NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Seed -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Seed -> NominalDiffTime) -> Seed -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Expirable a -> Seed
forall a. Expirable a -> Seed
expirationSeconds (Expirable a -> Seed) -> Expirable a -> Seed
forall a b. (a -> b) -> a -> b
$ ReceivedTokens -> Expirable a
accessor ReceivedTokens
gitHubTokens) UTCTime
currTime

getUsernameFromCookie ::
  TL.Text ->
  ReaderT Connection IO (Maybe UserAlias)
getUsernameFromCookie :: Text -> ReaderT Connection IO (Maybe UserAlias)
getUsernameFromCookie Text
cookieText = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO (Maybe UserAlias) -> ReaderT Connection IO (Maybe UserAlias)
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UserAlias) -> ReaderT Connection IO (Maybe UserAlias))
-> (IO [Only Text] -> IO (Maybe UserAlias))
-> IO [Only Text]
-> ReaderT Connection IO (Maybe UserAlias)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Only Text] -> Maybe UserAlias)
-> IO [Only Text] -> IO (Maybe UserAlias)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Only Text -> UserAlias) -> Maybe (Only Text) -> Maybe UserAlias
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> UserAlias
UserAlias (Text -> UserAlias)
-> (Only Text -> Text) -> Only Text -> UserAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only Text -> Text
forall a. Only a -> a
fromOnly) (Maybe (Only Text) -> Maybe UserAlias)
-> ([Only Text] -> Maybe (Only Text))
-> [Only Text]
-> Maybe UserAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only Text] -> Maybe (Only Text)
forall a. [a] -> Maybe a
listToMaybe) (IO [Only Text] -> ReaderT Connection IO (Maybe UserAlias))
-> IO [Only Text] -> ReaderT Connection IO (Maybe UserAlias)
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> Only Text -> IO [Only Text]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT alias FROM users WHERE cookie = ?;" (Text -> Only Text
forall a. a -> Only a
Only Text
cookieText)

-- * Retrieval

lookupScenarioContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
lookupScenarioContent :: Sha1 -> ReaderT Connection IO (Maybe ByteString)
lookupScenarioContent Sha1
sha1 = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO (Maybe ByteString) -> ReaderT Connection IO (Maybe ByteString)
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> ReaderT Connection IO (Maybe ByteString))
-> (IO [Only ByteString] -> IO (Maybe ByteString))
-> IO [Only ByteString]
-> ReaderT Connection IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Only ByteString] -> Maybe ByteString)
-> IO [Only ByteString] -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Only ByteString -> ByteString)
-> Maybe (Only ByteString) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only ByteString -> ByteString
forall a. Only a -> a
fromOnly (Maybe (Only ByteString) -> Maybe ByteString)
-> ([Only ByteString] -> Maybe (Only ByteString))
-> [Only ByteString]
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only ByteString] -> Maybe (Only ByteString)
forall a. [a] -> Maybe a
listToMaybe) (IO [Only ByteString] -> ReaderT Connection IO (Maybe ByteString))
-> IO [Only ByteString] -> ReaderT Connection IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> Only Sha1 -> IO [Only ByteString]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT content FROM scenarios WHERE content_sha1 = ?;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
sha1)

lookupSolutionContent :: Sha1 -> ReaderT Connection IO (Maybe LBS.ByteString)
lookupSolutionContent :: Sha1 -> ReaderT Connection IO (Maybe ByteString)
lookupSolutionContent Sha1
sha1 = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO (Maybe ByteString) -> ReaderT Connection IO (Maybe ByteString)
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> ReaderT Connection IO (Maybe ByteString))
-> (IO [Only ByteString] -> IO (Maybe ByteString))
-> IO [Only ByteString]
-> ReaderT Connection IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Only ByteString] -> Maybe ByteString)
-> IO [Only ByteString] -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Only ByteString -> ByteString)
-> Maybe (Only ByteString) -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only ByteString -> ByteString
forall a. Only a -> a
fromOnly (Maybe (Only ByteString) -> Maybe ByteString)
-> ([Only ByteString] -> Maybe (Only ByteString))
-> [Only ByteString]
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only ByteString] -> Maybe (Only ByteString)
forall a. [a] -> Maybe a
listToMaybe) (IO [Only ByteString] -> ReaderT Connection IO (Maybe ByteString))
-> IO [Only ByteString] -> ReaderT Connection IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> Only Sha1 -> IO [Only ByteString]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT content FROM solution_submission WHERE content_sha1 = ?;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
sha1)

lookupSolutionSubmission :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
lookupSolutionSubmission :: Sha1
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
lookupSolutionSubmission Sha1
contentSha1 = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO (Maybe AssociatedSolutionCharacterization)
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe AssociatedSolutionCharacterization)
 -> ReaderT
      Connection IO (Maybe AssociatedSolutionCharacterization))
-> IO (Maybe AssociatedSolutionCharacterization)
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
forall a b. (a -> b) -> a -> b
$ MaybeT IO AssociatedSolutionCharacterization
-> IO (Maybe AssociatedSolutionCharacterization)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO AssociatedSolutionCharacterization
 -> IO (Maybe AssociatedSolutionCharacterization))
-> MaybeT IO AssociatedSolutionCharacterization
-> IO (Maybe AssociatedSolutionCharacterization)
forall a b. (a -> b) -> a -> b
$ do
    Seed
evaluationId :: Int <-
      IO (Maybe Seed) -> MaybeT IO Seed
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Seed) -> MaybeT IO Seed)
-> IO (Maybe Seed) -> MaybeT IO Seed
forall a b. (a -> b) -> a -> b
$
        (Only Seed -> Seed) -> Maybe (Only Seed) -> Maybe Seed
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only Seed -> Seed
forall a. Only a -> a
fromOnly (Maybe (Only Seed) -> Maybe Seed)
-> ([Only Seed] -> Maybe (Only Seed)) -> [Only Seed] -> Maybe Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only Seed] -> Maybe (Only Seed)
forall a. [a] -> Maybe a
listToMaybe
          ([Only Seed] -> Maybe Seed) -> IO [Only Seed] -> IO (Maybe Seed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only Sha1 -> IO [Only Seed]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT solution_evaluation FROM solution_submission WHERE content_sha1 = ?;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
contentSha1)

    IO (Maybe AssociatedSolutionCharacterization)
-> MaybeT IO AssociatedSolutionCharacterization
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe AssociatedSolutionCharacterization)
 -> MaybeT IO AssociatedSolutionCharacterization)
-> IO (Maybe AssociatedSolutionCharacterization)
-> MaybeT IO AssociatedSolutionCharacterization
forall a b. (a -> b) -> a -> b
$
      [AssociatedSolutionCharacterization]
-> Maybe AssociatedSolutionCharacterization
forall a. [a] -> Maybe a
listToMaybe
        ([AssociatedSolutionCharacterization]
 -> Maybe AssociatedSolutionCharacterization)
-> IO [AssociatedSolutionCharacterization]
-> IO (Maybe AssociatedSolutionCharacterization)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query -> Only Seed -> IO [AssociatedSolutionCharacterization]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT scenario, wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE id = ?;" (Seed -> Only Seed
forall a. a -> Only a
Only Seed
evaluationId)

-- | There should only be one builtin solution for the scenario.
lookupScenarioSolution :: Sha1 -> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
lookupScenarioSolution :: Sha1
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
lookupScenarioSolution Sha1
scenarioSha1 = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Maybe SolutionCharacterization
solnChar <-
    IO (Maybe SolutionCharacterization)
-> ReaderT Connection IO (Maybe SolutionCharacterization)
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SolutionCharacterization)
 -> ReaderT Connection IO (Maybe SolutionCharacterization))
-> (IO [SolutionCharacterization]
    -> IO (Maybe SolutionCharacterization))
-> IO [SolutionCharacterization]
-> ReaderT Connection IO (Maybe SolutionCharacterization)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SolutionCharacterization] -> Maybe SolutionCharacterization)
-> IO [SolutionCharacterization]
-> IO (Maybe SolutionCharacterization)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SolutionCharacterization] -> Maybe SolutionCharacterization
forall a. [a] -> Maybe a
listToMaybe (IO [SolutionCharacterization]
 -> ReaderT Connection IO (Maybe SolutionCharacterization))
-> IO [SolutionCharacterization]
-> ReaderT Connection IO (Maybe SolutionCharacterization)
forall a b. (a -> b) -> a -> b
$
      Connection -> Query -> Only Sha1 -> IO [SolutionCharacterization]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT wall_time_seconds, ticks, seed, char_count, ast_size FROM evaluated_solution WHERE builtin AND scenario = ? LIMIT 1;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
scenarioSha1)
  Maybe AssociatedSolutionCharacterization
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
forall a. a -> ReaderT Connection IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AssociatedSolutionCharacterization
 -> ReaderT
      Connection IO (Maybe AssociatedSolutionCharacterization))
-> Maybe AssociatedSolutionCharacterization
-> ReaderT Connection IO (Maybe AssociatedSolutionCharacterization)
forall a b. (a -> b) -> a -> b
$ Sha1
-> SolutionCharacterization -> AssociatedSolutionCharacterization
AssociatedSolutionCharacterization Sha1
scenarioSha1 (SolutionCharacterization -> AssociatedSolutionCharacterization)
-> Maybe SolutionCharacterization
-> Maybe AssociatedSolutionCharacterization
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SolutionCharacterization
solnChar

listGames :: ReaderT Connection IO [TournamentGame]
listGames :: ReaderT Connection IO [TournamentGame]
listGames = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO [TournamentGame] -> ReaderT Connection IO [TournamentGame]
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TournamentGame] -> ReaderT Connection IO [TournamentGame])
-> IO [TournamentGame] -> ReaderT Connection IO [TournamentGame]
forall a b. (a -> b) -> a -> b
$
    Connection -> Query -> IO [TournamentGame]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions;"

listSubmissions :: Sha1 -> ReaderT Connection IO GameWithSolutions
listSubmissions :: Sha1 -> ReaderT Connection IO GameWithSolutions
listSubmissions Sha1
scenarioSha1 = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO GameWithSolutions -> ReaderT Connection IO GameWithSolutions
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GameWithSolutions -> ReaderT Connection IO GameWithSolutions)
-> IO GameWithSolutions -> ReaderT Connection IO GameWithSolutions
forall a b. (a -> b) -> a -> b
$ do
    [TournamentGame
game] <- Connection -> Query -> Only Sha1 -> IO [TournamentGame]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1, title FROM agg_scenario_submissions WHERE scenario = ?;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
scenarioSha1)
    [TournamentSolution]
solns <- Connection -> Query -> Only Sha1 -> IO [TournamentSolution]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT uploaded_at, solution_submitter, solution_sha1, wall_time_seconds, ticks, seed, char_count, ast_size FROM all_solution_submissions WHERE scenario = ?;" (Sha1 -> Only Sha1
forall a. a -> Only a
Only Sha1
scenarioSha1)
    GameWithSolutions -> IO GameWithSolutions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GameWithSolutions -> IO GameWithSolutions)
-> GameWithSolutions -> IO GameWithSolutions
forall a b. (a -> b) -> a -> b
$ TournamentGame -> [TournamentSolution] -> GameWithSolutions
GameWithSolutions TournamentGame
game [TournamentSolution]
solns

-- * Insertion

insertScenario ::
  CharacterizationResponse ScenarioUploadResponsePayload ->
  ReaderT Connection IO Sha1
insertScenario :: CharacterizationResponse ScenarioUploadResponsePayload
-> ReaderT Connection IO Sha1
insertScenario CharacterizationResponse ScenarioUploadResponsePayload
s = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  String
h <- IO String -> ReaderT Connection IO String
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ReaderT Connection IO String)
-> IO String -> ReaderT Connection IO String
forall a b. (a -> b) -> a -> b
$ do
    [Only String
resultList] <-
      Connection
-> Query
-> (Sha1, ByteString, Text, Text, UserAlias, Sha1)
-> IO [Only String]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
        Connection
conn
        Query
"INSERT INTO scenarios (content_sha1, content, original_filename, title, uploader, swarm_git_sha1) VALUES (?, ?, ?, ?, ?, ?) RETURNING content_sha1;"
        ( Sha1
scenarioSha
        , FileUpload -> ByteString
fileContent (FileUpload -> ByteString) -> FileUpload -> ByteString
forall a b. (a -> b) -> a -> b
$ UserAttributedUpload -> FileUpload
fileUpload (UserAttributedUpload -> FileUpload)
-> UserAttributedUpload -> FileUpload
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> UserAttributedUpload
forall a. CharacterizationResponse a -> UserAttributedUpload
upload CharacterizationResponse ScenarioUploadResponsePayload
s
        , FileMetadata -> Text
filename (FileMetadata -> Text)
-> (UserAttributedUpload -> FileMetadata)
-> UserAttributedUpload
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileUpload -> FileMetadata
fileMetadata (FileUpload -> FileMetadata)
-> (UserAttributedUpload -> FileUpload)
-> UserAttributedUpload
-> FileMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserAttributedUpload -> FileUpload
fileUpload (UserAttributedUpload -> Text) -> UserAttributedUpload -> Text
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> UserAttributedUpload
forall a. CharacterizationResponse a -> UserAttributedUpload
upload CharacterizationResponse ScenarioUploadResponsePayload
s
        , ScenarioUploadResponsePayload -> Text
sTitle (ScenarioUploadResponsePayload -> Text)
-> ScenarioUploadResponsePayload -> Text
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> ScenarioUploadResponsePayload
forall a. CharacterizationResponse a -> a
payload CharacterizationResponse ScenarioUploadResponsePayload
s
        , UserAttributedUpload -> UserAlias
uploader (UserAttributedUpload -> UserAlias)
-> UserAttributedUpload -> UserAlias
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> UserAttributedUpload
forall a. CharacterizationResponse a -> UserAttributedUpload
upload CharacterizationResponse ScenarioUploadResponsePayload
s
        , ScenarioUploadResponsePayload -> Sha1
swarmGameVersion (ScenarioUploadResponsePayload -> Sha1)
-> ScenarioUploadResponsePayload -> Sha1
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> ScenarioUploadResponsePayload
forall a. CharacterizationResponse a -> a
payload CharacterizationResponse ScenarioUploadResponsePayload
s
        )
    Seed
_ <- Connection -> Bool -> Sha1 -> SolutionCharacterization -> IO Seed
insertSolution Connection
conn Bool
True Sha1
scenarioSha (SolutionCharacterization -> IO Seed)
-> SolutionCharacterization -> IO Seed
forall a b. (a -> b) -> a -> b
$ AssociatedSolutionCharacterization -> SolutionCharacterization
characterization (AssociatedSolutionCharacterization -> SolutionCharacterization)
-> AssociatedSolutionCharacterization -> SolutionCharacterization
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> AssociatedSolutionCharacterization
forall a.
CharacterizationResponse a -> AssociatedSolutionCharacterization
associatedCharacterization CharacterizationResponse ScenarioUploadResponsePayload
s

    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
resultList
  Sha1 -> ReaderT Connection IO Sha1
forall a. a -> ReaderT Connection IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sha1 -> ReaderT Connection IO Sha1)
-> Sha1 -> ReaderT Connection IO Sha1
forall a b. (a -> b) -> a -> b
$ String -> Sha1
Sha1 String
h
 where
  scenarioSha :: Sha1
scenarioSha = FileMetadata -> Sha1
fileHash (FileMetadata -> Sha1)
-> (UserAttributedUpload -> FileMetadata)
-> UserAttributedUpload
-> Sha1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileUpload -> FileMetadata
fileMetadata (FileUpload -> FileMetadata)
-> (UserAttributedUpload -> FileUpload)
-> UserAttributedUpload
-> FileMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserAttributedUpload -> FileUpload
fileUpload (UserAttributedUpload -> Sha1) -> UserAttributedUpload -> Sha1
forall a b. (a -> b) -> a -> b
$ CharacterizationResponse ScenarioUploadResponsePayload
-> UserAttributedUpload
forall a. CharacterizationResponse a -> UserAttributedUpload
upload CharacterizationResponse ScenarioUploadResponsePayload
s

insertSolutionSubmission ::
  CharacterizationResponse SolutionUploadResponsePayload ->
  ReaderT Connection IO Sha1
insertSolutionSubmission :: CharacterizationResponse SolutionUploadResponsePayload
-> ReaderT Connection IO Sha1
insertSolutionSubmission (CharacterizationResponse UserAttributedUpload
solutionUpload AssociatedSolutionCharacterization
s (SolutionUploadResponsePayload Sha1
scenarioSha)) = do
  Connection
conn <- ReaderT Connection IO Connection
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO Sha1 -> ReaderT Connection IO Sha1
forall a. IO a -> ReaderT Connection IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Sha1 -> ReaderT Connection IO Sha1)
-> IO Sha1 -> ReaderT Connection IO Sha1
forall a b. (a -> b) -> a -> b
$ do
    Seed
solutionEvalId <- Connection -> Bool -> Sha1 -> SolutionCharacterization -> IO Seed
insertSolution Connection
conn Bool
False Sha1
scenarioSha (SolutionCharacterization -> IO Seed)
-> SolutionCharacterization -> IO Seed
forall a b. (a -> b) -> a -> b
$ AssociatedSolutionCharacterization -> SolutionCharacterization
characterization AssociatedSolutionCharacterization
s
    [Only String
echoedSha1] <-
      Connection
-> Query -> (UserAlias, Sha1, Seed, ByteString) -> IO [Only String]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
        Connection
conn
        Query
"INSERT INTO solution_submission (uploader, content_sha1, solution_evaluation, content) VALUES (?, ?, ?, ?) RETURNING content_sha1;"
        ( UserAttributedUpload -> UserAlias
uploader UserAttributedUpload
solutionUpload
        , FileMetadata -> Sha1
fileHash (FileMetadata -> Sha1) -> FileMetadata -> Sha1
forall a b. (a -> b) -> a -> b
$ FileUpload -> FileMetadata
fileMetadata (FileUpload -> FileMetadata) -> FileUpload -> FileMetadata
forall a b. (a -> b) -> a -> b
$ UserAttributedUpload -> FileUpload
fileUpload UserAttributedUpload
solutionUpload
        , Seed
solutionEvalId
        , FileUpload -> ByteString
fileContent (FileUpload -> ByteString) -> FileUpload -> ByteString
forall a b. (a -> b) -> a -> b
$ UserAttributedUpload -> FileUpload
fileUpload UserAttributedUpload
solutionUpload
        )
    Sha1 -> IO Sha1
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sha1 -> IO Sha1) -> Sha1 -> IO Sha1
forall a b. (a -> b) -> a -> b
$ String -> Sha1
Sha1 String
echoedSha1

insertSolution ::
  Connection ->
  Bool ->
  Sha1 ->
  SolutionCharacterization ->
  IO Int
insertSolution :: Connection -> Bool -> Sha1 -> SolutionCharacterization -> IO Seed
insertSolution Connection
conn Bool
isBuiltin Sha1
scenarioSha SolutionCharacterization
s = do
  [Only Seed
evaluationId] <-
    Connection
-> Query
-> (Sha1, Bool, Seconds, Int64, Seed, Seed, Seed)
-> IO [Only Seed]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query
      Connection
conn
      Query
"INSERT INTO evaluated_solution (scenario, builtin, wall_time_seconds, ticks, seed, char_count, ast_size) VALUES (?, ?, ?, ?, ?, ?, ?) RETURNING id;"
      (Sha1, Bool, Seconds, Int64, Seed, Seed, Seed)
insertion_items
  Seed -> IO Seed
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Seed
evaluationId
 where
  insertion_items :: (Sha1, Bool, Seconds, Int64, Seed, Seed, Seed)
insertion_items =
    ( Sha1
scenarioSha
    , Bool
isBuiltin
    , SolutionCharacterization -> Seconds
solutionWallTime SolutionCharacterization
s
    , TickNumber -> Int64
getTickNumber (TickNumber -> Int64) -> TickNumber -> Int64
forall a b. (a -> b) -> a -> b
$ SolutionCharacterization -> TickNumber
solutionTicks SolutionCharacterization
s
    , SolutionCharacterization -> Seed
scenarioSeed SolutionCharacterization
s
    , ScenarioCodeMetrics -> Seed
sourceTextLength (ScenarioCodeMetrics -> Seed) -> ScenarioCodeMetrics -> Seed
forall a b. (a -> b) -> a -> b
$ SolutionCharacterization -> ScenarioCodeMetrics
solutionCodeMetrics SolutionCharacterization
s
    , ScenarioCodeMetrics -> Seed
astSize (ScenarioCodeMetrics -> Seed) -> ScenarioCodeMetrics -> Seed
forall a b. (a -> b) -> a -> b
$ SolutionCharacterization -> ScenarioCodeMetrics
solutionCodeMetrics SolutionCharacterization
s
    )