144 lines
4.9 KiB
Haskell
144 lines
4.9 KiB
Haskell
{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications #-}
|
|
|
|
module Server
|
|
( insecureOAuthMock'
|
|
, runMockServer
|
|
, runMockServer'
|
|
) where
|
|
|
|
import AuthCode
|
|
import User
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.STM.TVar (newTVarIO)
|
|
import Control.Exception (bracket)
|
|
import Control.Monad (unless)
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Reader
|
|
|
|
import Data.Aeson
|
|
import Data.List (find)
|
|
import Data.Text hiding (elem, find, head, map, words)
|
|
import Data.Text.Encoding (decodeUtf8)
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import Network.HTTP.Client (newManager, defaultManagerSettings)
|
|
import Network.Wai.Handler.Warp
|
|
|
|
import Servant
|
|
import Servant.Client
|
|
import Servant.API
|
|
|
|
import Text.ParserCombinators.ReadPrec (look)
|
|
import Text.Read (readPrec)
|
|
|
|
|
|
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"}]
|
|
|
|
trustedClients :: [Text] -- TODO move to db
|
|
trustedClients = ["42"]
|
|
|
|
data ResponseType = Code -- ^ authorisation code grant
|
|
| Token -- ^ implicit grant via access token
|
|
| 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
|
|
|
|
type QScope = String
|
|
type QClient = String
|
|
type QResType = String
|
|
type QRedirect = String
|
|
|
|
type QParam = QueryParam' [Required, Strict]
|
|
|
|
type Auth user userData = BasicAuth "login" user
|
|
:> "auth"
|
|
:> QParam "scope" QScope
|
|
:> QParam "client_id" QClient
|
|
:> QParam "response_type" QResType
|
|
:> QParam "redirect_uri" QRedirect
|
|
:> Get '[JSON] userData
|
|
|
|
type Token = "token" :> Post '[JSON] Text -- TODO post jwt token
|
|
-- type Insert = "insert" :> Post '[JSON] User
|
|
|
|
|
|
type AuthHandler = ReaderT AuthState Handler
|
|
type AuthServer a = ServerT a AuthHandler
|
|
|
|
toHandler :: AuthState -> AuthHandler a -> Handler a
|
|
toHandler s h = runReaderT h s
|
|
|
|
authServer :: forall user userData . UserData user userData => AuthServer (Auth user userData)
|
|
authServer = handleAuth
|
|
where
|
|
handleAuth :: user
|
|
-> QScope
|
|
-> QClient
|
|
-> QResType
|
|
-> QRedirect
|
|
-> AuthHandler userData
|
|
handleAuth u scopes client responseType url = do
|
|
unless (pack client `elem` 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
|
|
mAuthCode <- asks (genUnencryptedCode client url 600) >>= liftIO
|
|
liftIO $ print mAuthCode
|
|
liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
|
|
return uData
|
|
|
|
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 <- newTVarIO $ State { activeCodes = Map.empty }
|
|
run port $ insecureOAuthMock' testUsers state
|
|
|
|
runMockServer' :: Int -> IO ()
|
|
runMockServer' port = do
|
|
mgr <- newManager defaultManagerSettings
|
|
state <- newTVarIO $ State { activeCodes = Map.empty }
|
|
bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
|
|
runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
|
|
>>= print
|
|
|
|
|
|
tokenEndpoint :: Server Token
|
|
tokenEndpoint = undefined
|
|
|