{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2020 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.CaseInsensitive as CI
import qualified Data.Char as Char
import qualified Data.HashMap.Lazy as HML
import qualified Data.HashMap.Strict as HM
import Data.String.Conversions (cs)
import Data.Text hiding (dropWhile)
import qualified Network.URI as Network

data WithId id a = WithId
  { WithId id a -> id
id :: id,
    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
/= :: 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
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
showList :: [WithId id a] -> ShowS
$cshowList :: forall id a. (Show id, Show a) => [WithId id a] -> ShowS
show :: WithId id a -> String
$cshow :: forall id a. (Show id, Show a) => WithId id a -> String
showsPrec :: Int -> WithId id a -> ShowS
$cshowsPrec :: forall id a. (Show id, Show a) => Int -> 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 (Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HML.insert Text
"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 -> Text -> Parser id
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"id" Parser (a -> WithId id a) -> Parser a -> Parser (WithId id a)
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
showList :: [URI] -> ShowS
$cshowList :: [URI] -> ShowS
show :: URI -> String
$cshow :: URI -> String
showsPrec :: Int -> URI -> ShowS
$cshowsPrec :: Int -> URI -> ShowS
Show, URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c== :: 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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid URI"
    Just URI
some -> URI -> Parser URI
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
/= :: ScimBool -> ScimBool -> Bool
$c/= :: ScimBool -> ScimBool -> Bool
== :: ScimBool -> ScimBool -> Bool
$c== :: 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
showList :: [ScimBool] -> ShowS
$cshowList :: [ScimBool] -> ShowS
show :: ScimBool -> String
$cshow :: ScimBool -> String
showsPrec :: Int -> ScimBool -> ShowS
$cshowsPrec :: Int -> 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
min :: ScimBool -> ScimBool -> ScimBool
$cmin :: ScimBool -> ScimBool -> ScimBool
max :: ScimBool -> ScimBool -> ScimBool
$cmax :: ScimBool -> ScimBool -> ScimBool
>= :: ScimBool -> ScimBool -> Bool
$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
compare :: ScimBool -> ScimBool -> Ordering
$ccompare :: ScimBool -> ScimBool -> Ordering
$cp1Ord :: Eq ScimBool
Ord)
  deriving newtype ([ScimBool] -> Encoding
[ScimBool] -> Value
ScimBool -> Encoding
ScimBool -> Value
(ScimBool -> Value)
-> (ScimBool -> Encoding)
-> ([ScimBool] -> Value)
-> ([ScimBool] -> Encoding)
-> ToJSON ScimBool
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ScimBool] -> Encoding
$ctoEncodingList :: [ScimBool] -> Encoding
toJSONList :: [ScimBool] -> Value
$ctoJSONList :: [ScimBool] -> Value
toEncoding :: ScimBool -> Encoding
$ctoEncoding :: ScimBool -> Encoding
toJSON :: ScimBool -> Value
$ctoJSON :: ScimBool -> Value
ToJSON)

instance FromJSON ScimBool where
  parseJSON :: Value -> Parser ScimBool
parseJSON (Bool Bool
bl) = ScimBool -> Parser ScimBool
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ScimBool
ScimBool Bool
True)
      CI Text
"false" -> ScimBool -> Parser ScimBool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ScimBool
ScimBool Bool
False)
      CI Text
_ -> String -> Parser ScimBool
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 (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 :: Bool
omitNothingFields = Bool
True,
      fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
toKeyword
    }

parseOptions :: Options
parseOptions :: Options
parseOptions =
  Options
defaultOptions
    { fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
toKeyword ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
Char.toLower
    }

-- | 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.
--
-- (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 :: Value -> Value
jsonLower :: Value -> Value
jsonLower (Object Object
o) = Object -> Value
Object (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object)
-> (Object -> [(Text, Value)]) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> (Text, Value))
-> [(Text, Value)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> (Text, Value)
lowerPair ([(Text, Value)] -> [(Text, Value)])
-> (Object -> [(Text, Value)]) -> Object -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
o
  where
    lowerPair :: (Text, Value) -> (Text, Value)
lowerPair (Text
key, Value
val) = (Text -> Text
toLower Text
key, Value -> Value
jsonLower Value
val)
jsonLower (Array Array
x) = Array -> Value
Array (Value -> Value
jsonLower (Value -> Value) -> Array -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array
x)
jsonLower Value
x = Value
x