added user endpoint for queries
This commit is contained in:
David Mosbach
parent
58423c6466
commit
564f964f7f
220
src/Server.hs
220
src/Server.hs
@ -1,10 +1,10 @@
|
||||
{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards #-}
|
||||
{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-}
|
||||
|
||||
module Server
|
||||
( insecureOAuthMock'
|
||||
{-( insecureOAuthMock'
|
||||
, runMockServer
|
||||
, runMockServer'
|
||||
) where
|
||||
-- , runMockServer'
|
||||
)-} where
|
||||
|
||||
import AuthCode
|
||||
import User
|
||||
@ -19,7 +19,7 @@ import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString (..), toStrict)
|
||||
import Data.ByteString (ByteString (..), fromStrict, toStrict)
|
||||
import Data.List (find, elemIndex)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.String (IsString (..))
|
||||
@ -30,6 +30,8 @@ import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurren
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import GHC.Read (readPrec, lexP)
|
||||
|
||||
import Jose.Jwa
|
||||
import Jose.Jwe
|
||||
import Jose.Jwk (generateRsaKeyPair, generateSymmetricKey, KeyUse(Enc), KeyId)
|
||||
@ -42,8 +44,9 @@ import Servant
|
||||
import Servant.Client
|
||||
import Servant.API
|
||||
|
||||
import Text.ParserCombinators.ReadPrec (look)
|
||||
import Text.Read (readPrec)
|
||||
import Text.ParserCombinators.ReadPrec (look, pfail)
|
||||
|
||||
import qualified Text.Read.Lex as Lex
|
||||
|
||||
|
||||
testUsers :: [User] -- TODO move to db
|
||||
@ -65,15 +68,24 @@ data ResponseType = Code -- ^ authorisation code grant
|
||||
| IDToken -- ^ implicit grant via access token & ID token
|
||||
deriving (Eq, Show)
|
||||
instance Read ResponseType where
|
||||
readPrec = look >>= \str -> return $ case str of
|
||||
"code" -> Code
|
||||
"token" -> Token
|
||||
"id_token" -> IDToken
|
||||
readPrec = do
|
||||
Lex.Ident str <- lexP
|
||||
Lex.EOF <- lexP
|
||||
case str of
|
||||
"code" -> return Code
|
||||
"token" -> return Token
|
||||
"id_token" -> return IDToken
|
||||
_ -> pfail
|
||||
|
||||
------------------------------
|
||||
---- Authorisation endpoint ----
|
||||
------------------------------
|
||||
|
||||
type QScope = String
|
||||
type QClient = String
|
||||
type QResType = String
|
||||
type QRedirect = String
|
||||
type QState = String
|
||||
|
||||
type QParam = QueryParam' [Required, Strict]
|
||||
|
||||
@ -83,6 +95,7 @@ type Auth user userData = BasicAuth "login" user
|
||||
:> QParam "client_id" QClient
|
||||
:> QParam "response_type" QResType
|
||||
:> QParam "redirect_uri" QRedirect
|
||||
:> QueryParam "state" QState
|
||||
:> Get '[JSON] userData
|
||||
|
||||
-- type Insert = "insert" :> Post '[JSON] User
|
||||
@ -102,80 +115,34 @@ authServer = handleAuth
|
||||
-> QClient
|
||||
-> QResType
|
||||
-> QRedirect
|
||||
-> Maybe QState
|
||||
-> AuthHandler userData
|
||||
handleAuth u scopes client responseType url = do
|
||||
handleAuth u scopes client responseType url mState = do
|
||||
unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
|
||||
throwError $ err404 { errBody = "Not a trusted client."}
|
||||
let
|
||||
scopes' = map (readScope @user @userData) $ words scopes
|
||||
uData = mconcat $ map (userScope @user @userData u) scopes'
|
||||
responseType' = read @ResponseType responseType
|
||||
let responseType' = read @ResponseType responseType
|
||||
liftIO $ print responseType'
|
||||
unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
|
||||
mAuthCode <- asks (genUnencryptedCode client url 600) >>= liftIO
|
||||
liftIO $ print mAuthCode
|
||||
liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
|
||||
-- return uData
|
||||
redirect $ url `withCode` mAuthCode
|
||||
-- liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
|
||||
redirect $ addParams url mAuthCode mState
|
||||
redirect :: Maybe ByteString -> AuthHandler userData
|
||||
redirect (Just url) = throwError err303 { errHeaders = [("Location", url)]}
|
||||
redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
|
||||
withCode :: String -> Maybe String -> Maybe ByteString
|
||||
withCode url Nothing = Nothing
|
||||
withCode url (Just code) =
|
||||
addParams :: String -> Maybe String -> Maybe String -> Maybe ByteString
|
||||
addParams url Nothing _ = Nothing
|
||||
addParams url (Just code) mState =
|
||||
let qPos = fromMaybe (length url) $ elemIndex '?' url
|
||||
(pre, post) = splitAt qPos url
|
||||
rState = case mState of {Just s -> "&state=" ++ s; Nothing -> ""}
|
||||
post' = if not (null post) then '&' : tail post else post
|
||||
in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post'
|
||||
in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post' ++ rState
|
||||
|
||||
|
||||
exampleAuthServer :: AuthServer (Auth User (Map.Map Text Text))
|
||||
exampleAuthServer = authServer
|
||||
|
||||
authAPI :: Proxy (Auth User (Map.Map Text Text))
|
||||
authAPI = Proxy
|
||||
|
||||
-- insecureOAuthMock :: Application
|
||||
-- insecureOAuthMock = authAPI `serve` exampleAuthServer
|
||||
|
||||
insecureOAuthMock' :: [User] -> AuthState -> Application
|
||||
insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler s) exampleAuthServer
|
||||
where
|
||||
c = authenticate testUsers :. EmptyContext
|
||||
p = Proxy :: Proxy '[BasicAuthCheck User]
|
||||
|
||||
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 -> IO ()
|
||||
runMockServer port = do
|
||||
state <- mkState
|
||||
run port $ insecureOAuthMock' testUsers state
|
||||
|
||||
runMockServer' :: Int -> IO ()
|
||||
runMockServer' port = do
|
||||
mgr <- newManager defaultManagerSettings
|
||||
state <- mkState
|
||||
bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
|
||||
runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
|
||||
>>= print
|
||||
|
||||
mkState :: IO AuthState
|
||||
mkState = do
|
||||
(publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
|
||||
let activeCodes = Map.empty
|
||||
newTVarIO State{..}
|
||||
|
||||
|
||||
------
|
||||
------ Token
|
||||
------
|
||||
----------------------
|
||||
---- Token Endpoint ----
|
||||
----------------------
|
||||
|
||||
|
||||
data ClientData = ClientData
|
||||
@ -228,9 +195,19 @@ data JWTWrapper = JWTW
|
||||
instance ToJSON JWTWrapper where
|
||||
toJSON (JWTW t e) = object ["access_token" .= t, "token_type" .= ("JWT" :: Text), "expires_in" .= e]
|
||||
|
||||
instance FromJSON JWTWrapper where
|
||||
parseJSON (Object o) = JWTW
|
||||
<$> o .: "access_token"
|
||||
<*> o .: "expires_in"
|
||||
|
||||
instance FromHttpApiData JWTWrapper where
|
||||
parseHeader bs = case decode (fromStrict bs) of
|
||||
Just x -> Right x
|
||||
Nothing -> Left "Invalid JWT wrapper"
|
||||
|
||||
type Token = "token"
|
||||
:> ReqBody '[JSON] ClientData
|
||||
:> Post '[JSON] JWTWrapper
|
||||
:> Get '[JSON] JWTWrapper
|
||||
|
||||
tokenEndpoint :: AuthServer Token
|
||||
tokenEndpoint = provideToken
|
||||
@ -261,3 +238,100 @@ mkToken state = do
|
||||
Left e -> error $ show e
|
||||
|
||||
|
||||
----------------------
|
||||
---- Users Endpoint ----
|
||||
----------------------
|
||||
|
||||
|
||||
type Users = "users"
|
||||
|
||||
type Me userData = Users
|
||||
:> Header "Authorization" JWTWrapper
|
||||
:> Get '[JSON] userData
|
||||
|
||||
type UserList userData = Users
|
||||
:> Header "Authorization" JWTWrapper
|
||||
:> Get '[JSON] [userData] -- TODO support query params
|
||||
|
||||
|
||||
userEndpoint :: forall user userData . UserData user userData => AuthServer (Me userData)
|
||||
userEndpoint = handleUserData
|
||||
where
|
||||
handleUserData :: Maybe JWTWrapper -> AuthHandler userData
|
||||
handleUserData jwtw = do
|
||||
undefined
|
||||
-- let
|
||||
-- scopes' = map (readScope @user @userData) $ words scopes
|
||||
-- uData = mconcat $ map (userScope @user @userData u) scopes'
|
||||
-- liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
|
||||
-- return uData
|
||||
|
||||
userListEndpoint :: forall user userData . UserData user userData => AuthServer (UserList userData)
|
||||
userListEndpoint = handleUserData
|
||||
where
|
||||
handleUserData :: Maybe JWTWrapper -> AuthHandler [userData]
|
||||
handleUserData jwtw = do
|
||||
undefined
|
||||
|
||||
|
||||
-------------------
|
||||
---- Server Main ----
|
||||
-------------------
|
||||
|
||||
type Routing user userData = Auth user userData
|
||||
:<|> Token
|
||||
:<|> Me userData
|
||||
:<|> UserList userData
|
||||
|
||||
routing :: forall user userData . UserData user userData => AuthServer (Routing user userData)
|
||||
routing = authServer @user @userData
|
||||
:<|> tokenEndpoint
|
||||
:<|> userEndpoint @user @userData
|
||||
:<|> userListEndpoint @user @userData
|
||||
|
||||
exampleAuthServer :: AuthServer (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 -> Application
|
||||
insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler s) exampleAuthServer
|
||||
where
|
||||
c = authenticate testUsers :. EmptyContext
|
||||
p = Proxy :: Proxy '[BasicAuthCheck User]
|
||||
|
||||
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 -> IO ()
|
||||
runMockServer port = do
|
||||
state <- mkState
|
||||
run port $ insecureOAuthMock' testUsers state
|
||||
|
||||
-- runMockServer' :: Int -> IO ()
|
||||
-- runMockServer' port = do
|
||||
-- mgr <- newManager defaultManagerSettings
|
||||
-- state <- mkState
|
||||
-- bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
|
||||
-- runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
|
||||
-- >>= print
|
||||
|
||||
mkState :: IO AuthState
|
||||
mkState = do
|
||||
(publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
|
||||
let activeCodes = Map.empty
|
||||
newTVarIO State{..}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user