Skip to content

Commit 1fd6662

Browse files
jaspervdjjaspervdj
committed
Make it compile
1 parent 192b695 commit 1fd6662

File tree

8 files changed

+81
-92
lines changed

8 files changed

+81
-92
lines changed

‎lib/Zureg/Captcha/HCaptcha.hs

+4-1
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ module Zureg.Captcha.HCaptcha
66
( module Zureg.Captcha
77
, Config (..)
88
, configFromEnv
9-
, new
9+
, withHandle
1010
) where
1111

1212
import Control.Exception (throwIO)
@@ -64,6 +64,9 @@ new Config {..} = pure Handle
6464
bail = throwIO $ VerificationFailed []
6565
paramName = "h-captcha-response" :: String
6666

67+
withHandle :: Config -> (Handle -> IO a) -> IO a
68+
withHandle cfg f = new cfg >>= f
69+
6770
data ApiResponse = ApiResponse
6871
{ arSuccess :: !Bool
6972
, _arHostname :: !T.Text

‎lib/Zureg/Database.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -92,8 +92,8 @@ putRegistrantsSummary _ _ = pure ()
9292
lookupRegistrantsSummary :: Handle -> IO RegistrantsSummary
9393
lookupRegistrantsSummary _ = undefined
9494

95-
insertRegistration :: Handle -> UUID -> InsertRegistration -> IO Registration
96-
insertRegistration _ _ _ = undefined
95+
insertRegistration :: Handle -> InsertRegistration -> IO Registration
96+
insertRegistration _ _ = undefined
9797

9898
setRegistrationState :: Handle -> UUID -> RegistrationState -> IO Registration
9999
setRegistrationState _ _ _ = undefined

‎lib/Zureg/Main/PopWaitlist.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ popWaitinglistUUIDs dbConfig hackathon uuids =
3030
registrant <- Database.setRegistrationState db uuid Registered
3131
IO.hPutStrLn IO.stderr $
3232
"Mailing " ++ T.unpack (rEmail registrant) ++ "..."
33-
sendPopWaitlistEmail mailer hackathon registrant uuid
33+
sendPopWaitlistEmail mailer hackathon registrant
3434
IO.hPutStrLn IO.stderr "OK"
3535

3636
main :: Hackathon -> IO ()

‎lib/Zureg/Main/Web.hs

+56-45
Original file line numberDiff line numberDiff line change
@@ -7,90 +7,100 @@ module Zureg.Main.Web
77
, app
88
) where
99

10-
import Control.Applicative (liftA2)
11-
import Control.Exception (throwIO)
12-
import Control.Monad (join, unless, when)
13-
import qualified Data.Aeson as A
14-
import Data.Maybe (isNothing)
15-
import qualified Data.Text as T
16-
import qualified Data.Text.Encoding as T
17-
import qualified Data.Text.Lazy.Encoding as TL
18-
import qualified Data.Time as Time
19-
import Data.UUID (UUID)
20-
import qualified Data.UUID as UUID
21-
import qualified Data.UUID.V4 as UUID
22-
import qualified Network.HTTP.Client as Http
23-
import qualified Network.HTTP.Client.TLS as Http
24-
import qualified Network.HTTP.Types as Http
25-
import qualified Network.Wai as Wai
26-
import qualified Network.Wai.Handler.Warp as Warp
27-
import qualified Text.Digestive as D
28-
import qualified Zureg.Captcha as Captcha
29-
import qualified Zureg.Database as Database
10+
import Control.Applicative (liftA2)
11+
import Control.Exception (throwIO)
12+
import Control.Monad (join, unless, void, when)
13+
import qualified Data.Aeson as A
14+
import Data.Maybe (isNothing)
15+
import qualified Data.Text as T
16+
import qualified Data.Text.Encoding as T
17+
import qualified Data.Text.Lazy.Encoding as TL
18+
import qualified Data.Time as Time
19+
import Data.UUID (UUID)
20+
import qualified Data.UUID as UUID
21+
import qualified Data.UUID.V4 as UUID
22+
import qualified Network.HTTP.Client as Http
23+
import qualified Network.HTTP.Client.TLS as Http
24+
import qualified Network.HTTP.Types as Http
25+
import qualified Network.Wai as Wai
26+
import qualified Network.Wai.Handler.Warp as Warp
27+
import qualified Text.Digestive as D
28+
import qualified Zureg.Captcha as Captcha
29+
import qualified Zureg.Captcha.HCaptcha as HCaptcha
30+
import qualified Zureg.Database as Database
3031
import Zureg.Database.Models
3132
import Zureg.Form
33+
import qualified Zureg.Hackathon as Hackathon
34+
import Zureg.Hackathon (Hackathon)
3235
import qualified Zureg.Hackathon.ZuriHac2020.Discord as Discord
33-
import qualified Zureg.Hackathon as Hackathon
34-
import Zureg.Hackathon (Hackathon)
3536
import Zureg.Http
36-
import qualified Zureg.SendEmail as SendEmail
37+
import qualified Zureg.SendEmail as SendEmail
3738
import Zureg.SendEmail.Hardcoded
38-
import qualified Zureg.Views as Views
39+
import qualified Zureg.Views as Views
3940

