feat(auth): WIP authorization function

src/Auth/OAuth2.hs

@@ -5,7 +5,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Auth.OAuth2
-( OAuthUserException(..)
+( AzureUserException(..)
 , oauth2MockServer
 , mockPluginName 
 ) where
@@ -18,11 +18,12 @@ import Yesod.Auth.OAuth2
 import Yesod.Auth.OAuth2.Prelude
 
 
-data OAuthUserException = OAuthUserError
+data AzureUserException = AzureUserError
-                        | OAuthUserAmbiguous -- TODO
+                        | AzureUserNoResult
+                        | AzureUserAmbiguous -- TODO
                         deriving (Show, Eq, Generic)
 
-instance Exception OAuthUserException
+instance Exception AzureUserException
 
 ----------------------------------------
 ---- OAuth2 development auth plugin ----

src/Foundation/Types.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -6,6 +6,9 @@ module Foundation.Types
   ( UpsertCampusUserMode(..)
   , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser
   , _upsertCampusUserIdent
+  , UpsertAzureUserMode(..)
+  , _UpsertAzureUserLoginOAuth, _UpsertAzureUserLoginDummy, _UpsertAzureUserLoginOther, _UpsertAzureUserOAuthSync, _UpsertAzureUserGuessUser
+  , _upsertAzureUserIdent
   ) where
 
 import Import.NoFoundation
@@ -21,3 +24,16 @@ data UpsertCampusUserMode
 
 makeLenses_ ''UpsertCampusUserMode
 makePrisms ''UpsertCampusUserMode
+
+
+-- Azure users logging in via OAuth2
+data UpsertAzureUserMode
+  = UpsertAzureUserLoginOAuth
+  | UpsertAzureUserLoginDummy { upsertAzureUserIdent :: UserIdent }
+  | UpsertAzureUserLoginOther { upsertAzureUserIdent :: UserIdent }
+  | UpsertAzureUserOAuthSync  { upsertAzureUserIdent :: UserIdent }
+  | UpsertAzureUserGuessUser
+  deriving (Eq, Ord, Read, Show, Generic)
+
+makeLenses_ ''UpsertAzureUserMode
+makePrisms ''UpsertAzureUserMode

src/Foundation/Yesod/Auth.hs

@@ -25,6 +25,7 @@ import Foundation.Authorization (AuthorizationCacheKey(..))
 
 import Yesod.Auth.Message
 import Auth.LDAP
+import Auth.OAuth2
 import Auth.PWHash (apHash)
 import Auth.Dummy (apDummy)
 
@@ -122,22 +123,22 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       -> acceptExisting
 
 
--- | Authentication via OAuth 2
+-- | Authentication via AzureADv2 / OAuth 2
 oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                  , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                  , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                  )
               => Creds UniWorX -> m (AuthenticationResult UniWorX)
 oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
+  $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
   now <- liftIO getCurrentTime
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertCampusUserMode -- TODO adjust do OAuth
+    upsertMode = creds ^? _upsertAzureUserMode
 
-    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
+    isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server 
-    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
+    isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode
 
     excRecovery res
       | isDummy || isOther
@@ -152,18 +153,18 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
 
     excHandlers =
       [ C.Handler $ \case
-          CampusUserNoResult -> do
+          AzureUserNoResult -> do
-            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+            $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
-          CampusUserAmbiguous -> do
+          AzureUserAmbiguous -> do
-            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+            $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
-            $logErrorS "LDAP" $ tshow err
+            $logErrorS "OAuth" $ tshow err
             mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError
+            excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from?
-      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+      , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not?
-          $logErrorS "LDAP" $ tshow cExc
+          $logErrorS "OAuth" $ tshow cExc
           mr <- getMessageRender
           excRecovery . ServerError $ mr cExc
       ]
@@ -181,12 +182,15 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "auth" $ tshow Creds{..}  
+  $logDebugS "oauth" $ tshow Creds{..}
-  pool <- getsYesod $ view _appLdapPool {-(case credsPlugin of
+  -- TODO look user up in DB
-              "azureadv2" -> getsYesod $ view _appLdapPool -- TODO
+  -- If not in DB then put (maybe prompt for email)
-              mockPluginName -> getsYesod $ view _appLdapPool -- TODO
+  -- If in DB but first time oauth then prompt for password & update entry
-              _ -> error "undefined" -- TODO
+  -- Now user should be in DB -> authenticated
-          )-}
+  flip catches excHandlers $ case upsertMode of
+    Just upsertMode' -> error $ show upsertMode' --TODO
+    Nothing -> error "nothing" --TODO
+  {-pool <- getsYesod $ view _appLdapPool
   flip catches excHandlers $ case pool of
     Just ldapPool
       | Just upsertMode' <- upsertMode -> do
@@ -194,7 +198,7 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
           Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
     _other
-      -> acceptExisting
+      -> acceptExisting-}
 
 
 
@@ -231,6 +235,29 @@ _upsertCampusUserMode mMode cs@Creds{..}
 
     defaultOther = apHash
 
+
+_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode
+_upsertAzureUserMode mMode cs@Creds{..}
+  | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent)
+  | credsPlugin == "azureadv2"    = setMode <$> mMode  UpsertAzureUserLoginOAuth
+  | otherwise                     = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent)
+  where
+    setMode UpsertAzureUserLoginOAuth
+      = cs{ credsPlugin = "azureadv2" }
+    setMode (UpsertAzureUserLoginDummy ident)
+      = cs{ credsPlugin = mockPluginName
+          , credsIdent  = CI.original ident
+          }
+    setMode (UpsertAzureUserLoginOther ident)
+      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2")
+          , credsIdent  = CI.original ident
+          }
+    setMode _ = cs
+
+    defaultOther = apHash
+
+
+
 ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
 ldapLookupAndUpsert ident = 
   getsYesod (view _appLdapPool) >>= \case