119 lines
4.7 KiB
Haskell
119 lines
4.7 KiB
Haskell
module Handler.Users.Add
|
|
( AuthenticationKind(..)
|
|
, classifyAuth, mkAuthMode
|
|
, AdminUserForm(..), adminUserForm
|
|
, getAdminUserAddR, postAdminUserAddR
|
|
) where
|
|
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Jobs
|
|
|
|
|
|
data AdminUserForm = AdminUserForm
|
|
{ aufTitle :: Maybe Text
|
|
, aufFirstName :: Text
|
|
, aufSurname :: UserSurname
|
|
, aufDisplayName :: UserDisplayName
|
|
, aufDisplayEmail :: UserEmail
|
|
, aufMatriculation :: Maybe UserMatriculation
|
|
, aufSex :: Maybe Sex
|
|
, aufEmail :: UserEmail
|
|
, aufIdent :: UserIdent
|
|
, aufAuth :: AuthenticationKind
|
|
}
|
|
|
|
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
instance Universe AuthenticationKind
|
|
instance Finite AuthenticationKind
|
|
embedRenderMessage ''UniWorX ''AuthenticationKind id
|
|
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
|
|
|
|
classifyAuth :: AuthenticationMode -> AuthenticationKind
|
|
classifyAuth AuthLDAP = AuthKindLDAP
|
|
classifyAuth AuthPWHash{} = AuthKindPWHash
|
|
|
|
mkAuthMode :: AuthenticationKind -> AuthenticationMode
|
|
mkAuthMode AuthKindLDAP = AuthLDAP
|
|
mkAuthMode AuthKindPWHash = AuthPWHash ""
|
|
|
|
adminUserForm :: Maybe AdminUserForm -> Form AdminUserForm
|
|
adminUserForm template = renderAForm FormStandard
|
|
$ AdminUserForm
|
|
<$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (aufTitle <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (aufFirstName <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (aufSurname <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template)
|
|
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template)
|
|
<*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> template)
|
|
<*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
|
|
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
|
|
|
|
|
|
getAdminUserAddR, postAdminUserAddR :: Handler Html
|
|
getAdminUserAddR = postAdminUserAddR
|
|
postAdminUserAddR = do
|
|
((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
|
|
|
|
formResult userRes $ \AdminUserForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
|
|
|
let
|
|
newUser@User{..} = User
|
|
{ userIdent = aufIdent
|
|
, userMaxFavourites = userDefaultMaxFavourites
|
|
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
|
, userTheme = userDefaultTheme
|
|
, userDateTimeFormat = userDefaultDateTimeFormat
|
|
, userDateFormat = userDefaultDateFormat
|
|
, userTimeFormat = userDefaultTimeFormat
|
|
, userDownloadFiles = userDefaultDownloadFiles
|
|
, userWarningDays = userDefaultWarningDays
|
|
, userShowSex = userDefaultShowSex
|
|
, userNotificationSettings = def
|
|
, userLanguages = Nothing
|
|
, userCsvOptions = def
|
|
, userTokensIssuedAfter = Nothing
|
|
, userCreated = now
|
|
, userLastLdapSynchronisation = Nothing
|
|
, userLdapPrimaryKey = Nothing
|
|
, userLastAuthentication = Nothing
|
|
, userEmail = aufEmail
|
|
, userDisplayName = aufDisplayName
|
|
, userDisplayEmail = aufDisplayEmail
|
|
, userFirstName = aufFirstName
|
|
, userSurname = aufSurname
|
|
, userTitle = aufTitle
|
|
, userSex = aufSex
|
|
, userMatrikelnummer = aufMatriculation
|
|
, userAuthentication = mkAuthMode aufAuth
|
|
}
|
|
|
|
didInsert <- runDBJobs . runMaybeT $ do
|
|
uid <- MaybeT $ insertUnique newUser
|
|
lift . queueDBJob $ JobSynchroniseLdapUser uid
|
|
lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
|
|
when (aufAuth == AuthKindPWHash) $
|
|
lift . queueDBJob $ JobSendPasswordReset uid
|
|
return uid
|
|
|
|
case didInsert of
|
|
Just uid -> do
|
|
addMessageI Success MsgUserAdded
|
|
cID <- encrypt uid
|
|
redirect $ AdminUserR cID
|
|
Nothing ->
|
|
addMessageI Error MsgUserCollision
|
|
|
|
siteLayoutMsg MsgHeadingUserAdd $ do
|
|
setTitleI MsgHeadingUserAdd
|
|
wrapForm userView def
|
|
{ formAction = Just $ SomeRoute AdminUserAddR
|
|
, formEncoding = userEnctype
|
|
}
|