Merge pull request #5 from bruderj15/main

Publish v0.2.0

CHANGELOG.md

@@ -6,6 +6,16 @@ file.
 The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
 and this project adheres to [PVP versioning](https://pvp.haskell.org/).
 
+## v0.2.0 _(2024-10-29)_
+
+### Added
+- Support for Content-Type `application/collection+json`
+- Classes `EmbeddingResource res` & `CollectingResource res` for resource-modification
+
+### Changed
+
+- *(breaking change)* Renamed class `HasResource` to `Resource`, removed associated type and Content-Type param
+
 ## v0.1.1 _(2024-10-25)_
 
 ### Changed

README.md

@@ -12,10 +12,11 @@ Currently in infant state.
 Final goal is something similar to what has been proposed [here](https://www.servant.dev/extending.html#other-directions).
 
 ## What can we do already?
-Define an instance for class `ToResource ct api a` where `ct` is the Content-Type, `a` is the datatype you want to have a resty Api for and
-`api` is the type of your Servant-Api within which the resty representation of your datatype `a` lives.
+Define an instance for class `ToResource api res a` where `api` is the type of your Servant-Api within which the resty representation
+of your datatype `a` lives and `res` is the resource-representation to create.
 
-When providing some extra information with an instance for `Related a` we can derive related links.
+When providing some extra information with an instance for `Related a` there are stock instances which derive the links
+based on the relations in your instance.
 ## Example
 ```haskell
 data User = User { usrId :: Int, addressId :: Int, income :: Double }
@@ -33,43 +34,49 @@ type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResour
 
 type UserApi = UserGetOne :<|> UserGetAll
 type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)
-type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])
+type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User)
 
 instance Related User where
-  type IdSelName User      = "usrId"              -- This is type-safe because of using class HasField
-  type GetOneApi User      = UserGetOne
+  type IdSelName User = "usrId"
+  type GetOneApi User = UserGetOne
   type CollectionName User = "users"
-  type Relations User      =
-    '[ 'HRel "address" "addressId" AddressGetOne  -- Also type-safe
+  type Relations User =
+    '[ 'HRel "address" "addressId" AddressGetOne
      ]
+
 ```
 ```haskell
->>> mimeRender (Proxy @JSON) $ toResource (Proxy @(HAL JSON)) (Proxy @CompleteApi) $ User 1 100 100000
+>>> mimeRender (Proxy @(HAL JSON)) $ toResource @CompleteApi @HALResource $ User 1 42 100000
 ```
 ```json
 {
   "_links": {
     "address": {
-      "href": "address/100"
+      "href": "address/42"
     },
     "self": {
       "href": "user/1"
     }
   },
-  "addressId": 100,
+  "addressId": 42,
   "income": 100000,
   "usrId": 1
 }
 ```
 
 ## Goals
-- [x] Deriving links where possible
+- [x] Deriving simple links for self and relations
 - [ ] Deriving links for paging, ...
 - [ ] Type-level rewriting of APIs like `CompleteAPI` to make API HATEOAS-compliant
 
 ## Media-Types
-Currently we only serve Content-Type `application/hal+json`.
-Support for others such as `application/vnd.collection+json` or `application/vnd.amundsen-uber+json` can easily be added
-with instances for `Accept` and `MimeRender`.
+- [x] `application/hal+json`
+- [x] `application/collection+json`
+- [ ] Others: Easily extensible
+
+Client usage with `MimeUnrender` is not yet supported.
+
+## Contact information
+Contributions, critics and bug reports are welcome!
 
-Client usage with `MimeUnrender` is not yet supported but easily extensible.
+Please feel free to contact me through GitHub.

servant-hateoas.cabal

@@ -1,11 +1,13 @@
 cabal-version:           3.0
 name:                    servant-hateoas
-version:                 0.1.1
+version:                 0.2.0
 synopsis:                HATEOAS extension for servant
 description:             Create Resource-Representations for your types and make your API HATEOAS-compliant.
   Resource construction is generic where possible and manually adjustable where required.
   Currently HAL+JSON is the only supported Content-Type, work for more is in progress.
   The ultimate goal is to generate an entirely HATEOAS-compliant API generically.
+homepage:                https://github.com/bruderj15/servant-hateoas
+bug-reports:             https://github.com/bruderj15/servant-hateoas/issues
 license:                 BSD-3-Clause
 license-file:            LICENSE
 author:                  Julian Bruder
@@ -29,6 +31,7 @@ library
                        , Servant.Hateoas.Some
                        , Servant.Hateoas.Resource
                        , Servant.Hateoas.ContentType.HAL
+                       , Servant.Hateoas.ContentType.Collection
 
     other-modules:       Servant.Hateoas.Example
 

src/Servant/Hateoas.hs

@@ -1,9 +1,11 @@
 module Servant.Hateoas
-( module Servant.Hateoas.ContentType.HAL
+( module Servant.Hateoas.ContentType.Collection
+, module Servant.Hateoas.ContentType.HAL
 , module Servant.Hateoas.Resource
 , module Servant.Hateoas.Some
 ) where
 
-import Servant.Hateoas.ContentType.HAL
+import Servant.Hateoas.ContentType.Collection (Collection, CollectionResource)
+import Servant.Hateoas.ContentType.HAL (HAL, HALResource)
 import Servant.Hateoas.Resource
 import Servant.Hateoas.Some

src/Servant/Hateoas/ContentType/Collection.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Servant.Hateoas.ContentType.Collection
+( Collection
+, CollectionResource(..)
+)
+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
+  { href  :: Maybe Link
+  , items :: [CollectionItem a]
+  , links :: [(String, Link)]
+  } deriving (Show, Generic)
+
+-- | A single item inside a 'CollectionResource'.
+data CollectionItem a = CollectionItem
+  { item :: a
+  , itemLinks :: [(String, Link)]
+  } deriving (Show, Generic)
+
+instance Resource CollectionResource where
+  addLink l (CollectionResource h r ls) = CollectionResource h r (l:ls)
+
+instance Resource CollectionItem where
+  addLink l (CollectionItem i ls) = CollectionItem i (l:ls)
+
+instance Accept (Collection JSON) where
+  contentType _ = "application" M.// "vnd.collection+json"
+
+instance ToJSON a => MimeRender (Collection JSON) (CollectionResource a) where
+  mimeRender _ = encode
+
+collectionLinks :: [(String, Link)] -> Value
+collectionLinks = Array . Foldable.foldl' (\xs (rel, l) -> pure (object ["name" .= rel, "value" .= linkURI l]) <> xs) mempty
+
+instance ToJSON a => ToJSON (CollectionItem a) where
+  toJSON (CollectionItem (toJSON -> Object m) ls) = object ["data" .= itemData, "links" .= collectionLinks ls]
+    where
+      itemData = Array $ Foldable.foldl' (\xs (k, v) -> pure (object ["name" .= k, "value" .= v]) <> xs) mempty $ toList m
+  toJSON (CollectionItem (toJSON -> v) _) = v
+
+instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (CollectionResource a) where
+  toJSON (CollectionResource mHref is ls) = object ["collection" .= collection]
+    where
+      collection = object $ ["version" .= ("1.0" :: String), "links" .= collectionLinks ls, "items" .= is'] <> maybe [] (pure . ("href" .=) . linkURI) mHref
+      is' = Array $ Foldable.foldl' (\xs i -> pure (toJSON i) <> xs) mempty is
+
+instance CollectingResource CollectionResource where
+  collect i (CollectionResource mHref is ls) = CollectionResource mHref (CollectionItem i mempty : is) 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 is = CollectionResource Nothing is' mempty
+    where
+      is' = Foldable.foldl' (\xs x -> CollectionItem x (defaultLinks (Proxy @api) x) : xs) mempty is

src/Servant/Hateoas/ContentType/HAL.hs

@@ -35,12 +35,15 @@ data HALResource a = HALResource
   , embedded :: [(String, SomeToJSON HALResource)]
   } deriving (Generic)
 
-instance HasResource (HAL t) where
-  type Resource (HAL t) = HALResource
+instance Resource HALResource where
+  addLink l (HALResource r ls es) = HALResource r (l:ls) es
 
 instance Accept (HAL JSON) where
   contentType _ = "application" M.// "hal+json"
 
+instance ToJSON a => MimeRender (HAL JSON) (HALResource a) where
+  mimeRender _ = encode
+
 instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
   toJSON (HALResource res ls es) = case toJSON res of
     Object kvm -> Object $ (singleton "_links" ls') <> (singleton "_embedded" es') <> kvm
@@ -49,18 +52,21 @@ instance {-# OVERLAPPABLE #-} ToJSON a => ToJSON (HALResource a) where
       ls' = object [fromString rel .= object ["href" .= linkURI href] | (rel, href) <- ls]
       es' = object [fromString name .= toJSON e | (name, e) <- es]
 
-instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON ([HALResource a]) where
+instance {-# OVERLAPPING #-} (ToJSON a, Related a, KnownSymbol (CollectionName a)) => ToJSON [HALResource a] where
   toJSON xs = object ["_links" .= (mempty :: Object), "_embedded" .= es]
     where
       es = object $
         [  fromString (symbolVal (Proxy @(CollectionName a)))
         .= (Array $ Foldable.foldl' (\xs' x -> xs' <> pure (toJSON x)) mempty xs)
         ]
 
+instance EmbeddingResource HALResource where
+  embed e (HALResource r ls es) = HALResource r ls $ fmap SomeToJSON e : 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
-  , HasResource (HAL t)
-  ) => ToResource (HAL t) api a where
-  toResource _ api x = HALResource x (defaultLinks api x) mempty
+  , Resource HALResource
+  ) => ToResource api HALResource a where
+  toResource x = HALResource x (defaultLinks (Proxy @api) x) mempty

src/Servant/Hateoas/Example.hs

@@ -23,7 +23,7 @@ type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResour
 
 type UserApi = UserGetOne :<|> UserGetAll
 type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)
-type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])
+type UserGetAll = "user" :> Get '[Collection JSON] (CollectionResource User)
 
 instance Related User where
   type IdSelName User = "usrId"

src/Servant/Hateoas/Resource.hs

@@ -1,10 +1,15 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Servant.Hateoas.Resource
 (
   -- * Resource
-  HasResource(..)
-, ToResource(..)
+  -- ** Construction
+  ToResource(..)
+, ToCollection(..)
+
+  -- ** Modification
+, Resource(..), EmbeddingResource(..), CollectingResource(..)
 
 -- * Hypermedia-Relations
 -- ** Type
@@ -21,18 +26,46 @@ where
 
 import Servant
 import Data.Kind
+import Data.Aeson
 import GHC.TypeLits
 import GHC.Records
 
--- | Class that indicates that a Content-Type has a specific Resource-Representation.
-class HasResource ct where
-  -- | Associated type for this Content-Type
-  type Resource ct :: Type -> Type
+-- | Class for resources that carry Hypermedia-Relations.
+class Resource res where
+  -- | Add a relation @(rel, link)@ to a resource.
+  addLink :: (String, Link) -> res a -> res a
+
+-- | Class for 'Resource's that can embed other resources.
+class Resource res => EmbeddingResource res where
+  -- | Embed a resource @b@ with its relation @rel@ as tuple @(rel, b)@.
+  embed :: ToJSON b => (String, b) -> res a -> res a
+
+-- | Class for 'Resource's that can collect multiple resources.
+class Resource res => CollectingResource res where
+  -- | Collect a resource into the collection.
+  collect :: a -> res a -> res a
 
 -- | Class for converting values of @a@ to their respective Resource-Representation.
-class HasResource ct => ToResource ct api a where
+class ToResource api res a where
   -- | Converts a value into it's Resource-Representation.
-  toResource :: Proxy ct -> Proxy api -> a -> Resource ct a
+  toResource :: a -> res a
+  toResource = toResource' (Proxy @api) (Proxy @res)
+
+  -- | Like 'toResource' but takes proxies for ambiguity.
+  toResource' :: Proxy api -> Proxy res -> a -> res a
+  toResource' _ _ = toResource @api @res
+  {-# MINIMAL toResource | toResource' #-}
+
+-- | Class for converting multiple values of @a@ to their respective collection-like representation.
+class ToCollection api res a where
+  -- | Converts many values into their Collection-Representation.
+  toCollection :: Foldable f => f a -> res a
+  toCollection = toCollection' (Proxy @api) (Proxy @res)
+
+  -- | Like 'toCollection' but takes proxies for ambiguity.
+  toCollection' :: Foldable f => Proxy api -> Proxy res -> f a -> res a
+  toCollection' _ _ = toCollection @api @res
+  {-# MINIMAL toCollection | toCollection' #-}
 
 -- | Data-Kind for Hypermedia-Relations.
 data HRel = HRel
@@ -78,7 +111,7 @@ instance
 relatedLinks :: forall api a. (Related a, BuildRels api (Relations a) a) => Proxy api -> a -> [(String, Link)]
 relatedLinks = buildRels (Proxy @(Relations a))
 
--- | Generates the pair (\"self\", link) where @link@ is the 'Link' to @a@ itself.
+-- | Generates the pair @(\"self\", link)@ where @link@ is the 'Link' to @a@ itself.
 selfLink :: forall api a id.
   ( Related a, HasField (IdSelName a) a id
   , IsElem (GetOneApi a) api, HasLink (GetOneApi a)