feat(auth): formatted output of user queries

src/Auth/OAuth2.hs

@@ -10,6 +10,7 @@ module Auth.OAuth2
 , oauth2MockServer
 , mockPluginName 
 , queryOAuth2User
+, UserDataException
 ) where
 
 import Data.Maybe (fromJust)
@@ -70,47 +71,54 @@ oauth2MockServer port =
 ---- User Queries ----
 ----------------------
 
-data UserData = UD deriving (Show)
-instance FromJSON UserData where
-  parseJSON _ = pure UD
+data UserDataException = UserDataJSONException JSONException
+                       | UserDataInternalException Text
+                       deriving Show
 
-queryOAuth2User :: forall m . (MonadIO m, MonadThrow m, MonadHandler m)
+instance Exception UserDataException
+
+queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m)
                 => Text
-                -> Text
-                -> m (Either JSONException Value)
-queryOAuth2User authPlugin userID = do
-  (queryUrl, tokenUrl) <- liftIO $ mkBaseUrls authPlugin
+                -> m (Either UserDataException j)
+queryOAuth2User userID = runExceptT $ do
+  (queryUrl, tokenUrl) <- liftIO mkBaseUrls
   req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID
   mTokens <- lookupSessionJson SessionOAuth2Token
-  unless (isJust mTokens) . liftIO . fail $ "Tried to load sesion Oauth2 tokens, but there are none"
-  eNewToken <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl (authPlugin == azurePluginName)
-  case eNewToken of
-    Left e -> return $ Left e
-    Right newTokens -> do
-      setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
-      getResponseBody <$> httpJSONEither @m @Value (req
-        { secure = authPlugin == azurePluginName
-        , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] })
+  unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none"
+# ifdef DEVELOPMENT
+  let secure = False
+# else
+  let secure = True
+# endif
+  newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure
+  setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens)
+  eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req
+    { secure = secure
+    , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] })
+  case eResult of
+    Left x -> throwE $ UserDataJSONException x
+    Right x -> return x
 
-mkBaseUrls :: Text -> IO (String, String)
-mkBaseUrls authPlugin
-  | authPlugin == azurePluginName = do
-    Just tenantID <- lookupEnv "AZURE_TENANT_ID"
-    return ( "https://graph.microsoft.com/v1.0/users/"
-           , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" )
-  | authPlugin == mockPluginName = do
-    Just port <- lookupEnv "OAUTH2_SERVER_PORT"
-    let base = "http://localhost:" ++ port
-    return ( base ++ "/users/query?id="
-           , base ++ "/token" )
-  | otherwise = fail $ "Unsupported auth plugin: " ++ unpack authPlugin
+
+mkBaseUrls :: IO (String, String)
+mkBaseUrls = do
+# ifndef DEVELOPMENT
+  Just tenantID <- lookupEnv "AZURE_TENANT_ID"
+  return ( "https://graph.microsoft.com/v1.0/users/"
+         , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" )
+# else
+  Just port <- lookupEnv "OAUTH2_SERVER_PORT"
+  let base = "http://localhost:" ++ port
+  return ( base ++ "/users/query?id="
+         , base ++ "/token" )
+# endif
 
 
 refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m)
                    => (Maybe AccessToken, Maybe RefreshToken)
                    -> String
                    -> Bool
-                   -> m (Either JSONException OAuth2Token)
+                   -> ExceptT UserDataException m OAuth2Token
 refreshOAuth2Token (_, rToken) url secure
   | isJust rToken = do
     req <- parseRequest $ "POST " ++ url
@@ -125,8 +133,11 @@ refreshOAuth2Token (_, rToken) url secure
         return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")]
       else return $ ("scope", "ID Profile") : body
     $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure })
-    getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
-  | otherwise = liftIO $ fail "Could not refresh access token. Refresh token is missing."
+    eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure })
+    case eResult of
+      Left x -> throwE $ UserDataJSONException x
+      Right x -> return x
+  | otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing."
 
 instance Show RequestBody where
   show (RequestBodyLBS x) = show x

src/Foundation/Yesod/Auth.hs

@@ -24,6 +24,7 @@ import Handler.Utils.Memcached
 import Foundation.Authorization (AuthorizationCacheKey(..))
 
 import Yesod.Auth.Message
+import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)
 import Auth.LDAP
 import Auth.OAuth2
 import Auth.PWHash (apHash)
@@ -131,6 +132,9 @@ oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
               => Creds UniWorX -> m (AuthenticationResult UniWorX)
 oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
   $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
+  setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds)
+  sess <- getSession
+  $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m"
   now <- liftIO getCurrentTime
 
   let

src/Handler/Admin/OAuth2.hs

@@ -9,17 +9,14 @@ module Handler.Admin.OAuth2
 
 import Import
 -- import qualified Data.CaseInsensitive as CI
-import Data.Text()
---import qualified Data.Text as Text
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.Encoding as T
 --import qualified Data.Text.Encoding as Text
 --import Foundation.Yesod.Auth (CampusUserConversionException()) 
 import Handler.Utils
 
-# ifdef DEVELOPMENT
-import Auth.OAuth2 (queryOAuth2User, mockPluginName)
-# else
-import Auth.OAuth2 (queryOAuth2User, azurePluginName)
-# endif
+import Auth.OAuth2 (queryOAuth2User)
 
 
 getAdminOAuth2R,   postAdminOAuth2R :: Handler Html
@@ -28,15 +25,12 @@ postAdminOAuth2R = do
    ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> 
      flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
  
-   let procFormPerson :: Text -> Handler (Maybe Text)
+   let procFormPerson :: Text -> Handler (Maybe T.Text)
        procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid
-# ifdef DEVELOPMENT
-         let authPlugin = mockPluginName
-# else
-         let authPlugin = azurePluginName
-# endif
-         eUserData <- queryOAuth2User authPlugin lid
-         return . Just $ tshow eUserData
+         eUserData <- queryOAuth2User @Value lid
+         case eUserData of
+          Left e -> throwM e
+          Right userData -> return . Just . T.decodeUtf8 $ encodePretty userData
    mOAuth2Data <- formResultMaybe presult procFormPerson
  
    --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> 

templates/oauth2.hamlet

@@ -13,6 +13,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       Antwort: #
     <dl .deflist>
           <dt>
-            #{show answers}
+            <pre>
+              #{answers}
           <dd>