diff --git a/app/Main.hs b/app/Main.hs index c7441db..f732a16 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,6 +5,7 @@ module Main (main) where import UniWorX import Server import Control.Applicative ((<|>)) +import Database.Persist (Entity(..)) import System.Environment (lookupEnv) import qualified Data.Map as M import qualified Data.Text as T @@ -14,7 +15,7 @@ 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" initDB - runMockServer @User @(M.Map T.Text T.Text) port + runMockServer @(Entity User) @(M.Map T.Text T.Text) port where determinePort :: IO Int determinePort = do diff --git a/app/UniWorX.hs b/app/UniWorX.hs index b85d14f..464b209 100644 --- a/app/UniWorX.hs +++ b/app/UniWorX.hs @@ -49,7 +49,7 @@ testUsers :: [User] -- TODO move to db testUsers = [ User "Fallback User" "foo@bar.com" , User "Tina Tester" "t@t.tt" - , User "Max Muster" "m@m.mm"] + , User "Max Muster" "m@m.mm" ] runDB :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a runDB action = do @@ -63,8 +63,8 @@ initDB = runDB $ do runMigration migrateAll forM_ testUsers $ void . insert -instance UserData User (Map Text Text) where - data Scope User = ID | Profile deriving (Show, Read, Eq) +instance UserData (Entity User) (Map Text Text) where + data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq) readScope = read showScope = show userScope (Entity uID _) ID = M.singleton "id" . T.pack $ show uID diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index de2efa7..7b5938d 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -37,17 +37,11 @@ library , base64 , blaze-html , bytestring - , conduit , containers , http-api-data , http-client , http-media , jose-jwt - , monad-logger - , mtl - , persistent - , persistent-postgresql - , persistent-template , servant , servant-client , servant-server @@ -116,18 +110,12 @@ 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 - , persistent-template , servant , servant-client , servant-server diff --git a/package.yaml b/package.yaml index 456f35a..5aa80c6 100644 --- a/package.yaml +++ b/package.yaml @@ -40,12 +40,6 @@ dependencies: - blaze-html - http-media - string-interpolate -- persistent -- persistent-postgresql -- persistent-template -- monad-logger -- conduit -- mtl ghc-options: - -Wall @@ -71,6 +65,12 @@ executables: - -with-rtsopts=-N dependencies: - oauth2-mock-server + - persistent + - persistent-postgresql + - persistent-template + - monad-logger + - conduit + - mtl tests: oauth2-mock-server-test: diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 30f8930..1d23864 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -21,8 +21,6 @@ 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, (>=>)) @@ -47,7 +45,7 @@ instance FromJSON JWT where data AuthRequest user = AuthRequest { client :: String , codeExpiration :: NominalDiffTime - , user :: Entity user + , user :: user , scopes :: [Scope user] } @@ -55,7 +53,7 @@ data AuthRequest user = AuthRequest data State user = State { activeCodes :: Map Text (AuthRequest user) - , activeTokens :: Map UUID (Entity user, [Scope user]) + , activeTokens :: Map UUID (user, [Scope user]) , publicKey :: Jwk , privateKey :: Jwk } @@ -86,7 +84,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 (Entity user, [Scope user])) +verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user])) verify code mClientID state = do now <- getCurrentTime mData <- atomically $ do diff --git a/src/Server.hs b/src/Server.hs index 7089d23..c4507bd 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -34,8 +34,6 @@ 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 @@ -247,7 +245,7 @@ tokenEndpoint = provideToken mkToken :: forall user userData . UserData user userData - => Entity user -> [Scope user] -> AuthState user -> IO JWTWrapper + => user -> [Scope user] -> AuthState user -> IO JWTWrapper mkToken u scopes state = do pubKey <- atomically $ readTVar state >>= return . publicKey now <- getCurrentTime diff --git a/src/User.hs b/src/User.hs index f1080e5..edd219e 100644 --- a/src/User.hs +++ b/src/User.hs @@ -1,50 +1,18 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-} -module User -( UserData(..) --- , User (..) --- , testUsers -) where +module User ( UserData(..) ) where import Data.Aeson -import Data.List (find) import Data.Map.Strict import Data.Maybe -import Data.Text hiding (singleton, find) - -import Database.Persist (PersistEntity(..), Entity(..)) - -import GHC.Generics +import Data.Text type UserName = Text type Password = Text -class (PersistEntity u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary +class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary data Scope u readScope :: String -> Scope u showScope :: Scope u -> String - userScope :: Entity u -> Scope u -> a - lookupUser :: UserName -> Password -> IO (Maybe (Entity u)) - - --- data User = User --- { name :: Text --- , email :: Text --- , password :: Text --- , uID :: Text --- } deriving (Eq, Show) - --- testUsers :: [User] -- TODO move to db --- testUsers = --- [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"} --- , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"} --- , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}] - - --- instance UserData User (Map Text Text) where --- data Scope User = ID | Profile deriving (Show, Read, Eq) --- readScope = read --- showScope = show --- userScope User{..} ID = singleton "id" uID --- userScope User{..} Profile = fromList [("name", name), ("email", email)] --- lookupUser e _ = return $ find (\User{..} -> email == e) testUsers \ No newline at end of file + userScope :: u -> Scope u -> a + lookupUser :: UserName -> Password -> IO (Maybe u)