-- 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 . module Handler.NewUser where import Import as I import Handler.Common import Text.Read import Text.Shakespeare.Text getNewUserR :: Handler Html getNewUserR = do time <- liftIO getCurrentTime let secs = read $ formatTime defaultTimeLocale "%s" time (newUserWidget, enctype) <- generateFormPost $ newUserForm secs defaultLayout $ $(widgetFile "newUser") postNewUserR :: Handler Html postNewUserR = do time <- liftIO getCurrentTime let secs = read $ formatTime defaultTimeLocale "%s" time ((res, _), _) <- runFormPost $ newUserForm secs case res of FormSuccess user -> do runDB $ insert_ user setMessageI MsgUserCreated redirect HomeR _ -> do setMessageI MsgUserNotCreated redirect NewUserR newUserForm :: Int -> Form User newUserForm secs = renderDivs $ User <$> areq textField (fieldSettingsLabel MsgName) Nothing <*> pure 0 <*> pure secs <*> aopt emailField (fieldSettingsLabel MsgEmailNotify) Nothing <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) Nothing where avatars = do ents <- runDB $ selectList [] [Asc AvatarIdent] optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents data UserConf = UserConf { userConfEmail :: Maybe Text , userConfAvatar :: Maybe AvatarId , userConfBarcode :: Maybe [Text] } getModifyUserR :: UserId -> Handler Html getModifyUserR uId = do mUser <- runDB $ I.get uId case mUser of Just user -> do p <- lookupGetParam "barcode" _ <- handleGetParam p (Left uId) rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] let bs = map (barcodeCode . entityVal) rawbs (modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user bs defaultLayout $ $(widgetFile "modifyUser") Nothing -> do setMessageI MsgUserUnknown redirect HomeR postModifyUserR :: UserId -> Handler Html postModifyUserR uId = do mUser <- runDB $ I.get uId case mUser of Just user -> do rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] let bs = map (barcodeCode . entityVal) rawbs ((res, _), _) <- runFormPost $ modifyUserForm user bs case res of FormSuccess uc -> do runDB $ update uId [ UserEmail =. userConfEmail uc , UserAvatar =. userConfAvatar uc ] liftIO $ notify user (userConfEmail uc) handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) setMessageI MsgUserEdited redirect $ SelectR uId _ -> do setMessageI MsgUserNotEdited redirect $ SelectR uId Nothing -> do setMessageI MsgUserUnknown redirect HomeR modifyUserForm :: User -> [Text] -> Form UserConf modifyUserForm user bs = renderDivs $ UserConf <$> aopt emailField (fieldSettingsLabel MsgEmailNotify) (Just $ userEmail user) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ userAvatar user) <*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs) 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 () | otherwise = case userEmail user of Just address -> sendMail address "Profiländerung" [stext| Hallo #{userIdent user}, deine Profileinstellungen wurden geändert. Nur damit du Bescheid weißt. Grüße, der Matemat |] Nothing -> return ()