一个问题有两个：
- 如何获取当前请求或 URL？
- 如何获得当前的“路线”？
请注意，该 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给处理程序实际上非常容易。这是“懒惰”的方法，我们在请求中要求“一切”，我们必须小心处理程序（例如我们不能 touch 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 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不是众所周知或使用的。但在这种情况下，它可能很有用。Vault 在使用 WAI 的 Vault 获得乐趣和利润的博客文章中进行了解释。它填补了强类型的“动态”空白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，我们将使用不同的模式，而不是创建一个值。
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
genericRecServegenericHoist预先组合了 的变体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和match。xy
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