chore(avs): add AuthNoLogin authentication mode

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

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

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

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

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

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"

test/Model/TypesSpec.hs

@@ -225,6 +225,7 @@ instance Arbitrary AuthenticationMode where
     ]
 
   shrink AuthLDAP = []
+  shrink AuthNoLogin = []
   shrink (AuthPWHash _) = [AuthLDAP]
 
 instance Arbitrary LecturerType where

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