{-# LANGUAGE UndecidableInstances #-}

{-| Creation of routes from functions. A route is a handler function
for single path of the server.
-}
module Mig.Core.Class.Route (
  Route (..),
  ToRoute (..),
  toRoute,
) where

import Control.Monad.IO.Class
import Data.OpenApi (ToParamSchema (..), ToSchema (..))
import Data.Proxy
import Data.String
import Data.Text (Text)
import GHC.TypeLits
import Mig.Core.Class.MediaType
import Mig.Core.Class.Monad
import Mig.Core.Class.Response (IsResp (..))
import Mig.Core.ServerFun
import Mig.Core.Types
import Web.FormUrlEncoded (FromForm)
import Web.HttpApiData

{-| Values that represent routes.
A route is a function of arbitrary number of arguments. Where
each argument is one of the special newtype-wrappers that
read type-safe information from HTTP-request and return type of the route function
is a value of something convertible to HTTP-request.
-}
class (MonadIO (MonadOf a)) => ToRoute a where
  -- | Update API info
  toRouteInfo :: RouteInfo -> RouteInfo

  -- | Convert to route
  toRouteFun :: a -> ServerFun (MonadOf a)

-- | Route contains API-info and how to run it
data Route m = Route
  { forall (m :: * -> *). Route m -> RouteInfo
info :: RouteInfo
  -- ^ definition of the API (to use it in OpenApi or clients)
  , forall (m :: * -> *). Route m -> ServerFun m
run :: ServerFun m
  -- ^ how to run a server
  }

-- | converts route-like value to route.
toRoute :: forall a. (ToRoute a) => a -> Route (MonadOf a)
toRoute :: forall a. ToRoute a => a -> Route (MonadOf a)
toRoute a
a =
  Route
    { $sel:info:Route :: RouteInfo
info = forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @a RouteInfo
emptyRouteInfo
    , $sel:run:Route :: ServerFun (MonadOf a)
run = forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun a
a
    }

-------------------------------------------------------------------------------------
-- identity instances

instance (MonadIO m) => ToRoute (Route m) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall a. a -> a
id
  toRouteFun :: Route m -> ServerFun (MonadOf (Route m))
toRouteFun = (.run)

-------------------------------------------------------------------------------------
-- request inputs

instance (ToSchema a, FromReqBody media a, ToRoute b) => ToRoute (Body media a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall {k} (ty :: k) a.
(ToMediaType ty, ToSchema a) =>
RouteInfo -> RouteInfo
addBodyInfo @media @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Body media a -> b) -> ServerFun (MonadOf (Body media a -> b))
toRouteFun Body media a -> b
f = forall {k} (media :: k) a (m :: * -> *).
(MonadIO m, FromReqBody media a) =>
(a -> ServerFun m) -> ServerFun m
withBody @media (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body media a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (media :: k) a. a -> Body media a
Body)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Query sym a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addQueryInfo @sym @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Query sym a -> b) -> ServerFun (MonadOf (Query sym a -> b))
toRouteFun Query sym a -> b
f = forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
Text -> (a -> ServerFun m) -> ServerFun m
withQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query sym a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. a -> Query sym a
Query)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Optional sym a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addOptionalInfo @sym @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Optional sym a -> b) -> ServerFun (MonadOf (Optional sym a -> b))
toRouteFun Optional sym a -> b
f = forall a (m :: * -> *).
FromHttpApiData a =>
Text -> (Maybe a -> ServerFun m) -> ServerFun m
withOptional (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optional sym a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. Maybe a -> Optional sym a
Optional)

