diff --git a/models/auth.model b/models/auth.model index 68bb8516b..e8092fe57 100644 --- a/models/auth.model +++ b/models/auth.model @@ -18,15 +18,15 @@ AuthSourceAzure AuthSourceLdap host Text -- ^ LDAP host destination to connect to -- TODO: switch to url type - port Natural -- ^ Port of the LDAP service to connect to - -- TODO: is there a port type? Maybe merge with host and make primary key? + port Word16 -- ^ Port of the LDAP service to connect to + -- TODO: Maybe merge with host and make primary key? tls Bool -- ^ Whether to connect to the host via TLS - user Text -- ^ User used for queries - pass Text -- ^ Password used for queries - baseDn Text - scope LdapScope - timeout Natural -- ^ Query timeout in milliseconds - searchTimeout Natural -- ^ Search query timeout in milliseconds + user LdapDn -- ^ User used for queries + pass LdapPass -- ^ Password used for queries + base LdapDn -- ^ TODO documentation needed + scope LdapScope -- ^ TODO documentation needed + timeout NominalDiffTime -- ^ Query timeout + searchTimeout Int32 -- ^ Search query timeout -- TODO: why not NominalDiffTime?? UniqueAuthSourceLdap host port -- TODO rethink! deriving Show Eq Ord Generic diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index c8650bc44..84603bb00 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -65,7 +65,7 @@ findUser :: LdapConf -> Text -- ^ needle -> [Ldap.Attr] -> IO [Ldap.SearchEntry] -findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters +findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident @@ -85,7 +85,7 @@ findUserMatr :: LdapConf -> Text -- ^ matriculation needle -> [Ldap.Attr] -> IO [Ldap.SearchEntry] -findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters +findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters where userFilters = [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr @@ -94,9 +94,9 @@ findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM ( userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search userSearchSettings LdapConf{..} = mconcat - [ Ldap.scope ldapScope + [ Ldap.scope ldapConfScope , Ldap.size 2 - , Ldap.time ldapSearchTimeout + , Ldap.time ldapConfSearchTimeout , Ldap.derefAliases Ldap.DerefAlways ] @@ -147,7 +147,7 @@ ldapUserWith :: ( MonadUnliftIO m -> Creds site -> m (Either LdapUserException (Ldap.AttrList [])) ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do - lift $ Ldap.bind ldap ldapDn ldapPassword + lift $ Ldap.bind ldap ldapConfDn ldapConfPassword results <- case lookup "DN" credsExtra of Just userDN -> do let userFilter = Ldap.Present ldapUserPrincipalName @@ -224,7 +224,7 @@ ldapUserMatr :: ( MonadUnliftIO m -> UserMatriculation -> m (Ldap.AttrList []) ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do - Ldap.bind ldap ldapDn ldapPassword + Ldap.bind ldap ldapConfDn ldapConfPassword results <- findUserMatr conf ldap userMatr [] case results of [] -> throwM LdapUserNoResult @@ -286,7 +286,7 @@ ldapLogin conf@LdapConf{..} pool = AuthPlugin{..} resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do ldapResult <- withLdap pool $ \ldap -> liftIO $ do - Ldap.bind ldap ldapDn ldapPassword + Ldap.bind ldap ldapConfDn ldapConfPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 90edef7a1..d5bd8072e 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -252,6 +252,7 @@ import Data.Encoding.UTF8 as Import (UTF8(UTF8)) import GHC.TypeLits as Import (KnownSymbol) +import Data.Word as Import (Word16) import Data.Word.Word24 as Import import Data.Kind as Import (Type, Constraint) diff --git a/src/Model/Types/Auth.hs b/src/Model/Types/Auth.hs index 92b2eb0d5..94edadd84 100644 --- a/src/Model/Types/Auth.hs +++ b/src/Model/Types/Auth.hs @@ -43,15 +43,54 @@ import Data.Universe import Data.Universe.Instances.Reverse () import Data.Universe.Instances.Reverse.MonoTraversable () +import qualified Database.Esqueleto.Legacy as E import Database.Persist.Sql +import qualified Ldap.Client as Ldap +import Ldap.Client.Instances () + import Servant.Docs (ToSample(..), samples) +type AzureScopes = Set Text + +-- Note: Ldap.Host also stores TLS settings, which we will generate ad-hoc based on AuthSourceLdapTls field instead. We therefore use Text to store the hostname only +-- newtype LdapHost = LdapHost { ldapHost :: Text } +-- deriving (Eq, Ord, Read, Show, Generic, Data) +-- deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql) +-- instance E.SqlString LdapHost +-- makeLenses_ ''LdapHost + +-- Note: Ldap.PortNumber comes from Network.Socket, which does not export the constructor of the newtype. Hence, no Data and Generic instances can be derived. But PortNumber is a member of Num, so we will use Word16 instead (Word16 is also used for storing the port number inside PortNumber) +-- newtype LdapPort = LdapPort { ldapPort :: Word16 } +-- deriving (Eq, Ord, Read, Show, Generic, Data) +-- deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql) +-- instance E.SqlString LdapPort +-- makeLenses_ ''LdapPort + +newtype LdapPass = LdapPass { ldapPass :: Ldap.Password } + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (NFData, PersistField, PersistFieldSql) +instance E.SqlString LdapPass +makeLenses_ ''LdapPass + +newtype LdapDn = LdapDn { ldapDn :: Ldap.Dn } + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql) +instance E.SqlString LdapDn +makeLenses_ ''LdapDn + +newtype LdapScope = LdapScope { ldapScope :: Ldap.Scope } + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql) +instance E.SqlString LdapScope +makeLenses_ ''LdapScope + type UserEduPersonPrincipalName = Text -- | Supported protocols for external user sources used for authentication queries +-- TODO: deprecated, delete data AuthenticationProtocol = AuthAzure -- ^ Azure ADv2 (OAuth2) | AuthLdap -- ^ LDAP @@ -62,9 +101,14 @@ nullaryPathPiece ''AuthenticationProtocol $ camelToPathPiece' 1 pathPieceJSON ''AuthenticationProtocol +-- TODO: delete once identification using model table is implemented type AuthenticationSourceIdent = Text +------------------- +----- AuthTag ----- +------------------- + data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer = AuthAdmin | AuthLecturer @@ -173,6 +217,10 @@ _ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags fromReducedActiveAuthTags (ReducedActiveAuthTags hm) = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm +------------------- +----- PredDNF ----- +------------------- + data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving (Eq, Ord, Read, Show, Data, Generic) deriving anyclass (Hashable, Binary, NFData) @@ -214,7 +262,6 @@ parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM pa | otherwise = Left t - $(return []) instance ToJSON a => ToJSON (PredDNF a) where diff --git a/src/Settings.hs b/src/Settings.hs index 242b0ca0d..45f1e0c89 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -44,7 +44,6 @@ import Language.Haskell.TH.Syntax (Exp, Q) import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Data.Scientific as Scientific -import Data.Word (Word16) import qualified Data.Text as Text diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs index 88df04e9d..1ef5081be 100644 --- a/src/Settings/Ldap.hs +++ b/src/Settings/Ldap.hs @@ -6,7 +6,7 @@ module Settings.Ldap ( LdapConf(..) - , _ldapHost, _ldapDn, _ldapBase, _ldapScope, _ldapTimeout, _ldapSearchTimeout + , _ldapConfHost, _ldapConfDn, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout ) where import ClassyPrelude @@ -24,24 +24,24 @@ import qualified Ldap.Client as Ldap data LdapConf = LdapConf - { ldapHost :: Ldap.Host - , ldapPort :: Ldap.PortNumber - , ldapDn :: Ldap.Dn - , ldapPassword :: Ldap.Password - , ldapBase :: Ldap.Dn - , ldapScope :: Ldap.Scope - , ldapTimeout :: NominalDiffTime - , ldapSearchTimeout :: Int32 + { ldapConfHost :: Ldap.Host + , ldapConfPort :: Ldap.PortNumber + , ldapConfDn :: Ldap.Dn + , ldapConfPassword :: Ldap.Password + , ldapConfBase :: Ldap.Dn + , ldapConfScope :: Ldap.Scope + , ldapConfTimeout :: NominalDiffTime + , ldapConfSearchTimeout :: Int32 } deriving (Show) makeLenses_ ''LdapConf -deriveFromJSON defaultOptions ''Ldap.Scope +deriveFromJSON defaultOptions ''Ldap.Scope -- TODO: move to Ldap.Client.Instances instance FromJSON LdapConf where parseJSON = withObject "LdapConf" $ \o -> do - ldapTls <- o .:? "tls" - tlsSettings <- case ldapTls :: Maybe String of + ldapConfTls <- o .:? "tls" + tlsSettings <- case ldapConfTls :: Maybe String of Just spec | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings | spec == "default" -> return $ Just Ldap.defaultTlsSettings @@ -50,12 +50,12 @@ instance FromJSON LdapConf where | null spec -> return Nothing Nothing -> return Nothing _otherwise -> fail "Could not parse LDAP TLSSettings" - ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" - ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" - ldapDn <- Ldap.Dn <$> o .:? "user" .!= "" - ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" - ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" - ldapScope <- o .: "scope" - ldapTimeout <- o .: "timeout" - ldapSearchTimeout <- o .: "search-timeout" + ldapConfHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= "" + ldapConfPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port" + ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= "" + ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= "" + ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= "" + ldapConfScope <- o .: "scope" + ldapConfTimeout <- o .: "timeout" + ldapConfSearchTimeout <- o .: "search-timeout" return LdapConf{..}