Compare commits

..

3 Commits

3 changed files with 50 additions and 19 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) import Datarekisteri.Backend.Email (sendVerificationEmail, sendApplicationAcceptedEmail, sendApplicationRejectedEmail)
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 = (,) <$> email <*> secret args = (,) <$> secret <*> email
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,15 +193,25 @@ makeNewKey (KeyData {..}) user = do
, dBKeyIsPrimaryEncryptionKey = True , dBKeyIsPrimaryEncryptionKey = True
} }
acceptApplication :: (MonadDB m, MonadTime m) => UserID -> m Unit acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail 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) => UserID -> m Unit rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail 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,11 +8,22 @@ import Data.Text.Lazy (fromStrict)
import Datarekisteri.Core.Types import Datarekisteri.Core.Types
import Network.Mail.Mime import Network.Mail.Mime
sendVerificationEmail :: MonadEmail m => Email -> Text -> m () sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
sendVerificationEmail to secret = do sendDatarekisteriEmail subject content to = do
from <- fromAddress from <- fromAddress
sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from subject $ fromStrict content
"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,6 +19,7 @@ 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
@ -33,6 +34,7 @@ query ProfilePage($id: UserID) {
homeplace homeplace
birthdate birthdate
phoneNumber phoneNumber
isMember
} }
permissions permissions
} }
@ -92,14 +94,18 @@ profileForm userID user extraHtml = do
|] |]
return (profileUpdateRes, widget) return (profileUpdateRes, widget)
profile :: UserID -> (Widget, Enctype) -> (Widget, Enctype) -> Widget profile :: ProfilePageUser -> (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"
passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR user) True let userID = let ProfilePageUser {..} = user in id
passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
[whamlet| [whamlet|
<h1> <h1>
Omat tiedot $if isMember user
<form action="@{ProfileR user}" method="post" enctype="#{profileEnctype}"> Jäsentiedot
$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
@ -114,7 +120,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 ((\x -> let ProfilePageUser {..} = x in id) $ fromJust user) defaultLayout $ profile (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"
@ -131,7 +137,9 @@ 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
defaultLayout $ profile userID (widget, enctype) passwordForm ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
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
@ -141,4 +149,6 @@ 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
defaultLayout $ profile userID profileForm (widget, enctype) ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
--- XXX fromJust explodes if the user no longer exists