{-# LANGUAGE UndecidableInstances #-}

module Servant.Hateoas.ResourceServer
(
  -- * Type-Class
  HasResourceServer(..),

  -- * Type-Families
  Resourcify,
  resourcifyProxy,
  ResourcifyServer
)
where

import Servant
import Servant.Hateoas.Layer
import Servant.Hateoas.Resource
import Servant.Hateoas.HasHandler
import Servant.Hateoas.RelationLink
import Servant.Hateoas.Internal.Polyvariadic
import Data.Kind
import Control.Monad.IO.Class

-- | Turns an API into a resourceful API by replacing the response type of each endpoint with a resource type.
type Resourcify :: k -> Type -> k
type family Resourcify api ct where
  Resourcify EmptyAPI        ct = EmptyAPI
  Resourcify (a :<|> b)      ct = Resourcify a ct :<|> Resourcify b ct
  Resourcify (a :> b)        ct = a :> Resourcify b ct
  Resourcify (Verb m s _ a)  ct = Verb m s '[ct] (MkResource ct a)
  Resourcify ('Layer api cs verb) ct = 'Layer (Resourcify api ct) (Resourcify cs ct) (Resourcify verb ct)
  Resourcify (x:xs)          ct = Resourcify x ct : Resourcify xs ct
  Resourcify a               _  = a

-- | A proxy function for 'Resourcify'.
resourcifyProxy :: forall api ct. Proxy api -> Proxy ct -> Proxy (Resourcify api ct)
resourcifyProxy :: forall {k} (api :: k) ct.
Proxy api -> Proxy ct -> Proxy (Resourcify api ct)
resourcifyProxy Proxy api
_ Proxy ct
_ = forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Resourcify api ct)

-- | Turns a 'ServerT' into a resourceful 'ServerT' by replacing the result type @m a@ of the function @server@ with @m (res a)@ where
-- @res := 'MkResource' ct@.
--
-- Together with 'Resourcify' the following 'Constraint' holds:
--
-- @
-- forall api ct m. ServerT (Resourcify api) ct m ~ ResourcifyServer (ServerT api m) ct m
-- @
type ResourcifyServer :: k -> Type -> (Type -> Type) -> Type
type family ResourcifyServer server ct m where
  ResourcifyServer EmptyServer ct m = EmptyServer
  ResourcifyServer (a :<|> b)  ct m = ResourcifyServer a ct m :<|> ResourcifyServer b ct m
  ResourcifyServer (a -> b)    ct m = a -> ResourcifyServer b ct m
  ResourcifyServer (m a)       ct m = m (MkResource ct a)
  ResourcifyServer (f a)       ct m = f (ResourcifyServer a ct m) -- needed for stepping into containers like [Foo]

-- | A typeclass providing a function to turn an API into a resourceful API.
class HasResourceServer api m ct where
  getResourceServer :: MonadIO m => Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m

instance {-# OVERLAPPING #-} (HasResourceServer a m ct, HasResourceServer b m ct) => HasResourceServer (a :<|> b) m ct where
  getResourceServer :: MonadIO m =>
Proxy m
-> Proxy ct
-> Proxy (a :<|> b)
-> ServerT (Resourcify (a :<|> b) ct) m
getResourceServer Proxy m
m Proxy ct
ct Proxy (a :<|> b)
_ = Proxy m -> Proxy ct -> Proxy a -> ServerT (Resourcify a ct) m
forall {k} (api :: k) (m :: * -> *) ct.
(HasResourceServer api m ct, MonadIO m) =>
Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m
getResourceServer Proxy m
m Proxy ct
ct (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) ServerT (Resourcify a ct) m
-> ServerT (Resourcify b ct) m
-> ServerT (Resourcify a ct) m :<|> ServerT (Resourcify b ct) m
forall a b. a -> b -> a :<|> b
:<|> Proxy m -> Proxy ct -> Proxy b -> ServerT (Resourcify b ct) m
forall {k} (api :: k) (m :: * -> *) ct.
(HasResourceServer api m ct, MonadIO m) =>
Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m
getResourceServer Proxy m
m Proxy ct
ct (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b)

-- | Adds a self-link to the resource.
instance {-# OVERLAPPABLE #-}
  ( server ~ ServerT api m
  , ServerT (Resourcify api ct) m ~ ResourcifyServer server ct m
  , mkLink ~ MkLink (Resourcify api ct) RelationLink
  , Accept ct
  , res ~ MkResource ct
  , Resource res
  , ToResource res a
  , HasHandler api
  , HasRelationLink (Resourcify api ct)
  , PolyvariadicComp2 server mkLink (IsFun server)
  , Return2 server mkLink (IsFun server) ~ (m a, RelationLink)
  , Replace2 server mkLink (m (res a)) (IsFun mkLink) ~ ResourcifyServer server ct m
  ) => HasResourceServer (api :: Type) m ct where
  getResourceServer :: MonadIO m =>
Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m
getResourceServer Proxy m
m Proxy ct
_ Proxy api
api = (Return2 server mkLink (IsFun mkLink) -> m (res a))
-> server
-> mkLink
-> Replace2 server mkLink (m (res a)) (IsFun mkLink)
forall r.
(Return2 server mkLink (IsFun mkLink) -> r)
-> server -> mkLink -> Replace2 server mkLink r (IsFun mkLink)
forall f g (b :: Bool) r.
PolyvariadicComp2 f g b =>
(Return2 f g b -> r) -> f -> g -> Replace2 f g r b
pcomp2 ((\(m a
ma, RelationLink
self) -> (RelationLink -> res a -> res a
forall (res :: * -> *) a.
Resource res =>
RelationLink -> res a -> res a
addSelfRel RelationLink
self (res a -> res a) -> (a -> res a) -> a -> res a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy res -> Proxy ct -> a -> res a
forall ct.
(res ~ MkResource ct, Accept ct) =>
Proxy res -> Proxy ct -> a -> res a
forall (res :: * -> *) a ct.
(ToResource res a, res ~ MkResource ct, Accept ct) =>
Proxy res -> Proxy ct -> a -> res a
toResource (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @res) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ct)) (a -> res a) -> m a -> m (res a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
ma)) (Proxy m -> Proxy api -> ServerT api m
forall {k} (api :: k) (m :: * -> *).
(HasHandler api, MonadIO m) =>
Proxy m -> Proxy api -> ServerT api m
forall (m :: * -> *).
MonadIO m =>
Proxy m -> Proxy api -> ServerT api m
getHandler Proxy m
m Proxy api
api) mkLink
MkLink (Resourcify api ct) RelationLink
mkSelf
    where
      mkSelf :: MkLink (Resourcify api ct) RelationLink
mkSelf = Proxy (Resourcify api ct)
-> MkLink (Resourcify api ct) RelationLink
forall {k} (endpoint :: k).
HasRelationLink endpoint =>
Proxy endpoint -> MkLink endpoint RelationLink
toRelationLink (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Resourcify api ct))

instance
  ( api ~ LayerApi l
  , rApi ~ Resourcify api ct
  , ServerT (Resourcify l ct) m ~ ResourcifyServer (ServerT l m) ct m
  , rServer ~ ResourcifyServer (ServerT l m) ct m
  , res ~ MkResource ct
  , buildFun ~ ReplaceHandler rServer [(String, RelationLink)]
  , Resource res
  , BuildLayerLinks (Resourcify l ct) m
  , PolyvariadicComp buildFun (IsFun buildFun)
  , Return buildFun (IsFun buildFun) ~ [(String, RelationLink)]
  , Replace buildFun (m (res Intermediate)) (IsFun buildFun) ~ rServer
  ) => HasResourceServer l m ct where
  getResourceServer :: MonadIO m =>
Proxy m -> Proxy ct -> Proxy l -> ServerT (Resourcify l ct) m
getResourceServer Proxy m
m Proxy ct
_ Proxy l
_ = (forall (m :: * -> *) a. Monad m => a -> m a
return @m (res Intermediate -> m (res Intermediate))
-> ([(String, RelationLink)] -> res Intermediate)
-> [(String, RelationLink)]
-> m (res Intermediate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, RelationLink) -> res Intermediate -> res Intermediate)
-> res Intermediate -> [(String, RelationLink)] -> res Intermediate
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, RelationLink) -> res Intermediate -> res Intermediate
forall a. (String, RelationLink) -> res a -> res a
forall (res :: * -> *) a.
Resource res =>
(String, RelationLink) -> res a -> res a
addRel (forall (res :: * -> *) a. Resource res => a -> res a
wrap @res (Intermediate -> res Intermediate)
-> Intermediate -> res Intermediate
forall a b. (a -> b) -> a -> b
$ () -> Intermediate
Intermediate ())) (Return
   (ReplaceHandler
      (ServerT (Resourcify l ct) m) [(String, RelationLink)])
   (IsFun
      (ReplaceHandler
         (ServerT (Resourcify l ct) m) [(String, RelationLink)]))
 -> m (res Intermediate))
