diff --git a/src/Roux/SchemaOrg.hs b/src/Roux/SchemaOrg.hs new file mode 100644 index 0000000..d7ed7d5 --- /dev/null +++ b/src/Roux/SchemaOrg.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Roux.SchemaOrg ( + SchemaOrgRecipe (..), + SchemaOrgPerson (..), + SchemaOrgImageObject (..), + SchemaOrgHowToStep (..), + SchemaOrgNutrition (..), + parseSchemaOrgRecipe, + schemaOrgToCooklang, + parseISODuration, +) where + +import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (parseMaybe) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import Data.CookLang + +-- --------------------------------------------------------------------------- +-- Data types +-- --------------------------------------------------------------------------- + +-- | A schema.org Recipe object. +data SchemaOrgRecipe = SchemaOrgRecipe + { soName :: !Text + , soDescription :: !(Maybe Text) + , soUrl :: !(Maybe Text) + , soTotalTime :: !(Maybe Text) + , soPrepTime :: !(Maybe Text) + , soCookTime :: !(Maybe Text) + , soRecipeYield :: !(Maybe Text) + , soRecipeCuisine :: !(Maybe Text) + , soRecipeCategory :: !(Maybe Text) + , soKeywords :: ![Text] + , soAuthor :: !(Maybe SchemaOrgPerson) + , soImage :: ![SchemaOrgImageObject] + , soDatePublished :: !(Maybe Text) + , soNutrition :: !(Maybe SchemaOrgNutrition) + , soRecipeIngredient :: ![Text] + , soRecipeInstructions :: ![SchemaOrgHowToStep] + } + deriving stock (Eq, Show) + +-- | A schema.org Person (recipe author). +data SchemaOrgPerson = SchemaOrgPerson + { soPersonName :: !Text + } + deriving stock (Eq, Show) + +-- | A schema.org ImageObject (recipe image). +data SchemaOrgImageObject = SchemaOrgImageObject + { soImageObjectUrl :: !Text + } + deriving stock (Eq, Show) + +-- | A schema.org HowToStep (one instruction step). +data SchemaOrgHowToStep = SchemaOrgHowToStep + { sohsText :: !Text + , sohsName :: !(Maybe Text) + } + deriving stock (Eq, Show) + +-- | A schema.org NutritionInformation block. +data SchemaOrgNutrition = SchemaOrgNutrition + { sonCalories :: !(Maybe Int) + , sonFatContent :: !(Maybe Text) + , sonCarbohydrateContent :: !(Maybe Text) + , sonProteinContent :: !(Maybe Text) + , sonSodiumContent :: !(Maybe Text) + , sonSugarContent :: !(Maybe Text) + , sonFiberContent :: !(Maybe Text) + , sonUnsaturatedFatContent :: !(Maybe Text) + , sonSaturatedFatContent :: !(Maybe Text) + , sonTransFatContent :: !(Maybe Text) + , sonCholesterolContent :: !(Maybe Text) + } + deriving stock (Eq, Show) + +-- --------------------------------------------------------------------------- +-- Helper functions for JSON quirks +-- --------------------------------------------------------------------------- + +-- | Parse an optional text-or-array field as a single Text (first if array). +parseOptionalTextOrArray :: A.Object -> A.Key -> Maybe Text +parseOptionalTextOrArray obj key = case KM.lookup key obj of + Just (A.String t) -> Just t + Just (A.Array arr) + | (A.String t : _) <- foldr (:) [] arr -> Just t + _ -> Nothing + +-- | Parse an optional text-or-array field as a list of Text. +parseOptionalTextList :: A.Object -> A.Key -> [Text] +parseOptionalTextList obj key = case KM.lookup key obj of + Just (A.String t) -> map T.strip (T.splitOn "," t) + Just (A.Array arr) -> mapMaybe (\case A.String t -> Just t; _ -> Nothing) (foldr (:) [] arr) + _ -> [] + +-- | Parse image: single URL string, single ImageObject dict, or array of ImageObject dicts. +parseImages :: A.Object -> A.Key -> [SchemaOrgImageObject] +parseImages obj key = case KM.lookup key obj of + Just (A.String url) -> [SchemaOrgImageObject url] + Just (A.Object inner) -> [parseImageObject inner] + Just (A.Array arr) -> mapMaybe (\case A.Object o -> Just (parseImageObject o); _ -> Nothing) (foldr (:) [] arr) + _ -> [] + +parseImageObject :: A.Object -> SchemaOrgImageObject +parseImageObject obj = + let url = case KM.lookup "url" obj of + Just (A.String u) -> u + _ -> case KM.lookup "contentUrl" obj of + Just (A.String u) -> u + _ -> "" + in SchemaOrgImageObject url + +parsePerson :: A.Object -> Maybe SchemaOrgPerson +parsePerson obj = case KM.lookup "author" obj of + Just (A.Object inner) -> + case KM.lookup "name" inner of + Just (A.String n) -> Just (SchemaOrgPerson n) + _ -> Nothing + _ -> Nothing + +parseNutrition :: A.Object -> Maybe SchemaOrgNutrition +parseNutrition obj = case KM.lookup "nutrition" obj of + Just (A.Object inner) -> Just (parseNutritionObject inner) + _ -> Nothing + +parseNutritionObject :: A.Object -> SchemaOrgNutrition +parseNutritionObject obj = + SchemaOrgNutrition + { sonCalories = parseInt "calories" obj + , sonFatContent = lookupText "fatContent" obj + , sonCarbohydrateContent = lookupText "carbohydrateContent" obj + , sonProteinContent = lookupText "proteinContent" obj + , sonSodiumContent = lookupText "sodiumContent" obj + , sonSugarContent = lookupText "sugarContent" obj + , sonFiberContent = lookupText "fiberContent" obj + , sonUnsaturatedFatContent = lookupText "unsaturatedFatContent" obj + , sonSaturatedFatContent = lookupText "saturatedFatContent" obj + , sonTransFatContent = lookupText "transFatContent" obj + , sonCholesterolContent = lookupText "cholesterolContent" obj + } + +parseHowToSteps :: A.Object -> [SchemaOrgHowToStep] +parseHowToSteps obj = case KM.lookup "recipeInstructions" obj of + Just (A.Object inner) -> [parseHowToStep inner] + Just (A.Array arr) -> mapMaybe (\case A.Object o -> Just (parseHowToStep o); _ -> Nothing) (foldr (:) [] arr) + _ -> [] + +parseHowToStep :: A.Object -> SchemaOrgHowToStep +parseHowToStep obj = + SchemaOrgHowToStep + { sohsText = fromMaybe "" (lookupText "text" obj) + , sohsName = lookupText "name" obj + } + +parseInt :: A.Key -> A.Object -> Maybe Int +parseInt key obj = case KM.lookup key obj of + Just (A.Number n) -> Just (floor n) + Just (A.String t) -> + case reads (T.unpack t) of + [(n, "")] -> Just n + _ -> Nothing + _ -> Nothing + +lookupText :: A.Key -> A.Object -> Maybe Text +lookupText key obj = case KM.lookup key obj of + Just (A.String t) -> Just t + _ -> Nothing + +-- --------------------------------------------------------------------------- +-- 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) + +-- | 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 + +-- --------------------------------------------------------------------------- +-- Stubs for future tasks +-- --------------------------------------------------------------------------- + +-- | Convert a SchemaOrgRecipe to a Cooklang Recipe. (Stub — will be implemented in Task 3) +schemaOrgToCooklang :: SchemaOrgRecipe -> Either String Recipe +schemaOrgToCooklang _ = Left "Not yet implemented" + +-- | Parse an ISO 8601 duration string. (Stub — will be implemented in Task 2) +parseISODuration :: Text -> Maybe Duration +parseISODuration _ = Nothing diff --git a/test/Roux/SchemaOrgSpec.hs b/test/Roux/SchemaOrgSpec.hs new file mode 100644 index 0000000..632a8f2 --- /dev/null +++ b/test/Roux/SchemaOrgSpec.hs @@ -0,0 +1,51 @@ +module Roux.SchemaOrgSpec (spec) where + +import qualified Data.Aeson as A +import Data.Maybe (fromJust, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy) + +import Roux.SchemaOrg + +-- | Extract the first schema.org Recipe JSON-LD from HTML. +tryDecode :: Text -> Maybe A.Value +tryDecode html = + case T.splitOn "" afterOpenTag of + (jsonContent : _) -> A.decodeStrict (TE.encodeUtf8 (T.strip jsonContent)) + _ -> Nothing + _ -> Nothing + +spec :: Spec +spec = describe "SchemaOrg" $ do + describe "parseSchemaOrgRecipe" $ do + it "parses fried-rice.html embedded JSON-LD" $ do + html <- readFile "test-data/fried-rice.html" + let decoded = tryDecode (T.pack html) + decoded `shouldSatisfy` isJust + let recipe = parseSchemaOrgRecipe (fromJust decoded) + recipe `shouldSatisfy` isJust + case recipe of + Nothing -> expectationFailure "expected Just SchemaOrgRecipe, got Nothing" + Just r -> do + soName r `shouldBe` "Fried Rice" + soRecipeYield r `shouldBe` Just "4 to 6 servings" + soTotalTime r `shouldBe` Just "PT20M" + soRecipeCuisine r `shouldBe` Just "asian" + length (soRecipeIngredient r) `shouldBe` 14 + length (soRecipeInstructions r) `shouldBe` 4 + + it "parses carrot-risotto.html embedded JSON-LD" $ do + html <- readFile "test-data/carrot-risotto.html" + let decoded = tryDecode (T.pack html) + decoded `shouldSatisfy` isJust + let recipe = parseSchemaOrgRecipe (fromJust decoded) + recipe `shouldSatisfy` isJust + case recipe of + Nothing -> expectationFailure "expected Just SchemaOrgRecipe, got Nothing" + Just r -> soName r `shouldBe` "Carrot Risotto With Chile Crisp" diff --git a/test/Spec.hs b/test/Spec.hs index 817a998..fbb312f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,14 +5,17 @@ import Test.Tasty.Hspec (testSpec) import qualified Roux.NYTimesSpec import qualified Roux.ParserSpec +import qualified Roux.SchemaOrgSpec main :: IO () main = do parserTests <- testSpec "Parser" Roux.ParserSpec.spec nytTests <- testSpec "NYTimes" Roux.NYTimesSpec.spec + schemaOrgTests <- testSpec "SchemaOrg" Roux.SchemaOrgSpec.spec defaultMain $ testGroup "roux-server" [ parserTests , nytTests + , schemaOrgTests ]