chore(model): use more specific (new)types for ldap model
This commit is contained in:
parent
1180ef6fd0
commit
7ed5e7a326
@ -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
|
||||
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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{..}
|
||||
|
||||
Reference in New Issue
Block a user