From fd534c0155eef1790500c834e612ab22cf9b67b6 Mon Sep 17 00:00:00 2001
From: sternenseemann <sternenseemann@systemli.org>
Date: Sat, 12 Mar 2022 14:26:44 +0100
Subject: [PATCH] Adjust for hoauth2 >= 2.3.0

hoauth2 is used by Stackage Nightly 2.3.0 and will thus be included in
Stackage LTS 19 when it comes out. Another motivation for this being
able to build with aeson 2.0 which is possible since hoauth2 2.1.

I've elected not to try to support a wider range (say >= 2.0 && < 2.4 or
even >= 1.3.0 && < 2.4) because *every version* released between 2.0 and
2.3 contains a breaking change that affects gitit, the CPP would turn
out to be quite the mess. Since there haven't been any functional
changes since the last release on master, people that can't upgrade yet
can safely skip a (hypothetical) immediate release.

If wanted, support for hoauth2 >= 2.1 && < 2.4 could possibly be
interesting, only supporting aeson >= 2.0 is probably a safe bet for
future releases.
---
 gitit.cabal                                |  2 +-
 src/Network/Gitit/Authentication/Github.hs | 22 +++++++++++-----------
 src/Network/Gitit/Config.hs                | 16 ++++++----------
 3 files changed, 18 insertions(+), 22 deletions(-)

Index: b/gitit.cabal
===================================================================
--- a/gitit.cabal
+++ b/gitit.cabal
@@ -155,7 +155,7 @@ Library
                      json >= 0.4 && < 0.11,
                      uri-bytestring >= 0.2.3.3,
                      split,
-                     hoauth2 >= 1.3.0 && < 1.17,
+                     hoauth2 >= 2.3.0 && < 2.4,
                      xml-conduit >= 1.5 && < 1.10,
                      http-conduit >= 2.1.6 && < 2.4,
                      http-client-tls >= 0.2.2 && < 0.4,
Index: b/src/Network/Gitit/Authentication/Github.hs
===================================================================
--- a/src/Network/Gitit/Authentication/Github.hs
+++ b/src/Network/Gitit/Authentication/Github.hs
@@ -27,6 +27,7 @@ import Control.Monad.Trans (liftIO)
 import Data.UUID (toString)
 import Data.UUID.V4 (nextRandom)
 import qualified Control.Exception as E
+import Control.Monad.Except
 import Prelude
 
 loginGithubUser :: OAuth2 -> Params -> Handler
@@ -54,16 +55,14 @@ getGithubUser ghConfig githubCallbackPar
   newManager tlsManagerSettings >>= getUserInternal
     where
     getUserInternal mgr =
-        liftIO $ do
+        liftIO $ runExceptT $ do
             let (Just state) = rState githubCallbackPars
             if state == githubState
               then do
                 let (Just code) = rCode githubCallbackPars
-                ifSuccess
-                   "No access token found yet"
-                   (fetchAccessToken mgr (oAuth2 ghConfig) (ExchangeToken $ pack code))
-                   (\at -> ifSuccess
-                           "User Authentication failed"
+                at <- withExceptT (oauthToGithubError "No access token found yet")
+                      $ fetchAccessToken mgr (oAuth2 ghConfig) (ExchangeToken $ pack code)
+                liftIO >=> liftEither $ ifSuccess "User Authentication failed"
                            (userInfo mgr (accessToken at))
                            (\githubUser -> ifSuccess
                             ("No email for user " ++ unpack (gLogin githubUser) ++ " returned by Github")
@@ -79,9 +78,9 @@ getGithubUser ghConfig githubCallbackPar
                                              Just githuborg -> ifSuccess
                                                       ("Membership check failed: the user " ++ unpack gitLogin ++  " is required to be a member of the organization "  ++ unpack githuborg ++ ".")
                                                       (orgInfo gitLogin githuborg mgr (accessToken at))
-                                                      (\_ -> return $ Right user))))
+                                                      (\_ -> return $ Right user)))
               else
