Use sqlite and static binary (#1837)

This is a rework of #1798 to facilitate a simpler web stack.

# Demo

View http://swarmgame.net/

NOTE: Requires IPv6

# Motivation

Hosting cost is a main motivation.  Cost per month for an EC2 instance, RDS, and the requisite other services approaches >$50 per month.  In contrast, the lowest-tier Lightsail instance is $3.50/month.

The deployment process is of course simplified.

An incidental benefit to using SQLite is reduced latency of web requests; we no longer need to fetch credentials from an AWS API to connect to Postgres.

## Changes

Major changes:
* Use `sqlite` instead of `postgres`
* Use Docker to build a statically-linked deployable binary, rather than deploying the app within a Docker image

Fortunately, the API of `sqlite-simple` is near-identical to that of `postgresql-simple`, so most of the code change there is just to rip out AWS-specific stuff and Postgres connection info.  I have no hesitation to delete this code since if we ever want to use the previous stack again, we can just look at #1798.

app/tournament/Main.hs

@@ -3,15 +3,12 @@
 module Main where
 
 import Control.Monad.Trans.Reader (runReaderT)
-import Data.IORef (newIORef)
 import Data.Maybe (fromMaybe)
 import Network.Wai.Handler.Warp (Port)
 import Options.Applicative
 import Swarm.Game.State (Sha1 (..))
 import Swarm.Web.Tournament
 import Swarm.Web.Tournament.Database.Query
-import System.Environment (lookupEnv)
-import System.Posix.User (getEffectiveUserName)
 
 data AppOpts = AppOpts
   { userWebPort :: Maybe Port
@@ -57,25 +54,14 @@ cliInfo =
         <> fullDesc
     )
 
-deduceConnType :: Bool -> IO DbConnType
-deduceConnType isLocalSocketConn =
-  if isLocalSocketConn
-    then LocalDBOverSocket . Username <$> getEffectiveUserName
-    else do
-      maybeDbPassword <- lookupEnv envarPostgresPasswordKey
-      case maybeDbPassword of
-        Just dbPasswordEnvar -> return $ LocalDBFromDockerOverNetwork $ Password dbPasswordEnvar
-        Nothing -> RemoteDB <$> newIORef Nothing
-
 main :: IO ()
 main = do
   opts <- execParser cliInfo
-  connType <- deduceConnType $ isLocalSocketConnection opts
   webMain
-    (AppData (gameGitVersion opts) (persistenceFunctions connType) connType)
+    (AppData (gameGitVersion opts) persistenceFunctions)
     (fromMaybe defaultPort $ userWebPort opts)
  where
-  persistenceFunctions connMode =
+  persistenceFunctions =
     PersistenceLayer
       { lookupScenarioFileContent = withConnInfo lookupScenarioContent
       , scenarioStorage =
@@ -90,10 +76,5 @@ main = do
             }
       }
    where
-    withConnInfo f x = do
-      -- This gets deferred and re-executed upon each invocation
-      -- of a DB interaction function.
-      -- We need this behavior because the password fetched via API
-      -- expires after 15 min.
-      connInfo <- mkConnectInfo connMode
-      runReaderT (f x) connInfo
+    withConnInfo f x =
+      runReaderT (f x) databaseFilename

scripts/test/run-tests.sh

@@ -1,7 +1,5 @@
 #!/bin/bash -ex
 
-SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )
-cd $SCRIPT_DIR/..
+cd $(git rev-parse --show-toplevel)
 
-# See https://github.com/swarm-game/swarm/issues/936
-STACK_WORK=.stack-work-test stack test --fast "$@"
+cabal test --test-show-details=direct -O0 -j "$@"

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

@@ -71,7 +71,6 @@ defaultSolutionTimeout = SolutionTimeout 15
 data AppData = AppData
   { swarmGameGitVersion :: Sha1
   , persistence :: PersistenceLayer
-  , dbConnType :: DbConnType
   }
 
 type TournamentAPI =
