-- 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.Meta where

import Data.Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text
import Data.Time.Clock
import GHC.Generics (Generic)
import Text.Read (readEither)
import Web.Scim.Schema.Common
import Web.Scim.Schema.ResourceType
import Prelude hiding (map)

data ETag = Weak Text | Strong Text
  deriving (ETag -> ETag -> Bool
(ETag -> ETag -> Bool) -> (ETag -> ETag -> Bool) -> Eq ETag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ETag -> ETag -> Bool
== :: ETag -> ETag -> Bool
$c/= :: ETag -> ETag -> Bool
/= :: ETag -> ETag -> Bool
Eq, Int -> ETag -> ShowS
[ETag] -> ShowS
ETag -> String
(Int -> ETag -> ShowS)
-> (ETag -> String) -> ([ETag] -> ShowS) -> Show ETag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ETag -> ShowS
showsPrec :: Int -> ETag -> ShowS
$cshow :: ETag -> String
show :: ETag -> String
$cshowList :: [ETag] -> ShowS
showList :: [ETag] -> ShowS
Show)

instance ToJSON ETag where
  toJSON :: ETag -> Value
toJSON (Weak Text
tag) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
"W/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Text -> String
forall a. Show a => a -> String
show Text
tag)
  -- (if a strong tag contains a "W/" prefix by accident, it will be parsed as weak tag.  this
  -- is mildly confusing, but should do no harm.)
  toJSON (Strong Text
tag) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (Text -> String
forall a. Show a => a -> String
show Text
tag)

instance FromJSON ETag where
  parseJSON :: Value -> Parser ETag
parseJSON = String -> (Text -> Parser ETag) -> Value -> Parser ETag
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ETag" ((Text -> Parser ETag) -> Value -> Parser ETag)
-> (Text -> Parser ETag) -> Value -> Parser ETag
forall a b. (a -> b) -> a -> b
$ \Text
s ->
    case Text -> Text -> Maybe Text
Text.stripPrefix Text
"W/" Text
s of
      Maybe Text
Nothing -> Text -> ETag
Strong (Text -> ETag) -> Parser Text -> Parser ETag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
forall {a} {f :: * -> *}. (Read a, MonadFail f) => Text -> f a
unquote Text
s
      Just Text
s' -> Text -> ETag
Weak (Text -> ETag) -> Parser Text -> Parser ETag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text
forall {a} {f :: * -> *}. (Read a, MonadFail f) => Text -> f a
unquote Text
s'
    where
      unquote :: Text -> f a
unquote Text
s = case String -> Either String a
forall a. Read a => String -> Either String a
readEither (Text -> String
unpack Text
s) of
        Right a
x -> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        Left String
e -> String -> f a
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"couldn't unquote the string: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e)

data Meta = Meta
  { Meta -> ResourceType
resourceType :: ResourceType,
    Meta -> UTCTime
created :: UTCTime,
    Meta -> UTCTime
lastModified :: UTCTime,
    -- | Resource version: <https://tools.ietf.org/html/rfc7644#section-3.14>.
    --
    -- A version is an /opaque/ string that doesn't need to conform to any
    -- format (e.g. it does not have to be a monotonically increasing integer,
    -- contrary to what the word @version@ suggests).
    --
    -- For 'Weak' versions we have to guarantee that different resources will
    -- have different 'version's. For 'Strong' versions we also have to
    -- guarantee that same resources will have the same 'version'.
    Meta -> ETag
version :: ETag,
    Meta -> URI
location :: URI
  }
  deriving (Meta -> Meta -> Bool
(Meta -> Meta -> Bool) -> (Meta -> Meta -> Bool) -> Eq Meta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Meta -> Meta -> Bool
== :: Meta -> Meta -> Bool
$c/= :: Meta -> Meta -> Bool
/= :: Meta -> Meta -> Bool
Eq, Int -> Meta -> ShowS
[Meta] -> ShowS
Meta -> String
(Int -> Meta -> ShowS)
-> (Meta -> String) -> ([Meta] -> ShowS) -> Show Meta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Meta -> ShowS
showsPrec :: Int -> Meta -> ShowS
$cshow :: Meta -> String
show :: Meta -> String
$cshowList :: [Meta] -> ShowS
showList :: [Meta] -> ShowS
Show, (forall x. Meta -> Rep Meta x)
-> (forall x. Rep Meta x -> Meta) -> Generic Meta
forall x. Rep Meta x -> Meta
forall x. Meta -> Rep Meta x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Meta -> Rep Meta x
from :: forall x. Meta -> Rep Meta x
$cto :: forall x. Rep Meta x -> Meta
to :: forall x. Rep Meta x -> Meta
Generic)

