haskell - Haskell Servant从处理程序获取当前路由/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的旧版本，这不再有效。新的 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

一个有两个问题：


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


请注意，URL（例如/route12/42）与路由不同
（例如`“” route12“：>捕获” id“ Int：>获取'[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 AsServer值并将其打开
进入 wai的 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 req调用。
那应该提醒我们。特定的组合器更加优雅。
能够在核心框架之外创建新的组合器，
是 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

vault wai中的 Request值不是众所周知的或未使用的。
但是在这种情况下，它可能会很有用。
保险柜在 Using WAI's vault for fun and profit博客文章中进行了说明。
它填补了强类型 Request的“动态”鸿沟：我们可以将任意数据附加到请求，
就像在Web框架中使用动态类型语言一样。
由于 servant-server基于 wai，因此使用库是第三个答案
问题的第一部分。

我们（不安全地）创建库的密钥：

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可用于将信息从中间件传递到处理程序
从处理程序到中间件。例如，可以完成身份验证
完全在中间件中，用户信息存储在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值。
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 :- api转换为 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“ middleware”中，这将
将路线信息放入 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