validate-aeson.hs

#! /usr/bin/env nix-shell
#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (pkgs: [ pkgs.aeson pkgs.validation pkgs.ghcid pkgs.errors ])"

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Error (fmapL)
import Control.Error.Util
import Data.Aeson
import Data.Aeson.Types
import qualified Data.HashMap.Strict as M
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty (..))
import Data.Scientific (floatingOrInteger)
import qualified Data.Text as T
import qualified Data.Validation as V

newtype Name = Name T.Text deriving (Show)

validationToParser :: V.Validation (NonEmpty ValidationErrors) a -> Parser a
validationToParser = either (fail . T.unpack . T.intercalate ". " . fmap validationErrorToText . NonEmpty.toList) pure . V.toEither

instance FromJSON Name where
  parseJSON = withText "Name" $ \s -> do
    validationToParser $ validateName (Name s)

newtype Surname = Surname T.Text deriving (Show)

instance FromJSON Surname where
  parseJSON = withText "Surname" $ \s -> do
    validationToParser $ validateSurname (Surname s)

newtype Age = Age Integer deriving (Show)

instance FromJSON Age where
  parseJSON = withScientific "Age" $ \s -> do
    validationToParser $ case floatingOrInteger s of
      Left _ -> V.validationNel $ Left (ValidationErrors_InvalidFormat "Value must be an Integer")
      Right i -> validateAge (Age i)

data User = User
  { name :: Name,
    surname :: Surname,
    age :: Maybe Age
  }
  deriving (Show)

data ValidationErrors
  = ValidationErrors_TooShort
  | ValidationErrors_TooOld
  | ValidationErrors_InvalidFormat T.Text
  | ValidationErrors_DoesNotExist T.Text
  | ValidationErrors_Other T.Text T.Text
  deriving (Show)

validationErrorToText (ValidationErrors_DoesNotExist f) = T.intercalate " " ["field", "'" <> f <> "'", "does not exist"]
validationErrorToText (ValidationErrors_TooShort) = "Value is too short"
validationErrorToText (ValidationErrors_TooOld) = "Value is too old"
validationErrorToText (ValidationErrors_InvalidFormat e) = T.intercalate " " ["Invalid format!", e]
validationErrorToText (ValidationErrors_Other f e) = T.intercalate " " ["[(" <> f <> "): " <> e <> "]"]

validateName :: Name -> V.Validation (NonEmpty ValidationErrors) Name
validateName vn@(Name n) =
  if T.length n < 3
    then V.Failure (ValidationErrors_TooShort :| [])
    else V.Success vn

validateSurname :: Surname -> V.Validation (NonEmpty ValidationErrors) Surname
validateSurname vs@(Surname s) =
  if T.length s < 3
    then V.Failure (ValidationErrors_TooShort :| [])
    else V.Success vs

validateAge :: Age -> V.Validation (NonEmpty ValidationErrors) Age
validateAge va@(Age a) =
  if a > 30
    then V.Failure (ValidationErrors_TooOld :| [])
    else V.Success va

infixr 5 .:|

(.:|) o f = pure . V.validationNel $ case M.lookup f o of
  Nothing -> Left (ValidationErrors_DoesNotExist f)
  Just val -> fmapL (ValidationErrors_Other f . T.pack) $ case parse parseJSON val of
    Error e -> Left e
    Success s -> Right s

infixr 5 .:|?

(.:|?) o f = pure . V.validationNel $ case M.lookup f o of
  Nothing -> Right Nothing
  Just val -> fmapL (ValidationErrors_Other f . T.pack) $ case parse parseJSON val of
    Error e -> Left e
    Success s -> Right s

instance FromJSON User where
  parseJSON = withObject "User" $ \o -> do
    name <- o .:| "name"
    surname <- o .:| "surname"
    age <- o .:|? "age"
    validationToParser $
      User
        <$> name
        <*> surname
        <*> age

str0 = "{\"haydar\": \"koray\"}"

str1 = "{\"name\": \"koray\"}"

str2 = "{\"surname\": \"\"}"

str3 = "{\"name\": \"koray\", \"surname\": \"al\", \"age\": 37.6}"

str4 = "{\"name\": \"koray\", \"surname\": \"al_\", \"age\": 29}"

main = do
  putStrLn (show (eitherDecode str0 :: Either String User))
  putStrLn (show (eitherDecode str1 :: Either String User))
  putStrLn (show (eitherDecode str2 :: Either String User))
  putStrLn (show (eitherDecode str3 :: Either String User))
  putStrLn (show (eitherDecode str4 :: Either String User))

-- Left "Error in $: field 'name' does not exist. field 'surname' does not exist"
-- Left "Error in $: field 'surname' does not exist"
-- Left "Error in $: field 'name' does not exist. [(surname): Value is too short]"
-- Left "Error in $: [(surname): Value is too short]. [(age): Invalid format! Value must be an Integer]"
-- Right (User {name = Name "koray", surname = Surname "al_", age = Just (Age 29)})