diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 8c794e228..626a701be 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -41,6 +41,7 @@ AuthLDAPInvalidLookup: Bestehender Nutzer/Bestehende Nutzerin konnte nicht einde AuthLDAPAlreadyConfigured: Nutzer:in meldet sich bereits per Fraport AG Kennung in FRADrive an AuthLDAPConfigured: Nutzer:in meldet sich nun per Fraport AG Kennung in FRADrive an AuthLDAP !ident-ok: Fraport AG Kennung +AuthNoLogin: Kein Login erlaubt. PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt UserAssimilateUser: Benutzer:in AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer/keiner Benutzerin zugeordnet werden @@ -84,4 +85,5 @@ AllUsersLdapSync: Alle LDAP-Synchronisieren UserHijack: Sitzung übernehmen AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung +AuthKindNoLogin: Kein Login möglich Name !ident-ok: Name \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 53d03d0a7..793ef4dfa 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -41,6 +41,7 @@ AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP e AuthLDAPAlreadyConfigured: User already logs in using their Fraport AG account AuthLDAPConfigured: User now logs in using their Fraport AG account AuthLDAP: Fraport AG account +AuthNoLogin: No login allowed. PasswordResetQueued: Sent link to reset password UserAssimilateUser: User AssimilateUserNotFound: Email could not be resolved to an user @@ -84,4 +85,5 @@ AllUsersLdapSync: Synchronise all with LDAP UserHijack: Hijack session AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account +AuthKindNoLogin: No login Name: Name \ No newline at end of file diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 0f186b8d0..8a929f059 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -205,7 +205,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do userAuthentication | is _UpsertCampusUserLoginOther upsertMode - = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") + = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known") | otherwise = AuthLDAP userLastAuthentication = guardOn isLogin now isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 36f6983ee..8e367710f 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -1,8 +1,7 @@ module Handler.Users.Add - ( AuthenticationKind(..) - , classifyAuth, mkAuthMode - , AdminUserForm(..), adminUserForm - , getAdminUserAddR, postAdminUserAddR + ( getAdminUserAddR, postAdminUserAddR + -- , AdminUserForm(..), adminUserForm -- no longer needed elsewhere + -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere ) where @@ -31,20 +30,24 @@ data AdminUserForm = AdminUserForm , aufAuth :: AuthenticationKind } -data AuthenticationKind = AuthKindLDAP | AuthKindPWHash +data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin 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 +classifyAuth AuthNoLogin = AuthKindNoLogin +-} mkAuthMode :: AuthenticationKind -> AuthenticationMode -mkAuthMode AuthKindLDAP = AuthLDAP -mkAuthMode AuthKindPWHash = AuthPWHash "" +mkAuthMode AuthKindLDAP = AuthLDAP +mkAuthMode AuthKindPWHash = AuthPWHash "" +mkAuthMode AuthKindNoLogin = AuthNoLogin adminUserForm :: Maybe AdminUserForm -> Form AdminUserForm adminUserForm template = renderAForm FormStandard diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index dfa135002..2d7915795 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -52,6 +52,7 @@ import Data.Binary.Instances.UnorderedContainers () data AuthenticationMode = AuthLDAP | AuthPWHash { authPWHash :: Text } + | AuthNoLogin deriving (Eq, Ord, Read, Show, Generic) instance Hashable AuthenticationMode diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b08851225..c14088475 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -239,7 +239,7 @@ fillDb = do } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" - , userAuthentication = AuthLDAP + , userAuthentication = AuthNoLogin , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing , userMatrikelnummer = Just "999" diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 4830ffca3..b24824f21 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -225,6 +225,7 @@ instance Arbitrary AuthenticationMode where ] shrink AuthLDAP = [] + shrink AuthNoLogin = [] shrink (AuthPWHash _) = [AuthLDAP] instance Arbitrary LecturerType where diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index c52d5634c..238dc0bec 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -2,6 +2,9 @@ module Utils.TypesSpec where import TestImport +instance Arbitrary SloppyBool where + arbitrary = SloppyBool <$> arbitrary + shrink (SloppyBool x) = SloppyBool <$> shrink x instance Arbitrary AvsPersonId where arbitrary = AvsPersonId <$> arbitrary @@ -11,6 +14,14 @@ instance Arbitrary AvsCardNo where arbitrary = AvsCardNo <$> arbitrary shrink (AvsCardNo x) = AvsCardNo <$> shrink x +instance Arbitrary AvsLicence where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsObjPersonId where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary AvsDataCardColor where arbitrary = genericArbitrary shrink = genericShrink @@ -27,6 +38,14 @@ instance Arbitrary AvsDataPerson where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary AvsPersonLicence where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsLicenceResponse where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary AvsResponsePerson where arbitrary = genericArbitrary shrink = genericShrink @@ -35,6 +54,14 @@ instance Arbitrary AvsResponseStatus where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary AvsResponseSetLicences where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsResponseGetLicences where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary AvsQueryStatus where arbitrary = genericArbitrary shrink = genericShrink @@ -43,6 +70,14 @@ instance Arbitrary AvsQueryPerson where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary AvsQuerySetLicences where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary AvsQueryGetLicences where + arbitrary = genericArbitrary + shrink = genericShrink + spec :: Spec spec = do