removed specific user types from library

2024-01-16 03:06:13 +01:00 · 2024-01-16 03:06:13 +01:00 · 4ccd17d357
commit 4ccd17d357
parent a0c5ed71de
8 changed files with 83 additions and 47 deletions
--- a/README.md
+++ b/README.md
@ -1 +1,5 @@
 # oauth2-mock-server
+ Windows:
+ ```
+ ghcup run --mingw-path -- stack run
+ ```
--- a/app/Main.hs
+++ b/app/Main.hs
@ -7,14 +7,15 @@ import Server
 import Control.Applicative ((<|>))
 import System.Environment (lookupEnv)
 import qualified Data.Map as M
+import qualified Data.Text as T

 main :: IO ()
 main = do
  port <- determinePort
  putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F"
-  runMockServer port testUsers
+  runMockServer @User @(M.Map T.Text T.Text) port
    where
      determinePort :: IO Int
      determinePort = do
-        Just port <- (read @Int <$> lookupEnv "OAUTH2_SERVER_PORT") <|> Just 9443
-        return port
+        Just port <- lookupEnv "OAUTH2_SERVER_PORT" >>= \p -> return $ p <|> Just "9443"
+        return $ read @Int port
--- a/app/UniWorX.hs
+++ b/app/UniWorX.hs
@ -1,4 +1,17 @@
-{-# Language GADTs, GeneralizedNewtypeDeriving, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+{-# Language GADTs,
+             GeneralizedNewtypeDeriving,
+             OverloadedStrings,
+             QuasiQuotes,
+             TemplateHaskell,
+             TypeFamilies,
+             TypeApplications,
+             DerivingStrategies,
+             StandaloneDeriving,
+             UndecidableInstances,
+             DataKinds,
+             FlexibleInstances,
+             MultiParamTypeClasses,
+             RecordWildCards #-}

 module UniWorX (User(..), initDB, testUsers) where

@ -6,6 +19,17 @@ import User

 import Control.Applicative ((<|>))
 import Control.Monad (void, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger (runStderrLoggingT, NoLoggingT)
+import Control.Monad.Reader (ReaderT)
+
+import Conduit (ResourceT)
+
+import Data.Map (Map(..))
+import Data.String (IsString(..))
+import Data.Text (Text(..))
+import qualified Data.Map as M
+import qualified Data.Text as T

 import Database.Persist
 import Database.Persist.TH
@ -23,15 +47,15 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|

 testUsers :: [User] -- TODO move to db
 testUsers =
-  [ User {name = "Fallback User", email = "foo@bar.com"}
-  , User {name = "Tina Tester", email = "t@t.tt"}
-  , User {name = "Max Muster", email = "m@m.mm"}]
+  [ User "Fallback User" "foo@bar.com"
+  , User "Tina Tester" "t@t.tt"
+  , User "Max Muster" "m@m.mm"]

-runDB :: IO a -> IO a
+runDB :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
 runDB action = do
-  Just port <- lookupEnv "OAUTH2_DB_PORT" <|> Just "9444"
-  let connStr = "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port
-  withPostgresqlPool connStr 10 $ \pool -> flip runSqlPersistMPool pool action
+  Just port <- lookupEnv "OAUTH2_DB_PORT" >>= \p -> return $ p <|> Just "9444"
+  let connStr = fromString @ConnectionString $ "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port
+  runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ flip runSqlPersistMPool pool action

 initDB :: IO ()
 initDB = runDB $ do
@ -42,11 +66,11 @@ instance UserData User (Map Text Text) where
  data Scope User = ID | Profile deriving (Show, Read, Eq)
  readScope = read
  showScope = show
-  userScope (Entity uID _) ID = singleton "id" uID
-  userScope (Entity _ User{..}) Profile = fromList [("name", name), ("email", email)]
+  userScope (Entity uID _) ID = M.singleton "id" . T.pack $ show uID
+  userScope (Entity _ User{..}) Profile = M.fromList [("name", userName), ("email", userEmail)]
  lookupUser email _ = runDB $ do
-    user <- selectList [UserEmail ==. e] []
+    user <- selectList [UserEmail ==. email] []
    case user of
-      [Entity _ u] -> return $ Just u
-      [] -> Nothing
+      [entity] -> return $ Just entity
+      [] -> return Nothing
      _ -> error "Ambiguous User."
--- a/oauth2-mock-server.cabal
+++ b/oauth2-mock-server.cabal
@ -37,11 +37,14 @@ library
    , base64
    , blaze-html
    , bytestring
+    , conduit
    , containers
    , http-api-data
    , http-client
    , http-media
    , jose-jwt
+    , monad-logger
+    , mtl
    , persistent
    , persistent-postgresql
    , persistent-template
@ -73,11 +76,14 @@ executable oauth2-mock-server-exe
    , base64
    , blaze-html
    , bytestring
+    , conduit
    , containers
    , http-api-data
    , http-client
    , http-media
    , jose-jwt
+    , monad-logger
+    , mtl
    , oauth2-mock-server
    , persistent
    , persistent-postgresql
@ -110,11 +116,14 @@ test-suite oauth2-mock-server-test
    , base64
    , blaze-html
    , bytestring
+    , conduit
    , containers
    , http-api-data
    , http-client
    , http-media
    , jose-jwt
+    , monad-logger
+    , mtl
    , oauth2-mock-server
    , persistent
    , persistent-postgresql
--- a/package.yaml
+++ b/package.yaml
@ -43,6 +43,9 @@ dependencies:
 - persistent
 - persistent-postgresql
 - persistent-template
+- monad-logger
+- conduit
+- mtl

 ghc-options:
 - -Wall
--- a/src/AuthCode.hs
+++ b/src/AuthCode.hs
@ -21,6 +21,8 @@ import Data.UUID

 import qualified Data.Map.Strict as M

+import Database.Persist (Entity(..))
+
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.STM.TVar
 import Control.Monad (void, (>=>))
@ -45,7 +47,7 @@ instance FromJSON JWT where
 data AuthRequest user = AuthRequest
  { client :: String
  , codeExpiration :: NominalDiffTime
-  , user :: user
+  , user :: Entity user
  , scopes :: [Scope user]
  }

@ -53,7 +55,7 @@ data AuthRequest user = AuthRequest

 data State user = State
  { activeCodes :: Map Text (AuthRequest user)
-  , activeTokens :: Map UUID (user, [Scope user])
+  , activeTokens :: Map UUID (Entity user, [Scope user])
  , publicKey   :: Jwk
  , privateKey  :: Jwk
  }
@ -84,7 +86,7 @@ expire code time state = void . forkIO $ do
  atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }


-verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user]))
+verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (Entity user, [Scope user]))
 verify code mClientID state = do
  now <- getCurrentTime
  mData <- atomically $ do
