{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.
{-# LANGUAGE TemplateHaskell #-}

module Wire.API.User.IdentityProvider where

import Cassandra qualified as Cql
import Control.Lens (makeLenses, (.~), (?~))
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types (parseMaybe)
import Data.Attoparsec.ByteString qualified as AP
import Data.Binary.Builder qualified as BSB
import Data.ByteString.Conversion qualified as BSC
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Id (TeamId)
import Data.OpenApi
import Data.Proxy (Proxy (Proxy))
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Data.Text.Lazy qualified as LT
import Imports
import Network.HTTP.Media ((//))
import SAML2.WebSSO (IdPConfig)
import SAML2.WebSSO qualified as SAML
import SAML2.WebSSO.Types.TH (deriveJSONOptions)
import Servant.API as Servant hiding (MkLink, URI (..))
import Wire.API.User.Orphans (samlSchemaOptions)
import Wire.API.Util.Aeson (defaultOptsDropChar)
import Wire.Arbitrary (Arbitrary, GenericUniform (GenericUniform))

-- | The identity provider type used in Spar.
type IdP = IdPConfig WireIdP

newtype IdPHandle = IdPHandle {IdPHandle -> Text
unIdPHandle :: Text}
  deriving (IdPHandle -> IdPHandle -> Bool
(IdPHandle -> IdPHandle -> Bool)
-> (IdPHandle -> IdPHandle -> Bool) -> Eq IdPHandle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdPHandle -> IdPHandle -> Bool
== :: IdPHandle -> IdPHandle -> Bool
$c/= :: IdPHandle -> IdPHandle -> Bool
/= :: IdPHandle -> IdPHandle -> Bool
Eq, Eq IdPHandle
Eq IdPHandle =>
(IdPHandle -> IdPHandle -> Ordering)
-> (IdPHandle -> IdPHandle -> Bool)
-> (IdPHandle -> IdPHandle -> Bool)
-> (IdPHandle -> IdPHandle -> Bool)
-> (IdPHandle -> IdPHandle -> Bool)
-> (IdPHandle -> IdPHandle -> IdPHandle)
-> (IdPHandle -> IdPHandle -> IdPHandle)
-> Ord IdPHandle
IdPHandle -> IdPHandle -> Bool
IdPHandle -> IdPHandle -> Ordering
IdPHandle -> IdPHandle -> IdPHandle
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IdPHandle -> IdPHandle -> Ordering
compare :: IdPHandle -> IdPHandle -> Ordering
$c< :: IdPHandle -> IdPHandle -> Bool
< :: IdPHandle -> IdPHandle -> Bool
$c<= :: IdPHandle -> IdPHandle -> Bool
<= :: IdPHandle -> IdPHandle -> Bool
$c> :: IdPHandle -> IdPHandle -> Bool
> :: IdPHandle -> IdPHandle -> Bool
$c>= :: IdPHandle -> IdPHandle -> Bool
>= :: IdPHandle -> IdPHandle -> Bool
$cmax :: IdPHandle -> IdPHandle -> IdPHandle
max :: IdPHandle -> IdPHandle -> IdPHandle
$cmin :: IdPHandle -> IdPHandle -> IdPHandle
min :: IdPHandle -> IdPHandle -> IdPHandle
Ord, Int -> IdPHandle -> ShowS
[IdPHandle] -> ShowS
IdPHandle -> String
(Int -> IdPHandle -> ShowS)
-> (IdPHandle -> String)
-> ([IdPHandle] -> ShowS)
-> Show IdPHandle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdPHandle -> ShowS
showsPrec :: Int -> IdPHandle -> ShowS
$cshow :: IdPHandle -> String
show :: IdPHandle -> String
$cshowList :: [IdPHandle] -> ShowS
showList :: [IdPHandle] -> ShowS
Show, Value -> Parser [IdPHandle]
Value -> Parser IdPHandle
(Value -> Parser IdPHandle)
-> (Value -> Parser [IdPHandle]) -> FromJSON IdPHandle
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser IdPHandle
parseJSON :: Value -> Parser IdPHandle
$cparseJSONList :: Value -> Parser [IdPHandle]
parseJSONList :: Value -> Parser [IdPHandle]
FromJSON, [IdPHandle] -> Value
[IdPHandle] -> Encoding
IdPHandle -> Value
IdPHandle -> Encoding
(IdPHandle -> Value)
-> (IdPHandle -> Encoding)
-> ([IdPHandle] -> Value)
-> ([IdPHandle] -> Encoding)
-> ToJSON IdPHandle
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: IdPHandle -> Value
toJSON :: IdPHandle -> Value
$ctoEncoding :: IdPHandle -> Encoding
toEncoding :: IdPHandle -> Encoding
$ctoJSONList :: [IdPHandle] -> Value
toJSONList :: [IdPHandle] -> Value
$ctoEncodingList :: [IdPHandle] -> Encoding
toEncodingList :: [IdPHandle] -> Encoding
ToJSON, Typeable IdPHandle
Typeable IdPHandle =>
(Proxy IdPHandle -> Declare (Definitions Schema) NamedSchema)
-> ToSchema IdPHandle
Proxy IdPHandle -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy IdPHandle -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy IdPHandle -> Declare (Definitions Schema) NamedSchema
ToSchema, Gen IdPHandle
Gen IdPHandle -> (IdPHandle -> [IdPHandle]) -> Arbitrary IdPHandle
IdPHandle -> [IdPHandle]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen IdPHandle
arbitrary :: Gen IdPHandle
$cshrink :: IdPHandle -> [IdPHandle]
shrink :: IdPHandle -> [IdPHandle]
Arbitrary, (forall x. IdPHandle -> Rep IdPHandle x)
-> (forall x. Rep IdPHandle x -> IdPHandle) -> Generic IdPHandle
forall x. Rep IdPHandle x -> IdPHandle
forall x. IdPHandle -> Rep IdPHandle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IdPHandle -> Rep IdPHandle x
from :: forall x. IdPHandle -> Rep IdPHandle x
$cto :: forall x. Rep IdPHandle x -> IdPHandle
to :: forall x. Rep IdPHandle x -> IdPHandle
Generic)

data WireIdP = WireIdP
  { WireIdP -> TeamId
_team :: TeamId,
    -- | list of issuer names that this idp has replaced, most recent first.  this is used
    -- for finding users that are still stored under the old issuer, see
    -- 'findUserWithOldIssuer', 'moveUserToNewIssuer'.
    WireIdP -> Maybe WireIdPAPIVersion
_apiVersion :: Maybe WireIdPAPIVersion,
    WireIdP -> [Issuer]
_oldIssuers :: [SAML.Issuer],
    -- | the issuer that has replaced this one.  this is set iff a new issuer is created
    -- with the @"replaces"@ query parameter, and it is used to decide whether users not
    -- existing on this IdP can be auto-provisioned (if 'isJust', they can't).
    WireIdP -> Maybe IdPId
_replacedBy :: Maybe SAML.IdPId,
    WireIdP -> IdPHandle
_handle :: IdPHandle
  }
  deriving (WireIdP -> WireIdP -> Bool
(WireIdP -> WireIdP -> Bool)
-> (WireIdP -> WireIdP -> Bool) -> Eq WireIdP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WireIdP -> WireIdP -> Bool
== :: WireIdP -> WireIdP -> Bool
$c/= :: WireIdP -> WireIdP -> Bool
/= :: WireIdP -> WireIdP -> Bool
Eq, Int -> WireIdP -> ShowS
[WireIdP] -> ShowS
WireIdP -> String
(Int -> WireIdP -> ShowS)
-> (WireIdP -> String) -> ([WireIdP] -> ShowS) -> Show WireIdP
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WireIdP -> ShowS
showsPrec :: Int -> WireIdP -> ShowS
$cshow :: WireIdP -> String
show :: WireIdP -> String
$cshowList :: [WireIdP] -> ShowS
showList :: [WireIdP] -> ShowS
Show, (forall x. WireIdP -> Rep WireIdP x)
-> (forall x. Rep WireIdP x -> WireIdP) -> Generic WireIdP
forall x. Rep WireIdP x -> WireIdP
forall x. WireIdP -> Rep WireIdP x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WireIdP -> Rep WireIdP x
from :: forall x. WireIdP -> Rep WireIdP x
$cto :: forall x. Rep WireIdP x -> WireIdP
to :: forall x. Rep WireIdP x -> WireIdP
Generic)

data WireIdPAPIVersion
  = -- | initial API
    WireIdPAPIV1
  | -- | support for different SP entityIDs per team
    WireIdPAPIV2
  deriving stock (WireIdPAPIVersion -> WireIdPAPIVersion -> Bool
(WireIdPAPIVersion -> WireIdPAPIVersion -> Bool)
-> (WireIdPAPIVersion -> WireIdPAPIVersion -> Bool)
-> Eq WireIdPAPIVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WireIdPAPIVersion -> WireIdPAPIVersion -> Bool
== :: WireIdPAPIVersion -> WireIdPAPIVersion -> Bool
$c/= :: WireIdPAPIVersion -> WireIdPAPIVersion -> Bool
/= :: WireIdPAPIVersion -> WireIdPAPIVersion -> Bool
Eq, Int -> WireIdPAPIVersion -> ShowS
[WireIdPAPIVersion] -> ShowS
WireIdPAPIVersion -> String
(Int -> WireIdPAPIVersion -> ShowS)
-> (WireIdPAPIVersion -> String)
-> ([WireIdPAPIVersion] -> ShowS)
-> Show WireIdPAPIVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WireIdPAPIVersion -> ShowS
showsPrec :: Int -> WireIdPAPIVersion -> ShowS
$cshow :: WireIdPAPIVersion -> String
show :: WireIdPAPIVersion -> String
$cshowList :: [WireIdPAPIVersion] -> ShowS
showList :: [WireIdPAPIVersion] -> ShowS
Show, Int -> WireIdPAPIVersion
WireIdPAPIVersion -> Int
WireIdPAPIVersion -> [WireIdPAPIVersion]
WireIdPAPIVersion -> WireIdPAPIVersion
WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
WireIdPAPIVersion
-> WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
(WireIdPAPIVersion -> WireIdPAPIVersion)
-> (WireIdPAPIVersion -> WireIdPAPIVersion)
-> (Int -> WireIdPAPIVersion)
-> (WireIdPAPIVersion -> Int)
-> (WireIdPAPIVersion -> [WireIdPAPIVersion])
-> (WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion])
-> (WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion])
-> (WireIdPAPIVersion
    -> WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion])
-> Enum WireIdPAPIVersion
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: WireIdPAPIVersion -> WireIdPAPIVersion
succ :: WireIdPAPIVersion -> WireIdPAPIVersion
$cpred :: WireIdPAPIVersion -> WireIdPAPIVersion
pred :: WireIdPAPIVersion -> WireIdPAPIVersion
$ctoEnum :: Int -> WireIdPAPIVersion
toEnum :: Int -> WireIdPAPIVersion
$cfromEnum :: WireIdPAPIVersion -> Int
fromEnum :: WireIdPAPIVersion -> Int
$cenumFrom :: WireIdPAPIVersion -> [WireIdPAPIVersion]
enumFrom :: WireIdPAPIVersion -> [WireIdPAPIVersion]
$cenumFromThen :: WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
enumFromThen :: WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
$cenumFromTo :: WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
enumFromTo :: WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
$cenumFromThenTo :: WireIdPAPIVersion
-> WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
enumFromThenTo :: WireIdPAPIVersion
-> WireIdPAPIVersion -> WireIdPAPIVersion -> [WireIdPAPIVersion]
Enum, WireIdPAPIVersion
WireIdPAPIVersion -> WireIdPAPIVersion -> Bounded WireIdPAPIVersion
forall a. a -> a -> Bounded a
$cminBound :: WireIdPAPIVersion
minBound :: WireIdPAPIVersion
$cmaxBound :: WireIdPAPIVersion
maxBound :: WireIdPAPIVersion
Bounded, (forall x. WireIdPAPIVersion -> Rep WireIdPAPIVersion x)
-> (forall x. Rep WireIdPAPIVersion x -> WireIdPAPIVersion)
-> Generic WireIdPAPIVersion
forall x. Rep WireIdPAPIVersion x -> WireIdPAPIVersion
forall x. WireIdPAPIVersion -> Rep WireIdPAPIVersion x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WireIdPAPIVersion -> Rep WireIdPAPIVersion x
from :: forall x. WireIdPAPIVersion -> Rep WireIdPAPIVersion x
$cto :: forall x. Rep WireIdPAPIVersion x -> WireIdPAPIVersion
to :: forall x. Rep WireIdPAPIVersion x -> WireIdPAPIVersion
Generic)
  deriving (Gen WireIdPAPIVersion
Gen WireIdPAPIVersion
-> (WireIdPAPIVersion -> [WireIdPAPIVersion])
-> Arbitrary WireIdPAPIVersion
WireIdPAPIVersion -> [WireIdPAPIVersion]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen WireIdPAPIVersion
arbitrary :: Gen WireIdPAPIVersion
$cshrink :: WireIdPAPIVersion -> [WireIdPAPIVersion]
shrink :: WireIdPAPIVersion -> [WireIdPAPIVersion]
Arbitrary) via (GenericUniform WireIdPAPIVersion)

-- | (Internal issue for making v2 the default:
-- https://wearezeta.atlassian.net/browse/SQSERVICES-781.  BEWARE: We probably shouldn't ever
-- do this, but remove V1 entirely instead.  which requires migrating away from the old table
-- on all on-prem installations.  which takes time.)
defWireIdPAPIVersion :: WireIdPAPIVersion
defWireIdPAPIVersion :: WireIdPAPIVersion
defWireIdPAPIVersion = WireIdPAPIVersion
WireIdPAPIV1

makeLenses ''WireIdP

deriveJSON deriveJSONOptions ''WireIdPAPIVersion

-- Changing the encoder since we've dropped the field prefixes
deriveJSON (defaultOptsDropChar '_') ''WireIdP

instance BSC.ToByteString WireIdPAPIVersion where
  builder :: WireIdPAPIVersion -> Builder
builder =
    ByteString -> Builder
BSB.fromByteString (ByteString -> Builder)
-> (WireIdPAPIVersion -> ByteString)
-> WireIdPAPIVersion
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      WireIdPAPIVersion
WireIdPAPIV1 -> ByteString
"v1"
      WireIdPAPIVersion
WireIdPAPIV2 -> ByteString
"v2"

instance BSC.FromByteString WireIdPAPIVersion where
  parser :: Parser WireIdPAPIVersion
parser =
    (ByteString -> Parser ByteString
AP.string ByteString
"v1" Parser ByteString
-> Parser WireIdPAPIVersion -> Parser WireIdPAPIVersion
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WireIdPAPIVersion -> Parser WireIdPAPIVersion
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WireIdPAPIVersion
WireIdPAPIV1)
      Parser WireIdPAPIVersion
-> Parser WireIdPAPIVersion -> Parser WireIdPAPIVersion
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> Parser ByteString
AP.string ByteString
"v2" Parser ByteString
-> Parser WireIdPAPIVersion -> Parser WireIdPAPIVersion
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WireIdPAPIVersion -> Parser WireIdPAPIVersion
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WireIdPAPIVersion
WireIdPAPIV2)

instance FromHttpApiData WireIdPAPIVersion where
  parseQueryParam :: Text -> Either Text WireIdPAPIVersion
parseQueryParam Text
txt =
    Either Text WireIdPAPIVersion
-> (WireIdPAPIVersion -> Either Text WireIdPAPIVersion)
-> Maybe WireIdPAPIVersion
-> Either Text WireIdPAPIVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either Text WireIdPAPIVersion
err WireIdPAPIVersion -> Either Text WireIdPAPIVersion
forall a b. b -> Either a b
Right (Maybe WireIdPAPIVersion -> Either Text WireIdPAPIVersion)
-> Maybe WireIdPAPIVersion -> Either Text WireIdPAPIVersion
forall a b. (a -> b) -> a -> b
$
      (ByteString -> Maybe WireIdPAPIVersion
forall a. FromByteString a => ByteString -> Maybe a
BSC.fromByteString' (ByteString -> Maybe WireIdPAPIVersion)
-> (Text -> ByteString) -> Text -> Maybe WireIdPAPIVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) Text
txt
    where
      err :: Either Text WireIdPAPIVersion
err = Text -> Either Text WireIdPAPIVersion
forall a b. a -> Either a b
Left (Text -> Either Text WireIdPAPIVersion)
-> Text -> Either Text WireIdPAPIVersion
forall a b. (a -> b) -> a -> b
$ Text
"FromHttpApiData WireIdPAPIVersion: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt

instance ToHttpApiData WireIdPAPIVersion where
  toQueryParam :: WireIdPAPIVersion -> Text
toQueryParam = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (WireIdPAPIVersion -> ByteString) -> WireIdPAPIVersion -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WireIdPAPIVersion -> ByteString
forall a. ToByteString a => a -> ByteString
BSC.toByteString'

instance ToParamSchema WireIdPAPIVersion where
  toParamSchema :: Proxy WireIdPAPIVersion -> Schema
toParamSchema Proxy WireIdPAPIVersion
Proxy =
    Schema
forall a. Monoid a => a
mempty
      { _schemaDefault = Just "v2",
        _schemaType = Just OpenApiString,
        _schemaEnum = Just (String . toQueryParam <$> [(minBound :: WireIdPAPIVersion) ..])
      }

instance Cql.Cql WireIdPAPIVersion where
  ctype :: Tagged WireIdPAPIVersion ColumnType
ctype = ColumnType -> Tagged WireIdPAPIVersion ColumnType
forall a b. b -> Tagged a b
Cql.Tagged ColumnType
Cql.IntColumn

  toCql :: WireIdPAPIVersion -> Value
toCql WireIdPAPIVersion
WireIdPAPIV1 = Int32 -> Value
Cql.CqlInt Int32
1
  toCql WireIdPAPIVersion
WireIdPAPIV2 = Int32 -> Value
Cql.CqlInt Int32
2

  fromCql :: Value -> Either String WireIdPAPIVersion
fromCql (Cql.CqlInt Int32
i) = case Int32
i of
    Int32
1 -> WireIdPAPIVersion -> Either String WireIdPAPIVersion
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WireIdPAPIVersion
WireIdPAPIV1
    Int32
2 -> WireIdPAPIVersion -> Either String WireIdPAPIVersion
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WireIdPAPIVersion
WireIdPAPIV2
    Int32
n -> String -> Either String WireIdPAPIVersion
forall a b. a -> Either a b
Left (String -> Either String WireIdPAPIVersion)
-> String -> Either String WireIdPAPIVersion
forall a b. (a -> b) -> a -> b
$ String
"Unexpected ClientCapability value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
n
  fromCql Value
_ = String -> Either String WireIdPAPIVersion
forall a b. a -> Either a b
Left String
"ClientCapability value: int expected"

-- | A list of 'IdP's, returned by some endpoints. Wrapped into an object to
-- allow extensibility later on.
newtype IdPList = IdPList {IdPList -> [IdP]
providers :: [IdP]}
  deriving (IdPList -> IdPList -> Bool
(IdPList -> IdPList -> Bool)
-> (IdPList -> IdPList -> Bool) -> Eq IdPList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdPList -> IdPList -> Bool
== :: IdPList -> IdPList -> Bool
$c/= :: IdPList -> IdPList -> Bool
/= :: IdPList -> IdPList -> Bool
Eq, Int -> IdPList -> ShowS
[IdPList] -> ShowS
IdPList -> String
(Int -> IdPList -> ShowS)
-> (IdPList -> String) -> ([IdPList] -> ShowS) -> Show IdPList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdPList -> ShowS
showsPrec :: Int -> IdPList -> ShowS
$cshow :: IdPList -> String
show :: IdPList -> String
$cshowList :: [IdPList] -> ShowS
showList :: [IdPList] -> ShowS
Show, (forall x. IdPList -> Rep IdPList x)
-> (forall x. Rep IdPList x -> IdPList) -> Generic IdPList
forall x. Rep IdPList x -> IdPList
forall x. IdPList -> Rep IdPList x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IdPList -> Rep IdPList x
from :: forall x. IdPList -> Rep IdPList x
$cto :: forall x. Rep IdPList x -> IdPList
to :: forall x. Rep IdPList x -> IdPList
Generic)

-- Same as WireIdP, we want the lenses, so we have to drop a prefix
deriveJSON (defaultOptsDropChar '_') ''IdPList

-- | JSON-encoded information about metadata: @{"value": <xml>}@.  (Here we could also
-- implement @{"uri": <url>, "cert": <pinned_pubkey>}@.  check both the certificate we get
-- from the server against the pinned one and the metadata url in the metadata against the one
-- we fetched the xml from, but it's unclear what the benefit would be.)
data IdPMetadataInfo = IdPMetadataValue Text SAML.IdPMetadata
  deriving (IdPMetadataInfo -> IdPMetadataInfo -> Bool
(IdPMetadataInfo -> IdPMetadataInfo -> Bool)
-> (IdPMetadataInfo -> IdPMetadataInfo -> Bool)
-> Eq IdPMetadataInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdPMetadataInfo -> IdPMetadataInfo -> Bool
== :: IdPMetadataInfo -> IdPMetadataInfo -> Bool
$c/= :: IdPMetadataInfo -> IdPMetadataInfo -> Bool
/= :: IdPMetadataInfo -> IdPMetadataInfo -> Bool
Eq, Int -> IdPMetadataInfo -> ShowS
[IdPMetadataInfo] -> ShowS
IdPMetadataInfo -> String
(Int -> IdPMetadataInfo -> ShowS)
-> (IdPMetadataInfo -> String)
-> ([IdPMetadataInfo] -> ShowS)
-> Show IdPMetadataInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdPMetadataInfo -> ShowS
showsPrec :: Int -> IdPMetadataInfo -> ShowS
$cshow :: IdPMetadataInfo -> String
show :: IdPMetadataInfo -> String
$cshowList :: [IdPMetadataInfo] -> ShowS
showList :: [IdPMetadataInfo] -> ShowS
Show, (forall x. IdPMetadataInfo -> Rep IdPMetadataInfo x)
-> (forall x. Rep IdPMetadataInfo x -> IdPMetadataInfo)
-> Generic IdPMetadataInfo
forall x. Rep IdPMetadataInfo x -> IdPMetadataInfo
forall x. IdPMetadataInfo -> Rep IdPMetadataInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IdPMetadataInfo -> Rep IdPMetadataInfo x
from :: forall x. IdPMetadataInfo -> Rep IdPMetadataInfo x
$cto :: forall x. Rep IdPMetadataInfo x -> IdPMetadataInfo
to :: forall x. Rep IdPMetadataInfo x -> IdPMetadataInfo
Generic)

-- | We want to store the raw xml text from the registration request in the database for
-- trouble shooting, but @SAML.XML@ only gives us access to the xml tree, not the raw text.
-- 'RawXML' helps with that.
data RawXML

instance Accept RawXML where
  contentType :: Proxy RawXML -> MediaType
contentType Proxy RawXML
Proxy = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"xml"

instance MimeUnrender RawXML IdPMetadataInfo where
  mimeUnrender :: Proxy RawXML -> ByteString -> Either String IdPMetadataInfo
mimeUnrender Proxy RawXML
Proxy ByteString
raw =
    Text -> IdPMetadata -> IdPMetadataInfo
IdPMetadataValue
      (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
raw)
      (IdPMetadata -> IdPMetadataInfo)
-> Either String IdPMetadata -> Either String IdPMetadataInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy XML -> ByteString -> Either String IdPMetadata
forall {k} (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SAML.XML) ByteString
raw

instance MimeRender RawXML RawIdPMetadata where
  mimeRender :: Proxy RawXML -> RawIdPMetadata -> ByteString
mimeRender Proxy RawXML
Proxy (RawIdPMetadata Text
raw) = ByteString -> ByteString
fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
raw

newtype RawIdPMetadata = RawIdPMetadata Text
  deriving (RawIdPMetadata -> RawIdPMetadata -> Bool
(RawIdPMetadata -> RawIdPMetadata -> Bool)
-> (RawIdPMetadata -> RawIdPMetadata -> Bool) -> Eq RawIdPMetadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawIdPMetadata -> RawIdPMetadata -> Bool
== :: RawIdPMetadata -> RawIdPMetadata -> Bool
$c/= :: RawIdPMetadata -> RawIdPMetadata -> Bool
/= :: RawIdPMetadata -> RawIdPMetadata -> Bool
Eq, Int -> RawIdPMetadata -> ShowS
[RawIdPMetadata] -> ShowS
RawIdPMetadata -> String
(Int -> RawIdPMetadata -> ShowS)
-> (RawIdPMetadata -> String)
-> ([RawIdPMetadata] -> ShowS)
-> Show RawIdPMetadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawIdPMetadata -> ShowS
showsPrec :: Int -> RawIdPMetadata -> ShowS
$cshow :: RawIdPMetadata -> String
show :: RawIdPMetadata -> String
$cshowList :: [RawIdPMetadata] -> ShowS
showList :: [RawIdPMetadata] -> ShowS
Show, (forall x. RawIdPMetadata -> Rep RawIdPMetadata x)
-> (forall x. Rep RawIdPMetadata x -> RawIdPMetadata)
-> Generic RawIdPMetadata
forall x. Rep RawIdPMetadata x -> RawIdPMetadata
forall x. RawIdPMetadata -> Rep RawIdPMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RawIdPMetadata -> Rep RawIdPMetadata x
from :: forall x. RawIdPMetadata -> Rep RawIdPMetadata x
$cto :: forall x. Rep RawIdPMetadata x -> RawIdPMetadata
to :: forall x. Rep RawIdPMetadata x -> RawIdPMetadata
Generic)

instance FromJSON IdPMetadataInfo where
  parseJSON :: Value -> Parser IdPMetadataInfo
parseJSON = String
-> (Object -> Parser IdPMetadataInfo)
-> Value
-> Parser IdPMetadataInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"IdPMetadataInfo" ((Object -> Parser IdPMetadataInfo)
 -> Value -> Parser IdPMetadataInfo)
-> (Object -> Parser IdPMetadataInfo)
-> Value
-> Parser IdPMetadataInfo
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Text
raw <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
    (String -> Parser IdPMetadataInfo)
-> (IdPMetadata -> Parser IdPMetadataInfo)
-> Either String IdPMetadata
-> Parser IdPMetadataInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser IdPMetadataInfo
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (IdPMetadataInfo -> Parser IdPMetadataInfo
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IdPMetadataInfo -> Parser IdPMetadataInfo)
-> (IdPMetadata -> IdPMetadataInfo)
-> IdPMetadata
-> Parser IdPMetadataInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IdPMetadata -> IdPMetadataInfo
IdPMetadataValue Text
raw) (LT -> Either String IdPMetadata
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
SAML.decode (Text -> LT
LT.fromStrict Text
raw))

instance ToJSON IdPMetadataInfo where
  toJSON :: IdPMetadataInfo -> Value
toJSON (IdPMetadataValue Text
_ IdPMetadata
x) =
    [Pair] -> Value
object [Key
"value" Key -> LT -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= IdPMetadata -> LT
forall a. HasXMLRoot a => a -> LT
SAML.encode IdPMetadata
x]

idPMetadataToInfo :: SAML.IdPMetadata -> IdPMetadataInfo
idPMetadataToInfo :: IdPMetadata -> IdPMetadataInfo
idPMetadataToInfo =
  -- 'undefined' is fine because `instance toJSON IdPMetadataValue` ignores it.  'fromJust' is
  -- ok as long as 'parseJSON . toJSON' always yields a value and not 'Nothing'.
  Maybe IdPMetadataInfo -> IdPMetadataInfo
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe IdPMetadataInfo -> IdPMetadataInfo)
-> (IdPMetadata -> Maybe IdPMetadataInfo)
-> IdPMetadata
-> IdPMetadataInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser IdPMetadataInfo) -> Value -> Maybe IdPMetadataInfo
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser IdPMetadataInfo
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Maybe IdPMetadataInfo)
-> (IdPMetadata -> Value) -> IdPMetadata -> Maybe IdPMetadataInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPMetadataInfo -> Value
forall a. ToJSON a => a -> Value
toJSON (IdPMetadataInfo -> Value)
-> (IdPMetadata -> IdPMetadataInfo) -> IdPMetadata -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IdPMetadata -> IdPMetadataInfo
IdPMetadataValue Text
forall a. HasCallStack => a
undefined

