Skip to content

Instantly share code, notes, and snippets.

@maksbotan

maksbotan/enums.md

Created December 30, 2019 07:19
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save maksbotan/339666ff5168e35f3cc9c40bd25b742d to your computer and use it in GitHub Desktop.
Save maksbotan/339666ff5168e35f3cc9c40bd25b742d to your computer and use it in GitHub Desktop.
Download ZIP
Generic валидация
Raw
enums.md

Валидация 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