Haskell 仆人从处理程序获取当前路由/URL

Question

我想获得与我的处理程序相对应的当前路线。这是我的服务器模型，仅供参考：

type ServerAPI = 
         "route01" :> Get '[HTML] Text
    :<|> "route02" :> "subroute" :> Get '[HTML] Text
    :<|> "route03" :> Get '[HTML] Text

这里有一些处理程序：

route1and2Handler :: Handler Text
route1and2Handler = do
    route <- getCurrentRoute
    addVisitCountForRouteToDatabaseOrSomethingOfThatSort...
    return template

route3Handler :: Handler Text
route3Handler = return "Hello, I'm route 03"

还有我的服务器：

server :: Server ServerAPI
server = route1and2Handler :<|> route1and2Handler :<|> route3Handler

所以，基本上我route1and2Handler应该有一些方法来获得当前路线。我已经尝试将请求对象放入我的处理程序并通过实现这样的HasServer实例从中提取 url ：

data FullRequest

instance HasServer a => HasServer (FullRequest :> a) where
    type Server (FullRequest :> a) = Request -> Server a
    route Proxy subserver request respond =
        route (Proxy :: Proxy a) (subserver request) request respond

---

[编辑]我刚刚注意到我正在查看旧版本仆人的 api，这不再有效。New 的route类型签名为route :: Proxy api -> Context context -> Delayed env (Server api) -> Router env，我真的不知道Request从这里获得的方法。

---

而不是使route1and2Handler类型签名成为Request -> Handler Text，但是在尝试创建HasServer实例时出现此错误：

`Server' is not a (visible) associated type of class `HasServer'

最后要指出的是，我的最终目标是从 中获取当前路线，在Handler数据库中为路线添加访问计数仅用于示例目的。我对更好的方式来计算访问或类似的东西不感兴趣。

Answer 1

一共有两个问题：

1. 如何获取当前请求或 URL？
2. 如何获得当前的“路线”？

请注意，URL（例如/route12/42）不同于路由（例如`"route12" :> Capture "id" Int :> Get '[JSON] Int）。在简短的语言编译指示和导入部分之后，让我们看看如何解决这两个问题。

{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE DeriveGeneric           #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE OverloadedStrings       #-}
{-# LANGUAGE RankNTypes              #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans         #-}
module Main where

import Data.Maybe             (fromMaybe)
import Control.Monad.IO.Class (liftIO)
import System.Environment     (getArgs)
import GHC.Generics           (to, from, M1 (..), K1 (..), (:*:) (..))

-- for "unsafe" vault key creation
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.ByteString.Char8    as BS8
import qualified Data.Vault.Lazy          as V
import qualified Network.Wai              as Wai
import qualified Network.Wai.Handler.Warp as Warp

import Servant
import Servant.API.Generic 
import Servant.Server.Generic
import Servant.Server.Internal.RoutingApplication (passToServer)

如何获取当前Request对象或 URL

将电流传递WAI Request给处理程序实际上很容易。这是“懒惰”的方法，我们在请求中要求“一切”，我们必须在处理程序中小心（例如，我们不能触摸requestBody）。此外，这个“组合器”将实现与wai服务器实现联系起来，这是一个实现细节（除了 之外，没有其他任何内容servant-server公开wai内部Raw）。

这个想法是使Server (Wai.Request :> api) = Wai.Request -> Server api. 如果我们想象一下我们有这样的功能，我们可以编写，使用Servant.API.Generic（参见“使用泛型”食谱）：

data Routes1 route = Routes1
    { route11 :: route :- Wai.Request :> "route1" :> Get '[JSON] Int
    , route12 :: route :- Wai.Request :> "route2" :> Capture "id" Int :> Get '[JSON] Int
    }
  deriving (Generic)

routes1 :: Routes1 AsServer
routes1 = Routes1
    { route11 = \req -> liftIO $ do
        let p = Wai.rawPathInfo req
        BS8.putStrLn p
        return (BS8.length p)
    , route12 = \req i -> liftIO $ do
        let p = Wai.rawPathInfo req
        BS8.putStrLn p
        return (succ i)
    }

app1 :: Application
app1 = genericServe routes1

我们定义了一个Routes1数据类型，实现了Routes1 AsServervalue 并将其转换为wai's Application。然而，为了编译这个例子，我们需要一个额外的实例。我们在 的实现中使用了一个内部 passToServer组合器route。

instance HasServer api ctx => HasServer (Wai.Request :> api) ctx where
    type ServerT (Wai.Request :> api) m = Wai.Request -> ServerT api m

    hoistServerWithContext _ pc nt s =
        hoistServerWithContext (Proxy :: Proxy api) pc nt . s

    route _ ctx d = route (Proxy :: Proxy api) ctx $
        passToServer d id

这个解决方案是很好的快速修复，但可以说有更好的方法。

特定组合子

我们可能会注意到我们的两个处理程序都使用Wai.rawPathInto reqcall。这应该提醒我们。特定的组合器更优雅。在核心框架之外创建新组合器的能力是servant.

data RawPathInfo

instance HasServer api ctx => HasServer (RawPathInfo :> api) ctx where
    type ServerT (RawPathInfo :> api) m = BS8.ByteString -> ServerT api m

    hoistServerWithContext _ pc nt s =
        hoistServerWithContext (Proxy :: Proxy api) pc nt . s

    route _ ctx d = route (Proxy :: Proxy api) ctx $
        passToServer d Wai.rawPathInfo

使用新的RawPathInfo组合器，我们可以重新实现我们的应用程序：

data Routes2 route = Routes2
    { route21 :: route :- RawPathInfo :> "route1" :> Get '[JSON] Int
    , route22 :: route :- RawPathInfo :> "route2" :> Capture "id" Int :> Get '[JSON] Int
    }
  deriving (Generic)

routes2 :: Routes2 AsServer
routes2 = Routes2
    { route21 = \p -> liftIO $ do
        BS8.putStrLn p
        return (BS8.length p)
    , route22 = \p i -> liftIO $ do
        BS8.putStrLn p
        return (succ i)
    }

app2 :: Application
app2 = genericServe routes2

此版本更具声明性，处理程序更具限制性。我们将rawPathInfo选择器从处理程序移动到组合器实现，删除了重复。

使用 Vault

vaultin的值wai Request并不为人所知或使用。但在这种情况下，它可能很有用。Vault 在Using WAI's Vault for fun and赢利博客文章中进行了解释。它填补了强类型的“动态”空白Request：我们可以将任意数据附加到请求中，这在动态类型语言的 Web 框架中很常见。由于servant-server是基于wai，使用Vault是第三个问题的答案的第一部分。

我们（不安全地）创建了一个金库的钥匙：

rpiKey :: V.Key BS8.ByteString
rpiKey = unsafePerformIO V.newKey

然后我们创建一个中间件，将投入rawPathInfo到vault。

middleware :: Wai.Middleware
middleware app req respond = do
    let vault' = V.insert rpiKey (Wai.rawPathInfo req) (Wai.vault req)
        req' = req { Wai.vault = vault' }
    app req' respond

使用它，我们制作了应用程序的第三个变体。请注意，我们的值可能不在保险库中，这是一个小的功能回归。

data Routes3 route = Routes3
    { route31 :: route :- Vault :> "route1" :> Get '[JSON] Int
    , route32 :: route :- Vault :> "route2" :> Capture "id" Int :> Get '[JSON] Int
    }
  deriving (Generic)

routes3 :: Routes3 AsServer
routes3 = Routes3
    { route31 = \v -> liftIO $ do
        let p = fromMaybe "?" $ V.lookup rpiKey v
        BS8.putStrLn p
        return (BS8.length p)
    , route32 = \v i -> liftIO $ do
        let p = fromMaybe "?" $ V.lookup rpiKey v
        BS8.putStrLn p
        return (succ i)
    }

app3 :: Application
app3 = middleware $ genericServe routes3

注意：这vault可用于将信息从中间件传递到处理程序，从处理程序传递到中间件。例如，身份验证可以完全在中间件中完成，用户信息存储在保管库中供处理者使用。

如何获取当前路线？

问题的第二部分是如何获得当前路线。有什么，我们可以route2/:id出去吗？请注意，处理程序是匿名的，函数也是。例如，要编写递归匿名函数，我们可以使用fix组合子。我们可以使用接近的东西来传递“路由到自身”，使用Servant.API.Generics我们也可以减少样板。

我们从看起来很普通的Routes4数据结构开始。

data Routes4 route = Routes4
    { route41 :: route :- "route1" :> Get '[JSON] Int
    , route42 :: route :- "route2" :> Capture "id" Int :> Get '[JSON] Int
    }
  deriving (Generic)

但是Routes4 AsServer我们将使用不同的mode，而不是创建一个值。 AsRecServer route是一个处理程序，它route :- api作为第一个参数。在这个例子中，我们使用HasLink'，但读者可以自由使用其他自动解释，例如servant-client制作代理！

data AsRecServer route
instance GenericMode (AsRecServer route) where
    type AsRecServer route :- api = (route :- api) -> (AsServer :- api)

routes4 :: Routes4 (AsRecServer (AsLink Link))
routes4 = Routes4
    { route41 = \l -> liftIO $ do
        print l
        return 42
    , route42 = \l i -> liftIO $ do
        print (l i)
        return i
    }

app4 :: Application
app4 = genericRecServe routes4

用法很简单，可惜实现不是。

毛茸茸的位

的实施genericRecServe令人生畏。缺少的位是一个函数genericHoist。简而言之，给定一个可以转换modeA :- api为modeB :- apifor all的函数api， genericHoist转换routes modeA为routes modeB. 也许这个功能应该存在于Servant.API.Generic？

genericHoist
    :: ( GenericMode modeA, GenericMode modeB
       , Generic (routes modeA), Generic (routes modeB)
       , GServantHoist c api modeA modeB (Rep (routes modeA)) (Rep (routes modeB))
       )
    => Proxy modeA -> Proxy modeB -> Proxy c -> Proxy api
    -> (forall api'. c api' => Proxy api' -> (modeA :- api') -> (modeB :- api'))
    -> routes modeA -> routes modeB
genericHoist pa pb pc api nt = to . gservantHoist pa pb pc api nt . from

genericRecServe被genericHoist预组成具有的变体genericServe。单线的实施，给出了一堵墙的限制。

genericRecServe
    :: forall routes.
       ( HasServer (ToServantApi routes) '[]
       , GenericServant routes AsApi
       , GenericServant routes AsServer
       , GenericServant routes (AsRecServer (AsLink Link))
       , Server (ToServantApi routes) ~ ToServant routes AsServer
       , GServantHoist 
          HasLink'
          (ToServantApi routes)
          (AsRecServer (AsLink Link))
          AsServer
          (Rep (routes (AsRecServer (AsLink Link))))
          (Rep (routes AsServer))
       )
    => routes (AsRecServer (AsLink Link)) -> Application
genericRecServe
    = serve (Proxy :: Proxy (ToServantApi routes)) 
    . toServant
    . genericHoist
        (Proxy :: Proxy (AsRecServer (AsLink Link)))
        (Proxy :: Proxy AsServer)
        (Proxy :: Proxy HasLink')
        (genericApi (Proxy :: Proxy routes))
        (\p f -> f $ safeLink p p)

我们在那里使用单实例类技巧来使部分适用HasLink。

class (IsElem api api, HasLink api) => HasLink' api
instance (IsElem api api, HasLink api) => HasLink' api

的工作马genericHoist是gservantHoist在Rep路线结构上工作。重要的是要注意c和api参数是类参数。这让我们在实例中约束它们。

class GServantHoist c api modeA modeB f g where
    gservantHoist
        :: Proxy modeA -> Proxy modeB -> Proxy c -> Proxy api
        -> (forall api'. c api' => Proxy api' -> (modeA :- api') -> (modeB :- api'))
        -> f x -> g x

M1（元数据）和:*:（产品）的实例是直接传递的，您会期望：

instance
    GServantHoist c api modeA modeB f g
    =>
    GServantHoist c api modeA modeB (M1 i j f) (M1 i' j' g)
  where
    gservantHoist pa pb pc api nt
        = M1
        . gservantHoist pa pb pc api nt
        . unM1

instance
    ( GServantHoist c apiA modeA modeB f f'
    , GServantHoist c apiB modeA modeB g g'
    ) =>
    GServantHoist c (apiA :<|> apiB) modeA modeB (f :*: g) (f' :*: g')
  where
    gservantHoist pa pb pc _ nt (f :*: g) =
        gservantHoist pa pb pc (Proxy :: Proxy apiA) nt f 
        :*:
        gservantHoist pa pb pc (Proxy :: Proxy apiB) nt g

叶的实现K1显示了我们为什么需要c和api 作为类参数：这里我们需要c api，和“一致性”条件，所以api，modeA，modeB，x和y匹配。

instance
    ( c api, (modeA :- api) ~ x, (modeB :- api) ~ y )
    => GServantHoist c api modeA modeB (K1 i x) (K1 i y)
  where
    gservantHoist _pa _pb _pc api nt
        = K1
        . nt api
        . unK1

结论

使用类似的Generic方法，我们可以对处理程序进行各种转换。例如，我们可以将普通路由包裹在servant“中间件”中，中间件会将路由信息放入 中vault，这些信息可能会被用于wai Middleware收集统计信息。通过这种方式，我们可以制作 的改进版本 servant-ekg，因为目前servant-ekg可能会因重叠路线而感到困惑。

主要用于测试

main :: IO ()
main = do
    args <- getArgs
    case args of
        ("run1":_) -> run app1
        ("run2":_) -> run app2
        ("run3":_) -> run app3
        ("run4":_) -> run app4
        _ -> putStrLn "To run, pass 'run1' argument: cabal new-run cookbook-generic run"
  where
    run app = do
        putStrLn "Starting cookbook-current-route at http://localhost:8000"
        Warp.run 8000 app