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

module Servant.Hateoas.ContentType.Collection
( Collection
, CollectionResource(..)
, CollectionItem(..)
)
where

import Servant.Hateoas.Resource
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.Aeson
import Data.Proxy
import GHC.Exts
import GHC.Records
import GHC.Generics

-- | Data-Kind representing Content-Types of HATEOAS collections.
--
-- Type parameter @t@ is the Mime-Type suffix in @application/vnd.collection+t@.
data Collection (t :: Type)

-- | Resource wrapper for 'Collection'.
data CollectionResource a = CollectionResource
  { forall a. CollectionResource a -> Maybe Link
href  :: Maybe Link                   -- ^ Link to the collection
  , forall a. CollectionResource a -> [CollectionItem a]
items :: [CollectionItem a]           -- ^ All items in the collection
  , forall a. CollectionResource a -> [(String, Link)]
links :: [(String, Link)]             -- ^ Pairs @(rel, link)@ for relations
  } deriving (Int -> CollectionResource a -> ShowS
[CollectionResource a] -> ShowS
CollectionResource a -> String
(Int -> CollectionResource a -> ShowS)
-> (CollectionResource a -> String)
-> ([CollectionResource a] -> ShowS)
-> Show (CollectionResource a)
forall a. Show a => Int -> CollectionResource a -> ShowS
forall a. Show a => [CollectionResource a] -> ShowS
forall a. Show a => CollectionResource a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> CollectionResource a -> ShowS
showsPrec :: Int -> CollectionResource a -> ShowS
$cshow :: forall a. Show a => CollectionResource a -> String
show :: CollectionResource a -> String
$cshowList :: forall a. Show a => [CollectionResource a] -> ShowS
showList :: [CollectionResource a] -> ShowS
Show, (forall x. CollectionResource a -> Rep (CollectionResource a) x)
-> (forall x. Rep (CollectionResource a) x -> CollectionResource a)
-> Generic (CollectionResource a)
forall x. Rep (CollectionResource a) x -> CollectionResource a
forall x. CollectionResource a -> Rep (CollectionResource a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (CollectionResource a) x -> CollectionResource a
forall a x. CollectionResource a -> Rep (CollectionResource a) x
$cfrom :: forall a x. CollectionResource a -> Rep (CollectionResource a) x
from :: forall x. CollectionResource a -> Rep (CollectionResource a) x
$cto :: forall a x. Rep (CollectionResource a) x -> CollectionResource a
to :: forall x. Rep (CollectionResource a) x -> CollectionResource a
Generic)

-- | A single item inside a 'CollectionResource'.
data CollectionItem a = CollectionItem
  { forall a. CollectionItem a -> a
item :: a                             -- ^ Wrapped item
  , forall a. CollectionItem a -> [(String, Link)]
itemLinks :: [(String, Link)]         -- ^ Links for the wrapped item
  } deriving (Int -> CollectionItem a -> ShowS
[CollectionItem a] -> ShowS
CollectionItem a -> String
(Int -> CollectionItem a -> ShowS)
-> (CollectionItem a -> String)
-> ([CollectionItem a] -> ShowS)
-> Show (CollectionItem a)
forall a. Show a => Int -> CollectionItem a -> ShowS
forall a. Show a => [CollectionItem a] -> ShowS
forall a. Show a => CollectionItem a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> CollectionItem a -> ShowS
showsPrec :: Int -> CollectionItem a -> ShowS
$cshow :: forall a. Show a => CollectionItem a -> String
show :: CollectionItem a -> String
$cshowList :: forall a. Show a => [CollectionItem a] -> ShowS
showList :: [CollectionItem a] -> ShowS
Show, (forall x. CollectionItem a -> Rep (CollectionItem a) x)
-> (forall x. Rep (CollectionItem a) x -> CollectionItem a)
-> Generic (CollectionItem a)
forall x. Rep (CollectionItem a) x -> CollectionItem a
forall x. CollectionItem a -> Rep (CollectionItem a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (CollectionItem a) x -> CollectionItem a
forall a x. CollectionItem a -> Rep (CollectionItem a) x
$cfrom :: forall a x. CollectionItem a -> Rep (CollectionItem a) x
from :: forall x. CollectionItem a -> Rep (CollectionItem a) x
$cto :: forall a x. Rep (CollectionItem a) x -> CollectionItem a
to :: forall x. Rep (CollectionItem a) x -> CollectionItem a
Generic)

instance Resource CollectionResource where
  addLink :: forall a.
(String, Link) -> CollectionResource a -> CollectionResource a
addLink (String, Link)
l (CollectionResource Maybe Link
h [CollectionItem a]
r [(String, Link)]
ls) = Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
forall a.
Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
CollectionResource Maybe Link
h [CollectionItem a]
r ((String, Link)
l(String, Link) -> [(String, Link)] -> [(String, Link)]
forall a. a -> [a] -> [a]
:[(String, Link)]
ls)

instance Resource CollectionItem where
  addLink :: forall a. (String, Link) -> CollectionItem a -> CollectionItem a
addLink (String, Link)
l (CollectionItem a
i [(String, Link)]
ls) = a -> [(String, Link)] -> CollectionItem a
forall a. a -> [(String, Link)] -> CollectionItem a
CollectionItem a
i ((String, Link)
l(String, Link) -> [(String, Link)] -> [(String, Link)]
forall a. a -> [a] -> [a]
:[(String, Link)]
ls)

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

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

collectionLinks :: [(String, Link)] -> Value
collectionLinks :: [(String, Link)] -> Value
collectionLinks = Array -> Value
Array (Array -> Value)
-> ([(String, Link)] -> Array) -> [(String, Link)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array -> (String, Link) -> Array)
-> Array -> [(String, Link)] -> 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 (String
rel, Link
l) -> Value -> Array
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pair] -> Value
object [Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
rel, Key
"value" 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
l]) Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
xs) Array
forall a. Monoid a => a
mempty