instance ToJSON Meta where
  toJSON :: Meta -> Value
toJSON = Options -> Meta -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
serializeOptions

instance FromJSON Meta where
  parseJSON :: Value -> Parser Meta
parseJSON = ([Text] -> Parser Meta)
-> (Value -> Parser Meta) -> Either [Text] Value -> Parser Meta
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Meta
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Meta)
-> ([Text] -> String) -> [Text] -> Parser Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> String
forall a. Show a => a -> String
show) (Options -> Value -> Parser Meta
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
parseOptions) (Either [Text] Value -> Parser Meta)
-> (Value -> Either [Text] Value) -> Value -> Parser Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either [Text] Value
forall (m :: * -> *). (m ~ Either [Text]) => Value -> m Value
jsonLower

data WithMeta a = WithMeta
  { forall a. WithMeta a -> Meta
meta :: Meta,
    forall a. WithMeta a -> a
thing :: a
  }
  deriving (WithMeta a -> WithMeta a -> Bool
(WithMeta a -> WithMeta a -> Bool)
-> (WithMeta a -> WithMeta a -> Bool) -> Eq (WithMeta a)
forall a. Eq a => WithMeta a -> WithMeta a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => WithMeta a -> WithMeta a -> Bool
== :: WithMeta a -> WithMeta a -> Bool
$c/= :: forall a. Eq a => WithMeta a -> WithMeta a -> Bool
/= :: WithMeta a -> WithMeta a -> Bool
Eq, Int -> WithMeta a -> ShowS
[WithMeta a] -> ShowS
WithMeta a -> String
(Int -> WithMeta a -> ShowS)
-> (WithMeta a -> String)
-> ([WithMeta a] -> ShowS)
-> Show (WithMeta a)
forall a. Show a => Int -> WithMeta a -> ShowS
forall a. Show a => [WithMeta a] -> ShowS
forall a. Show a => WithMeta a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithMeta a -> ShowS
showsPrec :: Int -> WithMeta a -> ShowS
$cshow :: forall a. Show a => WithMeta a -> String
show :: WithMeta a -> String
$cshowList :: forall a. Show a => [WithMeta a] -> ShowS
showList :: [WithMeta a] -> ShowS
Show, (forall x. WithMeta a -> Rep (WithMeta a) x)
-> (forall x. Rep (WithMeta a) x -> WithMeta a)
-> Generic (WithMeta a)
forall x. Rep (WithMeta a) x -> WithMeta a
forall x. WithMeta a -> Rep (WithMeta a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WithMeta a) x -> WithMeta a
forall a x. WithMeta a -> Rep (WithMeta a) x
$cfrom :: forall a x. WithMeta a -> Rep (WithMeta a) x
from :: forall x. WithMeta a -> Rep (WithMeta a) x
$cto :: forall a x. Rep (WithMeta a) x -> WithMeta a
to :: forall x. Rep (WithMeta a) x -> WithMeta a
Generic)

instance (ToJSON a) => ToJSON (WithMeta a) where
  toJSON :: WithMeta a -> Value
toJSON (WithMeta Meta
m 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
"meta" (Meta -> Value
forall a. ToJSON a => a -> Value
toJSON Meta
m) Object
o)
    Value
other -> Value
other

instance (FromJSON a) => FromJSON (WithMeta a) where
  parseJSON :: Value -> Parser (WithMeta a)
parseJSON = String
-> (Object -> Parser (WithMeta a)) -> Value -> Parser (WithMeta a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"WithMeta" ((Object -> Parser (WithMeta a)) -> Value -> Parser (WithMeta a))
-> (Object -> Parser (WithMeta a)) -> Value -> Parser (WithMeta a)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Meta -> a -> WithMeta a
forall a. Meta -> a -> WithMeta a
WithMeta (Meta -> a -> WithMeta a)
-> Parser Meta -> Parser (a -> WithMeta a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Meta
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"meta" Parser (a -> WithMeta a) -> Parser a -> Parser (WithMeta 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)