{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Roboservant.Types.ReifiedApi.Server(module Roboservant.Types.ReifiedApi.Server) where

import Servant
import Servant.Server.Generic (AsServer)

import Control.Monad.Except (runExceptT)
import Data.Bifunctor
import Data.Dynamic (Dynamic)
import Data.List.NonEmpty (NonEmpty)
import Data.Typeable (Typeable)
import Roboservant.Types.Breakdown
import Roboservant.Types.ReifiedApi

import qualified Data.Text as T
import qualified Data.Vinyl.Curry as V
import Data.Hashable(Hashable)

type ReifiedApi = [(ApiOffset, ReifiedEndpoint )]


class ToReifiedApi endpoints where
  toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi

instance ToReifiedApi '[] where
  toReifiedApi :: Bundled '[] -> Proxy '[] -> ReifiedApi
toReifiedApi Bundled '[]
NoEndpoints Proxy '[]
_ = []

instance
  ( GenericServant routes AsServer
  , FlattenServer (ToServantApi routes)
  , Server (ToServantApi routes) ~ ToServant routes AsServer
  , ToReifiedApi (Endpoints (ToServantApi routes))
  , ToReifiedApi endpoints
  ) =>
  ToReifiedApi (NamedRoutes routes ': endpoints)
  where
  toReifiedApi :: Bundled (NamedRoutes routes : endpoints)
-> Proxy (NamedRoutes routes : endpoints) -> ReifiedApi
toReifiedApi (Server endpoint
endpoint `AnEndpoint` Bundled endpoints
endpoints) Proxy (NamedRoutes routes : endpoints)
_ =
    let nested :: ReifiedApi
nested = Bundled (Endpoints (ToServantApi routes))
-> Proxy (Endpoints (ToServantApi routes)) -> ReifiedApi
forall {k} (endpoints :: [k]).
ToReifiedApi endpoints =>
Bundled endpoints -> Proxy endpoints -> ReifiedApi
toReifiedApi
                   (forall api.
FlattenServer api =>
Server api -> Bundled (Endpoints api)
flattenServer @(ToServantApi routes) (routes AsServer -> ToServant routes AsServer
forall {k} (routes :: k -> *) (mode :: k).
GenericServant routes mode =>
routes mode -> ToServant routes mode
toServant routes AsServer
Server endpoint
endpoint))
                   (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Endpoints (ToServantApi routes)))
        offset :: ApiOffset
offset = Int -> ApiOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ReifiedApi -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ReifiedApi
nested)
     in ReifiedApi
nested ReifiedApi -> ReifiedApi -> ReifiedApi
forall a. [a] -> [a] -> [a]
++ ApiOffset -> ReifiedApi -> ReifiedApi
shiftOffsets ApiOffset
offset (Bundled endpoints -> Proxy endpoints -> ReifiedApi
forall {k} (endpoints :: [k]).
ToReifiedApi endpoints =>
Bundled endpoints -> Proxy endpoints -> ReifiedApi
toReifiedApi Bundled endpoints
endpoints (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @endpoints))