--- a/src/Server.hs
+++ b/src/Server.hs
@ -34,6 +34,8 @@ import Data.UUID.V4
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Map.Strict as Map

+import Database.Persist (Entity(..))
+
 import GHC.Read (readPrec, lexP)

 import Jose.Jwa
@ -99,7 +101,6 @@ type QParam = QueryParam' [Required, Strict]

 -- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password
 -- type QuickAuth = "qauth" :> Auth -- Prompts for username only
-type Foo user userData = BasicAuth "login" user :> "foo" :> Get '[JSON] userData
 type Auth = "auth"
         :> QParam "scope" QScope
         :> QParam "client_id" QClient
@ -246,7 +247,7 @@ tokenEndpoint = provideToken


 mkToken :: forall user userData . UserData user userData
-        => user -> [Scope user] -> AuthState user -> IO JWTWrapper
+        => Entity user -> [Scope user] -> AuthState user -> IO JWTWrapper
 mkToken u scopes state = do
  pubKey <- atomically $ readTVar state >>= return . publicKey
  now <- getCurrentTime
@ -273,7 +274,7 @@ type HeaderR = Header' [Strict, Required]
 type Me userData = Users
                :> "me"
                :> HeaderR "Authorization" Text
-                :> Get '[JSON] userData
+                :> Get '[JSON] (Maybe userData)

 type UserList userData = Users
                      :> "query"
@ -284,7 +285,7 @@ type UserList userData = Users
 userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData)
 userEndpoint = handleUserData
  where
-    handleUserData :: Text -> AuthHandler user userData
+    handleUserData :: Text -> AuthHandler user (Maybe userData)
    handleUserData jwtw = do
      let mToken = stripPrefix "Bearer " jwtw
      unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format"}
@ -298,7 +299,7 @@ userEndpoint = handleUserData
          liftIO $ print jwt
          mUser <- ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens)
          case mUser of
-            Just (u, scopes) -> return . mconcat $ map (userScope @user @userData u) scopes
+            Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes
            Nothing -> throwError $ err500 { errBody = "Unknown token" }
      

@ -324,7 +325,6 @@ type Routing user userData = Auth
                        :<|> Token
                        :<|> Me userData
                        :<|> UserList userData
-                        :<|> Foo user userData
                        -- :<|> "qauth" :> Get '[HTML] Html

 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
@ -333,40 +333,33 @@ routing = loginServer @user @userData
     :<|> tokenEndpoint @user @userData
     :<|> userEndpoint @user @userData
     :<|> userListEndpoint @user @userData
-     :<|> undefined
    --  :<|> return (loginPage "/foobar")

-exampleAuthServer :: AuthServer User (Routing User (Map.Map Text Text))
-exampleAuthServer = routing


-authAPI :: Proxy (Routing User (Map.Map Text Text))
-authAPI = Proxy
-
 -- insecureOAuthMock :: Application
 -- insecureOAuthMock = authAPI `serve` exampleAuthServer

-insecureOAuthMock' :: [User] -> AuthState User -> Application
-insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler @User @(Map.Map Text Text) s) exampleAuthServer
+insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application
+insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData)
  where
-    c = authenticate testUsers :. EmptyContext
-    p = Proxy :: Proxy '[BasicAuthCheck User]
+    authAPI = Proxy @(Routing user userData)

-authenticate :: [User] -> BasicAuthCheck User
-authenticate users = BasicAuthCheck $ \authData -> do
-  let
-    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
-  case (find (\u -> email u == uEmail) users) of
-    Nothing -> return NoSuchUser
-    Just u  -> return $ if uPass == password u then Authorized u else BadPassword
+-- authenticate :: [User] -> BasicAuthCheck User
+-- authenticate users = BasicAuthCheck $ \authData -> do
+--   let
+--     (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
+--   case (find (\u -> email u == uEmail) users) of
+--     Nothing -> return NoSuchUser
+--     Just u  -> return $ if uPass == password u then Authorized u else BadPassword

 -- frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
 -- frontend ba = client authAPI ba "[ID]" "42" "code" ""

-runMockServer :: Int -> [User] -> IO ()
-runMockServer port testUsers = do
-  state <- mkState @User @(Map.Map Text Text)
-  run port $ insecureOAuthMock' testUsers state
+runMockServer :: forall user userData . UserData user userData => Int -> IO ()
+runMockServer port = do
+  state <- mkState @user @userData
+  run port $ insecureOAuthMock' @user @userData state

 -- runMockServer' :: Int -> IO ()
 -- runMockServer' port = do
--- a/src/User.hs
+++ b/src/User.hs
@ -24,7 +24,7 @@ class (PersistEntity u, Show u, ToJSON a, Monoid a) => UserData u a where -- TOD
  readScope :: String -> Scope u
  showScope :: Scope u -> String
  userScope  :: Entity u -> Scope u -> a
-  lookupUser :: UserName -> Password -> IO (Maybe u)
+  lookupUser :: UserName -> Password -> IO (Maybe (Entity u))


 -- data User = User