Make it compile

flake.nix

@@ -11,8 +11,21 @@
       let
         pkgs = inputs.nixpkgs.legacyPackages.${system};
         haskell = pkgs.haskell.packages.ghc96;
+        package = haskell.callCabal2nix "zureg" ./. {
+          urlencoded = (pkgs.haskell.lib.doJailbreak haskell.urlencoded);
+        };
+        packageExes = pkgs.haskell.lib.justStaticExecutables package;
       in {
-        packages = { default = haskell.callCabal2nix "zureg" ./. { }; };
+        packages = {
+          default = package;
+
+          docker = pkgs.dockerTools.buildLayeredImage {
+            name = "zureg";
+            tag = "latest";
+            contents = [ pkgs.cacert ];
+            config.Cmd = "${packageExes}/bin/zureg-web";
+          };
+        };
         devShells = {
           default = let
             postgres = {
@@ -31,8 +44,7 @@
               pkgs.awscli2
               haskell.stylish-haskell
               (haskell.ghc.withPackages (p:
-                inputs.self.packages.${system}.default.buildInputs
-                ++ [ p.postgresql-simple ]))
+                package.buildInputs ++ [ p.postgresql-simple ]))
             ];
 
             shellHook = ''
@@ -44,15 +56,6 @@
                 -p ${postgres.port}:5432 \
                 -d postgres
             '';
-
-            ZUREG_DB =
-              "postgresql://postgres:${postgres.password}@localhost:${postgres.port}/${postgres.db}";
-
-            ZUREG_HACKATHON_NAME = "ZuriHac 2025";
-            ZUREG_HACKATHON_URL = "https://zureg.zfoh.ch";
-            ZUREG_HACKATHON_CONTACT_URL = "https://zfoh.ch/zurihac2025/#contact";
-            ZUREG_HACKATHON_CAPACITY = "500";
-            ZUREG_HACKATHON_CONFIRMATION = "true";
           };
         };
         formatter = pkgs.nixfmt;

lib/Zureg/AWS.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Zureg.AWS
+    ( Config
+    , smartEnv
+    ) where
+
+import           Amazonka
+import           Amazonka.Auth
+import qualified Amazonka.Data          as Amazonka
+import qualified Data.Aeson.TH.Extended as A
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as T
+import qualified System.IO              as IO
+
+data Config = Config
+    { configRegion    :: !T.Text
+    , configAccessKey :: !T.Text
+    , configSecretKey :: !T.Text
+    } deriving (Show)
+
+-- | AWS region is not retrieved correctly from environment variables, and
+-- neither from the AWS profile.
+smartEnv :: Config -> IO Env
+smartEnv conf = do
+    logger' <- newLogger Info IO.stderr
+    region' <- either fail pure $ Amazonka.fromText (configRegion conf)
+    env <- newEnvNoAuth
+    pure $ fromKeys
+        (AccessKey $ T.encodeUtf8 $ configAccessKey conf)
+        (SecretKey $ T.encodeUtf8 $ configSecretKey conf)
+        env
+        { logger = logger'
+        , region = region'
+        }
+
+$(A.deriveJSON A.options ''Config)

lib/Zureg/Captcha/HCaptcha.hs

@@ -5,7 +5,6 @@
 module Zureg.Captcha.HCaptcha
     ( module Zureg.Captcha
     , Config (..)
-    , configFromEnv
     , new
     ) where
 
@@ -17,7 +16,6 @@ import qualified Data.Text.Encoding          as T
 import qualified Data.Text.Lazy              as TL
 import qualified Data.URLEncoded             as UrlEncoded
 import qualified Network.HTTP.Client         as Http
-import           System.Environment          (getEnv)
 import qualified Text.Blaze.Html5            as H
 import qualified Text.Blaze.Html5.Attributes as A
 import           Zureg.Captcha
@@ -27,11 +25,6 @@ data Config = Config
     , cSecretKey :: !T.Text
     } deriving (Show)
 
