{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}

module Servant.Hateoas.ContentType.HAL
( HAL
, HALResource(..)
)
where

import Servant.Hateoas.Resource
import Servant.Hateoas.Some
import Servant.API.ContentTypes
import qualified Network.HTTP.Media as M
import Servant.Links
import qualified Data.Foldable as Foldable
import Data.Kind
import Data.Proxy
import Data.Aeson
import Data.Aeson.KeyMap (singleton)
import GHC.Exts
import GHC.TypeLits
import GHC.Generics
import GHC.Records

-- | Data-Kind representing Content-Types of Hypertext Application Language (HAL).
--
--   Type parameter @t@ is the mime type suffix in @application/hal+t@.
data HAL (t :: Type)

-- | Resource wrapper for HAL.
data HALResource a = HALResource
  { forall a. HALResource a -> a
resource :: a                                       -- ^ Wrapped resource
  , forall a. HALResource a -> [(String, Link)]
links    :: [(String, Link)]                        -- ^ Pairs @(rel, link)@ for relations
  , forall a. HALResource a -> [(String, SomeToJSON HALResource)]
embedded :: [(String, SomeToJSON HALResource)]      -- ^ Pairs @(rel, resource)@ for embedded resources
  } deriving ((forall x. HALResource a -> Rep (HALResource a) x)
-> (forall x. Rep (HALResource a) x -> HALResource a)
-> Generic (HALResource a)
forall x. Rep (HALResource a) x -> HALResource a
forall x. HALResource a -> Rep (HALResource a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (HALResource a) x -> HALResource a
forall a x. HALResource a -> Rep (HALResource a) x
$cfrom :: forall a x. HALResource a -> Rep (HALResource a) x
from :: forall x. HALResource a -> Rep (HALResource a) x
$cto :: forall a x. Rep (HALResource a) x -> HALResource a
to :: forall x. Rep (HALResource a) x -> HALResource a
Generic)

instance Resource HALResource where
  addLink :: forall a. (String, Link) -> HALResource a -> HALResource a
addLink (String, Link)
l (HALResource a
r [(String, Link)]
ls [(String, SomeToJSON HALResource)]
es) = a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
forall a.
a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
HALResource a
r ((String, Link)
l(String, Link) -> [(String, Link)] -> [(String, Link)]
forall a. a -> [a] -> [a]
:[(String, Link)]
ls) [(String, SomeToJSON HALResource)]
es

instance Accept (HAL JSON) where
  contentType :: Proxy (HAL JSON) -> MediaType
contentType Proxy (HAL JSON)
_ = ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"hal+json"

instance ToJSON a => MimeRender (HAL JSON) (HALResource a) where
  mimeRender :: Proxy (HAL JSON) -> HALResource a -> ByteString
mimeRender Proxy (HAL JSON)
_ = HALResource a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
  toJSON :: HALResource a -> Value
toJSON (HALResource a
res [(String, Link)]
ls [(String, SomeToJSON HALResource)]
es) = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
res of
    Object Object
kvm -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
singleton Key
"_links" Value
ls') Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
singleton Key
"_embedded" Value
es') Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
kvm
    Value
v -> Value
v
    where
      ls' :: Value
ls' = [Pair] -> Value
object [String -> Key
forall a. IsString a => String -> a
fromString String
rel Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"href" Key -> URI -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Link -> URI
linkURI Link
href] | (String
rel, Link
href) <- [(String, Link)]
ls]
      es' :: Value
es' = [Pair] -> Value
object [String -> Key
forall a. IsString a => String -> a
fromString String
name Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeToJSON HALResource -> Value
forall a. ToJSON a => a -> Value
toJSON SomeToJSON HALResource
e | (String
name, SomeToJSON HALResource
e) <- [(String, SomeToJSON HALResource)]
es]

instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON [HALResource a] where
  toJSON :: [HALResource a] -> Value
toJSON [HALResource a]
xs = [Pair] -> Value
object [Key
"_links" Key -> Object -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Object
forall a. Monoid a => a
mempty :: Object), Key
"_embedded" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
es]
    where
      es :: Value
es = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [  String -> Key
forall a. IsString a => String -> a
fromString (Proxy (CollectionName a) -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(CollectionName a)))
        Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Array -> HALResource a -> Array)
-> Array -> [HALResource a] -> Array
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\Array
xs' HALResource a
x -> Array
xs' Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Value -> Array
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HALResource a -> Value
forall a. ToJSON a => a -> Value
toJSON HALResource a
x)) Array
forall a. Monoid a => a
mempty [HALResource a]
xs)
        ]

instance EmbeddingResource HALResource where
  embed :: forall b a.
ToJSON b =>
(String, b) -> HALResource a -> HALResource a
embed (String, b)
e (HALResource a
r [(String, Link)]
ls [(String, SomeToJSON HALResource)]
es) = a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
forall a.
a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
HALResource a
r [(String, Link)]
ls ([(String, SomeToJSON HALResource)] -> HALResource a)
-> [(String, SomeToJSON HALResource)] -> HALResource a
forall a b. (a -> b) -> a -> b
$ (b -> SomeToJSON HALResource)
-> (String, b) -> (String, SomeToJSON HALResource)
forall a b. (a -> b) -> (String, a) -> (String, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> SomeToJSON HALResource
forall {k} a (f :: k). ToJSON a => a -> SomeToJSON f
SomeToJSON (String, b)
e (String, SomeToJSON HALResource)
-> [(String, SomeToJSON HALResource)]
-> [(String, SomeToJSON HALResource)]
forall a. a -> [a] -> [a]
: [(String, SomeToJSON HALResource)]
es

instance {-# OVERLAPPABLE #-}
  ( Related a, HasField (IdSelName a) a id, IsElem (GetOneApi a) api
  , HasLink (GetOneApi a), MkLink (GetOneApi a) Link ~ (id -> Link)
  , BuildRels api (Relations a) a
  , Resource HALResource
  ) => ToResource api HALResource a where
  toResource :: a -> HALResource a
toResource a
x = a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
forall a.
a
-> [(String, Link)]
-> [(String, SomeToJSON HALResource)]
-> HALResource a
HALResource a
x (Proxy api -> a -> [(String, Link)]
forall api a id.
(Related a, HasField (IdSelName a) a id, IsElem (GetOneApi a) api,
 HasLink (GetOneApi a), MkLink (GetOneApi a) Link ~ (id -> Link),
 BuildRels api (Relations a) a) =>
Proxy api -> a -> [(String, Link)]
defaultLinks (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) a
x) [(String, SomeToJSON HALResource)]
forall a. Monoid a => a
mempty