Get new LDAP to run

config/settings.yml

@@ -42,6 +42,7 @@ ldap:
   pass:     "_env:LDAPPASS:"
   baseDN:   "_env:LDAPBASE:"
   scope:    "_env:LDAPSCOPE:WholeSubtree"
+  timeout:  "_env:LDAPTIMEOUT:5"
 
 default-favourites: 12
 default-theme: Default

messages/campus/de.msg

@@ -1,4 +1,5 @@
 CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben.
 CampusIdent: Campus-Kennung
 CampusPassword: Passwort
-CampusSubmit: Abschicken
+CampusSubmit: Abschicken
+CampusInvalidCredentials: Ungültige Logindaten

src/Auth/LDAP.hs

@@ -5,11 +5,14 @@
            , FlexibleContexts
            , FlexibleInstances
            , NoImplicitPrelude
+           , ScopedTypeVariables
   #-}
 
 module Auth.LDAP
   ( campusLogin
+  , campusUser
   , CampusMessage(..)
+  , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
   ) where
 
 import Import.NoFoundation
@@ -17,6 +20,12 @@ import Control.Lens
 
 import Utils.Form
 
+import qualified Ldap.Client as Ldap
+
+import qualified Data.Text.Encoding as Text
+
+import qualified Yesod.Auth.Message as Msg
+
 
 data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text }
 
@@ -24,6 +33,7 @@ data CampusMessage = MsgCampusIdentNote
                    | MsgCampusIdent
                    | MsgCampusPassword
                    | MsgCampusSubmit