-configFromEnv :: IO Config
-configFromEnv = Config
-    <$> (T.pack <$> getEnv "ZUREG_HCAPTCHA_SITEKEY")
-    <*> (T.pack <$> getEnv "ZUREG_HCAPTCHA_SECRET")
-
 new :: Config -> IO Handle
 new Config {..} = pure Handle
     { clientHtml = ClientHtml

lib/Zureg/Config.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Zureg.Config
+    ( Config (..)
+    , load
+    ) where
+
+import qualified Data.Aeson                          as A
+import qualified Data.Aeson.TH.Extended              as A
+import qualified Data.Text                           as T
+import           System.Directory                    (doesFileExist)
+import qualified Zureg.AWS                           as AWS
+import qualified Zureg.Captcha.HCaptcha              as HCaptcha
+import qualified Zureg.Database                      as Database
+import qualified Zureg.Hackathon                     as Hackathon
+import qualified Zureg.Hackathon.ZuriHac2020.Discord as Discord
+
+data Config = Config
+    { configHackathon     :: !Hackathon.Hackathon
+    , configDatabase      :: !Database.Config
+    , configDiscord       :: !Discord.Config
+    , configCaptcha       :: !(Maybe HCaptcha.Config)
+    , configAws           :: !AWS.Config
+    , configScannerSecret :: !T.Text
+    } deriving (Show)
+
+$(A.deriveFromJSON A.options ''Config)
+
+load :: IO Config
+load = do
+    local <- doesFileExist "zureg.json"
+    let path = if local then "zureg.json" else "/etc/zureg.json"
+    either fail pure =<< A.eitherDecodeFileStrict path

lib/Zureg/Database.hs

@@ -1,37 +1,36 @@
 -- | Storing the registrants in a DynamoDB table.  Uses the `Eventful` library.
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
 module Zureg.Database
     ( Config (..)
-    , configFromEnv
     , Handle
     , withHandle
-
-    -- Old stuff
-    , getRegistrant
-    , getRegistrantUuids
-
-    , putEmail
-    , deleteEmail
-    , lookupEmail
-
-    , RegistrantsSummary (..)
-    , lookupRegistrantsSummary
-    , putRegistrantsSummary
+    , Transaction
+    , withTransaction
 
     -- New stuff
+    , migrate
     , insertRegistration
+    , selectRegistrations
+    , selectRegistration
+    , selectRegistrationByEmail
+    , selectAttending
+    , selectWaitlist
     , setRegistrationState
     , setRegistrationScanned
+    , insertProject
     ) where
 
-import           Control.Exception      (Exception)
-import qualified Data.Aeson.TH.Extended as A
-import qualified Data.Text              as T
-import           Data.UUID              (UUID)
-import           System.Environment     (lookupEnv)
+import           Control.Exception          (Exception)
+import           Control.Monad              (void)
+import qualified Data.Text                  as T
+import           Data.UUID                  (UUID)
+import qualified Database.PostgreSQL.Simple as Pg
+import           Zureg.Database.Internal
+import           Zureg.Database.Migrations
 import           Zureg.Database.Models
 
 data DatabaseException
@@ -42,61 +41,101 @@ data DatabaseException
 
 instance Exception DatabaseException
 
-data Config = Config
-    { cConnectionString :: !T.Text
-    }
-
-configFromEnv :: IO Config
-configFromEnv = do
-    cstring <- lookupEnv "ZUREG_DB" >>= maybe (fail "ZUREG_DB not set") pure
-    pure Config {cConnectionString = T.pack cstring}
-
-data Handle = Handle
-    { hConfig :: !Config
-    }
-
-withHandle :: Config -> (Handle -> IO a) -> IO a
-withHandle hConfig f = do
-    f Handle {..}
-
-getRegistrant :: Handle -> UUID -> IO Registration
-getRegistrant _ _ = undefined
-
-getRegistrantUuids :: Handle -> IO [UUID]
-getRegistrantUuids _ = pure []
-
-putEmail :: Handle -> T.Text -> UUID -> IO ()
-putEmail _ _ _ = pure ()
-
-deleteEmail :: Handle -> T.Text -> IO ()
-deleteEmail _ _ = pure ()
-
-lookupEmail :: Handle -> T.Text -> IO (Maybe UUID)
-lookupEmail _ _ = pure Nothing
-
-data RegistrantsSummary = RegistrantsSummary
-    { rsTotal     :: Int
-    , rsWaiting   :: Int
-    , rsConfirmed :: Int
-    , rsAttending :: Int
-    , rsAvailable :: Int
-    , rsScanned   :: Int
-    , rsSpam      :: Int
-    } deriving (Show)
-
-$(A.deriveJSON A.options ''RegistrantsSummary)
-
-putRegistrantsSummary :: Handle -> RegistrantsSummary -> IO ()
-putRegistrantsSummary _ _ = pure ()
-
-lookupRegistrantsSummary :: Handle -> IO RegistrantsSummary
-lookupRegistrantsSummary _ = undefined
-
-insertRegistration :: Handle -> UUID -> InsertRegistration -> IO Registration
-insertRegistration _ _ _ = undefined
-
-setRegistrationState :: Handle -> UUID -> RegistrationState -> IO Registration
-setRegistrationState _ _ _ = undefined
-
-setRegistrationScanned :: Handle -> UUID -> IO Registration
-setRegistrationScanned _ _ = undefined
+insertRegistration :: Transaction -> InsertRegistration -> IO Registration
+insertRegistration (Transaction conn) ir = do
+    rows <- Pg.query conn
+        "INSERT INTO registrations (\n\
+        \    name,\n\
+        \    badge_name,\n\
+        \    email,\n\
+        \    affiliation,\n\
+        \    tshirt_size,\n\
+        \    region,\n\
+        \    occupation,\n\
+        \    beginner_track_interest\n\
+        \) VALUES (?, ?, ?, ?, ?, ?, ?, ?)\n\
+        \RETURNING *"
+        ir
+    case rows of
+        [registration] -> pure registration
+        _              -> fail "insertRegistration: expected one row"
+
+selectRegistrations :: Transaction -> IO [Registration]
+selectRegistrations (Transaction conn) =
+    Pg.query_ conn "SELECT * FROM registrations"
+
+selectRegistration :: Transaction -> UUID -> IO (Maybe Registration)
+selectRegistration (Transaction conn) uuid = do
+    rows <- Pg.query conn
+        "SELECT * FROM registrations WHERE id = ?"
+        (Pg.Only uuid)
+    case rows of
+        [registration] -> pure $ Just registration
+        []             -> pure Nothing
+        _              -> fail
+            "selectRegistration: expected one or zero rows"
+
+selectRegistrationByEmail :: Transaction -> T.Text -> IO (Maybe Registration)
+selectRegistrationByEmail (Transaction conn) email = do
+    rows <- Pg.query conn
+        "SELECT * FROM registrations WHERE email = ?"
+        (Pg.Only email)
+    case rows of
+        [registration] -> pure $ Just registration
+        []             -> pure Nothing
+        _              -> fail
+            "selectRegistrationByEmail: expected one or zero rows"
+
+selectAttending :: Transaction -> IO Int
+selectAttending (Transaction conn) = do
+    rows <- Pg.query conn
+        "SELECT COUNT(*) FROM registrations WHERE state = ? OR state = ?"
+        (Registered, Confirmed) :: IO [Pg.Only Int]
+    case rows of
+        [Pg.Only c] -> pure c
+        _           -> fail "selectAttending: expected one row"
+
+-- | Select all the attendees on the waiting list in the order they joined.
+selectWaitlist :: Transaction -> IO [Registration]
+selectWaitlist (Transaction conn) = Pg.query conn
+    "SELECT * FROM registrations WHERE state = ?\n\
+    \ORDER BY registered_at ASC"
+    (Pg.Only Waitlisted)
+
+setRegistrationState :: Transaction -> UUID -> RegistrationState -> IO Registration
+setRegistrationState (Transaction conn) uuid state = do
+    rows <- Pg.query conn
+        "UPDATE registrations SET state = ? WHERE id = ? RETURNING *"
+        (state, uuid)
+    case rows of
+        [registration] -> pure registration
+        _              -> fail "setRegistrationState: expected one row"
+
+setRegistrationScanned :: Transaction -> UUID -> IO Registration
+setRegistrationScanned (Transaction conn) uuid = do
+    rows <- Pg.query conn
+        "UPDATE registrations SET scanned_at = NOW() WHERE id = ? RETURNING *"
+        (Pg.Only uuid)
+    case rows of
+        [registration] -> pure registration
+        _              -> fail "setRegistrationScanned: expected one row"
+
+insertProject :: Transaction -> UUID -> Project -> IO ()
+insertProject (Transaction conn) registrationID project = void $ Pg.execute conn
+    "INSERT INTO projects (\n\
+    \    registration_id,\n\
+    \    name,\n\
+    \    link,\n\
+    \    short_description,\n\
+    \    contributor_level_beginner,\n\
+    \    contributor_level_intermediate,\n\
+    \    contributor_level_advanced\n\
+    \) VALUES (?, ?, ?, ?, ?, ?, ?)"
+    ( registrationID
+    , pName project
+    , pLink project
+    , pShortDescription project
+    , clBeginner $ pContributorLevel project
+    , clIntermediate $ pContributorLevel project
+    , clAdvanced $ pContributorLevel project
+    )