Route.hs

{-# 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
  { info :: RouteInfo
  -- ^ definition of the API (to use it in OpenApi or clients)
  , run :: ServerFun m
  -- ^ how to run a server
  }

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

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

instance (MonadIO m) => ToRoute (Route m) where
  toRouteInfo = id
  toRouteFun = (.run)

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

instance (ToSchema a, FromReqBody media a, ToRoute b) => ToRoute (Body media a -> b) where
  toRouteInfo = addBodyInfo @media @a . toRouteInfo @b
  toRouteFun f = withBody @media (toRouteFun . f . Body)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Query sym a -> b) where
  toRouteInfo = addQueryInfo @sym @a . toRouteInfo @b
  toRouteFun f = withQuery (getName @sym) (toRouteFun . f . Query)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Optional sym a -> b) where
  toRouteInfo = addOptionalInfo @sym @a . toRouteInfo @b
  toRouteFun f = withOptional (getName @sym) (toRouteFun . f . Optional)

instance (ToRoute b, KnownSymbol sym) => ToRoute (QueryFlag sym -> b) where
  toRouteInfo = addQueryFlagInfo @sym . toRouteInfo @b
  toRouteFun f = withQueryFlag (getName @sym) (toRouteFun . f . QueryFlag)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Capture sym a -> b) where
  toRouteInfo = addCaptureInfo @sym @a . toRouteInfo @b
  toRouteFun f = withCapture (getName @sym) (toRouteFun . f . Capture)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Header sym a -> b) where
  toRouteInfo = addHeaderInfo @sym @a . toRouteInfo @b
  toRouteFun f = withHeader (getName @sym) (toRouteFun . f . Header)

instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (OptionalHeader sym a -> b) where
  toRouteInfo = addOptionalHeaderInfo @sym @a . toRouteInfo @b
  toRouteFun f = withOptionalHeader (getName @sym) (toRouteFun . f . OptionalHeader)

instance (FromForm a, ToRoute b) => ToRoute (Cookie a -> b) where
  toRouteInfo = addOptionalHeaderInfo @"Cookie" @Text . toRouteInfo @b
  toRouteFun f = withCookie (toRouteFun . f . Cookie)

instance (ToRoute b) => ToRoute (PathInfo -> b) where
  toRouteInfo = toRouteInfo @b
  toRouteFun f = withPathInfo (toRouteFun . f . PathInfo)

instance (ToRoute b) => ToRoute (FullPathInfo -> b) where
  toRouteInfo = toRouteInfo @b
  toRouteFun f = withFullPathInfo (toRouteFun . f . FullPathInfo)

instance (ToRoute b) => ToRoute (RawRequest -> b) where
  toRouteInfo = toRouteInfo @b
  toRouteFun f = \req -> toRouteFun (f (RawRequest req)) req

instance (ToRoute b) => ToRoute (IsSecure -> b) where
  toRouteInfo = toRouteInfo @b
  toRouteFun f = \req -> toRouteFun (f (IsSecure req.isSecure)) req

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

instance {-# OVERLAPPABLE #-} (MonadIO m, IsResp a, IsMethod method) => ToRoute (Send method m a) where
  toRouteInfo = setMethod (toMethod @method) (getMedia @a)
  toRouteFun (Send a) = sendResponse $ toResponse <$> a

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

getName :: forall sym a. (KnownSymbol sym, IsString a) => a
getName = fromString (symbolVal (Proxy @sym))