+                   | MsgCampusInvalidCredentials
   
 
 campusForm :: ( RenderMessage site FormMessage
@@ -36,20 +46,91 @@ campusForm = CampusLogin
   <*> areq passwordField (fslI MsgCampusPassword) Nothing
   <*  submitButton
 
-campusLogin :: ( YesodAuth site
+campusLogin :: forall site.
+               ( YesodAuth site
                , RenderMessage site FormMessage
                , RenderMessage site CampusMessage
                , Button site SubmitButton
                , Show (ButtonCssClass site)
                ) => LdapConf -> AuthPlugin site
-campusLogin conf = AuthPlugin{..}
+campusLogin LdapConf{..} = AuthPlugin{..}
   where
     apName = "LDAP"
+    apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
+    apDispatch "POST" [] = do
+      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
+      case loginRes of
+        FormFailure errs -> do
+          forM_ errs $ addMessage "error" . toHtml
+          redirect LoginR
+        FormMissing -> redirect LoginR
+        FormSuccess CampusLogin{..} -> do
+          ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
+            Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
+            Ldap.bind ldap ldapDn ldapPassword
+            let
+              userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
+              userSearchSettings = mconcat
+                [ Ldap.scope ldapScope
+                , Ldap.size 2
+                , Ldap.time ldapTimeout
+                , Ldap.derefAliases Ldap.DerefAlways
+                ]
+            Ldap.search ldap ldapBase userSearchSettings userFilter [userPrincipalName]
+          case ldapResult of
+            Left err
+              | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
+                -> do
+                  $logDebugS "LDAP" "Invalid credentials"
+                  loginErrorMessageI LoginR Msg.InvalidLogin
+              | otherwise -> do
+                  $logErrorS "LDAP" $ "Error during login: " <> tshow err
+                  loginErrorMessageI LoginR Msg.AuthError
+            Right searchResults
+              | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
+              , Just [principalName] <- lookup userPrincipalName userAttrs
+              , Right credsIdent <- Text.decodeUtf8' principalName
+                -> do
+                  $logDebugS "LDAP" $ tshow searchResults
+                  lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
+              | otherwise -> do
+                  $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
+                  loginErrorMessageI LoginR Msg.AuthError
     apDispatch _ _ = notFound
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
       $(widgetFile "widgets/campus-login-form")
 
+userPrincipalName :: Ldap.Attr
+userPrincipalName = Ldap.Attr "userPrincipalName"
+
+data CampusUserException = CampusUserLdapError Ldap.LdapError
+                         | CampusUserNoDN
+                         | CampusUserNoResult
+                         | CampusUserAmbiguous
+  deriving (Show, Eq, Typeable)
+
+instance Exception CampusUserException
+
+campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
+campusUser LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
+  userDN <- case lookup "DN" credsExtra of
+    Just userDN -> return userDN
+    Nothing     -> throwM CampusUserNoDN
+  let userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 credsIdent
+      userSearchSettings = mconcat
+        [ Ldap.scope Ldap.BaseObject
+        , Ldap.size 2
+        , Ldap.time ldapTimeout
+        , Ldap.derefAliases Ldap.DerefAlways
+        ]
+  Ldap.bind ldap ldapDn ldapPassword
+  results <- Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
+  case results of
+    [] -> throwM CampusUserNoResult
+    [Ldap.SearchEntry _ attrs] -> return attrs
+    _otherwise -> throwM CampusUserAmbiguous
+
 -- ldapConfig :: UniWorX -> LDAPConfig
 -- ldapConfig _app@(appSettings -> settings) = LDAPConfig
 --   { usernameFilter = \u -> principalName <> "=" <> u

src/Foundation.hs

@@ -1093,49 +1093,76 @@ instance YesodAuth UniWorX where
           isPWFile = credsPlugin == "PWFile"
           uAuth = UniqueAuthentication userPlugin userIdent
 
-      $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds)
+      $logDebugS "auth" $ tshow creds
-
-      when (isDummy || isPWFile) . (throwError =<<) . lift $
-          maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
-
-      let
-        userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra
-        userEmail' = lookup "mail" credsExtra
-        userDisplayName' = lookup "displayName" credsExtra
-
-      userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail'
-      userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
 
       AppSettings{..} <- getsYesod appSettings
 
-      let
+      case appLdapConf of
-        userMaxFavourites = appDefaultMaxFavourites
+        Just ldapConf -> do
-        userTheme = appDefaultTheme
+          ldapData <- campusUser ldapConf creds
-        userDateTimeFormat = appDefaultDateTimeFormat
+
-        userDateFormat = appDefaultDateFormat
+          let
-        userTimeFormat = appDefaultTimeFormat
+            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
-        newUser = User{..}
+            userEmail' = lookup (Attr "mail") ldapData
-        userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+            userDisplayName' = lookup (Attr "displayName") ldapData
-                     , UserDisplayName =. userDisplayName
+
-                     , UserEmail =. userEmail
+          userEmail <- if
+            | Just [bs] <- userEmail'
+            , Right userEmail <- Text.decodeUtf8' bs
+              -> return $ CI.mk userEmail
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user email"
+          userDisplayName <- if
+            | Just [bs] <- userDisplayName'
+            , Right userDisplayName <- Text.decodeUtf8' bs
+              -> return userDisplayName
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user name"
+          userMatrikelnummer <- if
+            | Just [bs] <- userMatrikelnummer'
+            , Right userMatrikelnummer <- Text.decodeUtf8' bs
+              -> return $ Just userMatrikelnummer
+            | Nothing <- userMatrikelnummer'
+              -> return Nothing
+            | otherwise
+              -> throwError $ ServerError "Could not decode user matriculation"
+
+          let
+            userMaxFavourites = appDefaultMaxFavourites
+            userTheme = appDefaultTheme
+            userDateTimeFormat = appDefaultDateTimeFormat
+            userDateFormat = appDefaultDateFormat
+            userTimeFormat = appDefaultTimeFormat
+            newUser = User{..}
+            userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+                         , UserDisplayName =. userDisplayName
+                         , UserEmail =. userEmail
                      ]
 
-      userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
+          userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
 
-      let
+          let
-        userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
+            userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
-        userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ]
+            userStudyFeatures' = do
+              (k, v) <- ldapData
+              guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
+              v' <- v
+              Right str <- return $ Text.decodeUtf8' v'
+              return str
 
-      fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
+          fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
 
-      lift $ deleteWhere [StudyFeaturesUser ==. userId]
+          lift $ deleteWhere [StudyFeaturesUser ==. userId]
 
-      forM_ fs $ \StudyFeatures{..} -> do
+          forM_ fs $ \StudyFeatures{..} -> do
-        lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+            lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-        lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+            lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+
+          lift $ insertMany_ fs
+          return $ Authenticated userId
+        Nothing -> (throwError =<<) . lift $
+          maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
 
-      lift $ insertMany_ fs
-      return $ Authenticated userId
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 

src/Settings.hs

@@ -91,6 +91,7 @@ data LdapConf = LdapConf
   , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
+  , ldapTimeout :: Int32
   }
 
 deriveFromJSON defaultOptions ''Ldap.Scope
@@ -111,6 +112,7 @@ instance FromJSON LdapConf where
         ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
         ldapBase <- Ldap.Dn <$> o .: "baseDN"
         ldapScope <- o .: "scope"
+        ldapTimeout <- o .: "timeout"
         return LdapConf{..}
 
 instance FromJSON AppSettings where