diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown deleted file mode 100644 --- a/CHANGELOG.markdown +++ /dev/null @@ -1,7 +0,0 @@ -# Change log - -JSON Feed uses [Semantic Versioning][]. -The change log is available through the [releases on GitHub][]. - -[Semantic Versioning]: http://semver.org/spec/v2.0.0.html -[releases on GitHub]: https://github.com/tfausak/json-feed/releases diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,10 +1,9 @@ # JSON Feed -[![][build badge]][build status] +[![Travis CI](https://travis-ci.org/tfausak/json-feed.svg?branch=master)](https://travis-ci.org/tfausak/json-feed) +[![Hackage](https://img.shields.io/hackage/v/json-feed)](https://hackage.haskell.org/package/json-feed) +[![Stackage](https://www.stackage.org/package/json-feed/badge/nightly?label=stackage)](https://www.stackage.org/package/json-feed) This is an implementation of the JSON Feed spec in Haskell. The spec is available at . JSON Feed is similar to the Atom and RSS feed formats, but it is serialized as JSON rather than XML. - -[build badge]: https://travis-ci.org/tfausak/json-feed.svg?branch=master -[build status]: https://travis-ci.org/tfausak/json-feed diff --git a/json-feed.cabal b/json-feed.cabal --- a/json-feed.cabal +++ b/json-feed.cabal @@ -1,84 +1,71 @@ -cabal-version: 1.12 +name: json-feed +version: 1.0.10 --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 0237ba25ba89ff1d202ca5905037a4f062aecc9f1cfabee0851b168cdcf9c31a +synopsis: JSON Feed +description: + This is an implementation of the JSON Feed spec in Haskell. The spec is + available at . JSON Feed is similar to the Atom and RSS + feed formats, but it is serialized as JSON rather than XML. -name: json-feed -version: 1.0.9 -synopsis: JSON Feed -description: This is an implementation of the JSON Feed spec in Haskell. The spec is available at . JSON Feed is similar to the Atom and RSS feed formats, but it is serialized as JSON rather than XML. -category: Web -homepage: https://github.com/tfausak/json-feed#readme -bug-reports: https://github.com/tfausak/json-feed/issues -maintainer: Taylor Fausak -license: MIT -license-file: LICENSE.markdown -build-type: Simple +build-type: Simple +cabal-version: >= 1.10 +category: Web extra-source-files: - CHANGELOG.markdown - feeds/allenpike.com.json - feeds/daringfireball.net.json - feeds/flyingmeat.com.json - feeds/hypercritical.co.json - feeds/inessential.com.json - feeds/jsonfeed.org.json - feeds/manton.org.json - feeds/maybepizza.com.json - feeds/shapeof.com.json - feeds/therecord.co.json - feeds/timetable.manton.org.json - package.yaml - README.markdown - stack.yaml + README.markdown + feeds/allenpike.com.json + feeds/daringfireball.net.json + feeds/flyingmeat.com.json + feeds/hypercritical.co.json + feeds/inessential.com.json + feeds/jsonfeed.org.json + feeds/manton.org.json + feeds/maybepizza.com.json + feeds/shapeof.com.json + feeds/therecord.co.json + feeds/timetable.manton.org.json +license-file: LICENSE.markdown +license: MIT +maintainer: Taylor Fausak source-repository head - type: git location: https://github.com/tfausak/json-feed + type: git library - exposed-modules: - JsonFeed - other-modules: - Paths_json_feed - hs-source-dirs: - library - ghc-options: -Weverything -Wno-implicit-prelude -Wno-safe -Wno-unsafe build-depends: - aeson >=0.11.2 && <0.12 || >=1.0.2 && <1.5 - , base >=4.9.0 && <4.15 - , bytestring >=0.10.8 && <0.11 - , mime-types >=0.1.0 && <0.2 - , network-uri >=2.6.1 && <2.8 - , tagsoup >=0.14 && <0.15 - , text >=1.2.2 && <1.3 - , time >=1.6.0 && <1.10 - if impl(ghc >= 8.8.1) + aeson >= 0.11.2 && < 0.12 || >= 1.0.2 && < 1.6 + , base >= 4.9.0 && < 4.15 + , bytestring >= 0.10.8 && < 0.11 + , mime-types >= 0.1.0 && < 0.2 + , network-uri >= 2.6.1 && < 2.8 + , tagsoup >= 0.14 && < 0.15 + , text >= 1.2.2 && < 1.3 + , time >= 1.6.0 && < 1.10 + default-language: Haskell98 + exposed-modules: JsonFeed + ghc-options: + -Weverything + -Wno-implicit-prelude + -Wno-safe + -Wno-unsafe + hs-source-dirs: src/lib + + if impl(ghc >= 8.8) ghc-options: -Wno-missing-deriving-strategies - default-language: Haskell2010 + if impl(ghc >= 8.10) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + test-suite test - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_json_feed - hs-source-dirs: - tests - ghc-options: -Weverything -Wno-implicit-prelude -Wno-safe -Wno-unsafe -rtsopts -threaded build-depends: - aeson >=0.11.2 && <0.12 || >=1.0.2 && <1.5 - , base >=4.9.0 && <4.15 - , bytestring >=0.10.8 && <0.11 - , filepath >=1.4.1 && <1.5 - , hspec >=2.2.3 && <2.8 - , json-feed - , mime-types >=0.1.0 && <0.2 - , network-uri >=2.6.1 && <2.8 - , tagsoup >=0.14 && <0.15 - , text >=1.2.2 && <1.3 - , time >=1.6.0 && <1.10 - if impl(ghc >= 8.8.1) - ghc-options: -Wno-missing-deriving-strategies - default-language: Haskell2010 + base -any + , bytestring -any + , filepath >= 1.4.1 && < 1.5 + , hspec >= 2.2.3 && < 2.8 + , json-feed -any + default-language: Haskell98 + hs-source-dirs: src/test + main-is: Main.hs + type: exitcode-stdio-1.0 diff --git a/library/JsonFeed.hs b/library/JsonFeed.hs deleted file mode 100644 --- a/library/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/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,53 +0,0 @@ -name: json-feed -version: 1.0.9 - -category: Web -description: > - This is an implementation of the JSON Feed spec in Haskell. The spec is - available at . JSON Feed is similar to the Atom and RSS - feed formats, but it is serialized as JSON rather than XML. -extra-source-files: - - CHANGELOG.markdown - - feeds/*.json - - package.yaml - - README.markdown - - stack.yaml -github: tfausak/json-feed -license-file: LICENSE.markdown -license: MIT -maintainer: Taylor Fausak -synopsis: JSON Feed - -dependencies: - aeson: '>= 0.11.2 && < 0.12 || >= 1.0.2 && < 1.5' - base: '>= 4.9.0 && < 4.15' - bytestring: '>= 0.10.8 && < 0.11' - mime-types: '>= 0.1.0 && < 0.2' - network-uri: '>= 2.6.1 && < 2.8' - tagsoup: '>= 0.14 && < 0.15' - text: '>= 1.2.2 && < 1.3' - time: '>= 1.6.0 && < 1.10' -ghc-options: - - -Weverything - - -Wno-implicit-prelude - - -Wno-safe - - -Wno-unsafe - -when: - - condition: impl(ghc >= 8.8.1) - ghc-options: -Wno-missing-deriving-strategies - -library: - source-dirs: library - -tests: - test: - dependencies: - filepath: '>= 1.4.1 && < 1.5' - hspec: '>= 2.2.3 && < 2.8' - json-feed: -any - ghc-options: - - -rtsopts - - -threaded - main: Main.hs - source-dirs: tests diff --git a/src/lib/JsonFeed.hs b/src/lib/JsonFeed.hs new file mode 100644 --- /dev/null +++ b/src/lib/JsonFeed.hs @@ -0,0 +1,313 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,33 @@ +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/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,1 +0,0 @@ -resolver: lts-15.4 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/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" - ]