Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Control.Monad.Trans (lift)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.Coerce (coerce)
import Data.Proxy
import GHC.Generics

import Network.Wai
import Network.Wai.Handler.Warp

import Servant
import Servant.Server
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.Server.Internal.Router
import Servant.Server.Internal.RouteResult
import Servant.Server.StaticFiles

data Foo = Foo
  deriving stock Generic
  deriving anyclass (FromJSON, ToJSON)

data StrictRouting route

type API = StrictRouting ("foo" :> Post '[JSON] Foo) :<|> Raw
-- type API = "foo" :> Get '[JSON] Foo :<|> Raw

instance forall api context. HasServer api context => HasServer (StrictRouting api) context where
  type ServerT (StrictRouting api) m = ServerT api m

  hoistServerWithContext
    :: Proxy (StrictRouting api)
    -> Proxy context
    -> (forall x. m x -> n x)
    -> ServerT (StrictRouting api) m
    -> ServerT (StrictRouting api) n
  hoistServerWithContext _apiProxy contextProxy  mToN serverM =
    hoistServerWithContext (Proxy @api) contextProxy mToN serverM

  route :: Proxy (StrictRouting api) -> Context context -> Delayed env (Server (StrictRouting api)) -> Router env
  route _apiProxy ctx denv =
    let newDenv = denv
          { methodD = withRequest $ \req -> do
              liftIO $ putStrLn "foo"
              let rteResult = runDelayedIO (methodD denv) req
              subRouteResult <- liftIO $ runResourceT $ rteResult
              liftRouteResult $ case subRouteResult of
                Fail e -> FailFatal e
                result -> result
          }
    in
      route (Proxy @api) ctx newDenv

server :: Server API
server = pure Foo :<|> serveDirectoryFileServer "www"

main :: IO ()
main = run 8000 (serve (Proxy @API) server)