Compare commits
3 Commits
8cda69d30d
...
7f64d8f926
Author | SHA1 | Date |
---|---|---|
Saku Laesvuori | 7f64d8f926 | |
Saku Laesvuori | fb69b58f92 | |
Saku Laesvuori | 49536ad05b |
|
@ -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
|
||||||
|
|
|
@ -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>."
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue