servant-hateoas (empty) → 0.1.0

raw patch · 10 files changed

+385/−0 lines, 10 filesdep +aesondep +basedep +http-media

Dependencies added: aeson, base, http-media, servant, servant-hateoas, servant-server

Files

• CHANGELOG.md +12/−0
• LICENSE +29/−0
• README.md +75/−0
• servant-hateoas.cabal +49/−0
• src/Servant/Hateoas.hs +9/−0
• src/Servant/Hateoas/ContentType/HAL.hs +66/−0
• src/Servant/Hateoas/Example.hs +34/−0
• src/Servant/Hateoas/Resource.hs +97/−0
• src/Servant/Hateoas/Some.hs +10/−0
• test/Main.hs +4/−0

@@ -0,0 +1,12 @@+# Changelog++All notable changes to the servant-hateoas library will be documented in this+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.0.1 _(2024-10-25)_++### Added+- Released

@@ -0,0 +1,29 @@+Copyright (c) 2024, Julian Bruder+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,75 @@+[![Hackage](https://img.shields.io/hackage/v/servant-hateoas.svg)](https://hackage.haskell.org/package/servant-hateoas)+![Static Badge](https://img.shields.io/badge/Lang-GHC2021-blue)+[![Haskell-CI](https://github.com/bruderj15/servant-hateoas/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/bruderj15/servant-hateoas/actions/workflows/haskell-ci.yml)++# servant-hateoas+HATEOAS support for [servant](https://hackage.haskell.org/package/servant).++## State+This is not affiliated with the official `servant` maintainers.++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.++When providing some extra information with an instance for `Related a` we can derive related links.+## Example+```haskell+data User = User { usrId :: Int, addressId :: Int, income :: Double }+  deriving stock (Generic, Show, Eq, Ord)+  deriving anyclass ToJSON++data Address = Address { addrId :: Int, street :: String, number :: Int}+  deriving stock (Generic, Show, Eq, Ord)+  deriving anyclass ToJSON++type CompleteApi = AddressApi :<|> UserApi++type AddressApi = AddressGetOne+type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResource Address)++type UserApi = UserGetOne :<|> UserGetAll+type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)+type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])++instance Related User where+  type IdSelName User      = "usrId"              -- This is type-safe because of using class HasField+  type GetOneApi User      = UserGetOne+  type CollectionName User = "users"+  type Relations User      =+    '[ 'HRel "address" "addressId" AddressGetOne  -- Also type-safe+     ]+```+```haskell+>>> mimeRender (Proxy @JSON) $ toResource (Proxy @(HAL JSON)) (Proxy @CompleteApi) $ User 1 100 100000+```+```json+{+  "_links": {+    "address": {+      "href": "address/100"+    },+    "self": {+      "href": "user/1"+    }+  },+  "addressId": 100,+  "income": 100000,+  "usrId": 1+}+```++## Goals+- [x] Deriving links where possible+- [ ] 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`.++Client usage with `MimeUnrender` is not yet supported but easily extensible.

@@ -0,0 +1,49 @@+cabal-version:           3.0+name:                    servant-hateoas+version:                 0.1.0+synopsis:                HATEOAS extension for servant+description:             Create Resource-Representations for your types and make your API HATEOAS-compliant. Generic Resource-construction where possible, manual where ypu want.+license:                 BSD-3-Clause+license-file:            LICENSE+author:                  Julian Bruder+maintainer:              julian.bruder@outlook.com+copyright:               © 2024 Julian Bruder+category:                Servant, Web, REST, HATEOAS+build-type:              Simple+extra-source-files:      README.md+extra-doc-files:         CHANGELOG.md+tested-with:             GHC == 9.4.8+                       , GHC == 9.6.4+                       , GHC == 9.8.2++common warnings+    ghc-options:        -Wall++library+    import:              warnings++    exposed-modules:     Servant.Hateoas+                       , Servant.Hateoas.Some+                       , Servant.Hateoas.Resource+                       , Servant.Hateoas.ContentType.HAL++    other-modules:       Servant.Hateoas.Example++    build-depends:       base                          >= 4.17.2 && < 5+                       , aeson                         >= 2.2.3  && < 2.3+                       , http-media                    >= 0.8.1  && < 0.9+                       , servant                       >= 0.20.2 && < 0.21+                       , servant-server                >= 0.20.2 && < 0.21+    hs-source-dirs:      src+    default-language:    GHC2021+    default-extensions:  DataKinds, TypeFamilies++test-suite servant-hateoas-test+    import:              warnings+    default-language:    GHC2021+    type:                exitcode-stdio-1.0+    hs-source-dirs:      test+    main-is:             Main.hs+    build-depends:+                         base >= 4.17.2 && < 5+                       , servant-hateoas

@@ -0,0 +1,9 @@+module Servant.Hateoas+( module Servant.Hateoas.ContentType.HAL+, module Servant.Hateoas.Resource+, module Servant.Hateoas.Some+) where++import Servant.Hateoas.ContentType.HAL+import Servant.Hateoas.Resource+import Servant.Hateoas.Some

@@ -0,0 +1,66 @@+{-# 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 with 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+  { resource :: a+  , links    :: [(String, Link)]+  , embedded :: [(String, SomeToJSON HALResource)]+  } deriving (Generic)++instance HasResource (HAL t) where+  type Resource (HAL t) = HALResource++instance Accept (HAL JSON) where+  contentType _ = "application" M.// "hal+json"++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+    v -> v+    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+  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 {-# 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

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}++module Servant.Hateoas.Example where++import Servant.Hateoas+import Servant+import Data.Aeson+import GHC.Generics++data User = User { usrId :: Int, addressId :: Int, income :: Double }+  deriving stock (Generic, Show, Eq, Ord)+  deriving anyclass ToJSON++data Address = Address { addrId :: Int, street :: String, number :: Int}+  deriving stock (Generic, Show, Eq, Ord)+  deriving anyclass ToJSON++type CompleteApi = AddressApi :<|> UserApi++type AddressApi = AddressGetOne+type AddressGetOne = "address" :> Capture "id" Int :> Get '[HAL JSON] (HALResource Address)++type UserApi = UserGetOne :<|> UserGetAll+type UserGetOne = "user" :> Capture "id" Int :> Get '[HAL JSON] (HALResource User)+type UserGetAll = "user" :> Get '[HAL JSON] (HALResource [User])++instance Related User where+  type IdSelName User = "usrId"+  type GetOneApi User = UserGetOne+  type CollectionName User = "users"+  type Relations User =+    '[ 'HRel "address" "addressId" AddressGetOne+     ]

@@ -0,0 +1,97 @@+{-# LANGUAGE UndecidableInstances #-}++module Servant.Hateoas.Resource+(+  -- * Resource+  HasResource(..)+, ToResource(..)++-- * Hypermedia-Relations+-- ** Type+, HRel(..)++-- ** Class+, Related(..)++-- ** Construction+, BuildRels(..)+, selfLink, relatedLinks, defaultLinks+)+where++import Servant+import Data.Kind+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 converting values of @a@ to their respective Resource-Representation.+class HasResource ct => ToResource ct api a where+  -- | Converts a value into it's Resource-Representation.+  toResource :: Proxy ct -> Proxy api -> a -> Resource ct a++-- | Data-Kind for Hypermedia-Relations.+data HRel = HRel+  { relName  :: Symbol       -- ^ Name of the relation+  , selName  :: Symbol       -- ^ Record selectors field name+  , endpoint :: Type         -- ^ Servant-Endpoint to use for retrieving one value for relation @relName@+  }++-- | Types that have Hypermedia-Relations.+class Related a where+  type IdSelName a      :: Symbol       -- ^ Name of the record selector that holds the resources identifier+  type GetOneApi a      :: Type         -- ^ Servant-Endpoint for retrieving one @a@ by its identifier+  type CollectionName a :: Symbol       -- ^ Name for collected values, defaults to @\"item\"@+  type CollectionName a = "items"+  type Relations a      :: [HRel]       -- ^ List of all relations @a@ has++-- | Class for deriving Hypermedia-Relations for types.+type BuildRels :: Type -> [HRel] -> Type -> Constraint+class BuildRels api rs a where+  buildRels :: Proxy rs -> Proxy api -> a -> [(String, Link)]++instance BuildRels api '[] a where+  buildRels _ _ _ = []++instance+  ( KnownSymbol relName+  , HasField selName a id+  , HasLink endpoint+  , IsElem endpoint api+  , MkLink endpoint Link ~ (id -> Link)+  , BuildRels api rs a+  ) => BuildRels api (('HRel relName selName endpoint) ': rs) a where+  buildRels _ api x = l : buildRels (Proxy @rs) api x+    where+      mkLink = safeLink api (Proxy @endpoint)+      l = (symbolVal (Proxy @relName), mkLink $ getField @selName x)++-- | Generates pairs @(rel, link)@ for all related resources as defined with 'Relations'.+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.+selfLink :: forall api a id.+  ( Related a, HasField (IdSelName a) a id+  , IsElem (GetOneApi a) api, HasLink (GetOneApi a)+  , MkLink (GetOneApi a) Link ~ (id -> Link)+  ) => Proxy api -> a -> (String, Link)+selfLink api x = ("self", mkSelf $ getField @(IdSelName a) x)+  where+    mkSelf = safeLink api (Proxy @(GetOneApi a))++-- | Generate Hypermedia-Links by default.+--+-- @+-- defaultLinks api x = selfLink api x : relatedLinks api x+-- @+defaultLinks :: 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 api x = selfLink api x : relatedLinks api x

@@ -0,0 +1,10 @@+module Servant.Hateoas.Some where++import Data.Aeson++-- | Existential for types that can be converted 'ToJSON'.+data SomeToJSON f where+  SomeToJSON :: ToJSON a => a -> SomeToJSON f++instance ToJSON (SomeToJSON f) where+  toJSON (SomeToJSON x) = toJSON x

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."