-- 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/>.

module Wire.API.MLS.Credential where

import Control.Lens ((?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Binary
import Data.Binary.Get
import Data.Binary.Parser
import Data.Binary.Parser.Char8
import Data.Binary.Put
import Data.ByteString.Base64.URL qualified as B64URL
import Data.ByteString.Lazy qualified as L
import Data.Domain
import Data.Id
import Data.OpenApi qualified as S
import Data.Qualified
import Data.Schema
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.UUID
import Imports
import Web.HttpApiData
import Wire.API.MLS.Serialisation
import Wire.Arbitrary

-- | An MLS credential.
--
-- https://messaginglayersecurity.rocks/mls-protocol/draft-ietf-mls-protocol-20/draft-ietf-mls-protocol.html#section-5.3-3
data Credential = BasicCredential ByteString | X509Credential [ByteString]
  deriving stock (Credential -> Credential -> Bool
(Credential -> Credential -> Bool)
-> (Credential -> Credential -> Bool) -> Eq Credential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Credential -> Credential -> Bool
== :: Credential -> Credential -> Bool
$c/= :: Credential -> Credential -> Bool
/= :: Credential -> Credential -> Bool
Eq, Int -> Credential -> ShowS
[Credential] -> ShowS
Credential -> String
(Int -> Credential -> ShowS)
-> (Credential -> String)
-> ([Credential] -> ShowS)
-> Show Credential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Credential -> ShowS
showsPrec :: Int -> Credential -> ShowS
$cshow :: Credential -> String
show :: Credential -> String
$cshowList :: [Credential] -> ShowS
showList :: [Credential] -> ShowS
Show, (forall x. Credential -> Rep Credential x)
-> (forall x. Rep Credential x -> Credential) -> Generic Credential
forall x. Rep Credential x -> Credential
forall x. Credential -> Rep Credential x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Credential -> Rep Credential x
from :: forall x. Credential -> Rep Credential x
$cto :: forall x. Rep Credential x -> Credential
to :: forall x. Rep Credential x -> Credential
Generic)
  deriving (Gen Credential
Gen Credential
-> (Credential -> [Credential]) -> Arbitrary Credential
Credential -> [Credential]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen Credential
arbitrary :: Gen Credential
$cshrink :: Credential -> [Credential]
shrink :: Credential -> [Credential]
Arbitrary) via GenericUniform Credential

data CredentialTag = BasicCredentialTag | X509CredentialTag
  deriving stock (Int -> CredentialTag
CredentialTag -> Int
CredentialTag -> [CredentialTag]
CredentialTag -> CredentialTag
CredentialTag -> CredentialTag -> [CredentialTag]
CredentialTag -> CredentialTag -> CredentialTag -> [CredentialTag]
(CredentialTag -> CredentialTag)
-> (CredentialTag -> CredentialTag)
-> (Int -> CredentialTag)
-> (CredentialTag -> Int)
-> (CredentialTag -> [CredentialTag])
-> (CredentialTag -> CredentialTag -> [CredentialTag])
-> (CredentialTag -> CredentialTag -> [CredentialTag])
-> (CredentialTag
    -> CredentialTag -> CredentialTag -> [CredentialTag])
-> Enum CredentialTag
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 :: CredentialTag -> CredentialTag
succ :: CredentialTag -> CredentialTag
$cpred :: CredentialTag -> CredentialTag
pred :: CredentialTag -> CredentialTag
$ctoEnum :: Int -> CredentialTag
toEnum :: Int -> CredentialTag
$cfromEnum :: CredentialTag -> Int
fromEnum :: CredentialTag -> Int
$cenumFrom :: CredentialTag -> [CredentialTag]
enumFrom :: CredentialTag -> [CredentialTag]
$cenumFromThen :: CredentialTag -> CredentialTag -> [CredentialTag]
enumFromThen :: CredentialTag -> CredentialTag -> [CredentialTag]
$cenumFromTo :: CredentialTag -> CredentialTag -> [CredentialTag]
enumFromTo :: CredentialTag -> CredentialTag -> [CredentialTag]
$cenumFromThenTo :: CredentialTag -> CredentialTag -> CredentialTag -> [CredentialTag]
enumFromThenTo :: CredentialTag -> CredentialTag -> CredentialTag -> [CredentialTag]
Enum, CredentialTag
CredentialTag -> CredentialTag -> Bounded CredentialTag
forall a. a -> a -> Bounded a
$cminBound :: CredentialTag
minBound :: CredentialTag
$cmaxBound :: CredentialTag
maxBound :: CredentialTag
Bounded, CredentialTag -> CredentialTag -> Bool
(CredentialTag -> CredentialTag -> Bool)
-> (CredentialTag -> CredentialTag -> Bool) -> Eq CredentialTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CredentialTag -> CredentialTag -> Bool
== :: CredentialTag -> CredentialTag -> Bool
$c/= :: CredentialTag -> CredentialTag -> Bool
/= :: CredentialTag -> CredentialTag -> Bool
Eq, Int -> CredentialTag -> ShowS
[CredentialTag] -> ShowS
CredentialTag -> String
(Int -> CredentialTag -> ShowS)
-> (CredentialTag -> String)
-> ([CredentialTag] -> ShowS)
-> Show CredentialTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CredentialTag -> ShowS
showsPrec :: Int -> CredentialTag -> ShowS
$cshow :: CredentialTag -> String
show :: CredentialTag -> String
$cshowList :: [CredentialTag] -> ShowS
showList :: [CredentialTag] -> ShowS
Show, (forall x. CredentialTag -> Rep CredentialTag x)
-> (forall x. Rep CredentialTag x -> CredentialTag)
-> Generic CredentialTag
forall x. Rep CredentialTag x -> CredentialTag
forall x. CredentialTag -> Rep CredentialTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CredentialTag -> Rep CredentialTag x
from :: forall x. CredentialTag -> Rep CredentialTag x
$cto :: forall x. Rep CredentialTag x -> CredentialTag
to :: forall x. Rep CredentialTag x -> CredentialTag
Generic)
  deriving (Gen CredentialTag
Gen CredentialTag
-> (CredentialTag -> [CredentialTag]) -> Arbitrary CredentialTag
CredentialTag -> [CredentialTag]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen CredentialTag
arbitrary :: Gen CredentialTag
$cshrink :: CredentialTag -> [CredentialTag]
shrink :: CredentialTag -> [CredentialTag]
Arbitrary) via (GenericUniform CredentialTag)

instance ParseMLS CredentialTag where
  parseMLS :: Get CredentialTag
parseMLS = forall w a.
(Bounded a, Enum a, Integral w, Binary w) =>
String -> Get a
parseMLSEnum @Word16 String
"credential type"

instance SerialiseMLS CredentialTag where
  serialiseMLS :: CredentialTag -> Put
serialiseMLS = forall w a. (Enum a, Integral w, Binary w) => a -> Put
serialiseMLSEnum @Word16

instance ParseMLS Credential where
  parseMLS :: Get Credential
parseMLS =
    Get CredentialTag
forall a. ParseMLS a => Get a
parseMLS Get CredentialTag
-> (CredentialTag -> Get Credential) -> Get Credential
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CredentialTag
BasicCredentialTag ->
        ByteString -> Credential
BasicCredential
          (ByteString -> Credential) -> Get ByteString -> Get Credential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w. (Binary w, Integral w) => Get ByteString
parseMLSBytes @VarInt
      CredentialTag
X509CredentialTag ->
        [ByteString] -> Credential
X509Credential
          ([ByteString] -> Credential) -> Get [ByteString] -> Get Credential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w a. (Binary w, Integral w) => Get a -> Get [a]
parseMLSVector @VarInt (forall w. (Binary w, Integral w) => Get ByteString
parseMLSBytes @VarInt)

instance SerialiseMLS Credential where
  serialiseMLS :: Credential -> Put
serialiseMLS (BasicCredential ByteString
i) = do
    CredentialTag -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS CredentialTag
BasicCredentialTag
    forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytes @VarInt ByteString
i
  serialiseMLS (X509Credential [ByteString]
certs) = do
    CredentialTag -> Put
forall a. SerialiseMLS a => a -> Put
serialiseMLS CredentialTag
X509CredentialTag
    forall w a. (Binary w, Integral w) => (a -> Put) -> [a] -> Put
serialiseMLSVector @VarInt (forall w. (Binary w, Integral w) => ByteString -> Put
serialiseMLSBytes @VarInt) [ByteString]
certs

credentialTag :: Credential -> CredentialTag
credentialTag :: Credential -> CredentialTag
credentialTag (BasicCredential ByteString
_) = CredentialTag
BasicCredentialTag
credentialTag (X509Credential [ByteString]
_) = CredentialTag
X509CredentialTag

data ClientIdentity = ClientIdentity
  { ClientIdentity -> Domain
ciDomain :: Domain,
    ClientIdentity -> UserId
ciUser :: UserId,
    ClientIdentity -> ClientId
ciClient :: ClientId
  }
  deriving stock (ClientIdentity -> ClientIdentity -> Bool
(ClientIdentity -> ClientIdentity -> Bool)
-> (ClientIdentity -> ClientIdentity -> Bool) -> Eq ClientIdentity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientIdentity -> ClientIdentity -> Bool
== :: ClientIdentity -> ClientIdentity -> Bool
$c/= :: ClientIdentity -> ClientIdentity -> Bool
/= :: ClientIdentity -> ClientIdentity -> Bool
Eq, Eq ClientIdentity
Eq ClientIdentity =>
(ClientIdentity -> ClientIdentity -> Ordering)
-> (ClientIdentity -> ClientIdentity -> Bool)
-> (ClientIdentity -> ClientIdentity -> Bool)
-> (ClientIdentity -> ClientIdentity -> Bool)
-> (ClientIdentity -> ClientIdentity -> Bool)
-> (ClientIdentity -> ClientIdentity -> ClientIdentity)
-> (ClientIdentity -> ClientIdentity -> ClientIdentity)
-> Ord ClientIdentity
ClientIdentity -> ClientIdentity -> Bool
ClientIdentity -> ClientIdentity -> Ordering
ClientIdentity -> ClientIdentity -> ClientIdentity
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 :: ClientIdentity -> ClientIdentity -> Ordering
compare :: ClientIdentity -> ClientIdentity -> Ordering
$c< :: ClientIdentity -> ClientIdentity -> Bool
< :: ClientIdentity -> ClientIdentity -> Bool
$c<= :: ClientIdentity -> ClientIdentity -> Bool
<= :: ClientIdentity -> ClientIdentity -> Bool
$c> :: ClientIdentity -> ClientIdentity -> Bool
> :: ClientIdentity -> ClientIdentity -> Bool
$c>= :: ClientIdentity -> ClientIdentity -> Bool
>= :: ClientIdentity -> ClientIdentity -> Bool
$cmax :: ClientIdentity -> ClientIdentity -> ClientIdentity
max :: ClientIdentity -> ClientIdentity -> ClientIdentity
$cmin :: ClientIdentity -> ClientIdentity -> ClientIdentity
min :: ClientIdentity -> ClientIdentity -> ClientIdentity
Ord, (forall x. ClientIdentity -> Rep ClientIdentity x)
-> (forall x. Rep ClientIdentity x -> ClientIdentity)
-> Generic ClientIdentity
forall x. Rep ClientIdentity x -> ClientIdentity
forall x. ClientIdentity -> Rep ClientIdentity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClientIdentity -> Rep ClientIdentity x
from :: forall x. ClientIdentity -> Rep ClientIdentity x
$cto :: forall x. Rep ClientIdentity x -> ClientIdentity
to :: forall x. Rep ClientIdentity x -> ClientIdentity
Generic)
  deriving (Value -> Parser [ClientIdentity]
Value -> Parser ClientIdentity
(Value -> Parser ClientIdentity)
-> (Value -> Parser [ClientIdentity]) -> FromJSON ClientIdentity
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser ClientIdentity
parseJSON :: Value -> Parser ClientIdentity
$cparseJSONList :: Value -> Parser [ClientIdentity]
parseJSONList :: Value -> Parser [ClientIdentity]
FromJSON, [ClientIdentity] -> Value
[ClientIdentity] -> Encoding
ClientIdentity -> Value
ClientIdentity -> Encoding
(ClientIdentity -> Value)
-> (ClientIdentity -> Encoding)
-> ([ClientIdentity] -> Value)
-> ([ClientIdentity] -> Encoding)
-> ToJSON ClientIdentity
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: ClientIdentity -> Value
toJSON :: ClientIdentity -> Value
$ctoEncoding :: ClientIdentity -> Encoding
toEncoding :: ClientIdentity -> Encoding
$ctoJSONList :: [ClientIdentity] -> Value
toJSONList :: [ClientIdentity] -> Value
$ctoEncodingList :: [ClientIdentity] -> Encoding
toEncodingList :: [ClientIdentity] -> Encoding
ToJSON, Typeable ClientIdentity
Typeable ClientIdentity =>
(Proxy ClientIdentity -> Declare (Definitions Schema) NamedSchema)
-> ToSchema ClientIdentity
Proxy ClientIdentity -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy ClientIdentity -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy ClientIdentity -> Declare (Definitions Schema) NamedSchema
S.ToSchema) via Schema ClientIdentity
  deriving (Gen ClientIdentity
Gen ClientIdentity
-> (ClientIdentity -> [ClientIdentity]) -> Arbitrary ClientIdentity
ClientIdentity -> [ClientIdentity]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen ClientIdentity
arbitrary :: Gen ClientIdentity
$cshrink :: ClientIdentity -> [ClientIdentity]
shrink :: ClientIdentity -> [ClientIdentity]
Arbitrary) via (GenericUniform ClientIdentity)

instance Show ClientIdentity where
  show :: ClientIdentity -> String
show (ClientIdentity Domain
dom UserId
u ClientId
c) =
    UserId -> String
forall a. Show a => a -> String
show UserId
u
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (ClientId -> Text
clientToText ClientId
c)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"@"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Domain -> Text
domainText Domain
dom)

cidQualifiedClient :: ClientIdentity -> Qualified (UserId, ClientId)
cidQualifiedClient :: ClientIdentity -> Qualified (UserId, ClientId)
cidQualifiedClient ClientIdentity
cid = (UserId, ClientId) -> Domain -> Qualified (UserId, ClientId)
forall a. a -> Domain -> Qualified a
Qualified (ClientIdentity -> UserId
ciUser ClientIdentity
cid, ClientIdentity -> ClientId
ciClient ClientIdentity
cid) (ClientIdentity -> Domain
ciDomain ClientIdentity
cid)

cidQualifiedUser :: ClientIdentity -> Qualified UserId
cidQualifiedUser :: ClientIdentity -> Qualified UserId
cidQualifiedUser = ((UserId, ClientId) -> UserId)
-> Qualified (UserId, ClientId) -> Qualified UserId
forall a b. (a -> b) -> Qualified a -> Qualified b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UserId, ClientId) -> UserId
forall a b. (a, b) -> a
fst (Qualified (UserId, ClientId) -> Qualified UserId)
-> (ClientIdentity -> Qualified (UserId, ClientId))
-> ClientIdentity
-> Qualified UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIdentity -> Qualified (UserId, ClientId)
cidQualifiedClient

