{-# LANGUAGE OverloadedStrings #-}

module Servant.Hateoas.ContentType.HAL
(
  -- * Content-Type
  HAL

  -- * Resource-Type
, HALResource(..)
)
where

import Servant
import Servant.Hateoas.Resource
import Servant.Hateoas.RelationLink
import qualified Network.HTTP.Media as M
import qualified Data.Foldable as Foldable
import Data.Some.Constraint
import Data.Kind
import Data.Aeson
import Data.Aeson.KeyMap (singleton)
import qualified Data.Text as Text
import GHC.Exts
import GHC.Generics

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

type instance MkResource (HAL t) = HALResource

-- | HAL-resource representation.
data HALResource a = HALResource
  { forall a. HALResource a -> a
resource :: a                                       -- ^ Wrapped resource
  , forall a. HALResource a -> [(String, RelationLink)]
rels     :: [(String, RelationLink)]                -- ^ Pairs @(rel, link)@ for hypermedia relations
  , forall a. HALResource a -> [(String, SomeF HALResource ToJSON)]
embedded :: [(String, SomeF HALResource ToJSON)]    -- ^ 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, (forall a b. (a -> b) -> HALResource a -> HALResource b)
-> (forall a b. a -> HALResource b -> HALResource a)
-> Functor HALResource
forall a b. a -> HALResource b -> HALResource a
forall a b. (a -> b) -> HALResource a -> HALResource b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HALResource a -> HALResource b
fmap :: forall a b. (a -> b) -> HALResource a -> HALResource b
$c<$ :: forall a b. a -> HALResource b -> HALResource a
<$ :: forall a b. a -> HALResource b -> HALResource a
Functor)

instance Resource HALResource where
  wrap :: forall a. a -> HALResource a
wrap a
x = a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
forall a.
a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
HALResource a
x [] []
  addRel :: forall a. (String, RelationLink) -> HALResource a -> HALResource a
addRel (String, RelationLink)
l (HALResource a
r [(String, RelationLink)]
ls [(String, SomeF HALResource ToJSON)]
es) = a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
forall a.
a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
HALResource a
r ((String, RelationLink)
l(String, RelationLink)
-> [(String, RelationLink)] -> [(String, RelationLink)]
forall a. a -> [a] -> [a]
:[(String, RelationLink)]
ls) [(String, SomeF HALResource ToJSON)]
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 (HALResource 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

renderHalLink :: RelationLink -> Value
renderHalLink :: RelationLink -> Value
renderHalLink RelationLink
l = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
  [ Key
"href" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RelationLink -> Text
getHref RelationLink
l
  , Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
Text.intercalate Text
"|" (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (MediaType -> String) -> MediaType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MediaType -> String
forall a. Show a => a -> String
show (MediaType -> Text) -> [MediaType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelationLink -> [MediaType]
_contentTypes RelationLink
l)
  ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if RelationLink -> Bool
_templated RelationLink
l then [Key
"templated" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
True] else []
    [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> (Text -> [Pair]) -> Maybe Text -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Pair]
forall a. Monoid a => a
mempty (\Text
t -> [Key
"title" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
t]) (RelationLink -> Maybe Text
_title RelationLink
l)

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
  toJSON :: HALResource a -> Value
toJSON (HALResource a
res [(String, RelationLink)]
ls [(String, SomeF HALResource ToJSON)]
es) = 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
<> (case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
res of Object Object
kvm -> Object
kvm ; Value
_ -> Object
forall a. Monoid a => a
mempty)
    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
.= RelationLink -> Value
renderHalLink RelationLink
l | (String
rel, RelationLink
l) <- [(String, RelationLink)]
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
.= f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
e | (String
name, (Some1 f a
e)) <- [(String, SomeF HALResource ToJSON)]
es]

instance {-# OVERLAPPING #-} ToJSON a => ToJSON (HALResource [a]) where
  toJSON :: HALResource [a] -> Value
toJSON (HALResource [a]
xs [(String, RelationLink)]
ls [(String, SomeF HALResource ToJSON)]
es) = [Pair] -> Value
object [Key
"_links" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
ls', Key
"_embedded" 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 ([Pair]
exs [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
es')]
    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
.= RelationLink -> Value
renderHalLink RelationLink
l | (String
rel, RelationLink
l) <- [(String, RelationLink)]
ls]
      es' :: [Pair]
es' = ((String, SomeF HALResource ToJSON) -> Pair)
-> [(String, SomeF HALResource ToJSON)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
eName, (Some1 f a
e)) -> String -> Key
forall a. IsString a => String -> a
fromString String
eName Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
e) [(String, SomeF HALResource ToJSON)]
es
      exs :: [Pair]
exs = [ Key
"items"
              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 -> a -> Array) -> Array -> [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' 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 (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x)) Array
forall a. Monoid a => a
mempty [a]
xs)
            ]

instance EmbeddingResource HALResource where
  embed :: forall e a.
ToJSON e =>
(String, HALResource e) -> HALResource a -> HALResource a
embed (String, HALResource e)
e (HALResource a
r [(String, RelationLink)]
ls [(String, SomeF HALResource ToJSON)]
es) = a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
forall a.
a
-> [(String, RelationLink)]
-> [(String, SomeF HALResource ToJSON)]
-> HALResource a
HALResource a
r [(String, RelationLink)]
ls ([(String, SomeF HALResource ToJSON)] -> HALResource a)
-> [(String, SomeF HALResource ToJSON)] -> HALResource a
forall a b. (a -> b) -> a -> b
$ (HALResource e -> SomeF HALResource ToJSON)
-> (String, HALResource e) -> (String, SomeF HALResource ToJSON)
forall a b. (a -> b) -> (String, a) -> (String, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HALResource e -> SomeF HALResource ToJSON
forall k (csf :: [(k -> *) -> Constraint])
       (csa :: [k -> Constraint]) (f :: k -> *) (a :: k).
(AllC csf f, AllC csa a) =>
f a -> Somes1 csf csa
Some1 (String, HALResource e)
e (String, SomeF HALResource ToJSON)
-> [(String, SomeF HALResource ToJSON)]
-> [(String, SomeF HALResource ToJSON)]
forall a. a -> [a] -> [a]
: [(String, SomeF HALResource ToJSON)]
es