{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- 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 Web.Scim.Schema.Common where

import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.CaseInsensitive as CI
import Data.List (nub, (\\))
import Data.String.Conversions (cs)
import Data.Text (Text, pack, unpack)
import qualified Network.URI as Network

data WithId id a = WithId
  { forall id a. WithId id a -> id
id :: id,
    forall id a. WithId id a -> a
value :: a
  }
  deriving (WithId id a -> WithId id a -> Bool
(WithId id a -> WithId id a -> Bool)
-> (WithId id a -> WithId id a -> Bool) -> Eq (WithId id a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall id a. (Eq id, Eq a) => WithId id a -> WithId id a -> Bool
$c== :: forall id a. (Eq id, Eq a) => WithId id a -> WithId id a -> Bool
== :: WithId id a -> WithId id a -> Bool
$c/= :: forall id a. (Eq id, Eq a) => WithId id a -> WithId id a -> Bool
/= :: WithId id a -> WithId id a -> Bool
Eq, Int -> WithId id a -> ShowS
[WithId id a] -> ShowS
WithId id a -> String
(Int -> WithId id a -> ShowS)
-> (WithId id a -> String)
-> ([WithId id a] -> ShowS)
-> Show (WithId id a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall id a. (Show id, Show a) => Int -> WithId id a -> ShowS
forall id a. (Show id, Show a) => [WithId id a] -> ShowS
forall id a. (Show id, Show a) => WithId id a -> String
$cshowsPrec :: forall id a. (Show id, Show a) => Int -> WithId id a -> ShowS
showsPrec :: Int -> WithId id a -> ShowS
$cshow :: forall id a. (Show id, Show a) => WithId id a -> String
show :: WithId id a -> String
$cshowList :: forall id a. (Show id, Show a) => [WithId id a] -> ShowS
showList :: [WithId id a] -> ShowS
Show)

instance (ToJSON id, ToJSON a) => ToJSON (WithId id a) where
  toJSON :: WithId id a -> Value
toJSON (WithId id
i a
v) = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v of
    (Object Object
o) -> Object -> Value
Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"id" (id -> Value
forall a. ToJSON a => a -> Value
toJSON id
i) Object
o)
    Value
other -> Value
other

instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where
  parseJSON :: Value -> Parser (WithId id a)
parseJSON = String
-> (Object -> Parser (WithId id a))
-> Value
-> Parser (WithId id a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"WithId" ((Object -> Parser (WithId id a)) -> Value -> Parser (WithId id a))
-> (Object -> Parser (WithId id a))
-> Value
-> Parser (WithId id a)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    id -> a -> WithId id a
forall id a. id -> a -> WithId id a
WithId (id -> a -> WithId id a) -> Parser id -> Parser (a -> WithId id a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser id
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (a -> WithId id a) -> Parser a -> Parser (WithId id a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)

newtype URI = URI {URI -> URI
unURI :: Network.URI}
  deriving (Int -> URI -> ShowS
[URI] -> ShowS
URI -> String
(Int -> URI -> ShowS)
-> (URI -> String) -> ([URI] -> ShowS) -> Show URI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> URI -> ShowS
showsPrec :: Int -> URI -> ShowS
$cshow :: URI -> String
show :: URI -> String
$cshowList :: [URI] -> ShowS
showList :: [URI] -> ShowS
Show, URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
/= :: URI -> URI -> Bool
Eq)

instance FromJSON URI where
  parseJSON :: Value -> Parser URI
parseJSON = String -> (Text -> Parser URI) -> Value -> Parser URI
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"URI" ((Text -> Parser URI) -> Value -> Parser URI)
-> (Text -> Parser URI) -> Value -> Parser URI
forall a b. (a -> b) -> a -> b
$ \Text
uri -> case String -> Maybe URI
Network.parseURI (Text -> String
unpack Text
uri) of
    Maybe URI
Nothing -> String -> Parser URI
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid URI"
    Just URI
some -> URI -> Parser URI
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> Parser URI) -> URI -> Parser URI
forall a b. (a -> b) -> a -> b
$ URI -> URI
URI URI
some

instance ToJSON URI where
  toJSON :: URI -> Value
toJSON (URI URI
uri) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
uri

newtype ScimBool = ScimBool {ScimBool -> Bool
unScimBool :: Bool}
  deriving stock (ScimBool -> ScimBool -> Bool
(ScimBool -> ScimBool -> Bool)
-> (ScimBool -> ScimBool -> Bool) -> Eq ScimBool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScimBool -> ScimBool -> Bool
== :: ScimBool -> ScimBool -> Bool
$c/= :: ScimBool -> ScimBool -> Bool
/= :: ScimBool -> ScimBool -> Bool
Eq, Int -> ScimBool -> ShowS
[ScimBool] -> ShowS
ScimBool -> String
(Int -> ScimBool -> ShowS)
-> (ScimBool -> String) -> ([ScimBool] -> ShowS) -> Show ScimBool
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScimBool -> ShowS
showsPrec :: Int -> ScimBool -> ShowS
$cshow :: ScimBool -> String
show :: ScimBool -> String
$cshowList :: [ScimBool] -> ShowS
showList :: [ScimBool] -> ShowS
Show, Eq ScimBool
Eq ScimBool =>
(ScimBool -> ScimBool -> Ordering)
-> (ScimBool -> ScimBool -> Bool)
-> (ScimBool -> ScimBool -> Bool)
-> (ScimBool -> ScimBool -> Bool)
-> (ScimBool -> ScimBool -> Bool)
-> (ScimBool -> ScimBool -> ScimBool)
-> (ScimBool -> ScimBool -> ScimBool)
-> Ord ScimBool
ScimBool -> ScimBool -> Bool
ScimBool -> ScimBool -> Ordering
ScimBool -> ScimBool -> ScimBool
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 :: ScimBool -> ScimBool -> Ordering
compare :: ScimBool -> ScimBool -> Ordering
$c< :: ScimBool -> ScimBool -> Bool
< :: ScimBool -> ScimBool -> Bool
$c<= :: ScimBool -> ScimBool -> Bool
<= :: ScimBool -> ScimBool -> Bool
$c> :: ScimBool -> ScimBool -> Bool
> :: ScimBool -> ScimBool -> Bool
$c>= :: ScimBool -> ScimBool -> Bool
>= :: ScimBool -> ScimBool -> Bool
$cmax :: ScimBool -> ScimBool -> ScimBool
max :: ScimBool -> ScimBool -> ScimBool
$cmin :: ScimBool -> ScimBool -> ScimBool
min :: ScimBool -> ScimBool -> ScimBool
Ord)
  deriving newtype ([ScimBool] -> Value
[ScimBool] -> Encoding
ScimBool -> Value
ScimBool -> Encoding
(ScimBool -> Value)
-> (ScimBool -> Encoding)
-> ([ScimBool] -> Value)
-> ([ScimBool] -> Encoding)
-> ToJSON ScimBool
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: ScimBool -> Value
toJSON :: ScimBool -> Value
$ctoEncoding :: ScimBool -> Encoding
toEncoding :: ScimBool -> Encoding
$ctoJSONList :: [ScimBool] -> Value
toJSONList :: [ScimBool] -> Value
$ctoEncodingList :: [ScimBool] -> Encoding
toEncodingList :: [ScimBool] -> Encoding
ToJSON)

instance FromJSON ScimBool where
  parseJSON :: Value -> Parser ScimBool
parseJSON (Bool Bool
bl) = ScimBool -> Parser ScimBool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ScimBool
ScimBool Bool
bl)
  parseJSON (String Text
str) =
    case Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
str of
      CI Text
"true" -> ScimBool -> Parser ScimBool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ScimBool
ScimBool Bool
True)
      CI Text
"false" -> ScimBool -> Parser ScimBool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ScimBool
ScimBool Bool
False)
      CI Text
_ -> String -> Parser ScimBool
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ScimBool) -> String -> Parser ScimBool
forall a b. (a -> b) -> a -> b
$ String
"Expected true, false, \"true\", or \"false\" (case insensitive), but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
str
  parseJSON Value
bad = String -> Parser ScimBool
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ScimBool) -> String -> Parser ScimBool
forall a b. (a -> b) -> a -> b
$ String
"Expected true, false, \"true\", or \"false\" (case insensitive), but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
bad

toKeyword :: String -> String
toKeyword :: ShowS
toKeyword String
"typ" = String
"type"
toKeyword String
"ref" = String
"$ref"
toKeyword String
other = String
other

serializeOptions :: Options
serializeOptions :: Options
serializeOptions =
  Options
defaultOptions
    { omitNothingFields = True,
      fieldLabelModifier = toKeyword
    }

parseOptions :: Options
parseOptions :: Options
parseOptions =
  Options
defaultOptions
    { fieldLabelModifier = toKeyword . CI.foldCase
    }

-- | Turn all keys in a JSON object to lowercase recursively.  This is applied to the aeson
-- 'Value' to be parsed; 'parseOptions' is applied to the keys passed to '(.:)' etc.  If an
-- object contains two fields that only differ in casing, 'Left' is returned with a list of
-- the offending fields.
--
-- NB: be careful to not mix 'Data.Text.{toLower,toCaseFold}', 'Data.Char.toLower', and
-- 'Data.CaseInsensitive.foldCase'.  They're not all the same thing!
-- https://github.com/basvandijk/case-insensitive/issues/31
--
-- (FUTUREWORK: The "recursively" part is a bit of a waste and could be dropped, but we would
-- have to spend more effort in making sure it is always called manually in nested parsers.)
jsonLower :: forall m. (m ~ Either [Text]) => Value -> m Value
jsonLower :: forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower (Object (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList -> [(Key, Value)]
olist)) =
  Object -> Value
Object (Object -> Value)
-> ([(Key, Value)] -> Object) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Value) -> m [(Key, Value)] -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m ()
nubCI m () -> m [(Key, Value)] -> m [(Key, Value)]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Key, Value) -> m (Key, Value))
-> [(Key, Value)] -> m [(Key, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Key, Value) -> m (Key, Value)
lowerPair [(Key, Value)]
olist)
  where
    nubCI :: m ()
    nubCI :: m ()
nubCI =
      let unnubbed :: [Text]
unnubbed = Key -> Text
Key.toText (Key -> Text) -> ((Key, Value) -> Key) -> (Key, Value) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Value) -> Key
forall a b. (a, b) -> a
fst ((Key, Value) -> Text) -> [(Key, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Value)]
olist
       in case [Text]
unnubbed [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
unnubbed of
            [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            bad :: [Text]
bad@(Text
_ : [Text]
_) -> [Text] -> Either [Text] ()
forall a b. a -> Either a b
Left [Text]
bad
    lowerPair :: (Key.Key, Value) -> m (Key.Key, Value)
    lowerPair :: (Key, Value) -> m (Key, Value)
lowerPair (Key
key, Value
val) = (Key -> Key
lowerKey Key
key,) (Value -> (Key, Value)) -> m Value -> m (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower Value
val
jsonLower (Array Array
x) = Array -> Value
Array (Array -> Value) -> m Array -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> m Value) -> Array -> m Array
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM Value -> m Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower Array
x
jsonLower same :: Value
same@(String Text
_) = Value -> Either [Text] Value
forall a b. b -> Either a b
Right Value
same -- (only object attributes, not all texts in the value side of objects!)
jsonLower same :: Value
same@(Number Scientific
_) = Value -> Either [Text] Value
forall a b. b -> Either a b
Right Value
same
jsonLower same :: Value
same@(Bool Bool
_) = Value -> Either [Text] Value
forall a b. b -> Either a b
Right Value
same
jsonLower same :: Value
same@Value
Null = Value -> Either [Text] Value
forall a b. b -> Either a b
Right Value
same

lowerKey :: Key.Key -> Key.Key
lowerKey :: Key -> Key
lowerKey = Text -> Key
Key.fromText (Text -> Key) -> (Key -> Text) -> Key -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall s. FoldCase s => s -> s
CI.foldCase (Text -> Text) -> (Key -> Text) -> Key -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText