为固定 API 的安全查询字符串编写 Haskell 选项数据类型 预期用途尝试 1：Monoid 和 Last梦想问题编辑：基于丹尼尔瓦格纳的回答的解决方案

问题描述

我正在通过编写一个向音乐目录发出 Web 请求的应用程序来练习“真实世界”的 Haskell。我可以使用 https://example.com/search、title、artist 等可选参数的任意组合调用 year 这样的端点。例如，以下任何组合都是有效的：

https://example.com/search?title="Ecoute moi Camarade"
https://example.com/search?title="Ecoute moi Camarade"&artist="Mazouni"
https://example.com/search?year=1974&artist="Mazouni"

我可以使用 req 以友好的方式构建查询参数列表，

import qualified Network.HTTP.Req as Req
import qualified Data.Aeson as AE

makeSearch :: IO ()
makeSearch = Req.runReq Req.defaultHttpConfig $ do
    let url = https "example.com" /: "search"
    let params =
          "artist" =: ("Ecoute moi Camarade" :: Text)  <>
          "track"  =: ("Mazouni" :: Text)
    r <- (req GET url noreqBody jsonResponse params) :: (Req.Req (Req.JsonResponse AE.Value))
    liftIO $ print (Req.responseBody r :: AE.Value)

我希望 makeSearch 函数接受可选参数的任意组合。最简单的两个选项是：

• 为每个可选参数组合定义一个单独的函数。这是太多的重复，当有很多选项时工作量太大。

• 让调用者传入一个手动构造的 params 值，就像我上面定义的那样，但这不是非常类型安全。

相反，我想定义一些 Haskell 数据类型来模拟我所知道的关于我正在使用的 API。请注意，我不能控制 Web API 本身。

预期用途

我认为以下简单的标准是合理的：

• 添加新选项应该尽可能简单
• 用户只需为他们实际使用的选项定义值
• 用户不应意外传递不受支持的查询参数，或使用错误类型的查询参数

例如，以下内容对调用者来说会很好：

makeSearch (searchArtist "Mazouni" <> searchTitle "Ecoute moi Camarade")
makeSearch (searchYear 1974)

尝试 1：Monoid 和 Last

我尝试实现一个我在使用 Monoid 之前见过的模式，

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
import GHC.Generics ( Generic )
import Data.Monoid.Generic

data SearchOpts = SearchOpts {
        searchArtist :: Last Text,searchTitle  :: Last Text,searchYear   :: Last Integer
    } deriving (Generic,Show,Eq)
      deriving Semigroup via GenericSemigroup SearchOpts
      deriving Monoid    via GenericMonoid SearchOpts

但是，如果我们只想按标题搜索，我们仍然需要为其余选项提供nothing。我可以定义一些像下面这样的辅助函数，但如果它们以某种方式自动生成会更好。

matchArtist :: Text -> SearchOpts
matchArtist name = mempty { searchArtist = Last (Just name) }

matchTitle :: Text -> SearchOpts
matchTitle title = mempty { searchTitle = Last (Just title) }

matchYear :: Text -> SearchOpts
matchYear t = mempty { searchYear = Last (Just t) }

此外，我还没有找到用这种方法实现 makeSearch 的干净方法。并发症是：

• 我不知道如何很好地描述 sqArtist 等记录字段与 "artist" 等查询参数键之间的对应关系。
• req 库将参数与 <> 结合到 Options 'Https 类型的值上。我不确定如何将我的可选值列表转换为 req 可以用作查询字符串的内容。
• 我也不喜欢将所有内容都包含在 Last 中，因为在使用该值时我必须手动解包每个字段。

梦想

这种操作是非常常见的 TypeScript。这是一个 simple example。使用 UrlSearchParams 会进一步简化，但这并不是一个公平的比较。

interface SearchOpts {
    artist ?: string,title  ?: string,year   ?: number
}

function makeSearch(opts: SearchOpts): string {
  var params:string[] = [];

  if(opts.artist) { params.push("artist=" + encodeURIComponent(opts.artist)); }
  if(opts.title)  { params.push("title="  + encodeURIComponent(opts.title));  }
  if(opts.year)   { params.push("year="   + encodeURIComponent(opts.year));   }
  
  return params.join("&");
}

makeSearch({ title: "T"})                 // OK
makeSearch({ title: "T",artist: "A"})    // OK
makeSearch({ year: 1974,artist: "A"})    // OK
makeSearch({ title: "T"})                 // OK
makeSearch({ title: "T",extra: "Extra"}) // Error! (as desired)

问题

您建议如何在 Haskell 中解决这个问题？谢谢！

编辑：基于丹尼尔瓦格纳的回答的解决方案

以下 SearchOpts 和 makeSearch 实现还不错。我也会研究镜头和模板 Haskell！

data SearchOpts = SearchOpts {
        searchArtist :: Maybe Text,searchTitle  :: Maybe Text,searchYear   :: Maybe Text
    } deriving (Eq,Ord,Read,Show)

instance Default SearchOpts where
    def = SearchOpts nothing nothing nothing

matchArtist :: Text -> SearchOpts
matchArtist a = def { searchArtist = Just a }

matchTitle :: Text -> SearchOpts
matchTitle t = def { searchTitle = Just t }

matchYear :: Text -> SearchOpts
matchYear y = def { searchYear = Just y }

-- App is a MonadHttp instance
makeSearch :: SearchOpts -> App SearchResults
makeSearch query = do
    let url = https "example.com" /: "search"

    let args = [
            ("artist",searchArtist query),("title",searchTitle query),("type",searchYear query)
          ]
    
    let justArgs = [ (key,v) | arg@(key,Just v) <- args ]
    let params   = (map (uncurry (=:)) justArgs)
    let option   = (foldl (<>) mempty params)
    
    -- defined elsewhere
    makeReq url option

解决方法

标准技巧是只使用 Maybe（而不是 Last）并定义一个 Default 实例：

data SearchOpts = SearchOpts
    { searchArtist :: Maybe Text,searchTitle :: Maybe Text,searchYear :: Maybe Integer
    } deriving (Eq,Ord,Read,Show)

instance Default SearchOpts where
    def = SearchOpts Nothing Nothing Nothing

现在可以很容易地通过编写如下内容来仅提供您想要的字段：

def { searchArtist = Just "Mazouni" }
-- or
def
    { searchArtist = Just "Mazouni",searchTitle = Just "Ecoute moi Camarade"
    }

如果您已使用 Monoid 实例（可能是因为它让调用者跳过 Just），您仍然可以提供一个。

instance Semigroup SearchOpts where
    SearchOpts a t y <> SearchArtist a' t' y'
        = SearchOpts (a <|> a') (t <|> t') (y <|> y')
instance Monoid SearchOpts where mempty = def

要自动生成单字段“构造函数”，您可以查看一些模板 Haskell； makeLenses 或其变体也有可能让您到达需要去的地方。

,

只是为了好玩，这是使用非常不同的技术的第二个答案。我们将进行从字段名称到它们的类型的类型级映射；然后我们将创建一个可以包含给定字段的任何子集并支持字段查找的类型。首先我们深吸一口气，充满了类型级编程的氛围……

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Kind
import Data.Maybe
import Data.Type.Equality
import GHC.OverloadedLabels
import GHC.Prim
import GHC.TypeLits
import Unsafe.Coerce

我要做的第一件事就是向您保证Unsafe.Coerce 并没有那么糟糕。因此，我将在前面介绍整个可信计算基础——所有对 unsafeCoerce 的调用。我希望你会同意它们是相当合理的；声明是术语级别和类型级别的字符串比较操作彼此一致。

data SOrdering x where
    SLT :: SOrdering LT
    SEQ :: SOrdering EQ
    SGT :: SOrdering GT

scompare :: (KnownSymbol s,KnownSymbol s') =>
    Proxy# s -> Proxy# s' -> SOrdering (CmpSymbol s s')
scompare s s' = case compare (symbolVal' s) (symbolVal' s') of
    LT -> unsafeCoerce SLT
    EQ -> unsafeCoerce SEQ
    GT -> unsafeCoerce SGT

好的，现在，我们将介绍一个类型级别的映射。当这些映射之一具有重复键时，我们想向用户投诉；有多种方法可以做到这一点，但我们要做的方法是保持类型级映射的排序。这使得检查重复项变得容易。所以让我们定义一个类型级别的排序！

type family Sort kvs where
    Sort '[] = '[]
    Sort '[kv] = '[kv]
    Sort kvs = Merge (SortBoth (Split kvs))

type family Split xs where
    Split '[] = '( '[],'[] )
    Split (x:xs) = SplitHelper x (Split xs)

type family SplitHelper x rec where
    SplitHelper x '(xs,xs') = '(x:xs',xs)

type family SortBoth kvsPair where
    SortBoth '(kvs,kvs') = '(Sort kvs,Sort kvs')

type family Merge kvsPair where
    Merge '(('(k,v):kvs),('(k',v'):kvs')) = CataOrdering (CmpSymbol k k')
        ('(k,v):Merge '(kvs,v'):kvs')))
        (TypeError (Text "Duplicate key " :<>: ShowType k :<>: Text " in Merge"))
        ('(k',v'):Merge '(('(k,kvs'))
    Merge '( kvs,'[] ) = kvs
    Merge '( '[],kvs' ) = kvs'

type family CataOrdering ordering lt eq gt where
    CataOrdering LT lt eq gt = lt
    CataOrdering EQ lt eq gt = eq
    CataOrdering GT lt eq gt = gt

如果我们有这些排序映射之一，我们可以通过创建这个新数据类型的值来制作一个术语级别的映射来反映它：

data Map kvs where
    Nil :: Map '[]
    Cons :: KnownSymbol k => Proxy# k -> v -> Map kvs -> Map ('(k,v):kvs)

当然，还有比链表更高效的数据结构；我将其作为练习留给读者进行类型级别的黑客攻击，以完成其中一项工作！哎呀。

实际上，Cons 构造函数是不安全的——它不保留排序要求，也不保留非重复要求。所以一般情况下，我们不会暴露这个Map的构造函数；相反，我们会公开以下用于创建映射的 API：

instance (KnownSymbol k,kv ~ '[ '(k,v) ]) => IsLabel k (v -> Map kv) where
    fromLabel v = Cons proxy# v Nil

