refactor: replace aeson ToJSON/FromJSON with json-fleece schemas

- RecipeSearchEntry: replace genericToJSON ToJSON with Fleece schema using object combinators (required, optionalNullable, list text) - SchemaOrgRecipe: replace manual FromJSON instance with Fleece decoder that reuses existing helper functions for quirky fields - Html.hs: use Fleece.Aeson.Encoder.encode instead of Data.Aeson.encode - stack.yaml: add shrubbery + json-fleece extra-deps - package.yaml: add json-fleece-aeson + json-fleece-core deps - Remove unused LANGUAGE pragmas and redundant brackets
2026-05-19 23:24:24 -04:00
parent baa3c2434f
commit 8f8dbecea5
7 changed files with 152 additions and 42 deletions
@@ -29,6 +29,8 @@ ghc-options:
 dependencies:
  - base >= 4.7 && < 5
  - aeson
+  - json-fleece-aeson
+  - json-fleece-core
  - blaze-html
  - blaze-markup
  - bytestring
@@ -47,6 +47,8 @@ library
    , directory
    , filepath
    , http-types
+    , json-fleece-aeson
+    , json-fleece-core
    , optparse-applicative
    , parsec
    , text
@@ -79,6 +81,8 @@ executable check-recipes
    , directory
    , filepath
    , http-types
+    , json-fleece-aeson
+    , json-fleece-core
    , optparse-applicative
    , parsec
    , roux-server
@@ -112,6 +116,8 @@ executable roux-server
    , directory
    , filepath
    , http-types
+    , json-fleece-aeson
+    , json-fleece-core
    , optparse-applicative
    , parsec
    , roux-server
@@ -151,6 +157,8 @@ test-suite roux-server-test
    , filepath
    , hspec
    , http-types
+    , json-fleece-aeson
+    , json-fleece-core
    , optparse-applicative
    , parsec
    , roux-server
@@ -16,7 +16,6 @@ module Roux.Html (
 ) where

 import Control.Monad (unless)
-import Data.Aeson (encode)
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as LB
 import Data.Function ((&))
@@ -26,6 +25,8 @@ import Data.Ratio (denominator, numerator)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
+import qualified Fleece.Aeson as Fleece
+import qualified Fleece.Core as FC
 import qualified Text.Blaze.Html.Renderer.Utf8 as R
 import Text.Blaze.Html5 as H
 import Text.Blaze.Html5.Attributes as A
@@ -349,10 +350,10 @@ indexPage _mode recipes =
        H.div ! A.id "roux-recipe-list" $ H.p "Loading recipes..."
        -- Embedded JSON: recipe data
        H.script ! A.id "roux-recipe-data" ! A.type_ "application/json" $
-            H.toHtml (decodeUtf8 (LB.toStrict (encode (Prelude.map Idx.toSearchEntry (filterOk recipes)))))
+            H.toHtml (decodeUtf8 (LB.toStrict (Fleece.encode (Fleece.encoder (FC.list Idx.recipeSearchEntrySchema)) (Prelude.map Idx.toSearchEntry (filterOk recipes)))))
        -- Embedded JSON: error data
        H.script ! A.id "roux-errors-data" ! A.type_ "application/json" $
-            H.toHtml (decodeUtf8 (LB.toStrict (encode (Prelude.map Idx.toSearchEntry (filterBad recipes)))))
+            H.toHtml (decodeUtf8 (LB.toStrict (Fleece.encode (Fleece.encoder (FC.list Idx.recipeSearchEntrySchema)) (Prelude.map Idx.toSearchEntry (filterBad recipes)))))
        -- Inline JS
        H.script ! A.type_ "text/javascript" $ H.preEscapedText searchJs
  where
@@ -1,17 +1,17 @@
-{-# LANGUAGE DeriveGeneric #-}
-
 -- | Scanning and indexing of Cooklang recipe files on disk.
 module Roux.RecipeIndex (
    RecipeInfo (..),
    RecipeSearchEntry (..),
+    recipeSearchEntrySchema,
    scanRecipes,
    toSearchEntry,
 ) where

-import Data.Aeson (ToJSON (..), camelTo2, defaultOptions, fieldLabelModifier, genericToJSON)
 import Data.Text (Text)
 import qualified Data.Text as T
-import GHC.Generics (Generic)
+import Fleece.Aeson (EncoderDecoder)
+import Fleece.Core (constructor, list, object, optionalNullable, required, text, (#+))
+import qualified Fleece.Core as FC
 import System.Directory (listDirectory)
 import System.FilePath (takeBaseName, takeExtension, (</>))

@@ -58,10 +58,17 @@ data RecipeSearchEntry = RecipeSearchEntry
    , rseCourse :: !(Maybe Text)
    , rseTags :: ![Text]
    }
-    deriving stock (Generic)
+    deriving stock (Eq, Show)

-instance ToJSON RecipeSearchEntry where
-    toJSON = genericToJSON defaultOptions{fieldLabelModifier = camelTo2 '_' . drop 3}
+-- | Fleece schema for encoding 'RecipeSearchEntry' to JSON.
+recipeSearchEntrySchema :: FC.Schema EncoderDecoder RecipeSearchEntry
+recipeSearchEntrySchema =
+    object $
+        constructor RecipeSearchEntry
+            #+ required "title" rseTitle text
+            #+ required "filename" rseFilename text
+            #+ optionalNullable FC.EmitNull "course" rseCourse text
+            #+ required "tags" rseTags (list text)

 {- | Convert a 'RecipeInfo' into a 'RecipeSearchEntry', extracting course and
     tags from the parsed recipe metadata when available.
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}

 module Roux.SchemaOrg (
@@ -12,14 +13,15 @@ module Roux.SchemaOrg (
 ) where

 import Control.Monad (guard)
-import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
-import Data.Aeson.Types (parseMaybe)
 import Data.List.NonEmpty (NonEmpty ((:|)), fromList)
 import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Fleece.Aeson as Fleece
+import qualified Fleece.Aeson.Decoder as FleeceD
+import qualified Fleece.Core as FC

 import Data.CookLang

@@ -179,38 +181,78 @@ lookupText key obj = case KM.lookup key obj of
 -- FromJSON instance
 -- ---------------------------------------------------------------------------

-instance FromJSON SchemaOrgRecipe where
-    parseJSON = A.withObject "SchemaOrgRecipe" $ \obj ->
-        SchemaOrgRecipe
-            <$> obj .: "name"
-            <*> obj .:? "description"
-            <*> obj .:? "url"
-            <*> obj .:? "totalTime"
-            <*> obj .:? "prepTime"
-            <*> obj .:? "cookTime"
-            <*> obj .:? "recipeYield"
-            <*> pure (parseOptionalTextOrArray obj "recipeCuisine")
-            <*> pure (parseOptionalTextOrArray obj "recipeCategory")
-            <*> pure (parseOptionalTextList obj "keywords")
-            <*> pure (parsePerson obj)
-            <*> pure (parseImages obj "image")
-            <*> obj .:? "datePublished"
-            <*> pure (parseNutrition obj)
-            <*> (obj .:? "recipeIngredient" .!= [])
-            <*> pure (parseHowToSteps obj)
+-- | Fleece schema for decoding a schema.org Recipe from JSON-LD.
+schemaOrgRecipeSchema :: FC.Schema Fleece.Decoder SchemaOrgRecipe
+schemaOrgRecipeSchema =
+    FC.Schema
+        { FC.schemaName = FC.unqualifiedName "SchemaOrgRecipe"
+        , FC.schemaInterpreter = FleeceD.Decoder decodeRecipe
+        }
+  where
+    decodeRecipe val = do
+        obj <- case val of
+            A.Object o -> pure o
+            A.Array arr -> case foldr (:) [] arr of
+                (A.Object o : _) -> pure o
+                _ -> fail "Expected object or array of objects"
+            _ -> fail "Expected JSON object"
+        case KM.lookup "@type" obj of
+            Just (A.String "Recipe") -> pure ()
+            _ -> fail "Not a schema.org Recipe"
+        name <- requiredText "name" obj
+        description <- optionalText "description" obj
+        url <- optionalText "url" obj
+        totalTime <- optionalText "totalTime" obj
+        prepTime <- optionalText "prepTime" obj
+        cookTime <- optionalText "cookTime" obj
+        recipeYield <- optionalText "recipeYield" obj
+        let recipeCuisine = parseOptionalTextOrArray obj "recipeCuisine"
+            recipeCategory = parseOptionalTextOrArray obj "recipeCategory"
+            keywords = parseOptionalTextList obj "keywords"
+            author = parsePerson obj
+            image = parseImages obj "image"
+            nutrition = parseNutrition obj
+            ingsVal = KM.lookup "recipeIngredient" obj
+            ingredients = case ingsVal of
+                Just (A.Array arr) -> mapMaybe textFromValue (foldr (:) [] arr)
+                Just (A.String _) -> []
+                _ -> []
+            instructions = parseHowToSteps obj
+        datePublished <- optionalText "datePublished" obj
+        pure
+            SchemaOrgRecipe
+                { soName = name
+                , soDescription = description
+                , soUrl = url
+                , soTotalTime = totalTime
+                , soPrepTime = prepTime
+                , soCookTime = cookTime
+                , soRecipeYield = recipeYield
+                , soRecipeCuisine = recipeCuisine
+                , soRecipeCategory = recipeCategory
+                , soKeywords = keywords
+                , soAuthor = author
+                , soImage = image
+                , soDatePublished = datePublished
+                , soNutrition = nutrition
+                , soRecipeIngredient = ingredients
+                , soRecipeInstructions = instructions
+                }
+    requiredText key obj = case KM.lookup key obj of
+        Just (A.String t) -> pure t
+        Just _ -> fail "Expected string for field"
+        Nothing -> fail "Missing required field"
+    optionalText key obj = case KM.lookup key obj of
+        Just (A.String t) -> pure (Just t)
+        _ -> pure Nothing
+    textFromValue (A.String t) = Just t
+    textFromValue _ = Nothing

 -- | Parse a schema.org Recipe from a JSON Value, handling @type selection.
 parseSchemaOrgRecipe :: A.Value -> Maybe SchemaOrgRecipe
-parseSchemaOrgRecipe val = do
-    obj <- case val of
-        A.Object o -> Just o
-        A.Array arr -> case foldr (:) [] arr of
-            (A.Object o : _) -> Just o
-            _ -> Nothing
-        _ -> Nothing
-    case KM.lookup "@type" obj of
-        Just (A.String "Recipe") -> parseMaybe parseJSON (A.Object obj)
-        _ -> Nothing
+parseSchemaOrgRecipe val = case FleeceD.fromValue schemaOrgRecipeSchema val of
+    Right r -> Just r
+    Left _ -> Nothing

 -- ---------------------------------------------------------------------------
 -- Conversion to Cooklang Recipe
@@ -2,3 +2,14 @@ resolver: lts-24.38

 packages:
  - .
+
+extra-deps:
+  - github: flipstone/shrubbery
+    commit: 1847db5c280357ff341b5909250981b8c303f444
+    subdirs:
+      - .
+  - github: flipstone/json-fleece
+    commit: f2df040dee441a25dd1bbdc8bcf939bf04c74875
+    subdirs:
+      - json-fleece-core
+      - json-fleece-aeson
@@ -3,7 +3,46 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/topics/lock_files

-packages: []
+packages:
+- completed:
+    name: shrubbery
+    pantry-tree:
+      sha256: e9a7f795ed04b76955303132edcce72210bd646c6c9e1ee5dd930a63f2533aab
+      size: 2924
+    sha256: 77d0c3be3bb32ae48297881f937d7bb72a50423a9ebe27e962fc7bfb9c980b00
+    size: 30242
+    subdir: .
+    url: https://github.com/flipstone/shrubbery/archive/1847db5c280357ff341b5909250981b8c303f444.tar.gz
+    version: 0.2.3.2
+  original:
+    subdir: .
+    url: https://github.com/flipstone/shrubbery/archive/1847db5c280357ff341b5909250981b8c303f444.tar.gz
+- completed:
+    name: json-fleece-core
+    pantry-tree:
+      sha256: f17d0fe31bb3503b0f4566f256cc040e797800871544b26b3f7a4ecd75128022
+      size: 491
+    sha256: 0af34870fde6550c5be93bec6e471c27c7f358d796e5817ae284b37269f527a1
+    size: 3079817
+    subdir: json-fleece-core
+    url: https://github.com/flipstone/json-fleece/archive/f2df040dee441a25dd1bbdc8bcf939bf04c74875.tar.gz
+    version: 0.11.0.1
+  original:
+    subdir: json-fleece-core
+    url: https://github.com/flipstone/json-fleece/archive/f2df040dee441a25dd1bbdc8bcf939bf04c74875.tar.gz
+- completed:
+    name: json-fleece-aeson
+    pantry-tree:
+      sha256: c1204bd17604272fdcdff26ea9e7b932c3bd311acaad307835a37eb3038566f5
+      size: 628
+    sha256: 0af34870fde6550c5be93bec6e471c27c7f358d796e5817ae284b37269f527a1
+    size: 3079817
+    subdir: json-fleece-aeson
+    url: https://github.com/flipstone/json-fleece/archive/f2df040dee441a25dd1bbdc8bcf939bf04c74875.tar.gz
+    version: 0.5.0.0
+  original:
+    subdir: json-fleece-aeson
+    url: https://github.com/flipstone/json-fleece/archive/f2df040dee441a25dd1bbdc8bcf939bf04c74875.tar.gz
 snapshots:
 - completed:
    sha256: abc790b571e0c70e929db74b329e3c18d7e76a6e173e8bdf94f1ba20770d4c24