yammat/Handler/NewUser.hs

--  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/>.
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.NewUser where

import Import as I
import Handler.Common
import Text.Shakespeare.Text

getNewUserR :: Handler Html
getNewUserR = do
  settings <- getsYesod appSettings
  if appUserCreationBlocked settings
  then do
    setMessageI MsgCreationBlocked
    redirect HomeR
  else do
    today <- liftIO $ return . utctDay =<< getCurrentTime
    (newUserWidget, enctype) <- generateFormPost
      $ renderBootstrap3 BootstrapBasicForm
      $ newUserForm today
    defaultLayout $ do
      setTitleI MsgNewUser
      $(widgetFile "newUser")

postNewUserR :: Handler Html
postNewUserR = do
  settings <- getsYesod appSettings
  if appUserCreationBlocked settings
  then do
    setMessageI MsgCreationBlocked
    redirect HomeR
  else do
    today <- liftIO $ return . utctDay =<< getCurrentTime
    ((res, _), _) <- runFormPost
      $ renderBootstrap3 BootstrapBasicForm
      $ newUserForm today
    case res of
      FormSuccess user -> do
        namesakes <- runDB $ selectList [UserIdent ==. userIdent user] []
        if null namesakes
          then do
            runDB $ insert_ user
            setMessageI MsgUserCreated
            redirect HomeR
          else do
            setMessageI MsgUserIdentNotUnique
            redirect NewUserR
      _ -> do
        setMessageI MsgUserNotCreated
        redirect NewUserR

newUserForm :: Day -> AForm Handler User
newUserForm today = User
  <$> areq textField (bfs MsgName) Nothing
  <*> pure 0
  <*> pure today
  <*> aopt emailField (bfs MsgEmailNotify) Nothing
  <*> aopt (selectField avatars) (bfs MsgSelectAvatar) Nothing
  <*> aopt passwordField (bfs MsgUserPin) Nothing
  <*  bootstrapSubmit (msgToBSSubmit MsgSubmit)
  where
    avatars = do
      ents <- runDB $ selectList [] [Asc AvatarIdent]
      optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents

data UserConf = UserConf
  { userConfIdent :: Text
  , userConfEmail :: Maybe Text
  , userConfAvatar :: Maybe AvatarId
  , userConfBarcode :: Maybe [Text]
  , userConfPIN :: Maybe Text
  }

getModifyUserR :: UserId -> Handler Html
getModifyUserR uId =
  isUser uId HomeR >>= (\user -> do
    p <- lookupGetParam "barcode"
    _ <- handleGetParam p (Left uId)
    rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
    let bs = map (barcodeCode . entityVal) rawbs
    (modifyUserWidget, enctype) <- generateFormPost
      $ renderBootstrap3 BootstrapBasicForm
      $ modifyUserForm user bs
    defaultLayout $ do
      setTitleI (MsgModifyUser (userIdent user))
      $(widgetFile "modifyUser")
  )

postModifyUserR :: UserId -> Handler Html
postModifyUserR uId =
  isUser uId HomeR >>= (\user -> do
    rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
    let bs = map (barcodeCode . entityVal) rawbs
    ((res, _), _) <- runFormPost
      $ renderBootstrap3 BootstrapBasicForm
      $ modifyUserForm user bs
    case res of
      FormSuccess uc -> do
        namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] []
        if null namesakes
          then do
            runDB $ update uId
              [ UserIdent =. userConfIdent uc
              , UserEmail =. userConfEmail uc
              , UserAvatar =. userConfAvatar uc
              , UserPin =. userConfPIN uc
              ]
            master <- getYesod
            liftIO $ notify user (userConfEmail uc) master
            handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc)
            setMessageI MsgUserEdited
            redirect $ SelectR uId
          else do
            setMessageI MsgUserIdentNotUnique
            redirect $ ModifyUserR uId
      _ -> do
        setMessageI MsgUserNotEdited
        redirect $ SelectR uId
  )

modifyUserForm :: User -> [Text] -> AForm Handler UserConf
modifyUserForm user bs = UserConf
  <$> areq textField (bfs MsgName) (Just $ userIdent user)
  <*> aopt emailField (bfs MsgEmailNotify) (Just $ userEmail user)
  <*> aopt (selectField avatars) (bfs MsgSelectAvatar) (Just $ userAvatar user)
  <*> aopt barcodeField (bfs MsgBarcodeField) (Just $ Just bs)
  <*> aopt passwordField (bfs MsgUserPin) Nothing
  <*  bootstrapSubmit (msgToBSSubmit MsgSubmit)
  where
    avatars = do
      ents <- runDB $ selectList [] [Asc AvatarIdent]
      optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents

notify :: User -> Maybe Text -> App -> IO ()
notify user email master
  | (userEmail user) == email = return ()
  | otherwise = case userEmail user of
    Just address ->
      sendMail master address "Profiländerung"
        [stext|
Hallo #{userIdent user},

deine Profileinstellungen wurden geändert.
Nur damit du Bescheid weißt.

Grüße,

der Matemat
        |]
    Nothing -> return ()