yammat/Handler/NewUser.hs

152 lines
5 KiB
Haskell
Raw Normal View History

2015-08-09 19:16:33 +00:00
-- yammat - Yet Another MateMAT
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-04-04 04:46:33 +00:00
module Handler.NewUser where
2015-04-07 20:03:21 +00:00
import Import as I
import Handler.Common
import Text.Shakespeare.Text
2015-04-04 04:46:33 +00:00
getNewUserR :: Handler Html
getNewUserR = do
2016-03-17 22:59:52 +00:00
today <- liftIO $ return . utctDay =<< getCurrentTime
2015-10-22 21:57:27 +00:00
(newUserWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
2016-03-17 22:59:52 +00:00
$ newUserForm today
2015-09-14 22:49:13 +00:00
defaultLayout $
2015-04-04 04:46:33 +00:00
$(widgetFile "newUser")
postNewUserR :: Handler Html
postNewUserR = do
2016-03-17 22:59:52 +00:00
today <- liftIO $ return . utctDay =<< getCurrentTime
2015-10-22 21:57:27 +00:00
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
2016-03-17 22:59:52 +00:00
$ newUserForm today
2015-04-04 04:46:33 +00:00
case res of
FormSuccess user -> do
2015-10-26 17:33:34 +00:00
namesakes <- runDB $ selectList [UserIdent ==. userIdent user] []
if null namesakes
then do
runDB $ insert_ user
setMessageI MsgUserCreated
redirect HomeR
else do
setMessageI MsgUserIdentNotUnique
redirect NewUserR
2015-04-04 04:46:33 +00:00
_ -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserNotCreated
2015-09-14 22:49:13 +00:00
redirect NewUserR
2015-04-04 04:46:33 +00:00
2016-03-17 22:59:52 +00:00
newUserForm :: Day -> AForm Handler User
newUserForm today = User
2015-10-22 21:57:27 +00:00
<$> areq textField (bfs MsgName) Nothing
2015-04-04 04:46:33 +00:00
<*> pure 0
2016-03-17 22:59:52 +00:00
<*> pure today
2015-10-22 21:57:27 +00:00
<*> aopt emailField (bfs MsgEmailNotify) Nothing
<*> aopt (selectField avatars) (bfs MsgSelectAvatar) Nothing
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
2015-04-16 00:12:03 +00:00
where
avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents
2015-04-07 20:03:21 +00:00
data UserConf = UserConf
2015-10-26 17:33:34 +00:00
{ userConfIdent :: Text
, userConfEmail :: Maybe Text
2015-04-16 00:51:08 +00:00
, userConfAvatar :: Maybe AvatarId
2015-07-21 07:14:38 +00:00
, userConfBarcode :: Maybe [Text]
2015-04-07 20:03:21 +00:00
}
getModifyUserR :: UserId -> Handler Html
getModifyUserR uId = do
mUser <- runDB $ I.get uId
case mUser of
Just user -> do
2015-07-21 07:14:38 +00:00
p <- lookupGetParam "barcode"
_ <- handleGetParam p (Left uId)
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
2015-09-14 22:49:13 +00:00
let bs = map (barcodeCode . entityVal) rawbs
2015-10-22 21:57:27 +00:00
(modifyUserWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ modifyUserForm user bs
2015-09-14 22:49:13 +00:00
defaultLayout $
2015-07-21 07:14:38 +00:00
$(widgetFile "modifyUser")
2015-04-07 20:03:21 +00:00
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserUnknown
2015-09-14 22:49:13 +00:00
redirect HomeR
2015-04-07 20:03:21 +00:00
postModifyUserR :: UserId -> Handler Html
postModifyUserR uId = do
mUser <- runDB $ I.get uId
case mUser of
Just user -> do
2015-07-21 07:14:38 +00:00
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
2015-09-14 22:49:13 +00:00
let bs = map (barcodeCode . entityVal) rawbs
2015-10-22 21:57:27 +00:00
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ modifyUserForm user bs
2015-04-07 20:03:21 +00:00
case res of
2015-04-16 00:51:08 +00:00
FormSuccess uc -> do
2015-11-03 22:32:28 +00:00
namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] []
2015-10-26 17:33:34 +00:00
if null namesakes
then do
runDB $ update uId
[ UserIdent =. userConfIdent uc
, UserEmail =. userConfEmail uc
, UserAvatar =. userConfAvatar uc
]
liftIO $ notify user (userConfEmail uc)
handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc)
setMessageI MsgUserEdited
redirect $ SelectR uId
else do
setMessageI MsgUserIdentNotUnique
redirect $ ModifyUserR uId
2015-04-07 20:03:21 +00:00
_ -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserNotEdited
2015-04-07 20:03:21 +00:00
redirect $ SelectR uId
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserUnknown
2015-09-14 22:49:13 +00:00
redirect HomeR
2015-04-07 20:03:21 +00:00
2015-10-22 21:57:27 +00:00
modifyUserForm :: User -> [Text] -> AForm Handler UserConf
modifyUserForm user bs = UserConf
2015-10-26 17:33:34 +00:00
<$> areq textField (bfs MsgName) (Just $ userIdent user)
<*> aopt emailField (bfs MsgEmailNotify) (Just $ userEmail user)
2015-10-22 21:57:27 +00:00
<*> aopt (selectField avatars) (bfs MsgSelectAvatar) (Just $ userAvatar user)
<*> aopt barcodeField (bfs MsgBarcodeField) (Just $ Just bs)
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
2015-04-16 00:51:08 +00:00
where
avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents
notify :: User -> Maybe Text -> IO ()
notify user email
| (userEmail user) == email = return ()
2015-04-09 21:18:47 +00:00
| otherwise = case userEmail user of
Just address -> sendMail address "Profiländerung"
2015-04-09 21:18:47 +00:00
[stext|
Hallo #{userIdent user},
deine Profileinstellungen wurden geändert.
Nur damit du Bescheid weißt.
Grüße,
der Matemat
2015-04-09 21:18:47 +00:00
|]
Nothing -> return ()