-- Swagger instances

-- Same as WireIdP, check there for why this has different handling
instance ToSchema IdPList where
  declareNamedSchema :: Proxy IdPList -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy IdPList -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema (SchemaOptions
 -> Proxy IdPList -> Declare (Definitions Schema) NamedSchema)
-> SchemaOptions
-> Proxy IdPList
-> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Options -> SchemaOptions
fromAesonOptions (Options -> SchemaOptions) -> Options -> SchemaOptions
forall a b. (a -> b) -> a -> b
$ Char -> Options
defaultOptsDropChar Char
'_'

instance ToSchema WireIdPAPIVersion where
  declareNamedSchema :: Proxy WireIdPAPIVersion -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy WireIdPAPIVersion
-> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema SchemaOptions
samlSchemaOptions

instance ToSchema WireIdP where
  -- We don't want to use `samlSchemaOptions`, as it pulls from saml2-web-sso json options which
  -- as a `dropWhile not . isUpper` modifier. All we need is to drop the underscore prefix and
  -- keep the rest of the default processing. This isn't strictly in line with WPB-3798's requirements
  -- but it is close, and maintains the lens template haskell.
  declareNamedSchema :: Proxy WireIdP -> Declare (Definitions Schema) NamedSchema
declareNamedSchema = SchemaOptions
-> Proxy WireIdP -> Declare (Definitions Schema) NamedSchema
forall a.
(Generic a, GToSchema (Rep a), Typeable a) =>
SchemaOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema (SchemaOptions
 -> Proxy WireIdP -> Declare (Definitions Schema) NamedSchema)