instance ToSchema ClientIdentity where
  schema :: ValueSchema NamedSwaggerDoc ClientIdentity
schema =
    Text
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientIdentity
-> ValueSchema NamedSwaggerDoc ClientIdentity
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"ClientIdentity" (SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientIdentity
 -> ValueSchema NamedSwaggerDoc ClientIdentity)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientIdentity
-> ValueSchema NamedSwaggerDoc ClientIdentity
forall a b. (a -> b) -> a -> b
$
      Domain -> UserId -> ClientId -> ClientIdentity
ClientIdentity
        (Domain -> UserId -> ClientId -> ClientIdentity)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity Domain
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ClientIdentity
     (UserId -> ClientId -> ClientIdentity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientIdentity -> Domain
ciDomain (ClientIdentity -> Domain)
-> SchemaP SwaggerDoc Object [Pair] Domain Domain
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity Domain
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Domain Domain
-> SchemaP SwaggerDoc Object [Pair] Domain Domain
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"domain" SchemaP NamedSwaggerDoc Value Value Domain Domain
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ClientIdentity
  (UserId -> ClientId -> ClientIdentity)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity UserId
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ClientIdentity
     (ClientId -> ClientIdentity)
forall a b.
SchemaP SwaggerDoc Object [Pair] ClientIdentity (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity a
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientIdentity -> UserId
ciUser (ClientIdentity -> UserId)
-> SchemaP SwaggerDoc Object [Pair] UserId UserId
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity UserId
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value UserId UserId
-> SchemaP SwaggerDoc Object [Pair] UserId UserId
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"user_id" SchemaP NamedSwaggerDoc Value Value UserId UserId
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ClientIdentity
  (ClientId -> ClientIdentity)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientId
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientIdentity
forall a b.
SchemaP SwaggerDoc Object [Pair] ClientIdentity (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity a
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClientIdentity -> ClientId
ciClient (ClientIdentity -> ClientId)
-> SchemaP SwaggerDoc Object [Pair] ClientId ClientId
-> SchemaP SwaggerDoc Object [Pair] ClientIdentity ClientId
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value ClientId ClientId
-> SchemaP SwaggerDoc Object [Pair] ClientId ClientId
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"client_id" SchemaP NamedSwaggerDoc Value Value ClientId ClientId
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema

instance S.ToParamSchema ClientIdentity where
  toParamSchema :: Proxy ClientIdentity -> Schema
toParamSchema Proxy ClientIdentity
_ = Schema
forall a. Monoid a => a
mempty 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)
S.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
S.OpenApiString

instance FromHttpApiData ClientIdentity where
  parseHeader :: ByteString -> Either Text ClientIdentity
parseHeader = ByteString -> Either Text ClientIdentity
forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS'
  parseUrlPiece :: Text -> Either Text ClientIdentity
parseUrlPiece = ByteString -> Either Text ClientIdentity
forall a. ParseMLS a => ByteString -> Either Text a
decodeMLS' (ByteString -> Either Text ClientIdentity)
-> (Text -> ByteString) -> Text -> Either Text ClientIdentity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

instance ToHttpApiData ClientIdentity where
  toHeader :: ClientIdentity -> ByteString
toHeader = ClientIdentity -> ByteString
forall a. SerialiseMLS a => a -> ByteString
encodeMLS'
  toUrlPiece :: ClientIdentity -> Text
toUrlPiece = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ClientIdentity -> ByteString) -> ClientIdentity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIdentity -> ByteString
forall a. SerialiseMLS a => a -> ByteString
encodeMLS'

instance ParseMLS ClientIdentity where
  parseMLS :: Get ClientIdentity
parseMLS = do
    UserId
uid <-
      Get UserId -> (UUID -> Get UserId) -> Maybe UUID -> Get UserId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get UserId
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid UUID") (UserId -> Get UserId
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> Get UserId) -> (UUID -> UserId) -> UUID -> Get UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> UserId
forall {k} (a :: k). UUID -> Id a
Id) (Maybe UUID -> Get UserId)
-> (ByteString -> Maybe UUID) -> ByteString -> Get UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe UUID
fromASCIIBytes (ByteString -> Get UserId) -> Get ByteString -> Get UserId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Get ByteString
getByteString Int
36
    Char -> Get ()