@@ -126,10 +125,10 @@ mkApp appData =
     :<|> uploadSolution appData
     :<|> getScenarioMetadata appData
     :<|> downloadRedactedScenario appData
-    :<|> listScenarios appData
+    :<|> listScenarios
 
 uploadScenario :: AppData -> MultipartData Mem -> Handler ScenarioCharacterization
-uploadScenario (AppData gameVersion persistenceLayer _) multipartData =
+uploadScenario (AppData gameVersion persistenceLayer) multipartData =
   Handler . withExceptT toServantError . ExceptT $
     validateScenarioUpload
       args
@@ -144,7 +143,7 @@ uploadScenario (AppData gameVersion persistenceLayer _) multipartData =
         (scenarioStorage persistenceLayer)
 
 uploadSolution :: AppData -> MultipartData Mem -> Handler SolutionFileCharacterization
-uploadSolution (AppData _ persistenceLayer _) multipartData =
+uploadSolution (AppData _ persistenceLayer) multipartData =
   Handler . withExceptT toServantError . ExceptT $
     validateSubmittedSolution
       args
@@ -159,7 +158,7 @@ uploadSolution (AppData _ persistenceLayer _) multipartData =
         (solutionStorage persistenceLayer)
 
 getScenarioMetadata :: AppData -> Sha1 -> Handler ScenarioMetadata
-getScenarioMetadata (AppData _ persistenceLayer _) scenarioSha1 =
+getScenarioMetadata (AppData _ persistenceLayer) scenarioSha1 =
   Handler . withExceptT toServantError $ do
     doc <-
       ExceptT $
@@ -170,7 +169,7 @@ getScenarioMetadata (AppData _ persistenceLayer _) scenarioSha1 =
     return $ view scenarioMetadata s
 
 downloadRedactedScenario :: AppData -> Sha1 -> Handler TL.Text
-downloadRedactedScenario (AppData _ persistenceLayer _) scenarioSha1 = do
+downloadRedactedScenario (AppData _ persistenceLayer) scenarioSha1 = do
   Handler . withExceptT toServantError $ do
     doc <-
       ExceptT $
@@ -183,12 +182,12 @@ downloadRedactedScenario (AppData _ persistenceLayer _) scenarioSha1 = do
       encodeWith defaultEncodeOptions redactedDict
 
 -- NOTE: This is currently the only API endpoint that invokes
--- 'mkConnectInfo' directly
-listScenarios :: AppData -> Handler [TournamentGame]
-listScenarios (AppData _ _ connMode) =
-  Handler $ liftIO $ do
-    connInfo <- mkConnectInfo connMode
-    runReaderT listGames connInfo
+-- 'runReaderT' directly
+listScenarios :: Handler [TournamentGame]
+listScenarios =
+  Handler $
+    liftIO $
+      runReaderT listGames databaseFilename
 
 -- * Web app declaration
 

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

@@ -10,28 +10,24 @@
 -- SQL Queries for Swarm tournaments.
 module Swarm.Web.Tournament.Database.Query where
 
-import Control.Monad (guard)
 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.IORef
 import Data.Maybe (listToMaybe)
-import Data.String.Utils (strip)
 import Data.Time.Clock
-import Database.PostgreSQL.Simple
-import Database.PostgreSQL.Simple.FromRow
-import Database.PostgreSQL.Simple.ToField
+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.Tournament.Type
-import System.Exit (ExitCode (..))
-import System.Process
 
--- | Used for local development only
-envarPostgresPasswordKey :: String
-envarPostgresPasswordKey = "LOCAL_PGPASS"
+type ConnectInfo = String
+
+databaseFilename :: ConnectInfo
+databaseFilename = "swarm-games.db"
 
 newtype UserId = UserId Int
 
