{-# LANGUAGE UndecidableInstances #-}

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

  -- * Type-Families
  Resourcify,
  ResourcifyServer
)
where

import Servant
import Servant.Hateoas.Layer
import Servant.Hateoas.Resource
import Servant.Hateoas.HasHandler
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

-- | 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 api Link
  , res ~ MkResource ct
  , Resource res
  , ToResource res a
  , HasHandler api
  , HasLink api, IsElem api api
  , PolyvariadicComp2 server mkLink (IsFun server)
  , Return2 server mkLink (IsFun server) ~ (m a, Link)
  , 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, Link
self) -> (ResourceLink -> res a -> res a
forall (res :: * -> *) a.
Resource res =>
ResourceLink -> res a -> res a
addSelfRel (Link -> ResourceLink
CompleteLink Link
self) (res a -> res a) -> (a -> res a) -> a -> res a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy res -> a -> res a
forall (res :: * -> *) a.
ToResource res a =>
Proxy res -> a -> res a
toResource (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @res)) (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 api Link
mkSelf
    where
      mkSelf :: MkLink api Link
mkSelf = Proxy api -> Proxy api -> MkLink api Link
forall endpoint api.
(IsElem endpoint api, HasLink endpoint) =>
Proxy api -> Proxy endpoint -> MkLink endpoint Link
safeLink Proxy api
api Proxy api
api

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, ResourceLink)]
  , Resource res
  , BuildLayerLinks (Resourcify l ct) m
  , PolyvariadicComp buildFun (IsFun buildFun)
  , Return buildFun (IsFun buildFun) ~ [(String, ResourceLink)]
  , 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, ResourceLink)] -> res Intermediate)
-> [(String, ResourceLink)]
-> m (res Intermediate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ResourceLink) -> res Intermediate -> res Intermediate)
-> res Intermediate -> [(String, ResourceLink)] -> 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, ResourceLink) -> res Intermediate -> res Intermediate
forall a. (String, ResourceLink) -> res a -> res a
forall (res :: * -> *) a.
Resource res =>
(String, ResourceLink) -> 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, ResourceLink)])
   (IsFun
      (ReplaceHandler
         (ServerT (Resourcify l ct) m) [(String, ResourceLink)]))
 -> m (res Intermediate))
-> ReplaceHandler
     (ServerT (Resourcify l ct) m) [(String, ResourceLink)]
-> Replace
     (ReplaceHandler
        (ServerT (Resourcify l ct) m) [(String, ResourceLink)])
     (m (res Intermediate))
     (IsFun
        (ReplaceHandler
           (ServerT (Resourcify l ct) m) [(String, ResourceLink)]))
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, ResourceLink)]
forall (l :: Layer) (m :: * -> *).
(BuildLayerLinks l m, MonadIO m) =>
Proxy l
-> Proxy m -> ReplaceHandler (ServerT l m) [(String, ResourceLink)]
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)