{-# LANGUAGE OverloadedStrings #-}

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 GHC.Exts
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)

type instance MkResource (Collection t) = CollectionResource

-- | Resource wrapper for 'Collection'.
data CollectionResource a = CollectionResource
  { forall a. CollectionResource a -> Maybe URI
href  :: Maybe URI                   -- ^ Link to the collection
  , forall a. CollectionResource a -> [CollectionItem a]
items :: [CollectionItem a]          -- ^ All items in the collection
  , forall a. CollectionResource a -> [(String, ResourceLink)]
rels  :: [(String, ResourceLink)]    -- ^ 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, (forall a b.
 (a -> b) -> CollectionResource a -> CollectionResource b)
-> (forall a b. a -> CollectionResource b -> CollectionResource a)
-> Functor CollectionResource
forall a b. a -> CollectionResource b -> CollectionResource a
forall a b.
(a -> b) -> CollectionResource a -> CollectionResource 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) -> CollectionResource a -> CollectionResource b
fmap :: forall a b.
(a -> b) -> CollectionResource a -> CollectionResource b
$c<$ :: forall a b. a -> CollectionResource b -> CollectionResource a
<$ :: forall a b. a -> CollectionResource b -> CollectionResource a
Functor)

instance Semigroup (CollectionResource a) where
  (CollectionResource Maybe URI
_ [CollectionItem a]
is [(String, ResourceLink)]
ls) <> :: CollectionResource a
-> CollectionResource a -> CollectionResource a
<> (CollectionResource Maybe URI
_ [CollectionItem a]
is' [(String, ResourceLink)]
ls') = Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
forall a.
Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
CollectionResource Maybe URI
forall a. Maybe a
Nothing ([CollectionItem a]
is [CollectionItem a] -> [CollectionItem a] -> [CollectionItem a]
forall a. Semigroup a => a -> a -> a
<> [CollectionItem a]
is') ([(String, ResourceLink)]
ls [(String, ResourceLink)]
-> [(String, ResourceLink)] -> [(String, ResourceLink)]
forall a. Semigroup a => a -> a -> a
<> [(String, ResourceLink)]
ls')

instance Monoid (CollectionResource a) where
  mempty :: CollectionResource a
mempty = Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
forall a.
Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
CollectionResource Maybe URI
forall a. Maybe a
Nothing [] []

-- | A single item inside a 'CollectionResource'.
data CollectionItem a = CollectionItem
  { forall a. CollectionItem a -> a
item :: a                             -- ^ Wrapped item
  , forall a. CollectionItem a -> [(String, ResourceLink)]
itemLinks :: [(String, ResourceLink)]         -- ^ 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, (forall a b. (a -> b) -> CollectionItem a -> CollectionItem b)
-> (forall a b. a -> CollectionItem b -> CollectionItem a)
-> Functor CollectionItem
forall a b. a -> CollectionItem b -> CollectionItem a
forall a b. (a -> b) -> CollectionItem a -> CollectionItem 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) -> CollectionItem a -> CollectionItem b
fmap :: forall a b. (a -> b) -> CollectionItem a -> CollectionItem b
$c<$ :: forall a b. a -> CollectionItem b -> CollectionItem a
<$ :: forall a b. a -> CollectionItem b -> CollectionItem a
Functor)

instance Resource CollectionResource where
  wrap :: forall a. a -> CollectionResource a
wrap a
x = Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
forall a.
Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
CollectionResource Maybe URI
forall a. Maybe a
Nothing [a -> CollectionItem a
forall a. a -> CollectionItem a
forall (res :: * -> *) a. Resource res => a -> res a
wrap a
x] []
  addRel :: forall a.
(String, ResourceLink)
-> CollectionResource a -> CollectionResource a
addRel (String, ResourceLink)
l (CollectionResource Maybe URI
h [CollectionItem a]
r [(String, ResourceLink)]
ls) = Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
forall a.
Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
CollectionResource Maybe URI
h [CollectionItem a]
r ((String, ResourceLink)
l(String, ResourceLink)
-> [(String, ResourceLink)] -> [(String, ResourceLink)]
forall a. a -> [a] -> [a]
:[(String, ResourceLink)]
ls)

instance Resource CollectionItem where
  wrap :: forall a. a -> CollectionItem a
wrap a
x = a -> [(String, ResourceLink)] -> CollectionItem a
forall a. a -> [(String, ResourceLink)] -> CollectionItem a
CollectionItem a
x []
  addRel :: forall a.
(String, ResourceLink) -> CollectionItem a -> CollectionItem a
addRel (String, ResourceLink)
l (CollectionItem a
i [(String, ResourceLink)]
ls) = a -> [(String, ResourceLink)] -> CollectionItem a
forall a. a -> [(String, ResourceLink)] -> CollectionItem a
CollectionItem a
i ((String, ResourceLink)
l(String, ResourceLink)
-> [(String, ResourceLink)] -> [(String, ResourceLink)]
forall a. a -> [a] -> [a]
:[(String, ResourceLink)]
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 (CollectionResource 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, ResourceLink)] -> Value
collectionLinks :: [(String, ResourceLink)] -> Value
collectionLinks = Array -> Value
Array (Array -> Value)
-> ([(String, ResourceLink)] -> Array)
-> [(String, ResourceLink)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array -> (String, ResourceLink) -> Array)
-> Array -> [(String, ResourceLink)] -> 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, ResourceLink
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 -> ResourceLink -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ResourceLink
l]) Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
xs) Array
forall a. Monoid a => a
mempty

-- TODO: I dont like this at all
-- CollectionResource a represents [a]
-- So CollectionResource [a] represents [[a]]
-- This is bad, when rewriting [Foo] in for the ResourceServer we get CollectionResource [Foo] but we want CollectionResource Foo
-- Best would be to handle this when rewriting but does this result in bloat?
-- It actually may not because we can match specialized cases in type families Resourcify and ResourcifyServer
-- How does this affect other parts of the procedure?
-- Ideally we do not have to adjust any HasResourceServer/BuildLayerLink instances at all

instance ToJSON a => ToJSON (CollectionItem a) where
  toJSON :: CollectionItem a -> Value
toJSON (CollectionItem a
x [(String, ResourceLink)]
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, ResourceLink)] -> Value
collectionLinks [(String, ResourceLink)]
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
$ case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x of Object Object
o -> Object -> [Item Object]
forall l. IsList l => l -> [Item l]
toList Object
o ; Value
_ -> [Pair]
forall a. Monoid a => a
mempty

instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (CollectionResource a) where
  toJSON :: CollectionResource a -> Value
toJSON (CollectionResource Maybe URI
mHref [CollectionItem a]
is [(String, ResourceLink)]
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, ResourceLink)] -> Value
collectionLinks [(String, ResourceLink)]
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] -> (URI -> [Pair]) -> Maybe URI -> [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]) -> (URI -> Pair) -> URI -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"href" .=)) Maybe URI
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 URI
mHref [CollectionItem a]
is [(String, ResourceLink)]
ls) = Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
forall a.
Maybe URI
-> [CollectionItem a]
-> [(String, ResourceLink)]
-> CollectionResource a
CollectionResource Maybe URI
mHref (a -> [(String, ResourceLink)] -> CollectionItem a
forall a. a -> [(String, ResourceLink)] -> CollectionItem a
CollectionItem a
i [(String, ResourceLink)]
forall a. Monoid a => a
mempty CollectionItem a -> [CollectionItem a] -> [CollectionItem a]
forall a. a -> [a] -> [a]
: [CollectionItem a]
is) [(String, ResourceLink)]
ls