instance (ToRoute b, KnownSymbol sym) => ToRoute (QueryFlag sym -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol). KnownSymbol sym => RouteInfo -> RouteInfo
addQueryFlagInfo @sym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (QueryFlag sym -> b) -> ServerFun (MonadOf (QueryFlag sym -> b))
toRouteFun QueryFlag sym -> b
f = forall (m :: * -> *). Text -> (Bool -> ServerFun m) -> ServerFun m
withQueryFlag (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryFlag sym -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol). Bool -> QueryFlag sym
QueryFlag)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Capture sym a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addCaptureInfo @sym @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Capture sym a -> b) -> ServerFun (MonadOf (Capture sym a -> b))
toRouteFun Capture sym a -> b
f = forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
Text -> (a -> ServerFun m) -> ServerFun m
withCapture (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Capture sym a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. a -> Capture sym a
Capture)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Header sym a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addHeaderInfo @sym @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Header sym a -> b) -> ServerFun (MonadOf (Header sym a -> b))
toRouteFun Header sym a -> b
f = forall (m :: * -> *) a.
(Monad m, FromHttpApiData a) =>
HeaderName -> (a -> ServerFun m) -> ServerFun m
withHeader (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header sym a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. a -> Header sym a
Header)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (OptionalHeader sym a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addOptionalHeaderInfo @sym @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (OptionalHeader sym a -> b)
-> ServerFun (MonadOf (OptionalHeader sym a -> b))
toRouteFun OptionalHeader sym a -> b
f = forall a (m :: * -> *).
FromHttpApiData a =>
HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m
withOptionalHeader (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionalHeader sym a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sym :: Symbol) a. Maybe a -> OptionalHeader sym a
OptionalHeader)

instance (FromForm a, ToRoute b) => ToRoute (Cookie a -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall (sym :: Symbol) a.
(KnownSymbol sym, ToParamSchema a) =>
RouteInfo -> RouteInfo
addOptionalHeaderInfo @"Cookie" @Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (Cookie a -> b) -> ServerFun (MonadOf (Cookie a -> b))
toRouteFun Cookie a -> b
f = forall a (m :: * -> *).
FromForm a =>
(Maybe a -> ServerFun m) -> ServerFun m
withCookie (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Cookie a
Cookie)

instance (ToRoute b) => ToRoute (PathInfo -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (PathInfo -> b) -> ServerFun (MonadOf (PathInfo -> b))
toRouteFun PathInfo -> b
f = forall (m :: * -> *). ([Text] -> ServerFun m) -> ServerFun m
withPathInfo (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathInfo -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> PathInfo
PathInfo)

instance (ToRoute b) => ToRoute (FullPathInfo -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (FullPathInfo -> b) -> ServerFun (MonadOf (FullPathInfo -> b))
toRouteFun FullPathInfo -> b
f = forall (m :: * -> *). (Text -> ServerFun m) -> ServerFun m
withFullPathInfo (forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun forall b c a. (b -> c) -> (a -> b) -> a -> c
. FullPathInfo -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FullPathInfo
FullPathInfo)

instance (ToRoute b) => ToRoute (RawRequest -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (RawRequest -> b) -> ServerFun (MonadOf (RawRequest -> b))
toRouteFun RawRequest -> b
f = \Request
req -> forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun (RawRequest -> b
f (Request -> RawRequest
RawRequest Request
req)) Request
req

instance (ToRoute b) => ToRoute (IsSecure -> b) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = forall a. ToRoute a => RouteInfo -> RouteInfo
toRouteInfo @b
  toRouteFun :: (IsSecure -> b) -> ServerFun (MonadOf (IsSecure -> b))
toRouteFun IsSecure -> b
f = \Request
req -> forall a. ToRoute a => a -> ServerFun (MonadOf a)
toRouteFun (IsSecure -> b
f (Bool -> IsSecure
IsSecure Request
req.isSecure)) Request
req

-------------------------------------------------------------------------------------
-- outputs

instance {-# OVERLAPPABLE #-} (MonadIO m, IsResp a, IsMethod method) => ToRoute (Send method m a) where
  toRouteInfo :: RouteInfo -> RouteInfo
toRouteInfo = ByteString -> MediaType -> RouteInfo -> RouteInfo
setMethod (forall {k} (a :: k). IsMethod a => ByteString
toMethod @method) (forall a. IsResp a => MediaType
getMedia @a)
  toRouteFun :: Send method m a -> ServerFun (MonadOf (Send method m a))
toRouteFun (Send m a
a) = forall (m :: * -> *). Functor m => m Response -> ServerFun m
sendResponse forall a b. (a -> b) -> a -> b
$ forall a. IsResp a => a -> Response
toResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a

---------------------------------------------
-- utils

getName :: forall sym a. (KnownSymbol sym, IsString a) => a
getName :: forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName = forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym))