Fallbacks for lack of LDAP in environment

src/Auth/LDAP.hs

@@ -36,6 +36,20 @@ data CampusMessage = MsgCampusIdentNote
                    | MsgCampusInvalidCredentials
   
 
+findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
+  where
+    userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
+    userSearchSettings = mconcat
+      [ Ldap.scope ldapScope
+      , Ldap.size 2
+      , Ldap.time ldapTimeout
+      , Ldap.derefAliases Ldap.DerefAlways
+      ]
+  
+userPrincipalName :: Ldap.Attr
+userPrincipalName = Ldap.Attr "userPrincipalName"
+
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , Button site SubmitButton
@@ -53,7 +67,7 @@ campusLogin :: forall site.
                , Button site SubmitButton
                , Show (ButtonCssClass site)
                ) => LdapConf -> AuthPlugin site
-campusLogin LdapConf{..} = AuthPlugin{..}
+campusLogin conf@LdapConf{..} = AuthPlugin{..}
   where
     apName = "LDAP"
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
@@ -68,15 +82,7 @@ campusLogin LdapConf{..} = AuthPlugin{..}
           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
+            findUser conf ldap campusIdent [userPrincipalName]
-              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
@@ -101,11 +107,7 @@ campusLogin LdapConf{..} = AuthPlugin{..}
       (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)
@@ -113,19 +115,20 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
 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
+campusUser conf@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 []
+  results <- case lookup "DN" credsExtra of
+    Just userDN -> do
+      let userFilter = Ldap.Present userPrincipalName
+          userSearchSettings = mconcat
+            [ Ldap.scope Ldap.BaseObject
+            , Ldap.size 2
+            , Ldap.time ldapTimeout
+            , Ldap.derefAliases Ldap.DerefAlways
+            ]
+      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
+    Nothing -> do
+      findUser conf ldap credsIdent []
   case results of
     [] -> throwM CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs

src/Foundation.hs

@@ -1099,7 +1099,7 @@ instance YesodAuth UniWorX where
 
       case appLdapConf of
         Just ldapConf -> do
-          ldapData <- campusUser ldapConf creds
+          ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
 
           let
             userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData

src/Settings.hs

@@ -125,7 +125,10 @@ instance FromJSON AppSettings where
 #endif
         appStaticDir              <- o .: "static-dir"
         appDatabaseConf           <- o .: "database"
-        appLdapConf               <- o .:? "ldap"
+        let nonEmptyHost LdapConf{..} = case ldapHost of
+              Ldap.Tls host _ -> not $ null host
+              Ldap.Plain host -> not $ null host
+        appLdapConf               <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"