instance ToJSON a => ToJSON (CollectionItem a) where
  toJSON :: CollectionItem a -> Value
toJSON (CollectionItem (a -> Value
forall a. ToJSON a => a -> Value
toJSON -> Object Object
m) [(String, Link)]
ls) = [Pair] -> Value
object [Key
"data" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
itemData, Key
"links" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(String, Link)] -> Value
collectionLinks [(String, Link)]
ls]
    where
      itemData :: Value
itemData = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Array -> Pair -> Array) -> Array -> [Pair] -> 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 (Key
k, Value
v) -> Value -> Array
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pair] -> Value
object [Key
"name" Key -> Key -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Key
k, Key
"value" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v]) Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
xs) Array
forall a. Monoid a => a
mempty ([Pair] -> Array) -> [Pair] -> Array
forall a b. (a -> b) -> a -> b
$ Object -> [Item Object]
forall l. IsList l => l -> [Item l]
toList Object
m
  toJSON (CollectionItem (a -> Value
forall a. ToJSON a => a -> Value
toJSON -> Value
v) [(String, Link)]
_) = Value
v

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (CollectionResource a) where
  toJSON :: CollectionResource a -> Value
toJSON (CollectionResource Maybe Link
mHref [CollectionItem a]
is [(String, Link)]
ls) = [Pair] -> Value
object [Key
"collection" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
collection]
    where
      collection :: Value
collection = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Key
"version" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"1.0" :: String), Key
"links" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(String, Link)] -> Value
collectionLinks [(String, Link)]
ls, Key
"items" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
is'] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair] -> (Link -> [Pair]) -> Maybe Link -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Pair -> [Pair]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> [Pair]) -> (Link -> Pair) -> Link -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"href" .=) (URI -> Pair) -> (Link -> URI) -> Link -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Link -> URI
linkURI) Maybe Link
mHref
      is' :: Value
is' = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Array -> CollectionItem a -> Array)
-> Array -> [CollectionItem 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 CollectionItem a
i -> Value -> Array
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CollectionItem a -> Value
forall a. ToJSON a => a -> Value
toJSON CollectionItem a
i) Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
xs) Array
forall a. Monoid a => a
mempty [CollectionItem a]
is

instance CollectingResource CollectionResource where
  collect :: forall a. a -> CollectionResource a -> CollectionResource a
collect a
i (CollectionResource Maybe Link
mHref [CollectionItem a]
is [(String, Link)]
ls) = Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
forall a.
Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
CollectionResource Maybe Link
mHref (a -> [(String, Link)] -> CollectionItem a
forall a. a -> [(String, Link)] -> CollectionItem a
CollectionItem a
i [(String, Link)]
forall a. Monoid a => a
mempty CollectionItem a -> [CollectionItem a] -> [CollectionItem a]
forall a. a -> [a] -> [a]
: [CollectionItem a]
is) [(String, Link)]
ls

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 CollectionResource
  )
  => ToCollection api CollectionResource a where
  toCollection :: forall (f :: * -> *). Foldable f => f a -> CollectionResource a
toCollection f a
is = Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
forall a.
Maybe Link
-> [CollectionItem a] -> [(String, Link)] -> CollectionResource a
CollectionResource Maybe Link
forall a. Maybe a
Nothing [CollectionItem a]
is' [(String, Link)]
forall a. Monoid a => a
mempty
    where
      is' :: [CollectionItem a]
is' = ([CollectionItem a] -> a -> [CollectionItem a])
-> [CollectionItem a] -> f a -> [CollectionItem a]
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\[CollectionItem a]
xs a
x -> a -> [(String, Link)] -> CollectionItem a
forall a. a -> [(String, Link)] -> CollectionItem a
CollectionItem 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) CollectionItem a -> [CollectionItem a] -> [CollectionItem a]
forall a. a -> [a] -> [a]
: [CollectionItem a]
xs) [CollectionItem a]
forall a. Monoid a => a
mempty f a
is