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
        }