为固定API编写安全查询字符串的Haskell选项数据类型

Question

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

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本身。

期望使用

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

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

例如，下面这样的内容对调用者来说是很好的：

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。这是一个简单例子。使用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

Answer 1

标准的诀窍是只使用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或其变体也可能使您达到需要的位置。

Answer 2

只是为了好玩，这里有第二个答案，它使用了一种非常不同的技术。我们将从字段名到它们的类型进行类型级别的映射；然后我们将创建一个类型，它可以拥有给定字段的任何子集并支持字段查找。首先，我们做了一个大呼吸，充满了环境空气的类型水平的编程.

{-# 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, ('(k', v'):kvs')))
        (TypeError (Text "Duplicate key " :<>: ShowType k :<>: Text " in Merge"))
        ('(k', v'):Merge '(('(k, v):kvs), 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"，用于在artist字段中包含String "Mazouni"的映射。(<<>>)操作合并字段；例如，#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]), '("title", [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)
    , '("title", 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", [Char]), '("title", [Char]),
                   '("year", 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"

使用当前实现的...unfortunately，最终用户不会受到排印的保护：

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

这是可修复的，但我没有类型级别的黑客蒸汽。我鼓励你试一试！