module Servant.Util.Common.Common
    ( ApplicationLS
    , ApplicationRS
    , ApiHasArgClass (..)
    , ApiHasArg

    , inRouteServer
    , symbolValT

    , NameLabel (..)
    ) where

import Universum

import qualified Data.Text.Buildable as B
import Fmt (pretty)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Servant.API (Capture, QueryFlag, QueryParam', ReqBody, (:>))
import Servant.API.Modifiers (RequiredArgument)
import Servant.Server (Handler (..), HasServer (..), Server)
import qualified Servant.Server.Internal as SI

type family ApplicationLS x where
    ApplicationLS (a b) = a

-- | Extract right side of type application.
type family ApplicationRS x where
    ApplicationRS (a b) = b

-- | Proves info about argument specifier of servant API.
class ApiHasArgClass api where
    -- | For arguments-specifiers of API, get argument type.
    -- E.g. @Capture "cap" Int@ -> @Int@.
    type ApiArg api :: Type
    type ApiArg api = ApplicationRS api

    -- | Name of argument.
    -- E.g. name of argument specified by @Capture "nyan"@ is /nyan/.
    apiArgName
        :: Proxy api -> String
    default apiArgName
        :: forall n someApiType a. (KnownSymbol n, api ~ someApiType n a)
        => Proxy api -> String
    apiArgName Proxy api
_ =
        Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
B.build (Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n -> String) -> Proxy n -> String
forall a b. (a -> b) -> a -> b
$ Proxy n
forall k (t :: k). Proxy t
Proxy @n) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' field"

class ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)
   => ApiHasArgInvariant subApi res m
instance ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)
      => ApiHasArgInvariant subApi res m

type ApiHasArg subApi res =
    ( ApiHasArgClass subApi
    , ApiHasArgInvariant subApi res Handler
    )

instance KnownSymbol s => ApiHasArgClass (Capture s a)
instance KnownSymbol s => ApiHasArgClass (QueryParam' mods s a) where
    type ApiArg (QueryParam' mods s a) = RequiredArgument mods a
instance KnownSymbol s => ApiHasArgClass (QueryFlag s) where
    type ApiArg (QueryFlag s) = Bool
    apiArgName :: Proxy (QueryFlag s) -> String
apiArgName Proxy (QueryFlag s)
_ =
        Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall p. Buildable p => p -> Builder
B.build (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>  Builder
"' flag"
instance ApiHasArgClass (ReqBody ct a) where
    apiArgName :: Proxy (ReqBody ct a) -> String
apiArgName Proxy (ReqBody ct a)
_ = String
"request body"

-- | Modify handler in implementation of 'route'.
inRouteServer
    :: forall api api' ctx env.
       (Proxy api -> SI.Context ctx -> SI.Delayed env (Server api) -> SI.Router env)
    -> (Server api' -> Server api)
    -> (Proxy api' -> SI.Context ctx -> SI.Delayed env (Server api') -> SI.Router env)
inRouteServer :: (Proxy api
 -> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
routing Server api' -> Server api
f = \Proxy api'
_ Context ctx
ctx Delayed env (Server api')
delayed -> Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
routing Proxy api
forall k (t :: k). Proxy t
Proxy Context ctx
ctx ((Server api' -> Server api)
-> Delayed env (Server api') -> Delayed env (Server api)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Server api' -> Server api
f Delayed env (Server api')
delayed)

-- | Similar to 'symbolVal', but shorter in use.
symbolValT :: forall s. KnownSymbol s => Text
symbolValT :: Text
symbolValT = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)

-- | Helper for passing type-level symbol at term-level.
-- We do not use 'Proxy' for this because defining
-- @instance IsLabel name (Proxy name)@ in a library is not a really good idea.
data NameLabel (name :: Symbol) = NameLabel

instance (n1 ~ n2) => IsLabel n1 (NameLabel n2) where
    fromLabel :: NameLabel n2
fromLabel = NameLabel n2
forall (name :: Symbol). NameLabel name
NameLabel