chore(model): use more specific (new)types for ldap model

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
+  port           Word16       -- ^ Port of the LDAP service to connect to
-                              -- TODO: is there a port type? Maybe merge with host and make primary key?
+                              -- 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
+  user           LdapDn       -- ^ User used for queries
-  pass           Text         -- ^ Password used for queries
+  pass           LdapPass     -- ^ Password used for queries
-  baseDn         Text
+  base           LdapDn       -- ^ TODO documentation needed
-  scope          LdapScope
+  scope          LdapScope    -- ^ TODO documentation needed
-  timeout        Natural      -- ^ Query timeout in milliseconds
+  timeout        NominalDiffTime  -- ^ Query timeout
-  searchTimeout  Natural      -- ^ Search query timeout in milliseconds
+  searchTimeout  Int32            -- ^ Search query timeout -- TODO: why not NominalDiffTime??
   UniqueAuthSourceLdap host port -- TODO rethink!
   deriving Show Eq Ord Generic
 

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]

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)

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

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
 

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
+  { ldapConfHost     :: Ldap.Host
-  , ldapPort     :: Ldap.PortNumber
+  , ldapConfPort     :: Ldap.PortNumber
-  , ldapDn       :: Ldap.Dn
+  , ldapConfDn       :: Ldap.Dn
-  , ldapPassword :: Ldap.Password
+  , ldapConfPassword :: Ldap.Password
-  , ldapBase     :: Ldap.Dn
+  , ldapConfBase     :: Ldap.Dn
-  , ldapScope    :: Ldap.Scope
+  , ldapConfScope    :: Ldap.Scope
-  , ldapTimeout  :: NominalDiffTime
+  , ldapConfTimeout  :: NominalDiffTime
-  , ldapSearchTimeout :: Int32
+  , 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"
+    ldapConfTls <- o .:? "tls"
-    tlsSettings <- case ldapTls :: Maybe String of
+    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" .!= ""
+    ldapConfHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
-    ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+    ldapConfPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
-    ldapDn <- Ldap.Dn <$> o .:? "user" .!= ""
+    ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= ""
-    ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
+    ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
-    ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
+    ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
-    ldapScope <- o .: "scope"
+    ldapConfScope <- o .: "scope"
-    ldapTimeout <- o .: "timeout"
+    ldapConfTimeout <- o .: "timeout"
-    ldapSearchTimeout <- o .: "search-timeout"
+    ldapConfSearchTimeout <- o .: "search-timeout"
     return LdapConf{..}