(<<>>) :: Map kvs -> Map kvs' -> Map (Merge '(kvs,kvs'))
m@(Cons p v mt) <<>> m'@(Cons p' v' mt') = case scompare p p' of
    SLT -> Cons p v (mt <<>> m')
    SEQ -> error impossible
    SGT -> Cons p' v' (m <<>> mt')
    where
    impossible = unwords
        ["The impossible happened: duplicate key",symbolVal' p,"in (<<>>)),but no type error!"
        ]
Nil <<>> m' = m'
m <<>> Nil = m

IsLabel 实例让我们可以为 #artist "Mazouni" 字段中具有 String "Mazouni" 的映射编写例如 artist。 (<<>>) 操作合并字段；例如，#title "Ecoute moi Camarade" <<>> #artist "Mazouni" 表示一个两字段的数据结构。查看它的类型 -- artist 已经排在 title 之前：

> :t #title "Ecoute moi Camarade" <<>> #artist "Mazouni"
#title "Ecoute moi Camarade" <<>> #artist "Mazouni"
  :: Map '[ '("artist",[Char]),'("title",[Char])]
> :t #artist "Mazouni" <<>> #title "Ecoute moi Camarade"
#artist "Mazouni" <<>> #title "Ecoute moi Camarade"
  :: Map '[ '("artist",[Char])]

如果用户不小心将同一个字段包含了两次，他们会在使用映射时得到一个错误：

> f :: Map '[] -> (); f _ = ()
> f (#artist "Mazouni" <<>> #title "Ecoute moi Camarade" <<>> #artist "Bray")
    • Duplicate key "artist" in Merge
    • In the first argument of ‘f’,namely
        ‘(#artist "Mazouni" <<>> #title "Ecoute moi Camarade"
            <<>> #artist "Bray")’
      In the expression:
        f (#artist "Mazouni" <<>> #title "Ecoute moi Camarade"
             <<>> #artist "Bray")
      In an equation for ‘it’:
          it
            = f (#artist "Mazouni" <<>> #title "Ecoute moi Camarade"
                   <<>> #artist "Bray")

接下来我们实现查找。当我们在这些映射之一中查找一个字段时，我们会期望它在映射的使用者中具有某种类型。因此，我们需要一种方法来检查用户提供的映射是否具有与我们期望的类型兼容的类型。我们的做法如下：

type family AllCompatible kvs kvs' where
    AllCompatible '[] kvs' = CTrue
    AllCompatible ('(k,v):kvs) kvs' = (Compatible k v kvs',AllCompatible kvs kvs')

type family Compatible k v kvs where
    Compatible k v '[] = CTrue
    Compatible k v ('(k',v'):kvs) = CataOrdering (CmpSymbol k k')
        CTrue (v ~ v') (Compatible k v kvs)

type CTrue = () :: Constraint

type family LookupRaw k kvs kvsOriginal where
    LookupRaw k '[] kvsO = MissingKey k kvsO
    LookupRaw k ('(k',v):kvs) kvsO = CataOrdering (CmpSymbol k k')
        (MissingKey k kvsO)
        v
        (LookupRaw k kvs kvsO)

type family MissingKey k kvs where
    MissingKey k kvs = TypeError
        (    Text "Missing key in Lookup"
        :$$: Text "\tKey: " :<>: ShowType k
        :$$: Text "\tMapping: " :<>: ShowType kvs
        )

type Lookup k kvs = LookupRaw k kvs kvs

Compatible 检查某些字段是否具有某些类型（或缺少 - 这是允许的）； Lookup 从我们的预期字段映射中获取预期类型。这是术语级查找例程（称为 search，因为 lookup 被 Prelude 占用）：

search :: forall kvs k kvs'.
    (KnownSymbol k,Compatible k (Lookup k kvs) kvs') =>
    Map kvs' -> Maybe (Lookup k kvs)
search Nil = Nothing
search (Cons p v mt) = case scompare (proxy# @k) p of
    SLT -> Nothing
    SEQ -> Just v
    SGT -> search @kvs @k mt

您应该将上述所有内容视为一种小型图书馆。他们一劳永逸地完成了。下一点是您使用该工作与您关心的应用程序参数的地方。因此，例如，对于您在问题中描述的字段，您可以这样写：

-- calling Sort is defensive programming,in case some future idiot
-- (possibly you!) adds a field in the wrong order
type Opts = Sort
    [ '("artist",String),'("year",Integer)
    ]

showReq :: AllCompatible Opts opts => Map opts -> String
showReq opts = unwords
    [ fromMaybe "<no artist>" (search @Opts @"artist" opts),fromMaybe "<no title>" (search @Opts @"title" opts),maybe "<no year>" show (search @Opts @"year" opts)
    ]

showReq 的实现由编译器检查其字段；例如，如果您不小心写了，请说：

showReq :: AllCompatible Opts opts => Map opts -> String
showReq = search @Opts @"aritst"

你会得到一个错误：

    • Missing key in Lookup
        Key: "aritst"
        Mapping: '[ '("artist",Integer)]
    • In the expression: search @Opts @"aritst"
      In an equation for ‘showReq’: showReq = search @Opts @"aritst"

以下是用户使用 showReq 的样子：

> showReq (#artist "Mazouni" <<>> #title "Ecoute moi Camarade")
"Mazouni Ecoute moi Camarade <no year>"
> showReq (#year 1974)
"<no artist> <no title> 1974"

...不幸的是，在当前的实现中，最终用户无法避免打字错误：

> showReq (#aritst "Mazouni")
"<no artist> <no title> <no year>"

这是可以修复的，但我没有类型级别的黑客攻击能力。我鼓励你尝试一下！