-> SchemaOptions
-> Proxy WireIdP
-> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Options -> SchemaOptions
fromAesonOptions (Options -> SchemaOptions) -> Options -> SchemaOptions
forall a b. (a -> b) -> a -> b
$ Char -> Options
defaultOptsDropChar Char
'_'

-- TODO: would be nice to add an example here, but that only works for json?

instance ToSchema RawIdPMetadata where
  declareNamedSchema :: Proxy RawIdPMetadata -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy RawIdPMetadata
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)

instance ToSchema IdPMetadataInfo where
  declareNamedSchema :: Proxy IdPMetadataInfo -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy IdPMetadataInfo
_ =
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
      Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"IdPMetadataInfo") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
        Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties
            ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Text (Referenced Schema)
properties_
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMinProperties s a => Lens' s a
Lens' Schema (Maybe Integer)
minProperties
            ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer
1
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Integer -> Identity (Maybe Integer))
-> Schema -> Identity Schema
forall s a. HasMaxProperties s a => Lens' s a
Lens' Schema (Maybe Integer)
maxProperties
            ((Maybe Integer -> Identity (Maybe Integer))
 -> Schema -> Identity Schema)
-> Integer -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Integer
1
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_
            ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
    where
      properties_ :: InsOrdHashMap Text (Referenced Schema)
      properties_ :: InsOrdHashMap Text (Referenced Schema)
properties_ =
        [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList
          [ (Text
"value", Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy String -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @String)))
          ]