Make it compile

Author: jaspervdj

flake.nix

@@ -44,15 +44,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/Amazonka/Extended.hs renamed to lib/Zureg/AWS.hs

@@ -1,25 +1,31 @@
-module Amazonka.Extended
-    ( module Amazonka
+{-# LANGUAGE TemplateHaskell #-}
+module Zureg.AWS
+    ( Config
     , smartEnv
     ) where
 
 import           Amazonka
+import qualified Data.Aeson                  as A
+import qualified Data.Aeson.TH.Extended      as A
 import qualified Amazonka.Data      as Amazonka
 import qualified Data.Text          as T
 import           System.Environment (lookupEnv)
 import qualified System.IO          as IO
 
+data Config = Config
+    { configRegion :: !T.Text
+    } deriving (Show)
+
 -- | AWS region is not retrieved correctly from environment variables, and
 -- neither from the AWS profile.
-smartEnv :: IO Env
-smartEnv = do
+smartEnv :: Config -> IO Env
+smartEnv conf = do
     logger' <- newLogger Debug IO.stderr
-    maybeRegion <- lookupEnv "AWS_REGION"
-    region' <- case maybeRegion of
-        Just str | Right r <- Amazonka.fromText $ T.pack str -> pure r
-        _ -> fail "AWS_REGION needs to be set"
+    region' <- either fail pure $ Amazonka.fromText (configRegion conf)
     env <- newEnv discover
     pure env
         { logger = logger'
         , region = region'
         }
+
+$(A.deriveJSON A.options ''Config)

lib/Zureg/Config.hs

@@ -0,0 +1,28 @@
+{-# 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 qualified Zureg.AWS                           as AWS
+import qualified Zureg.Captcha.HCaptcha              as HCaptcha
+import qualified Zureg.Database                      as Database
+import qualified Zureg.Hackathon.Interface           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 = either fail pure =<< A.eitherDecodeFileStrict "config.json"

lib/Zureg/Database.hs

@@ -1,13 +1,16 @@
 -- | 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
+    , Transaction
+    , withTransaction
 
     -- Old stuff
     , getRegistrant
@@ -22,16 +25,23 @@ module Zureg.Database
     , putRegistrantsSummary
 
     -- New stuff
+    , migrate
     , insertRegistration
+    , selectRegistration
+    , selectAttending
     , setRegistrationState
     , setRegistrationScanned
     ) 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 qualified Data.Aeson                 as A
+import qualified Data.Aeson.TH.Extended     as A
+import qualified Data.Text                  as T
+import           Data.UUID                  (UUID)
+import qualified Database.PostgreSQL.Simple as Pg
+import           System.Environment         (lookupEnv)
+import           Zureg.Database.Internal
+import           Zureg.Database.Migrations
 import           Zureg.Database.Models
 
 data DatabaseException
@@ -42,23 +52,11 @@ 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
 
@@ -92,11 +90,25 @@ putRegistrantsSummary _ _ = pure ()
 lookupRegistrantsSummary :: Handle -> IO RegistrantsSummary
 lookupRegistrantsSummary _ = undefined
 
-insertRegistration :: Handle -> UUID -> InsertRegistration -> IO Registration
-insertRegistration _ _ _ = undefined
+insertRegistration :: Transaction -> InsertRegistration -> IO Registration
+insertRegistration (Transaction conn) ir = do
+    print ir
+    pure undefined
+
+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"
+
+selectRegistration :: Transaction -> UUID -> IO Registration
+selectRegistration _ _ = undefined
 
-setRegistrationState :: Handle -> UUID -> RegistrationState -> IO Registration
+setRegistrationState :: Transaction -> UUID -> RegistrationState -> IO Registration
 setRegistrationState _ _ _ = undefined
 
-setRegistrationScanned :: Handle -> UUID -> IO Registration
+setRegistrationScanned :: Transaction -> UUID -> IO Registration
 setRegistrationScanned _ _ = undefined

lib/Zureg/Database/Internal.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards            #-}
+module Zureg.Database.Internal
+    ( Config (..)
+    , Handle (..)
+    , withHandle
+    , Transaction (..)
+    , withTransaction
+    ) where
+
+import           Control.Exception          (bracket)
+import qualified Data.Aeson                 as A
+import qualified Data.ByteString.Char8      as BS8
+import qualified Data.Text                  as T
+import qualified Data.Text.Encoding         as T
+import qualified Database.PostgreSQL.Simple as Pg
+
+newtype Config = Config
+    { cConnectionString :: T.Text
+    } deriving (A.FromJSON, Show)
+
+data Handle = Handle
+    { hConfig :: !Config
+    }
+
+withHandle :: Config -> (Handle -> IO a) -> IO a
+withHandle hConfig f = do
+    f Handle {..}
+
+newtype Transaction = Transaction Pg.Connection
+
+withTransaction :: Handle -> (Transaction -> IO a) -> IO a
+withTransaction Handle {..} = bracket
+    (fmap Transaction $ Pg.connectPostgreSQL $
+        T.encodeUtf8 $ cConnectionString hConfig)
+    (\(Transaction conn) -> Pg.close conn)

lib/Zureg/Database/Migrations.hs

@@ -3,18 +3,17 @@ module Zureg.Database.Migrations
     ( migrate
     ) where
 
-import qualified Data.ByteString.Char8      as BS8
 import           Data.Char                  (isDigit)
 import           Data.Foldable              (for_)
 import           Data.List                  (sortOn)
 import           Data.String                (fromString)
 import           Data.Traversable           (for)
 import qualified Database.PostgreSQL.Simple as Pg
 import qualified System.Directory           as Directory
-import           System.Environment         (lookupEnv)
 import           System.FilePath            ((</>))
 import qualified System.IO                  as IO
 import           Text.Read                  (readMaybe)
+import           Zureg.Database.Internal
 
 listMigrations :: IO [(Int, FilePath)]
 listMigrations = sortOn fst <$> do
@@ -27,18 +26,17 @@ listMigrations = sortOn fst <$> do
   where
     dir = "lib/Zureg/Database/Migrations"
 
-migrate :: IO ()
-migrate = do
-    pgstring <- lookupEnv "ZUREG_DB" >>= maybe (fail "ZUREG_DB not set") pure
-    conn <- Pg.connectPostgreSQL $ BS8.pack pgstring
-    _ <- Pg.execute_ conn "\
+migrate :: Handle -> IO ()
+migrate h = do
+    _ <- withTransaction h $ \(Transaction conn) -> Pg.execute_ conn "\
         \CREATE TABLE IF NOT EXISTS migrations (\n\
         \    version INT NOT NULL PRIMARY KEY,\n\
         \    path TEXT NOT NULL\n\
         \)"
 
     migrations <- listMigrations
-    for_ migrations $ \(version, path) -> Pg.withTransaction conn $ do
+    for_ migrations $ \(version, path) -> withTransaction h $
+        \(Transaction conn) -> do
         rows <- Pg.query conn
             "SELECT version FROM migrations WHERE version = ?"
             (Pg.Only version) :: IO [Pg.Only Int]
@@ -53,5 +51,3 @@ migrate = do
                     "INSERT INTO migrations (version, path) VALUES (?, ?)"
                     (version, path)
                 pure ()
-
-    Pg.close conn

lib/Zureg/Database/Migrations/01-init.sql

@@ -32,6 +32,10 @@ INSERT INTO occupations (occupation) VALUES ('Tech');
 INSERT INTO occupations (occupation) VALUES ('Academia');
 INSERT INTO occupations (occupation) VALUES ('Other');
 
+CREATE TABLE registration_states (
+    state TEXT NOT NULL PRIMARY KEY
+);
+
 CREATE TABLE registrations (
     id UUID NOT NULL PRIMARY KEY DEFAULT GEN_RANDOM_UUID(),
     email TEXT NOT NULL,

lib/Zureg/Database/Models.hs

@@ -15,12 +15,13 @@ module Zureg.Database.Models
     , Registration (..)
     ) where
 
-import qualified Data.Aeson.TH.Extended as A
-import qualified Data.List              as L
-import qualified Data.Text              as T
-import qualified Data.Time              as Time
-import           Data.UUID              (UUID)
-import           Text.Read              (readMaybe)
+import qualified Data.Aeson.TH.Extended             as A
+import qualified Data.List                          as L
+import qualified Data.Text                          as T
+import qualified Data.Time                          as Time
+import           Data.UUID                          (UUID)
+import qualified Database.PostgreSQL.Simple.ToField as Pg
+import           Text.Read                          (readMaybe)
 
 data TShirtSize = XS | S | M | L | XL | XXL deriving (Bounded, Enum, Eq, Show)
 
@@ -86,7 +87,7 @@ data InsertRegistration = InsertRegistration
     , irOccupation            :: !(Maybe Occupation)
     , irBeginnerTrackInterest :: !Bool
     , irProject               :: !Project
-    }
+    } deriving (Show)
 
 data Registration = Registration
     { rUuid                  :: !UUID
@@ -112,3 +113,6 @@ $(A.deriveJSON A.options ''ContributorLevel)
 $(A.deriveJSON A.options ''Project)
 $(A.deriveJSON A.options ''RegistrationState)
 $(A.deriveJSON A.options ''Registration)
+
+instance Pg.ToField RegistrationState where
+    toField = Pg.toField . show

lib/Zureg/Hackathon/Interface.hs

@@ -1,19 +1,21 @@
+{-# LANGUAGE TemplateHaskell   #-}
 module Zureg.Hackathon.Interface
     ( Hackathon (..)
     , hackathonFromEnv
     ) where
 
 import qualified Data.Text as T
 import qualified Data.Time as Time
+import qualified Data.Aeson.TH.Extended as A
 
 data Hackathon = Hackathon
     {
     -- | Name of the Hackathon, e.g. "ZuriHac 2020"
       name           :: T.Text
     -- | Base URL, e.g. "https://zureg.zfoh.ch"
-    , baseUrl        :: T.Text
+    , baseURL        :: T.Text
     -- | URL of the contact homepage, e.g. "https://zfoh.ch/zurihac2019/#contact"
-    , contactUrl     :: T.Text
+    , contactURL     :: T.Text
     -- | Total capacity of the event
     , capacity       :: Int
     -- | When 'True', registrants can/must confirm their registration
@@ -23,9 +25,9 @@ data Hackathon = Hackathon
     , emailFrom      :: T.Text
     -- | When T-shirt order is sent.
     , tShirtDeadline :: Maybe Time.UTCTime
-    -- | Secret for accessing the scanner page.
-    , scannerSecret :: T.Text
-    }
+    } deriving (Show)
 
 hackathonFromEnv :: IO Hackathon
 hackathonFromEnv = pure undefined
+
+$(A.deriveJSON A.defaultOptions ''Hackathon)