{-# 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 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
  ( 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 = forall m. NormalizeFunction m => m -> Normal m
normalize Server endpoint
endpoint
         }
    )
      forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. Num a => a -> a -> a
+ApiOffset
1)
        (forall {k} (endpoints :: [k]).
ToReifiedApi endpoints =>
Bundled endpoints -> Proxy endpoints -> ReifiedApi
toReifiedApi Bundled endpoints
endpoints (forall {k} (t :: k). Proxy t
Proxy @endpoints))


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 = (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Handler a -> ExceptT ServerError IO a
runHandler') Handler x
handler forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ServerError
serverError -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ServerError
s) (ServerError -> Int
errHTTPCode ServerError
serverError forall a. Eq a => a -> a -> Bool
== Int
500)

    Right x
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ 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 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 forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` 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 forall {k} (endpoint :: k) (endpoints :: [k]).
Server endpoint
-> Bundled endpoints -> Bundled (endpoint : endpoints)
`AnEndpoint` 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. NormalizeFunction m => m -> Normal m
normalize