lens-aeson madness

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Main where

import Data.Foldable
import Data.Aeson.Lens
import Data.Aeson.Encode.Pretty
import Data.Aeson.QQ
import Control.Lens
import Control.Lens.Unsound
import Data.Aeson
import Data.ByteString.Lens
import Data.Text (Text)

requests :: [Value]
requests =
  [ [aesonQQ|{name: {forename: "hoho1", surname: "haha1", middleName: "hehe1"}}|]
  , [aesonQQ|{name: {forename: "hoho2", surname: "haha2", patronymic: "hehe2"}}|]
  ]

responses =
  [ [aesonQQ|{id: "name_id1", name: {forename: "hoho1", surname: "haha1", patronymic: "hehe1"}}|]
  , [aesonQQ|{id: "name_id2", name: {forename: "hoho2", surname: "haha2", patronymic: "hehe2"}}|]
  ]

aliases = [aesonQQ|
{
  patronymic: "middleName",
  middleName: "patronymic"
}
|]

schema = [aesonQQ|
{
    forename: "string",
    surname: "string",
    patronymic: "string",
    middleName: "string"
}
|]

schemaToLenses :: [ReifiedTraversal' Value Text]
schemaToLenses = fmap toLens $ schema ^@.. _Object . itraversed . _String
  where
    toLens (fld,tp) = Traversal $ keySyn fld . typeToLens tp
    typeToLens "string" = _String
    keySyn fld = runTraversal $
      adjoinAll $ [Traversal $ key fld] <> (aliases ^.. key fld . _String . to reifyKey)

reifyKey :: Text -> ReifiedTraversal' Value Value
reifyKey t = Traversal $ key t

adjoinAll :: [ReifiedTraversal' s a] -> ReifiedTraversal' s a
adjoinAll = foldl adjoin' (Traversal $ const pure)

adjoin' :: ReifiedTraversal' s a -> ReifiedTraversal' s a -> ReifiedTraversal' s a
adjoin' t1 t2 = Traversal $ adjoin (runTraversal t1) (runTraversal t2)

eqSchema this that = schemaToLenses
  & map
  (\fld -> all id
    [ this & has (runTraversal fld)
    , that & has (runTraversal fld)
    , this ^? runTraversal fld == that ^? runTraversal fld
    ]
  )
  & all id
  
main :: IO ()
main = do
  let
    withIds = map attachId requests
  traverse_ printPretty withIds
  where
    attachId rq = rq & _Object . at "id" .~ lookupId (rq ^?! key "name")
    lookupId rq = responses ^? traversed . filteredBy (key "name" . to (eqSchema rq) . only True) . key "id"

printPretty = 
  view $ to encodePretty . unpackedChars . to putStrLn

-- result:
-- {
--     "name": {
--         "surname": "haha1",
--         "forename": "hoho1",
--         "middleName": "hehe1"
--     },
--     "id": "name_id1"
-- }
-- {
--     "name": {
--         "surname": "haha2",
--         "forename": "hoho2",
--         "patronymic": "hehe2"
--     },
--     "id": "name_id2"
-- }