-                return $ Left $
+                throwError $
                        GithubLoginError ("The state sent to github is not the same as the state received: " ++ state ++ ", but expected sent state: " ++  githubState)
                                         Nothing
     ifSuccess errMsg failableAction successAction  = E.catch
@@ -90,6 +89,7 @@ getGithubUser ghConfig githubCallbackPar
                                                  (\exception -> liftIO $ return $ Left $
                                                                 GithubLoginError errMsg
                                                                                  (Just $ show (exception :: E.SomeException)))
+    oauthToGithubError errMsg e = GithubLoginError errMsg (Just $ show e)
 
 data GithubCallbackPars = GithubCallbackPars { rCode :: Maybe String
                                              , rState :: Maybe String }
@@ -106,14 +106,14 @@ userInfo :: Manager -> AccessToken -> IO
 #else
 userInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors GithubUser)
 #endif
-userInfo mgr token = authGetJSON mgr token $ githubUri "/user"
+userInfo mgr token = runExceptT $ authGetJSON mgr token $ githubUri "/user"
 
 #if MIN_VERSION_hoauth2(1, 9, 0)
 mailInfo :: Manager -> AccessToken -> IO (Either BSL.ByteString [GithubUserMail])
 #else
 mailInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors [GithubUserMail])
 #endif
-mailInfo mgr token = authGetJSON mgr token $ githubUri "/user/emails"
+mailInfo mgr token = runExceptT $ authGetJSON mgr token $ githubUri "/user/emails"
 
 #if MIN_VERSION_hoauth2(1, 9, 0)
 orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (Either BSL.ByteString BSL.ByteString)
@@ -122,7 +122,7 @@ orgInfo  :: Text -> Text -> Manager -> A
 #endif
 orgInfo gitLogin githubOrg mgr token = do
   let url = githubUri $ "/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin
-  authGetBS mgr token url
+  runExceptT $ authGetBS mgr token url
 
 type UriPath = BS.ByteString
 
Index: b/src/Network/Gitit/Config.hs
===================================================================
--- a/src/Network/Gitit/Config.hs
+++ b/src/Network/Gitit/Config.hs
@@ -40,7 +40,7 @@ import Paths_gitit (getDataFileName)
 import System.FilePath ((</>))
 import Text.Pandoc hiding (ERROR, WARNING, MathJax, MathML, WebTeX, getDataFileName)
 import qualified Control.Exception as E
-import Network.OAuth.OAuth2 (OAuth2(..), oauthCallback, oauthOAuthorizeEndpoint, oauthClientId, oauthClientSecret)
+import Network.OAuth.OAuth2 (OAuth2(..))
 import URI.ByteString (parseURI, laxURIParserOptions)
 import qualified Data.ByteString.Char8 as BS
 import Network.Gitit.Compat.Except
@@ -254,15 +254,11 @@ extractGithubConfig cp = do
       cfOrg <- if hasGithubProp "github-org"
                  then fmap Just (getGithubProp "github-org")
                  else return Nothing
-      let cfgOAuth2 = OAuth2 { oauthClientId = T.pack cfOauthClientId
-#if MIN_VERSION_hoauth2(1, 11, 0)
-                          , oauthClientSecret = Just $ T.pack cfOauthClientSecret
-#else
-                          , oauthClientSecret = T.pack cfOauthClientSecret
-#endif
-                          , oauthCallback = Just cfOauthCallback
-                          , oauthOAuthorizeEndpoint = cfOauthOAuthorizeEndpoint
-                          , oauthAccessTokenEndpoint = cfOauthAccessTokenEndpoint
+      let cfgOAuth2 = OAuth2 { oauth2ClientId = T.pack cfOauthClientId
+                          , oauth2ClientSecret = T.pack cfOauthClientSecret
+                          , oauth2RedirectUri = cfOauthCallback
+                          , oauth2AuthorizeEndpoint = cfOauthOAuthorizeEndpoint
+                          , oauth2TokenEndpoint = cfOauthAccessTokenEndpoint
                           }
       return $ githubConfig cfgOAuth2 $ fmap T.pack cfOrg
   where getGithubProp = get cp "Github"
