-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Users.Add
  ( getAdminUserAddR, postAdminUserAddR
  , AdminUserForm(..), AuthenticationKind(..)
  , addNewUser
  --, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere   
  ) 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
  , aufMobile    :: Maybe Text 
  , aufTelephone :: Maybe Text   
  , aufFPersonalNumber :: Maybe Text 
  , aufFDepartment     :: Maybe Text 
  , aufPostAddress     :: Maybe StoredMarkup
  , aufPrefersPostal   :: Bool
  , aufPinPassword     :: Maybe Text
  , aufEmail :: UserEmail
  , aufIdent :: UserIdent
  , aufAuth :: AuthenticationKind  
  }

data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite)
--instance Universe AuthenticationKind
--instance Finite AuthenticationKind
embedRenderMessage ''UniWorX ''AuthenticationKind id
nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2

{-
classifyAuth :: AuthenticationMode -> AuthenticationKind
classifyAuth AuthLDAP     = AuthKindLDAP
classifyAuth AuthPWHash{} = AuthKindPWHash
classifyAuth AuthNoLogin  = AuthKindNoLogin
-} 

mkAuthMode :: AuthenticationKind -> AuthenticationMode
mkAuthMode AuthKindLDAP     = AuthLDAP
mkAuthMode AuthKindPWHash   = AuthPWHash ""
mkAuthMode AuthKindNoLogin  = AuthNoLogin

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)
  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserMobile) (aufMobile <$> template)
  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserTelephone) (aufTelephone <$> template)  
  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template)
  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserFDepartment)     (aufFDepartment <$> template)
  <*> aopt htmlField                    (fslI MsgAdminUserPostAddress)     (aufPostAddress   <$> template) 
  <*> areq checkBoxField                (fslI MsgAdminUserPrefersPostal)   (aufPrefersPostal <$> template)
  <*> aopt (textField & cfStrip)        (fslI MsgAdminUserPinPassword)     (aufPinPassword <$> 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)
  
addNewUser :: AdminUserForm -> Handler (Maybe UserId)
addNewUser AdminUserForm{..} = do 
  now <- liftIO getCurrentTime
  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
  let 
    newUser = User
      { userIdent                   = aufIdent
      , userMaxFavourites           = userDefaultMaxFavourites
      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
      , userTheme                   = userDefaultTheme
      , userDateTimeFormat          = userDefaultDateTimeFormat
      , userDateFormat              = userDefaultDateFormat
      , userTimeFormat              = userDefaultTimeFormat
      , userDownloadFiles           = userDefaultDownloadFiles
      , userWarningDays             = userDefaultWarningDays
      , userShowSex                 = userDefaultShowSex
      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
      , userNotificationSettings    = def
      , userLanguages               = Nothing
      , userCsvOptions              = def
      , userTokensIssuedAfter       = Nothing
      , userCreated                 = now
      , userLastLdapSynchronisation = Nothing
      , userLdapPrimaryKey          = aufFPersonalNumber
      , userLastAuthentication      = Nothing
      , userEmail                   = aufEmail
      , userDisplayName             = aufDisplayName
      , userDisplayEmail            = aufDisplayEmail
      , userFirstName               = aufFirstName
      , userSurname                 = aufSurname
      , userTitle                   = aufTitle
      , userSex                     = aufSex        
      , userMobile                  = aufMobile
      , userTelephone               = aufTelephone
      , userCompanyPersonalNumber   = aufFPersonalNumber
      , userCompanyDepartment       = aufFDepartment    
      , userPostAddress             = aufPostAddress
      , userPrefersPostal           = aufPrefersPostal
      , userPinPassword             = aufPinPassword
      , userMatrikelnummer          = aufMatriculation
      , userAuthentication          = mkAuthMode aufAuth
      }
  runDBJobs . runMaybeT $ do
    uid <- MaybeT $ insertUnique newUser
    lift . queueDBJob $ JobSynchroniseLdapUser uid
    lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication)
    when (aufAuth == AuthKindPWHash) $
      lift . queueDBJob $ JobSendPasswordReset uid
    return uid


getAdminUserAddR, postAdminUserAddR :: Handler Html
getAdminUserAddR = postAdminUserAddR
postAdminUserAddR = do
  ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
  formResult userRes $ addNewUser >=> \case
      (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
        }
