Brittany

src/Yesod/Auth/OAuth2/Dispatch.hs

@@ -34,8 +34,10 @@ dispatchAuthRequest
     -> Text             -- ^ Method
     -> [Text]           -- ^ Path pieces
     -> AuthHandler m TypedContent
-dispatchAuthRequest name oauth2 _ "GET" ["forward"] = dispatchForward name oauth2
+dispatchAuthRequest name oauth2 _ "GET" ["forward"] =
-dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = dispatchCallback name oauth2 getCreds
+    dispatchForward name oauth2
+dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] =
+    dispatchCallback name oauth2 getCreds
 dispatchAuthRequest _ _ _ _ _ = notFound
 
 -- | Handle @GET \/forward@
@@ -81,32 +83,33 @@ withCallbackAndState name oauth2 csrf = do
     render <- getParentUrlRender
     let callbackText = render url
 
-    callback <- maybe
+    callback <-
-        (liftIO
+        maybe
-            $ throwString
+                (liftIO
-            $ "Invalid callback URI: "
+                $ throwString
-            <> T.unpack callbackText
+                $ "Invalid callback URI: "
-            <> ". Not using an absolute Approot?"
+                <> T.unpack callbackText
-        ) pure $ fromText callbackText
+                <> ". Not using an absolute Approot?"
+                )
+                pure
+            $ fromText callbackText
 
     pure oauth2
         { oauthCallback = Just callback
-        , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2
+        , oauthOAuthorizeEndpoint =
-            `withQuery` [("state", encodeUtf8 csrf)]
+            oauthOAuthorizeEndpoint oauth2
+                `withQuery` [("state", encodeUtf8 csrf)]
         }
 
 getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)
-getParentUrlRender = (.)
+getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent
-    <$> getUrlRender
-    <*> getRouteToParent
 
 -- | Set a random, 30-character value in the session
 setSessionCSRF :: MonadHandler m => Text -> m Text
 setSessionCSRF sessionKey = do
     csrfToken <- liftIO randomToken
     csrfToken <$ setSession sessionKey csrfToken
-  where
+    where randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen
-    randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen
 
 -- | Verify the callback provided the same CSRF token as in our session
 verifySessionCSRF :: MonadHandler m => Text -> m Text

src/Yesod/Auth/OAuth2/Prelude.hs

@@ -91,26 +91,37 @@ instance Exception YesodOAuth2Exception
 -- @'credsIdent'@. Additional information should either be re-parsed by or
 -- fetched via additional requests by consumers.
 --
-authGetProfile :: FromJSON a => Text -> Manager -> OAuth2Token -> URI -> IO (a, BL.ByteString)
+authGetProfile
+    :: FromJSON a
+    => Text
+    -> Manager
+    -> OAuth2Token
+    -> URI
+    -> IO (a, BL.ByteString)
 authGetProfile name manager token url = do
     resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url
     decoded <- fromAuthJSON name resp
     pure (decoded, resp)
 
 -- | Throws a @Left@ result as an @'InvalidProfileResponse'@
-fromAuthGet :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString
+fromAuthGet
+    :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString
 fromAuthGet _ (Right bs) = pure bs -- nice
-fromAuthGet name (Left err) = throwIO $ InvalidProfileResponse name $ encode err
+fromAuthGet name (Left err) =
+    throwIO $ InvalidProfileResponse name $ encode err
 
 -- | Throws a decoding error as an @'InvalidProfileResponse'@
 fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a
 fromAuthJSON name =
     -- FIXME: unique exception constructors
-    either (throwIO . InvalidProfileResponse name . BL8.pack) pure . eitherDecode
+    either (throwIO . InvalidProfileResponse name . BL8.pack) pure
+        . eitherDecode
 
 -- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter
 scopeParam :: Text -> [Text] -> (ByteString, ByteString)
-scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d
+scopeParam d = ("scope", ) . encodeUtf8 . T.intercalate d
+
+-- brittany-disable-next-binding
 
 -- | Construct part of @'credsExtra'@
 --
@@ -128,4 +139,4 @@ setExtra token userResponse =
     [ ("accessToken", atoken $ accessToken token)
     , ("userResponse", decodeUtf8 $ BL.toStrict userResponse)
     ]
-    <> maybe [] (pure . ("refreshToken",) . rtoken) (refreshToken token)
+    <> maybe [] (pure . ("refreshToken", ) . rtoken) (refreshToken token)