Compare commits

..

No commits in common. "7f64d8f9268c520cf2432d263c5de6a67260ebfb" and "8cda69d30d3316f5af7ebd3b50f52b55cd345a31" have entirely different histories.

3 changed files with 19 additions and 50 deletions

View File

@ -31,7 +31,7 @@ import Database.Persist (Entity, entityVal, entityKey, get, (=.))
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Datarekisteri.Backend.DB import Datarekisteri.Backend.DB
import Datarekisteri.Backend.DB.Queries import Datarekisteri.Backend.DB.Queries
import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail) import Datarekisteri.Backend.Email (sendVerificationEmail)
import Datarekisteri.Backend.Types import Datarekisteri.Backend.Types
import Datarekisteri.Backend.Utils import Datarekisteri.Backend.Utils
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64) import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
@ -143,7 +143,7 @@ sendVerificationSecret email = void $ do
maybeDBEmail <- runQuery $ get email maybeDBEmail <- runQuery $ get email
let email = dBEmailEmail <$> maybeDBEmail let email = dBEmailEmail <$> maybeDBEmail
secret = dBEmailVerificationSecret =<< maybeDBEmail secret = dBEmailVerificationSecret =<< maybeDBEmail
args = (,) <$> secret <*> email args = (,) <$> email <*> secret
maybe (pure ()) (uncurry sendVerificationEmail) args maybe (pure ()) (uncurry sendVerificationEmail) args
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) => updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m) =>
@ -193,25 +193,15 @@ makeNewKey (KeyData {..}) user = do
, dBKeyIsPrimaryEncryptionKey = True , dBKeyIsPrimaryEncryptionKey = True
} }
acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit acceptApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
acceptApplication user = void $ do acceptApplication user = void $ do
maybeEmail <- getUserEmail user
case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do
time <- currentTime time <- currentTime
markAsAccepted user time markAsAccepted user time
void $ sendApplicationAcceptedEmail $ dBEmailEmail $ entityVal email
rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit rejectApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit
rejectApplication user = void $ do rejectApplication user = void $ do
maybeEmail <- getUserEmail user
case maybeEmail of
Nothing -> throwError $ "No valid application for " <> show user <> "!"
Just email -> do
time <- currentTime time <- currentTime
markAsRejected user time markAsRejected user time
void $ sendApplicationRejectedEmail $ dBEmailEmail $ entityVal email
resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
resolveQuery = Query resolveQuery = Query

View File

@ -8,22 +8,11 @@ import Data.Text.Lazy (fromStrict)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Network.Mail.Mime import Network.Mail.Mime
sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m () sendVerificationEmail :: MonadEmail m => Email -> Text -> m ()
sendDatarekisteriEmail subject content to = do sendVerificationEmail to secret = do
from <- fromAddress from <- fromAddress
sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from subject $ fromStrict content sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from
"Sähköpostin vahvistuskoodi" $ fromStrict $
sendVerificationEmail :: MonadEmail m => Text -> Email -> m ()
sendVerificationEmail secret = sendDatarekisteriEmail "Sähköpostin vahvistuskoodi" $
"Vahvista sähköpostisi syöttämällä alla oleva koodi rekisteriin:\n\n" "Vahvista sähköpostisi syöttämällä alla oleva koodi rekisteriin:\n\n"
<> secret <> "\n\n" <> secret <> "\n\n"
<> "Mikäli et odottanut tätä viestiä, voit jättää sen turvallisesti huomiotta." <> "Mikäli et odottanut tätä viestiä, voit jättää sen turvallisesti huomiotta."
sendApplicationAcceptedEmail :: MonadEmail m => Email -> m ()
sendApplicationAcceptedEmail = sendDatarekisteriEmail "Jäsenhakemus hyväksytty" $
"Jäsenhakemuksesi Datat RY:lle on hyväksytty. Olet nyt yhdistyksen jäsen."
sendApplicationRejectedEmail :: MonadEmail m => Email -> m ()
sendApplicationRejectedEmail = sendDatarekisteriEmail "Jäsenhakemus hylätty" $
"Jäsenhakemuksesi Datat RY:lle on hylätty. Voit halutessasi kysyä hakemuksen"
<> " hylkäämisen syistä yhdistyksen hallitukselta <hallitus@datat.fi>."

View File

@ -19,7 +19,6 @@ import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.FormFields import Datarekisteri.Frontend.FormFields
import Data.Morpheus.Client import Data.Morpheus.Client
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Data.Maybe (fromJust)
import Yesod hiding (emailField) import Yesod hiding (emailField)
import Yesod.Auth import Yesod.Auth
@ -34,7 +33,6 @@ query ProfilePage($id: UserID) {
homeplace homeplace
birthdate birthdate
phoneNumber phoneNumber
isMember
} }
permissions permissions
} }
@ -94,18 +92,14 @@ profileForm userID user extraHtml = do
|] |]
return (profileUpdateRes, widget) return (profileUpdateRes, widget)
profile :: ProfilePageUser -> (Widget, Enctype) -> (Widget, Enctype) -> Widget profile :: UserID -> (Widget, Enctype) -> (Widget, Enctype) -> Widget
profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do
setTitle "Muokkaa profiilia" setTitle "Muokkaa profiilia"
let userID = let ProfilePageUser {..} = user in id passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR user) True
passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
[whamlet| [whamlet|
<h1> <h1>
$if isMember user Omat tiedot
Jäsentiedot <form action="@{ProfileR user}" method="post" enctype="#{profileEnctype}">
$else
Jäsenhakemuksen tiedot
<form action="@{ProfileR userID}" method="post" enctype="#{profileEnctype}">
^{profileWidget} ^{profileWidget}
<input type="submit" value="Päivitä tiedot"> <input type="submit" value="Päivitä tiedot">
$maybe route <- passwordRoute $maybe route <- passwordRoute
@ -120,7 +114,7 @@ getProfile userID = do
passwordForm <- liftHandler $ generateFormPost passwordForm passwordForm <- liftHandler $ generateFormPost passwordForm
profileForm <- liftHandler $ generateFormPost $ profileForm <- liftHandler $ generateFormPost $
profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user
defaultLayout $ profile (fromJust user) defaultLayout $ profile ((\x -> let ProfilePageUser {..} = x in id) $ fromJust user)
profileForm passwordForm profileForm passwordForm
where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user" where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
@ -137,9 +131,7 @@ postProfileR userID = do
FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID) FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
_ -> do _ -> do
passwordForm <- liftHandler $ generateFormPost passwordForm passwordForm <- liftHandler $ generateFormPost passwordForm
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID}) defaultLayout $ profile userID (widget, enctype) passwordForm
defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm
--- XXX fromJust explodes if the user no longer exists
postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
postUpdatePasswordR userID = do postUpdatePasswordR userID = do
@ -149,6 +141,4 @@ postUpdatePasswordR userID = do
apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID) apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
_ -> do _ -> do
profileForm <- liftHandler $ generateFormPost $ profileForm (Just userID) Nothing profileForm <- liftHandler $ generateFormPost $ profileForm (Just userID) Nothing
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID}) defaultLayout $ profile userID profileForm (widget, enctype)
defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
--- XXX fromJust explodes if the user no longer exists