@@ -117,90 +113,6 @@ data DbConnType
 tokenRefreshInterval :: NominalDiffTime
 tokenRefreshInterval = 10 * 60
 
-genNewToken :: ConnectInfo -> IO (Either String String)
-genNewToken ci = do
-  (exitCode, stdoutString, stderrString) <-
-    readProcessWithExitCode
-      "aws"
-      [ "rds"
-      , "generate-db-auth-token"
-      , "--hostname"
-      , connectHost ci
-      , "--port"
-      , show $ connectPort ci
-      , "--region"
-      , region
-      , "--username"
-      , connectUser ci
-      ]
-      ""
-  return $ case exitCode of
-    ExitSuccess -> Right $ strip stdoutString
-    ExitFailure _ -> Left stderrString
- where
-  region = "us-east-1"
-
-getAwsCredentials :: TokenRef -> ConnectInfo -> IO ConnectInfo
-getAwsCredentials tokRef ci = do
-  currTime <- getCurrentTime
-  maybePreviousTok <- readIORef tokRef
-  let maybeStillValidTok = case maybePreviousTok of
-        Nothing -> Nothing
-        Just (TokenWithExpiration exprTime tok) ->
-          guard (currTime < exprTime) >> Just tok
-
-  case maybeStillValidTok of
-    Just (Password tok) ->
-      return $
-        ci
-          { connectPassword = tok
-          }
-    Nothing -> do
-      eitherNewTok <- genNewToken ci
-      case eitherNewTok of
-        Right newTok -> do
-          let nextExpirationTime = addUTCTime tokenRefreshInterval currTime
-          atomicWriteIORef tokRef
-            . Just
-            . TokenWithExpiration nextExpirationTime
-            $ Password newTok
-          return $
-            ci
-              { connectPassword = newTok
-              }
-        -- NOTE: This is not exactly valid behavior:
-        Left _errMsg -> return ci
-
-mkConnectInfo :: DbConnType -> IO ConnectInfo
-mkConnectInfo connType = do
-  let swarmDbConnect =
-        defaultConnectInfo
-          { connectDatabase = "swarm"
-          }
-
-  case connType of
-    LocalDBFromDockerOverNetwork (Password dbPasswd) ->
-      return $
-        swarmDbConnect
-          { connectHost = "host.docker.internal"
-          , connectUser = "swarm-app"
-          , connectPassword = dbPasswd
-          }
-    LocalDBOverSocket (Username username) ->
-      return
-        swarmDbConnect
-          { connectHost = "/var/run/postgresql"
-          , connectUser = username
-          }
-    RemoteDB tokRef -> getAwsCredentials tokRef rdsConnectionInfo
- where
-  rdsConnectionInfo =
-    defaultConnectInfo
-      { connectHost = "swarm-tournaments.cv6iymakujnb.us-east-1.rds.amazonaws.com"
-      , connectUser = "swarm-app"
-      , connectDatabase = "swarm"
-      }
-
 -- * Authentication
 
 getUserId :: Connection -> UserAlias -> IO UserId
@@ -226,13 +138,13 @@ getUserId conn userAlias = do
 lookupScenarioContent :: Sha1 -> ReaderT ConnectInfo IO (Maybe LBS.ByteString)
 lookupScenarioContent sha1 = do
   connInfo <- ask
-  liftIO . fmap (fmap fromOnly . listToMaybe) . withConnect connInfo $ \conn ->
+  liftIO . fmap (fmap fromOnly . listToMaybe) . withConnection connInfo $ \conn ->
     query conn "SELECT content FROM scenarios WHERE content_sha1 = ?;" (Only sha1)
 
 lookupSolutionSubmission :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
 lookupSolutionSubmission contentSha1 = do
   connInfo <- ask
-  liftIO $ withConnect connInfo $ \conn -> runMaybeT $ do
+  liftIO $ withConnection connInfo $ \conn -> runMaybeT $ do
     evaluationId :: Int <-
       MaybeT $
         fmap fromOnly . listToMaybe