instance
  {-# OVERLAPPABLE #-}
  ( NormalizeFunction (ServerT endpoint Handler)
  , Normal (ServerT endpoint Handler) ~ V.Curried (EndpointArgs endpoint) (IO (Either InteractionError (NonEmpty (Dynamic,Int))))
  , ToReifiedEndpoint endpoint
  , ToReifiedApi endpoints
  ) =>
  ToReifiedApi (endpoint : endpoints)
  where
  toReifiedApi :: Bundled (endpoint : endpoints)
-> Proxy (endpoint : endpoints) -> ReifiedApi
toReifiedApi (Server endpoint
endpoint `AnEndpoint` Bundled endpoints
endpoints) Proxy (endpoint : endpoints)
_ =
    (ApiOffset
0, ReifiedEndpoint
         { reArguments :: Rec (TypedF Argument) (EndpointArgs endpoint)
reArguments    = forall endpoint.
ToReifiedEndpoint endpoint =>
Rec (TypedF Argument) (EndpointArgs endpoint)
reifiedEndpointArguments @endpoint
         , reEndpointFunc :: Curried
  (EndpointArgs endpoint)
  (IO (Either InteractionError (NonEmpty (Dynamic, Int))))
reEndpointFunc = ServerT endpoint Handler -> Normal (ServerT endpoint Handler)
forall m. NormalizeFunction m => m -> Normal m
normalize ServerT endpoint Handler
Server endpoint
endpoint
         }
    )
      (ApiOffset, ReifiedEndpoint) -> ReifiedApi -> ReifiedApi
forall a. a -> [a] -> [a]
: (((ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint))
-> ReifiedApi -> ReifiedApi
forall a b. (a -> b) -> [a] -> [b]
map (((ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint))
 -> ReifiedApi -> ReifiedApi)
-> ((ApiOffset -> ApiOffset)
    -> (ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint))
-> (ApiOffset -> ApiOffset)
-> ReifiedApi
-> ReifiedApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ApiOffset -> ApiOffset)
-> (ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (ApiOffset -> ApiOffset -> ApiOffset
forall a. Num a => a -> a -> a
+ApiOffset
1)
        (Bundled endpoints -> Proxy endpoints -> ReifiedApi
forall {k} (endpoints :: [k]).
ToReifiedApi endpoints =>
Bundled endpoints -> Proxy endpoints -> ReifiedApi
toReifiedApi Bundled endpoints
endpoints (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @endpoints))

shiftOffsets :: ApiOffset -> ReifiedApi -> ReifiedApi
shiftOffsets :: ApiOffset -> ReifiedApi -> ReifiedApi
shiftOffsets ApiOffset
offset = ((ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint))
-> ReifiedApi -> ReifiedApi
forall a b. (a -> b) -> [a] -> [b]
map ((ApiOffset -> ApiOffset)
-> (ApiOffset, ReifiedEndpoint) -> (ApiOffset, ReifiedEndpoint)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ApiOffset -> ApiOffset -> ApiOffset
forall a. Num a => a -> a -> a
+ ApiOffset
offset))


instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where
  type Normal (Handler x) = IO (Either InteractionError (NonEmpty (Dynamic,Int)))
  normalize :: Handler x -> Normal (Handler x)
normalize Handler x
handler = (ExceptT ServerError IO x -> IO (Either ServerError x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ServerError IO x -> IO (Either ServerError x))
-> (Handler x -> ExceptT ServerError IO x)
-> Handler x
-> IO (Either ServerError x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler x -> ExceptT ServerError IO x
forall a. Handler a -> ExceptT ServerError IO a
runHandler') Handler x
handler IO (Either ServerError x)
-> (Either ServerError x
    -> IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> IO (Either InteractionError (NonEmpty (Dynamic, Int)))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ServerError
serverError -> Either InteractionError (NonEmpty (Dynamic, Int))
-> IO (Either InteractionError (NonEmpty (Dynamic, Int)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InteractionError
-> Either InteractionError (NonEmpty (Dynamic, Int))
forall a b. a -> Either a b
Left (ServerError -> InteractionError
renderServerError ServerError
serverError))
      where
        -- | TODO improve this
        renderServerError :: ServerError -> InteractionError
        renderServerError :: ServerError -> InteractionError
renderServerError ServerError
s = Text -> Bool -> InteractionError
InteractionError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ServerError -> String
forall a. Show a => a -> String
show ServerError
s) (ServerError -> Int
errHTTPCode ServerError
serverError Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
500)

    Right x
x -> Either InteractionError (NonEmpty (Dynamic, Int))
-> IO (Either InteractionError (NonEmpty (Dynamic, Int)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InteractionError (NonEmpty (Dynamic, Int))
 -> IO (Either InteractionError (NonEmpty (Dynamic, Int))))
-> Either InteractionError (NonEmpty (Dynamic, Int))
-> IO (Either InteractionError (NonEmpty (Dynamic, Int)))
forall a b. (a -> b) -> a -> b
$ NonEmpty (Dynamic, Int)
-> Either InteractionError (NonEmpty (Dynamic, Int))
forall a b. b -> Either a b
Right (NonEmpty (Dynamic, Int)
 -> Either InteractionError (NonEmpty (Dynamic, Int)))
-> NonEmpty (Dynamic, Int)
-> Either InteractionError (NonEmpty (Dynamic, Int))
forall a b. (a -> b) -> a -> b
$ x -> NonEmpty (Dynamic, Int)
forall x.
(Hashable x, Typeable x, Breakdown x) =>
x -> NonEmpty (Dynamic, Int)
breakdown x
x


--          case errHTTPCode serverError of
--            500 -> throw serverError
--            _ ->
--              liftIO . logInfo . show $ ("ignoring non-500 error", serverError)


data Bundled endpoints where
  -- AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
  AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
  NoEndpoints :: Bundled '[]

class FlattenServer api where
  flattenServer :: Server api -> Bundled (Endpoints api)

instance
  ( FlattenServer api,
    Endpoints endpoint ~ '[endpoint]
  ) =>
  FlattenServer (endpoint :<|> api)
  where
  flattenServer :: Server (endpoint :<|> api)
-> Bundled (Endpoints (endpoint :<|> api))
flattenServer (ServerT endpoint Handler
endpoint :<|> ServerT api Handler
server) = ServerT endpoint Handler
endpoint ServerT endpoint Handler
-> Bundled (Endpoints api) -> Bundled (endpoint : Endpoints api)
forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` forall api.
FlattenServer api =>
Server api -> Bundled (Endpoints api)
flattenServer @api ServerT api Handler
server

instance
 (
   Endpoints api ~ '[api]
 ) =>
  FlattenServer (x :> api)
  where
  flattenServer :: Server (x :> api) -> Bundled (Endpoints (x :> api))
flattenServer Server (x :> api)
server = Server (x :> api)
server Server (x :> api) -> Bundled '[] -> Bundled '[x :> api]
forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` Bundled '[]
forall {k}. Bundled '[]
NoEndpoints

instance FlattenServer (Verb method statusCode contentTypes responseType)
  where
  flattenServer :: Server (Verb method statusCode contentTypes responseType)
-> Bundled
     (Endpoints (Verb method statusCode contentTypes responseType))
flattenServer Server (Verb method statusCode contentTypes responseType)
server = Server (Verb method statusCode contentTypes responseType)
server Server (Verb method statusCode contentTypes responseType)
-> Bundled '[]
-> Bundled '[Verb method statusCode contentTypes responseType]
forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` Bundled '[]
forall {k}. Bundled '[]
NoEndpoints

instance FlattenServer (NamedRoutes routes) where
  flattenServer :: Server (NamedRoutes routes)
-> Bundled (Endpoints (NamedRoutes routes))
flattenServer Server (NamedRoutes routes)
server = Server (NamedRoutes routes)
server Server (NamedRoutes routes)
-> Bundled '[] -> Bundled '[NamedRoutes routes]
forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` Bundled '[]
forall {k}. Bundled '[]
NoEndpoints

class NormalizeFunction m where
  type Normal m
  normalize :: m -> Normal m

instance NormalizeFunction x => NormalizeFunction (r -> x) where
  type Normal (r -> x) = r -> Normal x
  normalize :: (r -> x) -> Normal (r -> x)
normalize = (x -> Normal x) -> (r -> x) -> r -> Normal x
forall a b. (a -> b) -> (r -> a) -> r -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x -> Normal x
forall m. NormalizeFunction m => m -> Normal m
normalize