40-
main :: forall a. (A.FromJSON a, A.ToJSON a) => Hackathon a -> IO ()
41+
main :: Hackathon -> IO ()
4142
main hackathon = do
42-
dbConfig <- Database.configFromEnv
43+
db <- Database.configFromEnv
4344
discord <- Discord.configFromEnv
44-
app dbConfig hackathon >>= Warp.run 8000
45+
hcaptcha <- HCaptcha.configFromEnv
46+
app db discord hcaptcha hackathon >>= Warp.run 8000
4547

4648
app
4749
:: Database.Config
4850
-> Discord.Config
51+
-> HCaptcha.Config -- ^ TODO: generic captcha config?
4952
-> Hackathon
5053
-> IO Wai.Application
51-
app dbConfig discord hackathon =
54+
app dbConfig discord hcaptchaConfig hackathon =
5255
fmap httpExceptionMiddleware $
5356
Http.newManager Http.tlsManagerSettings >>= \httpManager ->
5457
Database.withHandle dbConfig $ \db ->
55-
SendEmail.withHandle (Hackathon.sendEmailConfig hackathon) $ \sendEmail ->
58+
SendEmail.withHandle $ \sendEmail ->
59+
HCaptcha.withHandle hcaptchaConfig $ \captcha ->
5660
pure $ \req respond -> case Wai.pathInfo req of
5761
["register"] -> do
5862
reqBody <- TL.decodeUtf8 <$> Wai.strictRequestBody req
5963
when (Wai.requestMethod req == Http.methodPost) $ Captcha.verify
60-
(Hackathon.captcha hackathon)
64+
captcha
6165
httpManager
6266
(Just reqBody)
6367
(view, mbReg) <- runForm req reqBody "register" $ D.checkM
6468
"Email address already registered"
65-
(fmap isNothing . Database.lookupEmail db . riEmail . fst)
66-
(liftA2 (,)
67-
(registerForm hackathon)
68-
(Hackathon.registerForm hackathon))
69+
(fmap isNothing . Database.lookupEmail db . irEmail)
70+
registerForm
6971
case mbReg of
7072
Nothing -> respond . html $ Views.register
7173
hackathon
72-
(Captcha.clientHtml $ Hackathon.captcha hackathon)
74+
(Captcha.clientHtml captcha)
7375
view
74-
Just (info, additionalInfo) -> do
76+
Just insert -> do
77+
-- TODO: transaction this
7578
registrantsSummary <- Database.lookupRegistrantsSummary db
7679
let atCapacity = Database.rsAvailable registrantsSummary <= 0
7780
if atCapacity then do
7881
-- You're on the waitlist
7982
uuid <- UUID.nextRandom
83+
{-
8084
time <- Time.getCurrentTime
8185
let wlinfo = WaitlistInfo time
8286
Database.writeEvents db uuid
8387
[Register info additionalInfo, Waitlist wlinfo]
8488
Database.putEmail db (riEmail info) uuid
85-
sendWaitlistEmail sendEmail hackathon info uuid
86-
respond . html $ Views.registerWaitlist uuid info
89+
-}
90+
registrant <- Database.insertRegistration db insert
91+
let uuid = rUuid registrant
92+
registrant' <- Database.setRegistrationState db uuid
93+
Waitlisted
94+
sendWaitlistEmail sendEmail hackathon registrant'
95+
respond . html $ Views.registerWaitlist registrant'
8796
else do
8897
-- Success registration
89-
uuid <- UUID.nextRandom
90-
Database.writeEvents db uuid [Register info additionalInfo]
91-
Database.putEmail db (riEmail info) uuid
92-
sendRegisterSuccessEmail sendEmail hackathon info uuid
93-
respond . html $ Views.registerSuccess uuid info
98+
registrant <- Database.insertRegistration db insert
99+
let uuid = rUuid registrant
100+
registrant' <- Database.setRegistrationState db uuid
101+
Registered
102+
sendRegisterSuccessEmail sendEmail hackathon registrant'
103+
respond . html $ Views.registerSuccess registrant'
94104

95105
["ticket"] | Wai.requestMethod req == Http.methodGet -> do
96106
uuid <- getUuidParam req
@@ -125,8 +135,9 @@ app dbConfig discord hackathon =
125135
uuid <- getUuidParam req
126136
registrant <- Database.getRegistrant db uuid
127137
case rState registrant of
128-
Just Registered -> Database.setRegistrationState db uuid Confirmed
129-
_ -> return ()
138+
Registered -> void $
139+
Database.setRegistrationState db uuid Confirmed
140+
_ -> pure ()
130141
respond . redirect $ "ticket?uuid=" <> UUID.toText uuid
131142

132143
["cancel"] -> do

‎lib/Zureg/SendEmail/Hardcoded.hs

+9-10
Original file line numberDiff line numberDiff line change
@@ -8,15 +8,14 @@ module Zureg.SendEmail.Hardcoded
88
) where
99