@@ -246,14 +158,14 @@ lookupSolutionSubmission contentSha1 = do
 lookupScenarioSolution :: Sha1 -> ReaderT ConnectInfo IO (Maybe AssociatedSolutionSolutionCharacterization)
 lookupScenarioSolution scenarioSha1 = do
   connInfo <- ask
-  solnChar <- liftIO . fmap listToMaybe . withConnect connInfo $ \conn ->
+  solnChar <- liftIO . fmap listToMaybe . withConnection 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
   connInfo <- ask
-  liftIO $ withConnect connInfo $ \conn ->
+  liftIO $ withConnection connInfo $ \conn ->
     query_ conn "SELECT original_filename, scenario_uploader, scenario, submission_count, swarm_git_sha1 FROM submissions;"
 
 -- * Insertion
@@ -263,7 +175,7 @@ insertScenario ::
   ReaderT ConnectInfo IO Sha1
 insertScenario s = do
   connInfo <- ask
-  h <- liftIO $ withConnect connInfo $ \conn -> do
+  h <- liftIO $ withConnection connInfo $ \conn -> do
     uid <- getUserId conn $ uploader $ upload s
     [Only resultList] <-
       query
@@ -287,7 +199,7 @@ insertSolutionSubmission ::
   ReaderT ConnectInfo IO Sha1
 insertSolutionSubmission (CharacterizationResponse solutionUpload s (SolutionUploadResponsePayload scenarioSha)) = do
   connInfo <- ask
-  liftIO $ withConnect connInfo $ \conn -> do
+  liftIO $ withConnection connInfo $ \conn -> do
     uid <- getUserId conn $ uploader solutionUpload
 
     solutionEvalId <- insertSolution conn False scenarioSha $ characterization s

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

@@ -10,7 +10,7 @@ module Swarm.Web.Tournament.Type where
 import Data.Aeson
 import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as T
-import Database.PostgreSQL.Simple.ToField
+import Database.SQLite.Simple.ToField
 import GHC.Generics (Generic)
 import Servant
 import Servant.Docs (ToCapture)

swarm.cabal

@@ -462,7 +462,6 @@ library swarm-tournament
   other-modules: Paths_swarm
   autogen-modules: Paths_swarm
   build-depends:
-    MissingH,
     SHA,
     aeson,
     base,
@@ -474,11 +473,10 @@ library swarm-tournament
     http-types,
     lens,
     mtl,
-    postgresql-simple >=0.7 && <0.7.1,
-    process,
     servant-docs,
     servant-multipart,
     servant-server >=0.19 && <0.21,
+    sqlite-simple >=0.4.19.0 && <0.4.20,
     text,
     time,
     transformers,
@@ -757,7 +755,6 @@ executable swarm-host-tournament
     base,
     optparse-applicative >=0.16 && <0.19,
     transformers,
-    unix,
     warp,
 
   build-depends:

test/tournament-host/Main.hs

@@ -50,8 +50,6 @@ main = do
     Tournament.AppData
       { Tournament.swarmGameGitVersion = Sha1 "abcdef"
       , Tournament.persistence = mkPersistenceLayer scenariosMap
-      , -- NOTE: This is not actually used/exercised by the tests:
-        Tournament.dbConnType = LocalDBOverSocket $ Username ""
       }
 
 type LocalFileLookup = NEMap Sha1 FilePathAndContent

tournament/README.md

@@ -0,0 +1,23 @@
+# Usage
+
+## Installation prerequisites:
+
+Install sqlite:
+```
+sudo apt install sqlite3
+```
+
+## Deployment
+
+Run this script (requires Docker):
+```
+tournament/scripts/docker/build-static-binary.sh
+```
+
+# Testing
+
+## Unit tests
+
+```
+scripts/test/run-tests.sh swarm:test:tournament-host
+```