feat: add SchemaOrgRecipe types and FromJSON parsing
This commit is contained in:
@@ -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
|
||||
@@ -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 "<script type=\"application/ld+json" html of
|
||||
(_before : rest : _) ->
|
||||
-- Skip past the closing > of the opening script tag, which may have extra attributes
|
||||
let afterOpenTag = T.drop 1 (T.dropWhile (/= '>') rest)
|
||||
in case T.splitOn "</script>" 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"
|
||||
@@ -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
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user