From b4f08c28df5c670792f54458d8013c8c9931249d Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 2 Aug 2018 14:38:32 +0200
Subject: [PATCH] Make maintenance logins resilient to LDAP failures

---
 package.yaml      |  1 +
 src/Auth/LDAP.hs  | 14 ++++++++++++-
 src/Foundation.hs | 52 +++++++++++++++++++++++++++++++++--------------
 3 files changed, 51 insertions(+), 16 deletions(-)

diff --git a/package.yaml b/package.yaml
index 47b09239e..74bb7bf3c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -87,6 +87,7 @@ dependencies:
 - gitrev
 - Glob
 - ldap-client
+- connection
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 77269ffa9..ec0493e8f 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -10,6 +10,7 @@
 
 module Auth.LDAP
   ( campusLogin
+  , CampusUserException(..)
   , campusUser
   , CampusMessage(..)
   , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
@@ -17,6 +18,9 @@ module Auth.LDAP
 
 import Import.NoFoundation
 import Control.Lens
+import Network.Connection
+
+import qualified Control.Monad.Catch as Exc
 
 import Utils.Form
 
@@ -108,6 +112,9 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
       $(widgetFile "widgets/campus-login-form")
 
 data CampusUserException = CampusUserLdapError Ldap.LdapError
+                         | CampusUserHostNotResolved String
+                         | CampusUserLineTooLong
+                         | CampusUserHostCannotConnect String [IOException]
                          | CampusUserNoResult
                          | CampusUserAmbiguous
   deriving (Show, Eq, Typeable)
@@ -115,7 +122,7 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
 instance Exception CampusUserException
 
 campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
-campusUser conf@LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
+campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
   Ldap.bind ldap ldapDn ldapPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
@@ -133,6 +140,11 @@ campusUser conf@LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLda
     [] -> throwM CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
     _otherwise -> throwM CampusUserAmbiguous
+  where
+    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
+                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
+                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
+                  ]
 
 -- ldapConfig :: UniWorX -> LDAPConfig
 -- ldapConfig _app@(appSettings -> settings) = LDAPConfig
diff --git a/src/Foundation.hs b/src/Foundation.hs
index b32f2b59b..6931f8eb7 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -70,6 +70,7 @@ import Control.Monad.Trans.Reader (runReader)
 import Control.Monad.Trans.Writer (WriterT(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Catch (handleAll)
+import qualified Control.Monad.Catch as C
 
 import System.FilePath
 
@@ -1076,23 +1077,45 @@ instance YesodAuth UniWorX where
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
-    authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do
-      let (userPlugin, userIdent)
-            | isDummy
-            , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
-            = (dummyPlugin, dummyIdent)
-            | otherwise
-            = (credsPlugin, credsIdent)
-          isDummy = credsPlugin == "dummy"
-          isPWFile = credsPlugin == "PWFile"
-          uAuth = UniqueAuthentication userPlugin userIdent
+    authenticate Creds{..} = runDB $ do
+      let
+        (userPlugin, userIdent)
+          | isDummy
+          , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
+          = (dummyPlugin, dummyIdent)
+          | otherwise
+          = (credsPlugin, credsIdent)
+        isDummy = credsPlugin == "dummy"
+        isPWFile = credsPlugin == "PWFile"
+        uAuth = UniqueAuthentication userPlugin userIdent
 
-      $logDebugS "auth" $ tshow creds
+        excHandlers
+          | isDummy || isPWFile
+          = [ C.Handler $ \err -> do
+                addMessage "error" (toHtml $ tshow (err :: CampusUserException))
+                $logErrorS "LDAP" $ tshow err
+                acceptExisting
+            ]
+          | otherwise
+          = [ C.Handler $ \case
+                CampusUserNoResult -> do
+                  $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+                  return . UserError $ IdentifierNotFound credsIdent
+                CampusUserAmbiguous -> do
+                  $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+                  return . UserError $ IdentifierNotFound credsIdent
+                err -> do
+                  $logErrorS "LDAP" $ tshow err
+                  return $ ServerError "LDAP lookup failed"
+            ]
 
+        acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+
+      $logDebugS "auth" $ tshow Creds{..}
       AppSettings{..} <- getsYesod appSettings
 
-      case appLdapConf of
-        Just ldapConf -> do
+      flip catches excHandlers $ case appLdapConf of
+        Just ldapConf -> fmap (either id id) . runExceptT $ do
           ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
 
@@ -1155,8 +1178,7 @@ instance YesodAuth UniWorX where
 
           lift $ insertMany_ fs
           return $ Authenticated userId
-        Nothing -> (throwError =<<) . lift $
-          maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+        Nothing -> acceptExisting
 
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())