char Char
':'
    ClientId
cid <- Word64 -> ClientId
ClientId (Word64 -> ClientId) -> Get Word64 -> Get ClientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
forall a. (Integral a, Bits a) => Get a
hexadecimal
    Char -> Get ()
char Char
'@'
    Domain
dom <-
      (String -> Get Domain)
-> (Domain -> Get Domain) -> Either String Domain -> Get Domain
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get Domain
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Domain -> Get Domain
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Domain -> Get Domain)
-> (String -> Either String Domain) -> String -> Get Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either String Domain
mkDomain (Text -> Either String Domain)
-> (String -> Text) -> String -> Either String Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String -> Get Domain) -> Get String -> Get Domain
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Char -> Get String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Get Char
anyChar
    ClientIdentity -> Get ClientIdentity
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> Get ClientIdentity)
-> ClientIdentity -> Get ClientIdentity
forall a b. (a -> b) -> a -> b
$ Domain -> UserId -> ClientId -> ClientIdentity
ClientIdentity Domain
dom UserId
uid ClientId
cid

-- format of the x509 client identity: {userid}%21{deviceid}@{host}
parseX509ClientIdentity :: Get ClientIdentity
parseX509ClientIdentity :: Get ClientIdentity
parseX509ClientIdentity = do
  ByteString
