diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,4 @@ +# Change log + +JSON Feed follows the [Package Versioning Policy](https://pvp.haskell.org). +You can find release notes [on GitHub](https://github.com/tfausak/json-feed/releases). diff --git a/LICENSE.markdown b/LICENSE.markdown --- a/LICENSE.markdown +++ b/LICENSE.markdown @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2020 Taylor Fausak +Copyright (c) 2022 Taylor Fausak Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/json-feed.cabal b/json-feed.cabal --- a/json-feed.cabal +++ b/json-feed.cabal @@ -1,7 +1,7 @@ -cabal-version: >= 1.10 +cabal-version: 2.2 name: json-feed -version: 1.0.15 +version: 2.0.0.0 synopsis: JSON Feed description: @@ -12,6 +12,7 @@ build-type: Simple category: Web extra-source-files: + CHANGELOG.markdown README.markdown feeds/allenpike.com.json feeds/daringfireball.net.json @@ -32,39 +33,64 @@ location: https://github.com/tfausak/json-feed type: git -library +flag pedantic + default: False + description: Enables @-Werror@, which turns warnings into errors. + manual: True + +common library build-depends: - base >= 4.13.0 && < 4.16 + base >= 4.13.0 && < 4.17 , aeson >= 1.4.7 && < 1.6 || >= 2.0.0 && < 2.1 - , bytestring >= 0.10.10 && < 0.11 + , bytestring >= 0.10.10 && < 0.12 , mime-types >= 0.1.0 && < 0.2 , network-uri >= 2.6.3 && < 2.7 , tagsoup >= 0.14.8 && < 0.15 , text >= 1.2.4 && < 1.3 , time >= 1.9.3 && < 1.10 default-language: Haskell2010 - exposed-modules: JsonFeed ghc-options: -Weverything + -Wno-all-missed-specialisations -Wno-implicit-prelude + -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-exported-signatures -Wno-unsafe - hs-source-dirs: src/lib + if flag(pedantic) + ghc-options: -Werror + if impl(ghc >= 8.10) ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures + +common executable + import: library + + build-depends: json-feed + ghc-options: + -rtsopts + -threaded + -Wno-unused-packages + +library + import: library + + exposed-modules: JsonFeed + hs-source-dirs: source/library + test-suite test + import: executable + build-depends: - base -any - , bytestring -any , filepath >= 1.4.2 && < 1.5 , hspec >= 2.7.6 && < 2.10 - , json-feed -any - default-language: Haskell2010 - hs-source-dirs: src/test + hs-source-dirs: source/test-suite main-is: Main.hs type: exitcode-stdio-1.0 diff --git a/source/library/JsonFeed.hs b/source/library/JsonFeed.hs new file mode 100644 --- /dev/null +++ b/source/library/JsonFeed.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | +module JsonFeed + ( parseFeed + , renderFeed + -- * Types + , Feed(..) + , Author(..) + , Item(..) + , Attachment(..) + , Hub(..) + -- * Wrappers + , Html(..) + , Mime(..) + , Url(..) + ) where + +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Aeson.Types (Options) +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Network.Mime (MimeType) +import Network.URI (URI) +import Numeric.Natural (Natural) +import Text.HTML.TagSoup (Tag) + +import qualified Data.Aeson as Json (eitherDecode, encode) +import qualified Data.Aeson.Types as Json +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Network.URI as Uri +import qualified Text.HTML.TagSoup as Html + + +parseFeed :: ByteString -> Either String Feed +parseFeed = Json.eitherDecode + + +renderFeed :: Feed -> ByteString +renderFeed = Json.encode + + +data Feed = Feed + { feedAuthor :: Maybe Author + -- ^ The feed author. The author object has several members. These are all + -- optional --- but if you provide an author object, then at least one is + -- required. + , feedDescription :: Maybe Text + -- ^ Provides more detail, beyond the title, on what the feed is about. A + -- feed reader may display this text. + , feedExpired :: Maybe Bool + -- ^ Says whether or not the feed is finished --- that is, whether or not it + -- will ever update again. A feed for a temporary event, such as an instance + -- of the Olympics, could expire. If the value is 'True', then it's expired. + -- Any other value, or the absence of 'feedExpired', means the feed may + -- continue to update. + , feedFavicon :: Maybe Url + -- ^ The URL of an image for the feed suitable to be used in a source list. + -- It should be square and relatively small, but not smaller than 64 x 64 (so + -- that it can look good on retina displays). As with 'feedIcon', this image + -- should use transparency where appropriate, since it may be rendered on a + -- non-white background. + , feedFeedUrl :: Maybe Url + -- ^ The URL of the feed, and serves as the unique identifier for the feed. + -- As with 'feedHomePageUrl', this should be considered required for feeds on + -- the public web. + , feedHomePageUrl :: Maybe Url + -- ^ The URL of the resource that the feed describes. This resource may or + -- may not actually be a "home" page, but it should be an HTML page. If a + -- feed is published on the public web, this should be considered as + -- required. But it may not make sense in the case of a file created on a + -- desktop computer, when that file is not shared or is shared only + -- privately. + , feedHubs :: Maybe [Hub] + -- ^ Describes endpoints that can be used to subscribe to real-time + -- notifications from the publisher of this feed. Each object has a type and + -- URL, both of which are required. + , feedIcon :: Maybe Url + -- ^ The URL of an image for the feed suitable to be used in a timeline, much + -- the way an avatar might be used. It should be square and relatively large + -- --- such as 512 x 512 --- so that it can be scaled-down and so that it can + -- look good on retina displays. It should use transparency where + -- appropriate, since it may be rendered on a non-white background. + , feedItems :: [Item] + -- ^ An array of objects that describe each object in the list. + , feedNextUrl :: Maybe Url + -- ^ The URL of a feed that provides the next /n/ items, where /n/ is + -- determined by the publisher. This allows for pagination, but with the + -- expectation that reader software is not required to use it and probably + -- won't use it very often. 'feedNextUrl' must not be the same as + -- 'feedFeedUrl', and it must not be the same as a previous 'feedNextUrl' (to + -- avoid infinite loops). + , feedTitle :: Text + -- ^ The name of the feed, which will often correspond to the name of the + -- website (blog, for instance), though not necessarily. + , feedUserComment :: Maybe Text + -- ^ A description of the purpose of the feed. This is for the use of people + -- looking at the raw JSON, and should be ignored by feed readers. + , feedVersion :: Url + -- ^ The URL of the version of the format the feed uses. + } + deriving (Eq, Generic, Show) + +instance FromJSON Feed where + parseJSON = Json.genericParseJSON (jsonOptions "feed") + +instance ToJSON Feed where + toJSON = Json.genericToJSON (jsonOptions "feed") + + +data Author = Author + { authorAvatar :: Maybe Url + -- ^ The URL for an image for the author. As with icon, it should be square + -- and relatively large --- such as 512 x 512 --- and should use transparency + -- where appropriate, since it may be rendered on a non-white background. + , authorName :: Maybe Text + -- ^ The author's name. + , authorUrl :: Maybe Url + -- ^ The URL of a site owned by the author. It could be a blog, micro-blog, + -- Twitter account, and so on. Ideally the linked-to page provides a way to + -- contact the author, but that's not required. The URL could be a @mailto:@ + -- link, though we suspect that will be rare. + } + deriving (Eq, Generic, Show) + +instance FromJSON Author where + parseJSON value = do + author <- Json.genericParseJSON (jsonOptions "author") value + case (authorAvatar author, authorName author, authorUrl author) of + (Nothing, Nothing, Nothing) -> fail ("invalid Author: " <> show author) + _ -> pure author + +instance ToJSON Author where + toJSON = Json.genericToJSON (jsonOptions "author") + + +data Item = Item + { itemAttachments :: Maybe [Attachment] + -- ^ Lists related resources. Podcasts, for instance, would include an + -- attachment that's an audio or video file. + , itemAuthor :: Maybe Author + -- ^ Has the same structure as the top-level 'feedAuthor'. If not specified + -- in an item, then the top-level author, if present, is the author of the + -- item. + , itemBannerImage :: Maybe Url + -- ^ The URL of an image to use as a banner. Some blogging systems (such as + -- Medium) display a different banner image chosen to go with each post, but + -- that image wouldn't otherwise appear in the content_html. A feed reader + -- with a detail view may choose to show this banner image at the top of the + -- detail view, possibly with the title overlaid. + , itemContentHtml :: Maybe Html + -- ^ 'itemContentHtml' and 'itemContentText' are each optional strings --- + -- but one or both must be present. This is the HTML or plain text of the + -- item. Important: the only place HTML is allowed in this format is in + -- 'itemContentHtml'. A Twitter-like service might use 'itemContentText', + -- while a blog might use 'itemContentHtml'. Use whichever makes sense for + -- your resource. (It doesn't even have to be the same for each item in a + -- feed.) + , itemContentText :: Maybe Text + -- ^ See 'itemContentHtml'. + , itemDateModified :: Maybe UTCTime + -- ^ Specifies the modification date in RFC 3339 format. + , itemDatePublished :: Maybe UTCTime + -- ^ Specifies the date in RFC 3339 format. (Example: + -- @2010-02-07T14:04:00-05:00@.) + , itemExternalUrl :: Maybe Url + -- ^ The URL of a page elsewhere. This is especially useful for linkblogs. If + -- 'itemUrl' links to where you're talking about a thing, then + -- 'itemExternalUrl' links to the thing you're talking about. + , itemId :: Value + -- ^ Unique for the item in the feed over time. If an item is ever updated, + -- the ID should be unchanged. New items should never use a previously-used + -- ID. If an ID is presented as a number or other type, a JSON Feed reader + -- must coerce it to a string. Ideally, the ID is the full URL of the + -- resource described by the item, since URLs make great unique identifiers. + , itemImage :: Maybe Url + -- ^ The URL of the main image for the item. This image may also appear in + -- the 'itemContentHtml' --- if so, it's a hint to the feed reader that this + -- is the main, featured image. Feed readers may use the image as a preview + -- (probably resized as a thumbnail and placed in a timeline). + , itemSummary :: Maybe Text + -- ^ A plain text sentence or two describing the item. This might be + -- presented in a timeline, for instance, where a detail view would display + -- all of 'itemContentHtml' or 'itemContentText'. + , itemTags :: Maybe [Text] + -- ^ Can have any plain text values you want. Tags tend to be just one word, + -- but they may be anything. Note: they are not the equivalent of Twitter + -- hashtags. Some blogging systems and other feed formats call these + -- categories. + , itemTitle :: Maybe Text + -- ^ Plain text. Microblog items in particular may omit titles. + , itemUrl :: Maybe Url + -- ^ The URL of the resource described by the item. It's the permalink. This + -- may be the same as the ID --- but should be present regardless. + } + deriving (Eq, Generic, Show) + +instance FromJSON Item where + parseJSON value = do + item <- Json.genericParseJSON (jsonOptions "item") value + case (itemContentHtml item, itemContentText item) of + (Nothing, Nothing) -> fail ("invalid Item: " <> show item) + _ -> pure item + +instance ToJSON Item where + toJSON = Json.genericToJSON (jsonOptions "item") + + +data Attachment = Attachment + { attachmentDurationInSeconds :: Maybe Natural + -- ^ Specifies how long it takes to listen to or watch, when played at normal + -- speed. + , attachmentMimeType :: Mime + -- ^ Specifies the type of the attachment, such as @audio/mpeg@. + , attachmentSizeInBytes :: Maybe Natural + -- ^ Specifies how large the file is. + , attachmentTitle :: Maybe Text + -- ^ Is a name for the attachment. Important: if there are multiple + -- attachments, and two or more have the exact same title (when title is + -- present), then they are considered as alternate representations of the + -- same thing. In this way a podcaster, for instance, might provide an audio + -- recording in different formats. + , attachmentUrl :: Url + -- ^ Specifies the location of the attachment. + } + deriving (Eq, Generic, Show) + +instance FromJSON Attachment where + parseJSON = Json.genericParseJSON (jsonOptions "attachment") + +instance ToJSON Attachment where + toJSON = Json.genericToJSON (jsonOptions "attachment") + + +data Hub = Hub + { hubType :: Text + , hubUrl :: Url + } + deriving (Eq, Generic, Show) + +instance FromJSON Hub where + parseJSON = Json.genericParseJSON (jsonOptions "hub") + +instance ToJSON Hub where + toJSON = Json.genericToJSON (jsonOptions "hub") + + +newtype Html = Html + { htmlValue :: [Tag Text] + } deriving (Eq, Show) + +instance FromJSON Html where + parseJSON = Json.withText + "Html" + (\text -> pure Html { htmlValue = Html.parseTags text }) + +instance ToJSON Html where + toJSON html = Json.String (Html.renderTags (htmlValue html)) + + +newtype Mime = Mime + { mimeValue :: MimeType + } deriving (Eq, Show) + +instance FromJSON Mime where + parseJSON = Json.withText + "Mime" + (\text -> pure Mime { mimeValue = Text.encodeUtf8 text }) + +instance ToJSON Mime where + toJSON mime = Json.String (Text.decodeUtf8 (mimeValue mime)) + + +newtype Url = Url + { urlValue :: URI + } deriving (Eq, Show) + +instance FromJSON Url where + parseJSON = Json.withText + "Url" + (\text -> case Uri.parseURI (Text.unpack text) of + Just uri -> pure Url { urlValue = uri } + Nothing -> fail ("invalid Url: " <> show text) + ) + +instance ToJSON Url where + toJSON url = Json.String (Text.pack (show (urlValue url))) + + +jsonOptions :: String -> Options +jsonOptions prefix = + Json.defaultOptions { Json.fieldLabelModifier = fieldLabelModifier prefix } + + +fieldLabelModifier :: String -> String -> String +fieldLabelModifier prefix string = + Json.camelTo2 '_' (unsafeDropPrefix prefix string) + + +unsafeDropPrefix :: String -> String -> String +unsafeDropPrefix prefix string = case dropPrefix prefix string of + Just suffix -> suffix + Nothing -> error + (unwords + ["unsafeDropPrefix:", show prefix, "is not a prefix of", show string] + ) + + +dropPrefix :: String -> String -> Maybe String +dropPrefix prefix string = if prefix `List.isPrefixOf` string + then Just (drop (length prefix) string) + else Nothing diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Main.hs @@ -0,0 +1,35 @@ +module Main + ( main + ) where + +import System.FilePath ((<.>), ()) + +import qualified Control.Monad as Monad +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Either as Either +import qualified JsonFeed +import qualified Test.Hspec as Hspec + + +main :: IO () +main = Hspec.hspec . Hspec.parallel . Hspec.describe "JsonFeed" $ do + Monad.forM_ feeds $ \feed -> do + Hspec.it ("parses the " <> feed <> " feed") $ do + let file = "feeds" feed <.> "json" + contents <- ByteString.readFile file + JsonFeed.parseFeed contents `Hspec.shouldSatisfy` Either.isRight + +feeds :: [String] +feeds = + [ "allenpike.com" + , "daringfireball.net" + , "flyingmeat.com" + , "hypercritical.co" + , "inessential.com" + , "jsonfeed.org" + , "manton.org" + , "maybepizza.com" + , "shapeof.com" + , "therecord.co" + , "timetable.manton.org" + ] diff --git a/src/lib/JsonFeed.hs b/src/lib/JsonFeed.hs deleted file mode 100644 --- a/src/lib/JsonFeed.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - --- | -module JsonFeed - ( parseFeed - , renderFeed - -- * Types - , Feed (..) - , Author (..) - , Item (..) - , Attachment (..) - , Hub (..) - -- * Wrappers - , Html (..) - , Mime (..) - , Url (..) - ) where - -import Data.Aeson (FromJSON, ToJSON, Value) -import Data.Aeson.Types (Options) -import Data.ByteString.Lazy (ByteString) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) -import Network.Mime (MimeType) -import Network.URI (URI) -import Numeric.Natural (Natural) -import Text.HTML.TagSoup (Tag) - -import qualified Data.Aeson as Json (eitherDecode, encode) -import qualified Data.Aeson.Types as Json -import qualified Data.List as List -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Network.URI as Uri -import qualified Text.HTML.TagSoup as Html - - -parseFeed :: ByteString -> Either String Feed -parseFeed = Json.eitherDecode - - -renderFeed :: Feed -> ByteString -renderFeed = Json.encode - - -data Feed = Feed - { feedAuthor :: Maybe Author - -- ^ The feed author. The author object has several members. These are all - -- optional --- but if you provide an author object, then at least one is - -- required. - , feedDescription :: Maybe Text - -- ^ Provides more detail, beyond the title, on what the feed is about. A - -- feed reader may display this text. - , feedExpired :: Maybe Bool - -- ^ Says whether or not the feed is finished --- that is, whether or not it - -- will ever update again. A feed for a temporary event, such as an instance - -- of the Olympics, could expire. If the value is 'True', then it's expired. - -- Any other value, or the absence of 'feedExpired', means the feed may - -- continue to update. - , feedFavicon :: Maybe Url - -- ^ The URL of an image for the feed suitable to be used in a source list. - -- It should be square and relatively small, but not smaller than 64 x 64 (so - -- that it can look good on retina displays). As with 'feedIcon', this image - -- should use transparency where appropriate, since it may be rendered on a - -- non-white background. - , feedFeedUrl :: Maybe Url - -- ^ The URL of the feed, and serves as the unique identifier for the feed. - -- As with 'feedHomePageUrl', this should be considered required for feeds on - -- the public web. - , feedHomePageUrl :: Maybe Url - -- ^ The URL of the resource that the feed describes. This resource may or - -- may not actually be a "home" page, but it should be an HTML page. If a - -- feed is published on the public web, this should be considered as - -- required. But it may not make sense in the case of a file created on a - -- desktop computer, when that file is not shared or is shared only - -- privately. - , feedHubs :: Maybe [Hub] - -- ^ Describes endpoints that can be used to subscribe to real-time - -- notifications from the publisher of this feed. Each object has a type and - -- URL, both of which are required. - , feedIcon :: Maybe Url - -- ^ The URL of an image for the feed suitable to be used in a timeline, much - -- the way an avatar might be used. It should be square and relatively large - -- --- such as 512 x 512 --- so that it can be scaled-down and so that it can - -- look good on retina displays. It should use transparency where - -- appropriate, since it may be rendered on a non-white background. - , feedItems :: [Item] - -- ^ An array of objects that describe each object in the list. - , feedNextUrl :: Maybe Url - -- ^ The URL of a feed that provides the next /n/ items, where /n/ is - -- determined by the publisher. This allows for pagination, but with the - -- expectation that reader software is not required to use it and probably - -- won't use it very often. 'feedNextUrl' must not be the same as - -- 'feedFeedUrl', and it must not be the same as a previous 'feedNextUrl' (to - -- avoid infinite loops). - , feedTitle :: Text - -- ^ The name of the feed, which will often correspond to the name of the - -- website (blog, for instance), though not necessarily. - , feedUserComment :: Maybe Text - -- ^ A description of the purpose of the feed. This is for the use of people - -- looking at the raw JSON, and should be ignored by feed readers. - , feedVersion :: Url - -- ^ The URL of the version of the format the feed uses. - } deriving (Eq, Generic, Show) - -instance FromJSON Feed where - parseJSON = Json.genericParseJSON (jsonOptions "feed") - -instance ToJSON Feed where - toJSON = Json.genericToJSON (jsonOptions "feed") - - -data Author = Author - { authorAvatar :: Maybe Url - -- ^ The URL for an image for the author. As with icon, it should be square - -- and relatively large --- such as 512 x 512 --- and should use transparency - -- where appropriate, since it may be rendered on a non-white background. - , authorName :: Maybe Text - -- ^ The author's name. - , authorUrl :: Maybe Url - -- ^ The URL of a site owned by the author. It could be a blog, micro-blog, - -- Twitter account, and so on. Ideally the linked-to page provides a way to - -- contact the author, but that's not required. The URL could be a @mailto:@ - -- link, though we suspect that will be rare. - } deriving (Eq, Generic, Show) - -instance FromJSON Author where - parseJSON value = do - author <- Json.genericParseJSON (jsonOptions "author") value - case (authorAvatar author, authorName author, authorUrl author) of - (Nothing, Nothing, Nothing) -> fail ("invalid Author: " ++ show author) - _ -> pure author - -instance ToJSON Author where - toJSON = Json.genericToJSON (jsonOptions "author") - - -data Item = Item - { itemAttachments :: Maybe [Attachment] - -- ^ Lists related resources. Podcasts, for instance, would include an - -- attachment that's an audio or video file. - , itemAuthor :: Maybe Author - -- ^ Has the same structure as the top-level 'feedAuthor'. If not specified - -- in an item, then the top-level author, if present, is the author of the - -- item. - , itemBannerImage :: Maybe Url - -- ^ The URL of an image to use as a banner. Some blogging systems (such as - -- Medium) display a different banner image chosen to go with each post, but - -- that image wouldn't otherwise appear in the content_html. A feed reader - -- with a detail view may choose to show this banner image at the top of the - -- detail view, possibly with the title overlaid. - , itemContentHtml :: Maybe Html - -- ^ 'itemContentHtml' and 'itemContentText' are each optional strings --- - -- but one or both must be present. This is the HTML or plain text of the - -- item. Important: the only place HTML is allowed in this format is in - -- 'itemContentHtml'. A Twitter-like service might use 'itemContentText', - -- while a blog might use 'itemContentHtml'. Use whichever makes sense for - -- your resource. (It doesn't even have to be the same for each item in a - -- feed.) - , itemContentText :: Maybe Text - -- ^ See 'itemContentHtml'. - , itemDateModified :: Maybe UTCTime - -- ^ Specifies the modification date in RFC 3339 format. - , itemDatePublished :: Maybe UTCTime - -- ^ Specifies the date in RFC 3339 format. (Example: - -- @2010-02-07T14:04:00-05:00@.) - , itemExternalUrl :: Maybe Url - -- ^ The URL of a page elsewhere. This is especially useful for linkblogs. If - -- 'itemUrl' links to where you're talking about a thing, then - -- 'itemExternalUrl' links to the thing you're talking about. - , itemId :: Value - -- ^ Unique for the item in the feed over time. If an item is ever updated, - -- the ID should be unchanged. New items should never use a previously-used - -- ID. If an ID is presented as a number or other type, a JSON Feed reader - -- must coerce it to a string. Ideally, the ID is the full URL of the - -- resource described by the item, since URLs make great unique identifiers. - , itemImage :: Maybe Url - -- ^ The URL of the main image for the item. This image may also appear in - -- the 'itemContentHtml' --- if so, it's a hint to the feed reader that this - -- is the main, featured image. Feed readers may use the image as a preview - -- (probably resized as a thumbnail and placed in a timeline). - , itemSummary :: Maybe Text - -- ^ A plain text sentence or two describing the item. This might be - -- presented in a timeline, for instance, where a detail view would display - -- all of 'itemContentHtml' or 'itemContentText'. - , itemTags :: Maybe [Text] - -- ^ Can have any plain text values you want. Tags tend to be just one word, - -- but they may be anything. Note: they are not the equivalent of Twitter - -- hashtags. Some blogging systems and other feed formats call these - -- categories. - , itemTitle :: Maybe Text - -- ^ Plain text. Microblog items in particular may omit titles. - , itemUrl :: Maybe Url - -- ^ The URL of the resource described by the item. It's the permalink. This - -- may be the same as the ID --- but should be present regardless. - } deriving (Eq, Generic, Show) - -instance FromJSON Item where - parseJSON value = do - item <- Json.genericParseJSON (jsonOptions "item") value - case (itemContentHtml item, itemContentText item) of - (Nothing, Nothing) -> fail ("invalid Item: " ++ show item) - _ -> pure item - -instance ToJSON Item where - toJSON = Json.genericToJSON (jsonOptions "item") - - -data Attachment = Attachment - { attachmentDurationInSeconds :: Maybe Natural - -- ^ Specifies how long it takes to listen to or watch, when played at normal - -- speed. - , attachmentMimeType :: Mime - -- ^ Specifies the type of the attachment, such as @audio/mpeg@. - , attachmentSizeInBytes :: Maybe Natural - -- ^ Specifies how large the file is. - , attachmentTitle :: Maybe Text - -- ^ Is a name for the attachment. Important: if there are multiple - -- attachments, and two or more have the exact same title (when title is - -- present), then they are considered as alternate representations of the - -- same thing. In this way a podcaster, for instance, might provide an audio - -- recording in different formats. - , attachmentUrl :: Url - -- ^ Specifies the location of the attachment. - } deriving (Eq, Generic, Show) - -instance FromJSON Attachment where - parseJSON = Json.genericParseJSON (jsonOptions "attachment") - -instance ToJSON Attachment where - toJSON = Json.genericToJSON (jsonOptions "attachment") - - -data Hub = Hub - { hubType :: Text - , hubUrl :: Url - } deriving (Eq, Generic, Show) - -instance FromJSON Hub where - parseJSON = Json.genericParseJSON (jsonOptions "hub") - -instance ToJSON Hub where - toJSON = Json.genericToJSON (jsonOptions "hub") - - -newtype Html = Html - { htmlValue :: [Tag Text] - } deriving (Eq, Show) - -instance FromJSON Html where - parseJSON = Json.withText "Html" (\text -> - pure Html { htmlValue = Html.parseTags text }) - -instance ToJSON Html where - toJSON html = Json.String (Html.renderTags (htmlValue html)) - - -newtype Mime = Mime - { mimeValue :: MimeType - } deriving (Eq, Show) - -instance FromJSON Mime where - parseJSON = Json.withText "Mime" (\text -> - pure Mime { mimeValue = Text.encodeUtf8 text }) - -instance ToJSON Mime where - toJSON mime = Json.String (Text.decodeUtf8 (mimeValue mime)) - - -newtype Url = Url - { urlValue :: URI - } deriving (Eq, Show) - -instance FromJSON Url where - parseJSON = Json.withText "Url" (\text -> - case Uri.parseURI (Text.unpack text) of - Just uri -> pure Url { urlValue = uri } - Nothing -> fail ("invalid Url: " ++ show text)) - -instance ToJSON Url where - toJSON url = Json.String (Text.pack (show (urlValue url))) - - -jsonOptions :: String -> Options -jsonOptions prefix = - Json.defaultOptions - { Json.fieldLabelModifier = fieldLabelModifier prefix - } - - -fieldLabelModifier :: String -> String -> String -fieldLabelModifier prefix string = - Json.camelTo2 '_' (unsafeDropPrefix prefix string) - - -unsafeDropPrefix :: String -> String -> String -unsafeDropPrefix prefix string = - case dropPrefix prefix string of - Just suffix -> suffix - Nothing -> error (unwords - [ "unsafeDropPrefix:" - , show prefix - , "is not a prefix of" - , show string - ]) - - -dropPrefix :: String -> String -> Maybe String -dropPrefix prefix string = - if List.isPrefixOf prefix string - then Just (drop (length prefix) string) - else Nothing diff --git a/src/test/Main.hs b/src/test/Main.hs deleted file mode 100644 --- a/src/test/Main.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Main (main) where - -import System.FilePath ((), (<.>)) - -import qualified Control.Monad as Monad -import qualified Data.ByteString.Lazy as ByteString -import qualified Data.Either as Either -import qualified JsonFeed -import qualified Test.Hspec as Hspec - - -main :: IO () -main = Hspec.hspec . Hspec.parallel . Hspec.describe "JsonFeed" $ do - Monad.forM_ feeds $ \feed -> do - Hspec.it ("parses the " ++ feed ++ " feed") $ do - let file = "feeds" feed <.> "json" - contents <- ByteString.readFile file - JsonFeed.parseFeed contents `Hspec.shouldSatisfy` Either.isRight - -feeds :: [String] -feeds = - [ "allenpike.com" - , "daringfireball.net" - , "flyingmeat.com" - , "hypercritical.co" - , "inessential.com" - , "jsonfeed.org" - , "manton.org" - , "maybepizza.com" - , "shapeof.com" - , "therecord.co" - , "timetable.manton.org" - ]