Haskell 仆人从处理程序获取当前路由/URL [英] Haskell Servant Get Current Route / URL From Handler

问题描述

我想获取与我的处理程序相对应的当前路线.这是我的服务器模型仅供参考:

I'd like to get current route that corresponds to my handler. Here is mockup of my server just for reference:

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 ，如下所示:

So, essentially my route1and2Handler should have some way of getting current route. I've tried getting a request object into my handler and extracting url from that by implementing HasServer instance like so :

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，这不再有效.新的 route 具有 route :: Proxy api -> 类型签名上下文上下文 ->延迟环境(服务器 api)->路由器环境，我真的看不到从这里获取 Request 的方法.

---

I have just noticed that I was looking at api for old version of servant and this isn't valid any more. New route has type signature of route :: Proxy api -> Context context -> Delayed env (Server api) -> Router env and I don't really see way to get Request from here.

然后使 route1and2Handler 类型签名成为 Request ->处理程序文本，但在尝试创建 HasServer 实例时出现此错误:

And than making route1and2Handler type signature to be Request -> Handler Text, but I'm getting this error when trying to create HasServer instance :

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

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

And just to point out in the end, my end goal is to get current route from within the Handler, adding visit count for route in the database is just for example purposes. I'm not interested in better way to count visits or something of that sort.

推荐答案

有两个问题合二为一:

1. 如何获取当前请求或 URL?
2. 如何获取当前的路线"?

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

Note, that URL (e.g. /route12/42) is different than route (e.g. `"route12" :> Capture "id" Int :> Get '[JSON] Int). Let's see how we can solve both of these questions, right after a short language pragma and import section.

{-# 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).

How to get current Request object or URL

Passing current WAI Request to the handler is actually quite easy. This is "lazy" approach, we ask for "everything" in the request, and we have to be careful in the handler (e.g. we cannot touch requestBody). Also this "combinator" ties implementation to the wai server implementation, which is an implementation detail (nothing else in servant-server exposes wai internals, except of Raw).

的想法是让 Server (Wai.Request :> api) = Wai.Request ->服务器api.如果我们想象一下我们有这样的功能，我们可以使用 Servant.API.Generic 编写(参见使用泛型"食谱):

The idea is to make Server (Wai.Request :> api) = Wai.Request -> Server api. If we imagine for a second that we have such functionality in place, we can write, using Servant.API.Generic (see "Using generics" cookbook recipe):

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 = 
eq -> liftIO $ do
        let p = Wai.rawPathInfo req
        BS8.putStrLn p
        return (BS8.length p)
    , route12 = 
eq i -> liftIO $ do
        let p = Wai.rawPathInfo req
        BS8.putStrLn p
        return (succ i)
    }

app1 :: Application
app1 = genericServe routes1

我们定义一个Routes1数据类型，实现Routes1 AsServer值并转进入wai的Application.然而，为了编译这个例子，我们需要一个附加实例.我们在 internal passToServer 组合器中使用route 的实现.

We define a Routes1 data type, implement Routes1 AsServer value and turn it into the wai's Application. However, to compile this example, we need an additional instance. We use an internal passToServer combinator in the implementation of 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

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

This solution is good quick fix, but there are arguably better ways.

我们可能注意到我们的两个处理程序都使用 Wai.rawPathInto req 调用.这应该提醒我们.特定的组合器更优雅.能够在核心框架之外创建新的组合器，是servant的设计原则之一.

We may notice that both our handlers use Wai.rawPathInto req call. That should alert us. Specific combinator is more elegant. An ability to create new combinators outside the core framework, is one of design principles of 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 组合器，我们可以重新实现我们的应用程序:

Using new RawPathInfo combinator, we can re-implement our application:

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 选择器从处理程序移动到组合器实现，删除重复.

This version is slightly more declarative, and handlers are more restrictive. We moved the rawPathInfo selector from handlers to combinator implementation, removed repetition.

wai Request 中的 vault 值并不为人所知或使用.但在这种情况下，它可能很有用.使用 WAI 的 Vault 来获取乐趣和利润 博客文章中解释了 Vault.它填补了强类型 Request 的动态"空白:我们可以将任意数据附加到请求中，这在动态类型语言的 Web 框架中很常见.由于 servant-server 基于 wai，所以使用 vault 是第三个答案到问题的第一部分.

The vault value in wai Request is not well known or used. But in this scenario it can be useful. Vault is explained in Using WAI's vault for fun and profit blog post. It fills a "dynamic" gap of strongly typed Request: we can attach arbitrary data to the request, as is common in web frameworks in a dynamically typed languages. As servant-server is based on wai, using vault is the third answer to the first part of the question.

我们(不安全地)创建了一个金库的钥匙:

We (unsafely) create a key to the vault:

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

然后我们创建一个中间件，它将rawPathInfo放入vault.

Then we create a middleware which will put rawPathInfo into the 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

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

Using this we make third variant of our application. Note that we values might not be in the vault, that's small functional regression.

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 可用于将信息从中间件传递到处理程序从处理程序到中间件.例如，可以进行身份​​验证完全在中间件中，用户信息存储在保险库中要使用的处理程序.

Note: that vault can be used to pass information from middlewares to handlers and from handlers to middlewares. For example, the authentication can be done completely in the middleware, with a user information stored in the vault for handlers to use.

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

The second part of a question, is how to get current route. Something, we can get route2/:id out? Note that handlers are anonymous, in the same sense functions are. E.g. to write recursive anonymous functions, we can use fix combinator. We can use something close to that to pass "route into itself", using Servant.API.Generics we can reduce the boilerplate too.

我们从普通的 Routes4 数据结构开始.

We start with ordinary looking Routes4 data structure.

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

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

But instead of making a Routes4 AsServer value, we'll use a different mode. AsRecServer route is a handler which takes route :- api as a first argument. In this example we use HasLink', but reader is free to use other automatic interpretations, e.g. servant-client to make a proxy!

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

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

The usage is very simple, unfortunately the implementation is not.

genericRecServe 的实现令人生畏.缺失的位是一个函数genericHoist.简而言之，给定一个可以将 modeA :- api 转换为 modeB :- api 的函数，适用于所有 api，genericHoist 将routes modeA 转换为routes modeB.也许这个函数应该存在于 Servant.API.Generic 中?

The implementation of genericRecServe is intimidating. The missing bit is a function genericHoist. In short, given a function which can convert modeA :- api into modeB :- api for all api, genericHoist converts routes modeA into routes modeB. Maybe this function should exist in 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 是由 genericServe 的变体预先组合而成的 genericHoist.给定一堵约束墙，实现单行.

genericRecServe is genericHoist precomposed with a variant of genericServe. The implementation of one-liner, given a wall of constraints.

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.

There we us single-instance-class trick to make partially applicable HasLink.

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

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

The work horse of genericHoist is gservantHoist which works on Rep of route structures. It's important to notice that c and api arguments are class arguments. This let us constraint them in instances.

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 for M1 (metadata) and :*: (product) are straight-forward pass-through, something you would expect:

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 匹配.

The implementation for the leaf K1 shows why we need c and api as class arguments: here we require c api, and "coherence" conditions, so api, modeA, modeB, x and y match.

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 可能会被重叠的路线混淆.

Conclusion

Using similar Generic approach, we can do various transformations on handlers. For example we can wrap ordinary routes in servant "middleware", which would put route information into vault, and that information may be used by wai Middleware to collect statistics. This way we can make an improved version of servant-ekg, as currently servant-ekg may get confused by overlapping routes.

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

这篇关于Haskell 仆人从处理程序获取当前路由/URL的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！