From 3d0980811d61a78f265ec06dd5bd4ef2cde1cbdf Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 22 Jan 2023 01:37:20 +0100
Subject: oauth2 via uffd

this is unfortunately uffd-specific, since oauth2 is apparently sort of
a vague standard. But since it doesn't actually do much it should
probably be possible to make it fully configurable & generic if needed.
---
 lib/Yesod/Auth/Uffd.hs | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)
 create mode 100644 lib/Yesod/Auth/Uffd.hs

(limited to 'lib/Yesod/Auth')

diff --git a/lib/Yesod/Auth/Uffd.hs b/lib/Yesod/Auth/Uffd.hs
new file mode 100644
index 0000000..4d5e5af
--- /dev/null
+++ b/lib/Yesod/Auth/Uffd.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE RecordWildCards #-}
+module Yesod.Auth.Uffd (uffdClient, UffdUser(..)) where
+
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Aeson                ((.=))
+import qualified Data.Aeson                as A
+import           Data.ByteString           (ByteString)
+import qualified Data.ByteString.Char8     as C8
+import           Data.ByteString.Lazy      (fromStrict, toStrict)
+import qualified Data.Text                 as T
+import           Data.Text.Encoding        (decodeUtf8)
+import           URI.ByteString            (Absolute, URIRef (..))
+import           Yesod.Auth
+import           Yesod.Auth.OAuth2.Prelude
+import           Yesod.Core                (PathPiece (..))
+import           Yesod.Core.Handler        (setSession)
+
+data UffdUser = UffdUser
+  { uffdId          :: Int
+  , uffdName        :: Text
+  , uffdDisplayName :: Text
+  , uffdEmail       :: Text
+  , uffdGroups      :: [Text]
+  } deriving (Show)
+
+instance PathPiece UffdUser where
+  fromPathPiece = A.decode . fromStrict . C8.pack . T.unpack
+  toPathPiece = decodeUtf8 . toStrict . A.encode
+
+instance FromJSON UffdUser where
+  parseJSON = withObject "User" $ \o -> UffdUser
+    <$> o .: "id"
+    <*> o .: "nickname"
+    <*> o .: "name"
+    <*> o .: "email"
+    <*> o .: "groups"
+
+instance ToJSON UffdUser where
+  toJSON UffdUser {..} = A.object
+    [ "id" .=  uffdId
+    , "nickname" .= uffdName
+    , "name" .= uffdDisplayName
+    , "email" .= uffdEmail
+    , "groups" .= uffdGroups
+    ]
+
+pluginName = "uffd"
+
+
+uffdClient :: YesodAuth m => URIRef Absolute -> Text -> Text -> AuthPlugin m
+uffdClient url clientId clientSecret =
+  authOAuth2 "uffd" oauth2 $ \manager token -> do
+    resp@(user@UffdUser {..}, userResponse) <- authGetProfile
+      "uffd"
+      manager
+      token
+      (url { uriPath = "/oauth2/userinfo" })
+
+    pure Creds { credsPlugin = "uffd"
+               , credsIdent = T.pack $ show uffdId
+               , credsExtra =
+                 [ ("json", decodeUtf8 $ toStrict (A.encode user)) ]
+                 -- just dump the entire extra thing into the session, so we can reconstruct it later
+               }
+  where oauth2 = OAuth2
+          { oauth2ClientId = clientId
+          , oauth2ClientSecret = Just clientSecret
+          , oauth2AuthorizeEndpoint =
+              url { uriPath = "/oauth2/authorize" }
+          , oauth2TokenEndpoint =
+              url { uriPath = "/oauth2/token" }
+          , oauth2RedirectUri = Nothing
+          }
-- 
cgit v1.2.3