diff --git a/package.yaml b/package.yaml index d21c6d4..3c78ac1 100644 --- a/package.yaml +++ b/package.yaml @@ -29,6 +29,8 @@ ghc-options: dependencies: - base >= 4.7 && < 5 - aeson + - json-fleece-aeson + - json-fleece-core - blaze-html - blaze-markup - bytestring diff --git a/roux-server.cabal b/roux-server.cabal index 0d5a06f..337dcc3 100644 --- a/roux-server.cabal +++ b/roux-server.cabal @@ -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 diff --git a/src/Roux/Html.hs b/src/Roux/Html.hs index d8f31a4..c13074b 100644 --- a/src/Roux/Html.hs +++ b/src/Roux/Html.hs @@ -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 diff --git a/src/Roux/RecipeIndex.hs b/src/Roux/RecipeIndex.hs index 89cb8c1..c467b2d 100644 --- a/src/Roux/RecipeIndex.hs +++ b/src/Roux/RecipeIndex.hs @@ -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. diff --git a/src/Roux/SchemaOrg.hs b/src/Roux/SchemaOrg.hs index 6b4ea57..b7a3cb9 100644 --- a/src/Roux/SchemaOrg.hs +++ b/src/Roux/SchemaOrg.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index 007bafe..149a821 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock index d025909..7b14b49 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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