diff --git a/src/Server.hs b/src/Server.hs index 408b76a..e11731c 100644 --- a/src/Server.hs +++ b/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{..} +