diff --git a/src/Server.hs b/src/Server.hs index c4507bd..c205428 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -17,10 +17,12 @@ import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar) import Control.Exception (bracket) import Control.Monad (unless, (>=>)) import Control.Monad.IO.Class +import Control.Monad.Trans.Error (Error(..)) import Control.Monad.Trans.Reader import Data.Aeson import Data.ByteString (ByteString (..), fromStrict, toStrict) +import Data.Either (fromRight) import Data.List (find, elemIndex) import Data.Maybe (fromMaybe, fromJust, isJust, isNothing) import Data.String (IsString (..)) @@ -183,9 +185,11 @@ codeServer = handleCreds ---- Token Endpoint ---- ---------------------- +newtype ACode = ACode String deriving (Show) +newtype RToken = RToken String deriving (Show) data ClientData = ClientData --TODO support other flows - { authCode :: String + { authID :: Either ACode RToken , clientID :: Maybe String , clientSecret :: Maybe String , redirect :: Maybe String @@ -198,24 +202,33 @@ instance FromHttpApiData AuthFlow where instance FromForm ClientData where fromForm f = ClientData - <$> ((parseUnique @AuthFlow "grant_type" f) *> parseUnique "code" f) + <$> ((parseUnique @AuthFlow "grant_type" f) *> ((Left . ACode <$> parseUnique "code" f) <|> (Right . RToken <$> parseUnique "refresh_token" f))) <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f +instance Error Text where + strMsg = pack + data JWTWrapper = JWTW - { token :: String - , expiresIn :: NominalDiffTime + { acessToken :: String + , expiresIn :: NominalDiffTime + , refreshToken :: Maybe String } deriving (Show) instance ToJSON JWTWrapper where - toJSON (JWTW t e) = object ["access_token" .= t, "token_type" .= ("JWT" :: Text), "expires_in" .= e] + toJSON (JWTW a e r) = object + [ "access_token" .= a + , "token_type" .= ("JWT" :: Text) + , "expires_in" .= fromEnum e + , "refresh_token" .= r ] instance FromJSON JWTWrapper where parseJSON (Object o) = JWTW - <$> o .: "access_token" - <*> o .: "expires_in" + <$> o .: "access_token" + <*> o .: "expires_in" + <*> o .:? "refresh_token" instance FromHttpApiData JWTWrapper where parseHeader bs = case decode (fromStrict bs) of @@ -235,13 +248,16 @@ tokenEndpoint = provideToken unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid client" } - mUser <- asks (verify (pack $ authCode client) (clientID client)) >>= liftIO -- TODO verify redirect url here - unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" } - -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} - let (user, scopes) = fromJust mUser - token <- asks (mkToken @user @userData user scopes) >>= liftIO - liftIO . putStrLn $ "token: " ++ show token - return token + case authID client of + Left (ACode authCode) -> do + mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here + unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" } + -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} + let (user, scopes) = fromJust mUser + token <- asks (mkToken @user @userData user scopes) >>= liftIO + liftIO . putStrLn $ "token: " ++ show token + return token + Right (RToken rToken) -> undefined mkToken :: forall user userData . UserData user userData @@ -251,13 +267,18 @@ mkToken u scopes state = do now <- getCurrentTime uuid <- nextRandom let - lifetime = nominalDay / 24 -- TODO make configurable - jwt = JWT "Oauth2MockServer" (lifetime `addUTCTime` now) uuid - encoded <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode jwt) - case encoded of - Right (Jwt token) -> do + lifetimeAT = 120 :: NominalDiffTime -- TODO make configurable + lifetimeRT = nominalDay -- TODO make configurable + at = JWT "Oauth2MockServer" (lifetimeAT `addUTCTime` now) uuid + rt = JWT "Oauth2MockServer" (lifetimeRT `addUTCTime` now) uuid + encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at) + encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt) + case encodedAT >> encodedRT of + Right _ -> do + let Jwt aToken = fromRight undefined encodedAT + Jwt rToken = fromRight undefined encodedRT atomically . modifyTVar state $ \s -> s { activeTokens = Map.insert uuid (u, scopes) (activeTokens s) } - return $ JWTW (BS.unpack token) lifetime + return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) Left e -> error $ show e @@ -286,7 +307,7 @@ userEndpoint = handleUserData handleUserData :: Text -> AuthHandler user (Maybe userData) handleUserData jwtw = do let mToken = stripPrefix "Bearer " jwtw - unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format"} + unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" } token <- asks (decodeToken @user @userData (fromJust mToken)) >>= liftIO liftIO $ putStrLn "decoded token:" >> print token case token of