diff --git a/src/Server.hs b/src/Server.hs index 64269af..9764359 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings #-} +{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications #-} module Server ( insecureOAuthMock @@ -8,6 +8,7 @@ import User import Control.Monad.IO.Class +import Data.Aeson import Data.List (find) import Data.Text hiding (find, head, map) @@ -22,27 +23,30 @@ testUsers = [ User {name = "TestName", email = "foo@bar.com", uID = "1"}] -type Auth = "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe (Map.Map Text Text)) +type Auth userData = "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe userData) -- TODO also parametrise "auth" to (auth :: Symbol) type Token = "token" :> Post '[JSON] Text -- TODO post jwt token -- type Insert = "insert" :> Post '[JSON] User -authServer :: Server Auth -authServer = handleAuth +authServer :: forall user userData . UserData user userData => [user] -> Server (Auth userData) +authServer testUsers = handleAuth where - handleAuth :: Maybe String -> Handler (Maybe (Map.Map Text Text)) + handleAuth :: Maybe String -> Handler (Maybe userData) handleAuth Nothing = liftIO (putStrLn "no query param given") >> return Nothing handleAuth (Just x) = do let - scopes = read x :: [Scope] - userData = mconcat $ map (userScope $ head testUsers) scopes - liftIO (putStrLn $ "query param: " ++ show scopes) - return $ Just userData + scopes = readScopes @user @userData x + ud = mconcat $ map (userScope @user @userData $ head testUsers) scopes + liftIO (putStrLn $ "query param: " ++ showScopes @user @userData scopes) + return $ Just ud -authAPI :: Proxy Auth +exampleAuthServer :: Server (Auth (Map.Map Text Text)) +exampleAuthServer = authServer testUsers + +authAPI :: Proxy (Auth (Map.Map Text Text)) authAPI = Proxy insecureOAuthMock :: Application -insecureOAuthMock = authAPI `serve` authServer +insecureOAuthMock = authAPI `serve` exampleAuthServer tokenEndpoint :: Server Token tokenEndpoint = undefined diff --git a/src/User.hs b/src/User.hs index 853e6ea..955236f 100644 --- a/src/User.hs +++ b/src/User.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DeriveGeneric, OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-} module User -( - User (..) -, Scope (..) -, userScope +( UserData(..) +, User (..) ) where import Data.Aeson @@ -14,16 +12,24 @@ import Data.Text hiding (singleton) import GHC.Generics +class (Eq u, ToJSON a, Monoid a) => UserData u a where -- TODO Eq maybe not necessary, but currently needed for TypeApplications + data Scope u + readScopes :: String -> [Scope u] + showScopes :: [Scope u] -> String + userScope :: u -> Scope u -> a + + data User = User - { name :: Text - , email :: Text - , uID :: Text - } deriving (Eq, Show, Generic) + { name :: Text + , email :: Text + , password :: Text + , uID :: Text + } deriving (Eq, Show) -instance ToJSON User -data Scope = ID | Profile deriving (Show, Read, Eq) - -userScope :: User -> Scope -> Map Text Text -userScope User{..} ID = singleton "id" uID -userScope User{..} Profile = fromList [("name", name), ("email", email)] \ No newline at end of file +instance UserData User (Map Text Text) where + data Scope User = ID | Profile deriving (Show, Read, Eq) + readScopes = read + showScopes = show + userScope User{..} ID = singleton "id" uID + userScope User{..} Profile = fromList [("name", name), ("email", email)] \ No newline at end of file