inter-hub-haskell/Web/Controller/Api/V2/Token.hs

module Web.Controller.Api.V2.Token where

-- POST /api/v2/token — OAuth 2.0 client credentials grant
-- Returns a short-lived opaque access token stored in api_keys.

import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (object, (.=))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.UUID as UUID
import qualified "cryptohash-sha256" Crypto.Hash.SHA256 as SHA256
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Random as Random
import Data.Time (addUTCTime)
import Network.Wai (requestMethod)
import Web.Controller.Api.V2.Auth (respondWithStatus, hashApiKey)

instance Controller ApiV2TokenController where

    action ApiV2CreateTokenAction = do
        when (requestMethod ?request /= "POST") do
            respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]

        let grantType    = paramOrNothing @Text "grant_type"
            clientId     = paramOrNothing @Text "client_id"
            clientSecret = paramOrNothing @Text "client_secret"
            mScope       = paramOrNothing @Text "scope"

        -- grant_type must be client_credentials
        case grantType of
            Just "client_credentials" -> pure ()
            Just _  -> respondWithStatus 400 $ object
                [ "error" .= ("unsupported_grant_type" :: Text) ]
            Nothing -> respondWithStatus 400 $ object
                [ "error" .= ("invalid_request" :: Text)
                , "error_description" .= ("grant_type is required" :: Text)
                ]

        -- Both client_id and client_secret required
        case (clientId, clientSecret) of
            (Nothing, _) -> respondWithStatus 400 $ object
                [ "error" .= ("invalid_request" :: Text)
                , "error_description" .= ("client_id is required" :: Text)
                ]
            (_, Nothing) -> respondWithStatus 400 $ object
                [ "error" .= ("invalid_request" :: Text)
                , "error_description" .= ("client_secret is required" :: Text)
                ]
            (Just cid, Just csec) -> do
                -- Look up consumer by id
                case UUID.fromText cid of
                    Nothing -> respondWithStatus 400 $ object
                        ["error" .= ("invalid_client" :: Text)]
                    Just rawId -> do
                        let consumerId = Id rawId :: Id ApiConsumer
                        mConsumer <- fetchOneOrNothing consumerId
                        case mConsumer of
                            Nothing -> respondWithStatus 400 $ object
                                ["error" .= ("invalid_client" :: Text)]
                            Just consumer -> do
                                unless consumer.isActive $ respondWithStatus 400 $ object
                                    ["error" .= ("invalid_client" :: Text)]

                                -- Validate secret against a static key for this consumer
                                let secretHash = hashApiKey csec
                                mKey <- query @ApiKey
                                    |> filterWhere (#apiConsumerId, consumer.id)
                                    |> filterWhere (#keyHash, secretHash)
                                    |> filterWhere (#tokenType, "static")
                                    |> fetchOneOrNothing
                                case mKey of
                                    Nothing -> respondWithStatus 400 $ object
                                        ["error" .= ("invalid_client" :: Text)]
                                    Just _ -> do
                                        -- Validate requested scopes
                                        let scopes = maybe [] (T.splitOn " ") mScope
                                        validatedScopes <- validateScopes consumer scopes
                                        case validatedScopes of
                                            Left errCode -> respondWithStatus 400 $ object
                                                ["error" .= errCode]
                                            Right scopeStr -> do
                                                -- Issue token
                                                rawToken <- liftIO $ Random.random 32
                                                let tokenText = TE.decodeUtf8 (Base16.encode rawToken)
                                                let tokenHash = hashApiKey tokenText
                                                let prefix = T.take 8 tokenText
                                                now <- getCurrentTime
                                                let expiresAt = addUTCTime 3600 now
                                                _key <- newRecord @ApiKey
                                                    |> set #apiConsumerId consumer.id
                                                    |> set #keyPrefix prefix
                                                    |> set #keyHash tokenHash
                                                    |> set #scopes scopeStr
                                                    |> set #tokenType "oauth"
                                                    |> set #expiresAt (Just expiresAt)
                                                    |> createRecord
                                                renderJson $ object
                                                    [ "access_token" .= tokenText
                                                    , "token_type"   .= ("Bearer" :: Text)
                                                    , "expires_in"   .= (3600 :: Int)
                                                    , "scope"        .= scopeStr
                                                    ]

-- | Validate requested scope strings against the consumer's permissions.
-- hub:{slug}:write requires an active manifest for that hub.
validateScopes :: (?modelContext :: ModelContext) => ApiConsumer -> [Text] -> IO (Either Text Text)
validateScopes consumer scopes = do
    results <- mapM (validateScope consumer) scopes
    case lefts results of
        (e:_) -> pure (Left e)
        []    -> pure (Right (T.intercalate " " scopes))

validateScope :: (?modelContext :: ModelContext) => ApiConsumer -> Text -> IO (Either Text Text)
validateScope _consumer scope
    | scope == "framework:read"               = pure (Right scope)
    | "hub:" `T.isPrefixOf` scope && ":read" `T.isSuffixOf` scope = pure (Right scope)
    | "hub:" `T.isPrefixOf` scope && ":write" `T.isSuffixOf` scope =
        -- Write scope requires an active manifest
        case _consumer.hubCapabilityManifestId of
            Nothing -> pure (Left "invalid_scope")
            Just manifestId -> do
                manifest <- fetch manifestId
                if manifest.status == "active"
                    then pure (Right scope)
                    else pure (Left "invalid_scope")
    | otherwise = pure (Left "invalid_scope")