Skip to content

Commit c6ada5c

Browse files
jaspervdjjaspervdj
committed
Make export work nicely again
1 parent 18bf56a commit c6ada5c

File tree

13 files changed

+189
-103
lines changed

13 files changed

+189
-103
lines changed

‎lib/Data/Aeson/TH/Extended.hs

+7-3
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ module Data.Aeson.TH.Extended
44
) where
55

66
import Data.Aeson.TH
7-
import Data.Char (isUpper, toLower)
7+
import Data.Char (isUpper, toLower, isLower)
88

99
options :: Options
1010
options = defaultOptions
@@ -13,5 +13,9 @@ options = defaultOptions
1313

1414
dropPrefix :: String -> String
1515
dropPrefix str = case break isUpper str of
16-
(_, (y : ys)) -> toLower y : ys
17-
_ -> str
16+
(_, []) -> str
17+
(_, field) -> case break isLower field of
18+
(_, []) -> map toLower field
19+
([], _) -> map toLower field
20+
(xs@[_], ys) -> map toLower xs ++ ys
21+
(xs@(_ : _), ys) -> map toLower (init xs) ++ [last xs] ++ ys

‎lib/Zureg/Database.hs

+14-24
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE RecordWildCards #-}
55
{-# LANGUAGE TemplateHaskell #-}
66
{-# LANGUAGE TypeFamilies #-}
7+
{-# LANGUAGE TypeOperators #-}
78
module Zureg.Database
89
( Config (..)
910
, Handle
@@ -14,14 +15,14 @@ module Zureg.Database
1415
-- New stuff
1516
, migrate
1617
, insertRegistration
17-
, selectRegistrations
1818
, selectRegistration
1919
, selectRegistrationByEmail
2020
, selectAttending
2121
, selectWaitlist
2222
, setRegistrationState
2323
, setRegistrationScanned
2424
, insertProject
25+
, selectRegistrationsWithProjects
2526
) where
2627

2728
import Control.Exception (Exception)
@@ -60,10 +61,6 @@ insertRegistration (Transaction conn) ir = do
6061
[registration] -> pure registration
6162
_ -> fail "insertRegistration: expected one row"
6263

63-
selectRegistrations :: Transaction -> IO [Registration]
64-
selectRegistrations (Transaction conn) =
65-
Pg.query_ conn "SELECT * FROM registrations"
66-
6764
selectRegistration :: Transaction -> UUID -> IO (Maybe Registration)
6865
selectRegistration (Transaction conn) uuid = do
6966
rows <- Pg.query conn
@@ -120,22 +117,15 @@ setRegistrationScanned (Transaction conn) uuid = do
120117
[registration] -> pure registration
121118
_ -> fail "setRegistrationScanned: expected one row"
122119

123-
insertProject :: Transaction -> UUID -> Project -> IO ()
124-
insertProject (Transaction conn) registrationID project = void $ Pg.execute conn
125-
"INSERT INTO projects (\n\
126-
\ registration_id,\n\
127-
\ name,\n\
128-
\ link,\n\
129-
\ short_description,\n\
130-
\ contributor_level_beginner,\n\
131-
\ contributor_level_intermediate,\n\
132-
\ contributor_level_advanced\n\
133-
\) VALUES (?, ?, ?, ?, ?, ?, ?)"
134-
( registrationID
135-
, pName project
136-
, pLink project
137-
, pShortDescription project
138-
, clBeginner $ pContributorLevel project
139-
, clIntermediate $ pContributorLevel project
140-
, clAdvanced $ pContributorLevel project
141-
)
120+
insertProject :: Transaction -> Project -> IO ()
121+
insertProject (Transaction conn) project = void $ Pg.execute conn
122+
"INSERT INTO projects VALUES (?, ?, ?, ?, ?, ?, ?)" project
123+
124+
selectRegistrationsWithProjects
125+
:: Transaction -> IO [(Registration, Maybe Project)]
126+
selectRegistrationsWithProjects (Transaction conn) = fmap (fmap toTuple) $
127+
Pg.query_ conn
128+
"SELECT registrations.*, projects.* FROM registrations \n\
129+
\LEFT JOIN projects ON registrations.id = projects.registration_id"
130+
where
131+
toTuple (x Pg.:. y) = (x, y)

‎lib/Zureg/Database/Models.hs

+34-23
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,13 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE FlexibleInstances #-}
13
{-# LANGUAGE LambdaCase #-}
2-
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE OverloadedStrings #-}
45
{-# LANGUAGE RecordWildCards #-}
56
{-# LANGUAGE TemplateHaskell #-}
67
module Zureg.Database.Models
78
( TShirtSize (..)
89
, Region (..)
910
, Occupation (..)
10-
, ContributorLevel (..)
1111
, InsertRegistration (..)
1212
, RegistrationState (..)
1313
, parseRegistrationState
@@ -52,16 +52,9 @@ data Occupation
5252
| Other
5353
deriving (Bounded, Enum, Eq, Read, Show)
5454

55-
data ContributorLevel = ContributorLevel
56-
{ clBeginner :: !Bool
57-
, clIntermediate :: !Bool
58-
, clAdvanced :: !Bool
59-
} deriving (Eq, Show)
60-
6155
data RegistrationState = Registered | Confirmed | Cancelled | Waitlisted | Spam
6256
deriving (Bounded, Enum, Eq, Read, Show)
6357

64-
-- TODO: move?
6558
parseRegistrationState :: String -> Either String RegistrationState
6659
parseRegistrationState str = case readMaybe str of
6760
Just rs -> return rs
@@ -90,7 +83,7 @@ data InsertRegistration = InsertRegistration
9083
} deriving (Generic, Show)
9184

9285
data Registration = Registration
93-
{ rUuid :: !UUID
86+
{ rID :: !UUID
9487
, rName :: !T.Text
9588
, rBadgeName :: !(Maybe T.Text)
9689
, rEmail :: !T.Text
@@ -103,7 +96,7 @@ data Registration = Registration
10396
, rState :: !RegistrationState
10497
, rScannedAt :: !(Maybe Time.UTCTime)
10598
, rVip :: !Bool
106-
} deriving (Eq, Show)
99+
} deriving (Eq, Generic, Show)
107100

108101
instance Pg.ToField Region where toField = Pg.toField . show
109102
instance Pg.ToField TShirtSize where toField = Pg.toField . show
@@ -127,23 +120,41 @@ instance Pg.FromField Occupation where fromField = readField
127120
instance Pg.FromField RegistrationState where fromField = readField
128121

129122
instance Pg.ToRow InsertRegistration
130-
131123
instance Pg.FromRow Registration where
132-
fromRow = Registration
133-
<$> Pg.field <*> Pg.field <*> Pg.field <*> Pg.field <*> Pg.field
134-
<*> Pg.field <*> Pg.field <*> Pg.field <*> Pg.field <*> Pg.field
135-
<*> Pg.field <*> Pg.field <*> Pg.field
136124

137125
data Project = Project
138-
{ pName :: !(Maybe T.Text)
139-
, pLink :: !(Maybe T.Text)
140-
, pShortDescription :: !(Maybe T.Text)
141-
, pContributorLevel :: !ContributorLevel
142-
} deriving (Eq, Show)
126+
{ pRegistrationID :: !UUID
127+
, pName :: !T.Text
128+
, pLink :: !(Maybe T.Text)
129+
, pShortDescription :: !(Maybe T.Text)
130+
, pContributorLevelBeginner :: !Bool
131+
, pContributorLevelIntermediate :: !Bool
132+
, pContributorLevelAdvanced :: !Bool
133+
} deriving (Eq, Generic, Show)
134+
135+
instance Pg.ToRow Project
136+
instance Pg.FromRow Project
137+
138+
-- | This is a variation on MaybeT that will never short-circuit. The reason
139+
-- for this is that short-circuiting affects the number of columns expected
140+
-- in a type by postgresql-simple.
141+
newtype EagerMaybeT m a = EagerMaybeT {runEagerMaybe :: m (Maybe a)}
142+
143+
instance Functor m => Functor (EagerMaybeT m) where
144+
fmap f = EagerMaybeT . fmap (fmap f) . runEagerMaybe
145+
146+
instance Applicative m => Applicative (EagerMaybeT m) where
147+
pure = EagerMaybeT . pure . Just
148+
fx <*> mx = EagerMaybeT $ (<*>) <$> runEagerMaybe fx <*> runEagerMaybe mx
149+
150+
instance Pg.FromRow (Maybe Project) where
151+
fromRow = runEagerMaybe $ Project
152+
<$> EagerMaybeT Pg.field <*> EagerMaybeT Pg.field
153+
<*> EagerMaybeT Pg.field <*> EagerMaybeT Pg.field
154+
<*> EagerMaybeT Pg.field <*> EagerMaybeT Pg.field
155+
<*> EagerMaybeT Pg.field
143156

144157
$(A.deriveJSON A.options ''TShirtSize)
145158
$(A.deriveJSON A.options ''Region)
146159
$(A.deriveJSON A.options ''Occupation)
147-
$(A.deriveJSON A.options ''ContributorLevel)
148160
$(A.deriveJSON A.options ''RegistrationState)
149-
$(A.deriveJSON A.options ''Registration)

‎lib/Zureg/Form.hs

+24-15
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,8 @@
33
{-# LANGUAGE OverloadedStrings #-}
44
{-# LANGUAGE RecordWildCards #-}
55
module Zureg.Form
6-
( registerForm
6+
( ProjectForm (..)
7+
, registerForm
78
, registerView
89

910
, cancelForm
@@ -23,9 +24,18 @@ import Zureg.Database.Models
2324
import qualified Zureg.Hackathon as Hackathon
2425
import Zureg.Hackathon (Hackathon)
2526

27+
data ProjectForm = ProjectForm
28+
{ pfName :: Maybe T.Text
29+
, pfLink :: Maybe T.Text
30+
, pfShortDescription :: Maybe T.Text
31+
, pfContributorLevelBeginner :: !Bool
32+
, pfContributorLevelIntermediate :: !Bool
33+
, pfContributorLevelAdvanced :: !Bool
34+
} deriving (Eq, Show)
35+
2636
-- | The 'IO' in this type signature is because we want to get the registration
2737
-- time.
28-
registerForm :: Monad m => D.Form H.Html m (InsertRegistration, Maybe Project)
38+
registerForm :: Monad m => D.Form H.Html m (InsertRegistration, Maybe ProjectForm)
2939
registerForm = (,)
3040
<$> ("registration" D..: (InsertRegistration
3141
<$> "name" D..: (D.check "Name is required"
@@ -53,14 +63,13 @@ registerForm = (,)
5363
]
5464
(Just Nothing)
5565
<*> ("beginnerTrackInterest" D..: D.bool Nothing)))
56-
<*> ("project" D..: (fmap guardProject $ Project
66+
<*> ("project" D..: (fmap guardProject $ ProjectForm
5767
<$> "name" D..: optionalText
5868
<*> "website" D..: optionalText
5969
<*> "description" D..: optionalText
60-
<*> ("contributorLevel" D..: (ContributorLevel
61-
<$> "beginner" D..: D.bool Nothing
62-
<*> "intermediate" D..: D.bool Nothing
63-
<*> "advanced" D..: D.bool Nothing))))
70+
<*> "contributorLevelBeginner" D..: D.bool Nothing
71+
<*> "contributorLevelIntermediate" D..: D.bool Nothing
72+
<*> "contributorLevelAdvanced" D..: D.bool Nothing))
6473
where
6574
simpleEmailCheck = D.check "Invalid email address" $ \email ->
6675
case T.split (== '@') email of
@@ -76,8 +85,8 @@ registerForm = (,)
7685
(D.text Nothing)
7786

7887
guardProject p
79-
| isNothing (pName p) && isNothing (pShortDescription p) = Nothing
80-
| otherwise = Just p
88+
| isNothing (pfName p) && isNothing (pfShortDescription p) = Nothing
89+
| otherwise = Just p
8190

8291
registerView :: Hackathon -> Captcha.ClientHtml -> D.View H.Html -> H.Html
8392
registerView h captchaHtml view = DH.form view "?" $ do
@@ -167,14 +176,14 @@ registerView h captchaHtml view = DH.form view "?" $ do
167176
DH.label "project.description" view "Project description"
168177
DH.inputText "project.description" view
169178
H.p "Recommended contributor level(s)"
170-
DH.inputCheckbox "project.contributorLevel.beginner" view H.! A.class_ "checkbox"
171-
DH.label "project.contributorLevel.beginner" view $ "Beginner"
179+
DH.inputCheckbox "project.contributorLevelBeginner" view H.! A.class_ "checkbox"
180+
DH.label "project.contributorLevelBeginner" view $ "Beginner"
172181
H.br
173-
DH.inputCheckbox "project.contributorLevel.intermediate" view H.! A.class_ "checkbox"
174-
DH.label "project.contributorLevel.intermediate" view $ "Intermediate"
182+
DH.inputCheckbox "project.contributorLevelIntermediate" view H.! A.class_ "checkbox"
183+
DH.label "project.contributorLevelIntermediate" view $ "Intermediate"
175184
H.br
176-
DH.inputCheckbox "project.contributorLevel.advanced" view H.! A.class_ "checkbox"
177-
DH.label "project.contributorLevel.advanced" view $ "Advanced"
185+
DH.inputCheckbox "project.contributorLevelAdvanced" view H.! A.class_ "checkbox"
186+
DH.label "project.contributorLevelAdvanced" view $ "Advanced"
178187

179188
H.h2 $ "Captcha (sorry)"
180189
Captcha.chForm captchaHtml

‎lib/Zureg/Main/Badges.hs

+8-5
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import qualified Data.Aeson as A
1111
import Data.Char (toLower)
1212
import Data.Foldable (for_)
1313
import Data.List (sortOn)
14-
import Data.Maybe (mapMaybe)
14+
import Data.Maybe (fromMaybe, mapMaybe)
1515
import qualified Data.Text as T
1616
import System.Environment (getArgs, getProgName)
1717
import System.Exit (exitFailure)
@@ -21,14 +21,17 @@ import qualified Text.Blaze.Html5 as H
2121
import qualified Text.Blaze.Html5.Attributes as HA
2222
import Text.Read (readMaybe)
2323
import Zureg.Database.Models
24+
import Zureg.Main.Export hiding (main)
2425

2526
newtype Badge = Badge {unBadge :: String}
2627

27-
registrantToBadge :: Registration -> Maybe Badge
28+
registrantToBadge :: ExportRegistration -> Maybe Badge
2829
registrantToBadge r
29-
| rState r `elem` [Confirmed, Registered] =
30-
Just . Badge . T.unpack $ rName r
30+
| erState r `elem` [Confirmed, Registered] = Just $ Badge $
31+
T.unpack $ fromMaybe (erName registrant) (erBadgeName registrant)
3132
| otherwise = Nothing
33+
where
34+
registrant = erRegistrant r
3235

3336
-- | For 2023, we used 21 70mm 42.4mm
3437
data Options = Options
@@ -98,7 +101,7 @@ main = do
98101
}
99102
registrantsOrError <- A.eitherDecodeFileStrict exportPath
100103
registrants <- either (fail . show) return registrantsOrError
101-
:: IO [Registration]
104+
:: IO [ExportRegistration]
102105
putStrLn $ H.renderHtml $ renderBadges options $
103106
sortOn (map toLower . unBadge) $
104107
mapMaybe registrantToBadge registrants

‎lib/Zureg/Main/Email.hs

+8-7
Original file line numberDiff line numberDiff line change
@@ -17,8 +17,8 @@ import System.Exit (exitFailure)
1717
import qualified System.IO as IO
1818
import qualified Text.Mustache as Mustache
1919
import qualified Zureg.Config as Config
20-
import Zureg.Database.Models
2120
import qualified Zureg.Hackathon as Hackathon
21+
import Zureg.Main.Export hiding (main)
2222
import qualified Zureg.SendEmail as SendEmail
2323

2424
withStateFile
@@ -52,9 +52,9 @@ main = do
5252

5353
registrantsOrError <- A.eitherDecodeFileStrict exportPath
5454
registrants <- either (fail . show) return registrantsOrError
55-
:: IO [Registration]
55+
:: IO [ExportRegistration]
5656

57-
let prepare :: Registration -> IO T.Text
57+
let prepare :: ExportRegistration -> IO T.Text
5858
prepare registrant = do
5959
let (errs, t) = Mustache.checkedSubstitute
6060
template (A.toJSON registrant)
@@ -70,13 +70,14 @@ main = do
7070
withStateFile statefile $ \done append ->
7171
SendEmail.withHandle configAws $ \sendEmail ->
7272
forM_ registrants $ \registrant -> do
73-
when (not (rEmail registrant `HS.member` done)) $ do
73+
let to = erEmail $ erRegistrant registrant
74+
when (not (to `HS.member` done)) $ do
7475
IO.hPutStrLn IO.stderr $
75-
"Mailing " ++ T.unpack (rEmail registrant) ++ "..."
76+
"Mailing " ++ T.unpack to ++ "..."
7677
t <- prepare registrant
7778
SendEmail.sendEmail sendEmail
78-
emailFrom (rEmail registrant) (T.pack subject) t
79-
append (rEmail registrant)
79+
emailFrom to (T.pack subject) t
80+
append to
8081

8182
_ -> do
8283
IO.hPutStr IO.stderr $ unlines

0 commit comments

Comments
 (0)