Skip to content

Instantly share code, notes, and snippets.

@maksbotan
Created December 30, 2019 07:19
Show Gist options
  • Save maksbotan/339666ff5168e35f3cc9c40bd25b742d to your computer and use it in GitHub Desktop.
Save maksbotan/339666ff5168e35f3cc9c40bd25b742d to your computer and use it in GitHub Desktop.
Generic валидация

Валидация enum'ов во вложенных структурах

Про этот файл

Это Literate Haskell файл. Вот как загрузить его в ghci:

$ stack --resolver=lts-13.6 install markdown-unlit
$ stack --resolver=lts-13.6 ghci enums.md --package aeson --package validation --package semigroups --package containers --package lens --package generic-lens --ghci-options='-pgmL markdown-unlit'
Экстеншены и импорты
{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Enums where

import           Data.Aeson      (FromJSON, ToJSON)
import           Data.Kind
import           Data.Validation (Validation (..))
import           GHC.Exts        (proxy#)
import           Control.Lens ((&), (.~))
import           Data.Generics.Product.Fields (HasField'(..))
import           GHC.Generics
import           GHC.TypeLits
import           Data.Semigroup.Generic (gmappend, gmempty)
import           Data.Set (Set, singleton)

Что мы хотим

Пусть у нас есть такая структура данных:

data Element = Element
  { elType :: String
  , elSpec :: String
  , elTags :: [String]
  }

data Binder = Binder
  { bType     :: String
  , bElements :: [Element]
  }

data Molecule = Molecule
  { molName    :: String
  , molBinders :: [Binder]
  }

От пользователя приходит Molecule, который мы хотим провалидировать. А именно, надо убедиться, что поля type, spec и tags содержат только строки из фиксированного списка вариантов.

При этом хочется достичь двух целей — полноты и безопасности:

  1. Полнота — нельзя забыть провалидировать какое-то из полей. В частности, при добавлении нового поля приходится вспоминать, что его надо добавить в валидацию. То же самое при изменении структуры.
  2. Безопасность — в идеале, хотелось бы различать на уровне типов "сырую" и уже провалидированную структуру. Таким образом код, обрабатывающий их, может быть уверен, что данные корректные.

Первой цели будем добиваться с помощью валидации произвольных типов через Generic, а второй — через метки в виде фантомных типов.

Кроме этого, при валидации нам надо собрать сразу все неверные строки, найденные в структуре, чтобы выдать пользователю полный отчёт об ошибках.

Представление валидированных данных.

Для представления отчёта об ошибках заведём структуру ValidationErrors:

data ValidationErrors = ValidationErrors
  { unknownSpecs   :: Set String
  , unknownTags    :: Set String
  , unknownElTypes :: Set String
  , unknownBTypes  :: Set String
  }
  deriving (Eq, Show, Generic)

instance Semigroup ValidationErrors where
  (<>) = gmappend

instance Monoid ValidationErrors where
  mempty = gmempty

Инстанс Monoid позволяет независимо валидировать разные поля, а потом собирать ошибки в один отчёт.

Для различения валидированных и невалидированных данных заведём type-level тег:

data Validity = NotValidated | Validated

Мы будем работать с типами кайнда Validity -> Type, то есть с типами, имеющими метку, показывающую их статус валидации. Заведём для них класс с функцией validate, которая, собственно, будет проводить валидацию:

class Validable e (a :: Validity -> Type) where
  validate :: a 'NotValidated -> Validation e (a 'Validated)

Функция validate получает "сырые" данные и возвращает проверенные в функторе Validation. Этот аппликативный функтор похож на Either, но его операция <*> объединяет ошибки от двух выражений с помощью инстанса Monoid — именно то поведение, которое мы хотим. При этом класс может работать с любым типом отчёта.

Таким образом, мы не сможем получить доступ к валидированным данным, если функция validate вернула Failure.

Информацию о допустимых значениях для какого-то поля будем представлять с помощью newtype над строкой:

newtype EnumText (enum :: [Symbol]) (field :: Symbol) (v :: Validity)
  = EnumText String
  deriving (Eq, Show, Generic)

deriving instance FromJSON (EnumText enum field 'NotValidated)
deriving instance ToJSON (EnumText enum field v)

Тип EnumText имеет три фантомных параметра: список допустимых строк (enum :: [Symbol]), название поля в структуре ValidationErrors (field :: Symbol) — в это поле будут записываться найденные неверные строки, и статус валидации (v :: Validity). При этом инстанс FromJSON есть только для тега 'NotValidated — при чтении из внешних источников мы можем получить только сырые данные.

Для того, чтобы написать instance Validable (EnumText enum field), нам понадобится функция, передающая type-level список строк enum :: [Symbol] на term-level. Такие функции в Haskell реализуются с помощью классов типов:

class EnumOptions (enum :: [Symbol]) where
  enumOptions :: [String]

instance EnumOptions '[] where
  enumOptions = []

instance (KnownSymbol e, EnumOptions es) => EnumOptions (e ': es) where
  enumOptions = symbolVal' (proxy# @_ @e) : enumOptions @es

Теперь мы можем написать функцию, валидирующую одну строку:

instance (HasField' field e (Set String), Monoid e, EnumOptions enum) => Validable e (EnumText enum field) where
  validate (EnumText value) =
    if value `elem` enumOptions @enum
      then Success $ EnumText value
      else Failure $ mempty & field' @field .~ singleton value

Функция validate работает для любых типов отчёта об ошибках (наш ValidationErrors) с помощью generic-lens. В случае, если строка не найдена в списке вариантов, validate создаст пустой отчёт типа e и запишет одно своё неверное значение в поле, указанное в параметре field.

Проверим, как это работает:

λ> validate @ValidationErrors $ EnumText @["knob", "hole"] @"unknownTags" "knob"
Success (EnumText "knob")

λ> validate @ValidationErrors $ EnumText @["knob", "hole"] @"unknownTags" "LALA"
Failure (ValidationErrors {unknownSpecs = fromList [], unknownTags = fromList ["LALA"]})

Действительно, для неизвестного тега валидация вернула ошибку, записав его в правильное место отчёта.

Кроме того, класс HasField' из generic-lens гарантирует, что мы не можем ошибиться в названии этого поля:

λ> validate @ValidationErrors $ EnumText @["knob", "hole"] @"unknownSomething" "LALA"

<interactive>:14:1: error:
    • The type ValidationErrors does not contain a field named 'unknownSomething'.

Валидация рекордов

Отлично, мы умеем валидировать одну строку. Теперь надо научиться валидировать произвольные структуры. Запишем наш пример с помощью EnumText:

data Element (v :: Validity) = Element
  { elType :: EnumText ["VH", "VL"] "unknownElTypes" v
  , elSpec :: EnumText ["HIV", "Ebola"] "unknownSpecs" v
  , elTags :: [EnumText ["knob", "hole"] "unknownTags" v]
  }
  deriving (Eq, Show, Generic, Generic1, ToJSON)
deriving instance FromJSON (Element 'NotValidated)

data Binder (v :: Validity) = Binder
  { bType     :: EnumText ["opposite", "sequential"] "unknownBTypes" v
  , bElements :: [Element v]
  }
  deriving (Eq, Show, Generic, Generic1, ToJSON)
deriving instance FromJSON (Binder 'NotValidated)

data Molecule (v :: Validity) = Molecule
  { molName    :: String
  , molBinders :: [Binder v]
  }
  deriving (Eq, Show, Generic, Generic1, ToJSON)
deriving instance FromJSON (Molecule 'NotValidated)

Все типы имеют кайнд Validity -> Type, поэтому для них можно написать инстанс Validable, например так:

instance Validable ValidationErrors Element where
  validate (Element typ spec tags) =
    Element <$> validate typ <*> validate spec <*> traverse validate tags

Однако писать такие инстансы руками утомительно. К счастью, Haskell позволяет использовать механизм Generic для того, чтобы генерировать их автоматически.

Так как наш класс работает с типами кайнда Validity -> Type, нам понадобится класс Generic1.

Опишем вспомогательный класс GValidable, работающий с типом Rep1 из Generic:

class GValidable e (g :: Validity -> Type) where
  gvalidate :: g 'NotValidated -> Validation e (g 'Validated)

Тогда для нашего класса Validable можно добавить инстанс по умолчанию:

class Validable e (a :: Validity -> Type) where
  validate :: a 'NotValidated -> Validation e (a 'Validated)

  default validate :: (Generic1 a, GValidable e (Rep1 a)) => a 'NotValidated -> Validation e (a 'Validated)
  validate = fmap to1 . gvalidate . from1

Таким образом, для любого типа, для которого подходит наше Generic описание GValidable, автоматически можно получить и инстанс Validable.

Реализация GValidable

Написать такой Generic инстанс оказывается очень легко:

-- Rec1 --  представление произвольного параметра типа 'a' внутри нашего рекорда.
-- Если для типа 'a' уже есть инстанс Validable, то им мы и воспользуемся.
instance Validable e a => GValidable e (Rec1 (a :: Validity -> Type)) where
  gvalidate (Rec1 a) = Rec1 <$> validate a

-- Если же наш 'a' вложен в любой Traversable контейнер типа списка, мы можем воспользоваться
-- функцией traverse.
--
-- Здесь :.: и Comp1 -- представление композиции типов в Generic.
instance (Traversable f, Semigroup e, GValidable e a) => GValidable e (f :.: a) where
  gvalidate (Comp1 as) = Comp1 <$> traverse gvalidate as

-- Если же нам встретился любой "чистый" тип a, то валидировать ничего не надо, можно просто вернуть
-- успех с помощью pure.
instance Semigroup e => GValidable e (Rec0 (a :: Type)) where
  gvalidate (K1 a) = K1 <$> pure a

-- И наконец, для случая нескольких полей мы валидируем их независимо.
instance (GValidable e a, Semigroup e, GValidable e b) => GValidable e (a :*: b) where
  gvalidate (l :*: r) = (:*:) <$> gvalidate l <*> gvalidate r

-- Оставшиеся инстансы обслуживают разные обертки из Generic.
instance GValidable e a => GValidable e (S1 meta a) where
  gvalidate (M1 a) = M1 <$> gvalidate a

instance GValidable e a => GValidable e (C1 meta a) where
  gvalidate (M1 a) = M1 <$> gvalidate a

instance GValidable e a => GValidable e (D1 meta a) where
  gvalidate (M1 a) = M1 <$> gvalidate a

Пример

Имея Generic инстансы и реализацию по умолчанию в классе Validable мы можем получить инстансы для наших типов автоматически с помощью DeriveAnyClass:

deriving instance Validable ValidationErrors Element
deriving instance Validable ValidationErrors Binder
deriving instance Validable ValidationErrors Molecule

Проверим, что всё работает как ожидается:

element :: Element 'NotValidated
element = Element { elType = EnumText "VH", elSpec = EnumText "HIV", elTags = [EnumText "knob"] }

element_err :: Element 'NotValidated
element_err = Element { elType = EnumText "CK", elSpec = EnumText "CD3", elTags = [EnumText "knob", EnumText "LALA"] }
λ> validate @ValidationErrors element
Success (Element {elType = EnumText "VH", elSpec = EnumText "HIV", elTags = [EnumText "knob"]})

λ> validate @ValidationErrors element_err 
Failure (ValidationErrors {unknownSpecs = fromList ["CD3"], unknownTags = fromList ["LALA"], unknownElTypes = fromList ["CK"], unknownBTypes = fromList []})

И наконец, убедимся, что всё работает для вложенных типов:

binder_err :: Binder 'NotValidated
binder_err = Binder { bType = EnumText "funny", bElements = [element, element_err] }

molecule_err :: Molecule 'NotValidated
molecule_err = Molecule { molName = "candy", molBinders = [binder_err] }
λ> validate @ValidationErrors molecule_err 
Failure (ValidationErrors {unknownSpecs = fromList ["CD3"], unknownTags = fromList ["LALA"], unknownElTypes = fromList ["CK"], unknownBTypes = fromList ["funny"]})

Как можно видеть, валидация нашла все ошибки в полях всех вложенных типов.

Заключение

Такой механизм позволит нам писать любые типы и быть уверенными, что компилятор не позволит нам забыть их провалидировать.

Кроме того, тот же механизм можно использовать для других типов валидации, благодаря тому, что класс Validable работает с произвольным типом отчёта об ошибках.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment