content: {-# LANGUAGE CPP #-}
  
  module Network.OIDC.WellKnown where
  
  import Control.Monad.Except
  #if MIN_VERSION_base(4,18,0)
  import Control.Monad.IO.Class
  #endif
  import Data.Aeson
  import Data.Aeson.Types
  import Data.Bifunctor
  import Data.ByteString.Lazy (ByteString)
  import Data.Text.Lazy (Text)
  import Data.Text.Lazy qualified as TL
  import Data.Text.Lazy.Encoding qualified as TL
  import Network.HTTP.Simple
  import Network.HTTP.Types.Status
  import URI.ByteString
  import URI.ByteString.Aeson ()
  
  -- | Slim OpenID Configuration
  --
  -- See spec <https://openid.net/specs/openid-connect-discovery-1_0.html#ProviderMetadata>
  data OpenIDConfiguration = OpenIDConfiguration
    { issuer :: URI
    , authorizationEndpoint :: URI
    , tokenEndpoint :: URI
    , userinfoEndpoint :: URI
    , jwksUri :: URI
    , deviceAuthorizationEndpoint :: URI
    }
    deriving (Show, Eq)
  
  instance FromJSON OpenIDConfiguration where
    parseJSON :: Value -> Parser OpenIDConfiguration
    parseJSON = withObject "parseJSON OpenIDConfiguration" $ \t -> do
      issuer <- t .: "issuer"
      authorizationEndpoint <- t .: "authorization_endpoint"
      tokenEndpoint <- t .: "token_endpoint"
      userinfoEndpoint <- t .: "userinfo_endpoint"
      jwksUri <- t .: "jwks_uri"
      deviceAuthorizationEndpoint <- t .: "device_authorization_endpoint"
      pure OpenIDConfiguration {..}
  
  wellknownUrl :: TL.Text
  wellknownUrl = "/.well-known/openid-configuration"
  
  fetchWellKnown ::
    MonadIO m =>
    -- | Domain
    TL.Text ->
    ExceptT Text m OpenIDConfiguration
  fetchWellKnown domain = ExceptT $ do
    let uri = "https://" <> domain <> wellknownUrl
    req <- liftIO $ parseRequest (TL.unpack uri)
    resp <- httpLbs req
    pure (handleWellKnownResponse resp)
  
  handleWellKnownResponse :: Response ByteString -> Either Text OpenIDConfiguration
  handleWellKnownResponse resp = do
    let rawBody = getResponseBody resp
    let rStatus = getResponseStatus resp
    if rStatus == status200
      then first (("handleWellKnownResponse decode response failed: " <>) . TL.pack) (eitherDecode rawBody)
      else Left $ "handleWellKnownResponse failed: " <> TL.pack (show rStatus) <> TL.decodeUtf8 rawBody
  