-> ReplaceHandler
     (ServerT (Resourcify l ct) m) [(String, RelationLink)]
-> Replace
     (ReplaceHandler
        (ServerT (Resourcify l ct) m) [(String, RelationLink)])
     (m (res Intermediate))
     (IsFun
        (ReplaceHandler
           (ServerT (Resourcify l ct) m) [(String, RelationLink)]))
forall f (b :: Bool) r.
(PolyvariadicComp f b, IsFun f ~ b) =>
(Return f b -> r) -> f -> Replace f r b
... Proxy (Resourcify l ct)
-> Proxy m
-> ReplaceHandler
     (ServerT (Resourcify l ct) m) [(String, RelationLink)]
forall (l :: Layer) (m :: * -> *).
(BuildLayerLinks l m, MonadIO m) =>
Proxy l
-> Proxy m -> ReplaceHandler (ServerT l m) [(String, RelationLink)]
buildLayerLinks (forall {k} (t :: k). Proxy t
forall (t :: Layer). Proxy t
Proxy @(Resourcify l ct)) Proxy m
m

instance HasResourceServer ('[] :: [Layer]) m ct where
  getResourceServer :: MonadIO m =>
Proxy m -> Proxy ct -> Proxy '[] -> ServerT (Resourcify '[] ct) m
getResourceServer Proxy m
_ Proxy ct
_ Proxy '[]
_ = ServerT (Resourcify '[] ct) m
ServerT EmptyAPI m
forall (m :: * -> *). ServerT EmptyAPI m
emptyServer

instance
  ( MonadIO m
  , HasResourceServer ls m ct
  , HasResourceServer l m ct
  , BuildLayerLinks (Resourcify l ct) m
  ) => HasResourceServer (l ': ls) m ct where
  getResourceServer :: MonadIO m =>
Proxy m
-> Proxy ct -> Proxy (l : ls) -> ServerT (Resourcify (l : ls) ct) m
getResourceServer Proxy m
m Proxy ct
ct Proxy (l : ls)
_ = Proxy m -> Proxy ct -> Proxy l -> ServerT (Resourcify l ct) m
forall {k} (api :: k) (m :: * -> *) ct.
(HasResourceServer api m ct, MonadIO m) =>
Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m
getResourceServer Proxy m
m Proxy ct
ct (forall {k} (t :: k). Proxy t
forall (t :: Layer). Proxy t
Proxy @l) ServerT (Resourcify l ct) m
-> ServerT (Resourcify ls ct) m
-> ServerT (Resourcify l ct) m :<|> ServerT (Resourcify ls ct) m
forall a b. a -> b -> a :<|> b
:<|> Proxy m -> Proxy ct -> Proxy ls -> ServerT (Resourcify ls ct) m
forall {k} (api :: k) (m :: * -> *) ct.
(HasResourceServer api m ct, MonadIO m) =>
Proxy m -> Proxy ct -> Proxy api -> ServerT (Resourcify api ct) m
getResourceServer Proxy m
m Proxy ct
ct (forall (t :: [Layer]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ls)