b64uuid <- Int -> Get ByteString
getByteString Int
22
  ByteString
uidBytes <- (String -> Get ByteString)
-> (ByteString -> Get ByteString)
-> Either String ByteString
-> Get ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get ByteString
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> Get ByteString
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> Get ByteString)
-> Either String ByteString -> Get ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64URL.decodeUnpadded ByteString
b64uuid
  UserId
uid <- Get UserId -> (UUID -> Get UserId) -> Maybe UUID -> Get UserId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get UserId
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid UUID") (UserId -> Get UserId
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserId -> Get UserId) -> (UUID -> UserId) -> UUID -> Get UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> UserId
forall {k} (a :: k). UUID -> Id a
Id) (Maybe UUID -> Get UserId) -> Maybe UUID -> Get UserId
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe UUID
fromByteString (ByteString -> ByteString
L.fromStrict ByteString
uidBytes)
  ByteString -> Get ()
string ByteString
"%21"
  ClientId
cid <- Word64 -> ClientId
ClientId (Word64 -> ClientId) -> Get Word64 -> Get ClientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
forall a. (Integral a, Bits a) => Get a
hexadecimal
  Char -> Get ()
char Char
'@'
  Domain
dom <-
    (String -> Get Domain)
-> (Domain -> Get Domain) -> Either String Domain -> Get Domain
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Get Domain
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Domain -> Get Domain
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Domain -> Get Domain)
-> (String -> Either String Domain) -> String -> Get Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either String Domain
mkDomain (Text -> Either String Domain)
-> (String -> Text) -> String -> Either String Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (String -> Get Domain) -> Get String -> Get Domain
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Char -> Get String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Get Char
anyChar
  ClientIdentity -> Get ClientIdentity
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientIdentity -> Get ClientIdentity)
-> ClientIdentity -> Get ClientIdentity
forall a b. (a -> b) -> a -> b
$ Domain -> UserId -> ClientId -> ClientIdentity
ClientIdentity Domain
dom UserId
uid ClientId
cid

instance SerialiseMLS ClientIdentity where
  serialiseMLS :: ClientIdentity -> Put
serialiseMLS ClientIdentity
cid = do
    ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ UUID -> ByteString
toASCIIBytes (UserId -> UUID
forall {k} (a :: k). Id a -> UUID
toUUID (ClientIdentity -> UserId
ciUser ClientIdentity
cid))
    Char -> Put
putCharUtf8 Char
':'
    String -> Put
putStringUtf8 (String -> Put) -> String -> Put
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (ClientId -> Text
clientToText (ClientIdentity -> ClientId
ciClient ClientIdentity
cid))
    Char -> Put
putCharUtf8 Char
'@'
    String -> Put
putStringUtf8 (String -> Put) -> String -> Put
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Domain -> Text
domainText (ClientIdentity -> Domain
ciDomain ClientIdentity
cid))

mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity
mkClientIdentity (Qualified UserId
uid Domain
domain) = Domain -> UserId -> ClientId -> ClientIdentity
ClientIdentity Domain
domain UserId
uid