1010
import qualified Data.Text as T
11-
import Data.UUID (UUID)
1211
import qualified Data.UUID as UUID
1312
import Zureg.Database.Models
1413
import Zureg.Hackathon
1514
import qualified Zureg.SendEmail as SendEmail
1615

1716
sendRegisterSuccessEmail
18-
:: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
19-
sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
17+
:: SendEmail.Handle -> Hackathon -> Registration -> IO ()
18+
sendRegisterSuccessEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
2019
sendEmail
2120
emailFrom
2221
(rEmail info)
@@ -29,7 +28,7 @@ sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmai
2928
, ""
3029
, "You can view your registration and join our chat here:"
3130
, ""
32-
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
31+
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
3332
, ""
3433
, "If you have any concerns, you can find our contact info here:"
3534
, ""
@@ -41,8 +40,8 @@ sendRegisterSuccessEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmai
4140
]
4241

4342
sendWaitlistEmail
44-
:: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
45-
sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
43+
:: SendEmail.Handle -> Hackathon -> Registration -> IO ()
44+
sendWaitlistEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
4645
sendEmail
4746
emailFrom
4847
(rEmail info)
@@ -55,7 +54,7 @@ sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
5554
, ""
5655
, "You can view your status here:"
5756
, ""
58-
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
57+
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
5958
, ""
6059
, "If you have any concerns, you can find our contact info here:"
6160
, ""
@@ -66,8 +65,8 @@ sendWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
6665
]
6766

6867
sendPopWaitlistEmail
69-
:: SendEmail.Handle -> Hackathon -> Registration -> UUID -> IO ()
70-
sendPopWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
68+
:: SendEmail.Handle -> Hackathon -> Registration -> IO ()
69+
sendPopWaitlistEmail sendEmail Hackathon {..} info = SendEmail.sendEmail
7170
sendEmail
7271
emailFrom
7372
(rEmail info)
@@ -80,7 +79,7 @@ sendPopWaitlistEmail sendEmail Hackathon {..} info uuid = SendEmail.sendEmail
8079
, ""
8180
, "You can view your registration and join our chat here:"
8281
, ""
83-
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText uuid
82+
, " " <> baseUrl <> "/ticket?uuid=" <> UUID.toText (rUuid info)
8483
, ""
8584
, "If you have any concerns, you can find our contact info here:"
8685
, ""

‎lib/Zureg/Views.hs

+8-8
Original file line numberDiff line numberDiff line change
@@ -98,18 +98,18 @@ register hackathon captchaHtml view =
9898
template (Captcha.chScript captchaHtml) $
9999
Form.registerView hackathon captchaHtml view
100100

101-
registerSuccess :: UUID -> InsertRegistration -> H.Html
102-
registerSuccess _uuid InsertRegistration {..} = template mempty $ do
101+
registerSuccess :: Registration -> H.Html
102+
registerSuccess Registration {..} = template mempty $ do
103103
H.h1 "Registration successful"
104-
H.p $ H.toHtml irName <> ", your registration was successful."
105-
H.p $ "You will receive a confirmation mail at " <> H.toHtml irEmail <>
104+
H.p $ H.toHtml rName <> ", your registration was successful."
105+
H.p $ "You will receive a confirmation mail at " <> H.toHtml rEmail <>
106106
" soon."
107107

108-
registerWaitlist :: UUID -> InsertRegistration -> H.Html
109-
registerWaitlist _uuid InsertRegistration {..} = template mempty $ do
108+
registerWaitlist :: Registration -> H.Html
109+
registerWaitlist Registration {..} = template mempty $ do
110110
H.h1 "You are now on the waitlist"
111-
H.p $ H.toHtml irName <> ", your have been added to the waitlist."
112-
H.p $ "You will receive an email at " <> H.toHtml irEmail <> " soon."
111+
H.p $ H.toHtml rName <> ", your have been added to the waitlist."
112+
H.p $ "You will receive an email at " <> H.toHtml rEmail <> " soon."
113113

114114
ticket :: Hackathon -> Registration -> H.Html
115115
ticket hackathon registration@Registration {..} = template

‎src/Lambda.hs

-17
This file was deleted.

‎zureg.cabal

+1-8
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,7 @@ Library
7272
digestive-functors-blaze >= 0.6 && < 0.7,
7373
directory >= 1.3 && < 1.4,
7474
file-embed >= 0.0 && < 0.1,
75-
filepath >= 1.4 && < 1.5,
75+
filepath >= 1.4 && < 1.6,
7676
http-client >= 0.5 && < 0.8,
7777
http-client-tls >= 0.3 && < 0.4,
7878
http-types >= 0.12 && < 0.13,
@@ -128,10 +128,3 @@ Executable zureg-badges
128128
Executable zureg-janitor
129129
Import: exe
130130
Main-is: Janitor.hs
131-
132-
Executable zureg-lambda
133-
Import: exe
134-
Main-is: Lambda.hs
135-
Build-depends:
136-
hal >= 1.0 && < 1.1,
137-
wai-handler-hal >= 0.3 && < 0.5

0 commit comments

Comments
 (0)