diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,1 @@ +Copyright 2017 Alex Brandt diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# Revision history for collection-json + +## 1.0.0.0 -- 2017-08-05 + +* Add Property Test Suite +* Add Code of Conduct +* Update README +* Add Travis CI Configuration +* Other Package Updates diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,35 @@ -# collection-json +# Description -A Haskell supporting library for the Collection+JSON media type. +[Collection+JSON] Tools -In progess. +Types, classes, and functions for using the +[Collection+JSON—Hypermedia Type][Collection+JSON] in [Haskell]. +# Getting Started -See for information about this media type. +Documentation is available on [Hackage] and information about +`application/vnd.collection+json` can be found at +. + +# Reporting Issues + +Any issues discovered should be recorded on [github][issues]. If you believe +you've found an error or have a suggestion for a new feature; please, ensure +that it is reported. + +If you would like to contribute a fix or new feature; please, submit a pull +request. This project follows [git flow] and utilizes [travis] to automatically +check pull requests before a manual review. + +# Contributors + +The `COPYRIGHT` file contains a list of contributors with their respective +copyrights and other information. If you submit a pull request and would like +attribution; please, add yourself to the `COPYRIGHT` file. + +[Collection+JSON]: http://amundsen.com/media-types/collection/ +[git flow]: http://nvie.com/posts/a-successful-git-branching-model/ +[Hackage]: https://hackage.haskell.org/package/collection-json +[Haskell]: https://www.haskell.org/ +[issues]: https://github.com/alunduil/collection-json.hs/issues +[travis]: https://travis-ci.org/alunduil/collection-json.hs diff --git a/Text/JSON/CollectionJSON/Types.hs b/Text/JSON/CollectionJSON/Types.hs deleted file mode 100644 --- a/Text/JSON/CollectionJSON/Types.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} -module Text.JSON.CollectionJSON.Types where -import Data.Aeson hiding (Error) -import Data.Text (Text) -import Control.Applicative - -data Collection = Collection { - cVersion :: Text - , cHref :: Text - , cLinks :: [Link] - , cItems :: [Item] - , cQueries :: [Query] - , cTemplate :: Maybe Template - , cError :: Maybe Error - } deriving Show - -data Error = Error { - eTitle :: Text - , eCode :: Maybe Text - , eMessage :: Maybe Text - } deriving Show - -{- Each has five possible properties: href (REQUIRED), rel (REQURIED), name (OPTIONAL), render (OPTIONAL), and prompt, (OPTIONAL). --} - -data Link = Link { - lHref :: Text - , lRel :: Text - , lName :: Maybe Text - , lRender :: Maybe Text - , lPrompt :: Maybe Text - } deriving Show - -{- The queries array SHOULD contain one or more anonymous objects. Each object composed of five possible properties: href (REQUIRED), rel (REQUIRED), name (OPTIONAL), prompt (OPTIONAL), and a data array (OPTIONAL). -} - -data Query = Query { - qHref :: Text - , qRel :: Text - , qName :: Maybe Text - , qPrompt :: Maybe Text - , qData :: [Data] - } deriving Show - -{- The data array SHOULD contain one or more anonymous objects. Each -object MAY have any of three possible properties: name (REQUIRED), value -(OPTIONAL), and prompt (OPTIONAL). -} - -data Data = Data { - dName :: Text - , dValue :: Maybe Text - , dPrompt :: Maybe Text - } deriving Show - -{- Each element in the items array SHOULD contain an href property. The -href property MUST contain a URI. This URI MAY be used to retrieve a -Collection+JSON document representing the associated item. It MAY be used -to edit or delete the associated item. See Reading and Writing Data for -details. - -The items array MAY have a data array child property. - -The items array MAY have a links array child property. --} - -data Item = Item { - iHref :: Text - , iData :: [Data] - , iLinks :: [Link] - } deriving Show - -{- The template object SHOULD have a data array child property. -} - - -data Template = Template { - tData :: [Data] - } deriving Show - ------------------------------------------------------------------------- --- FromJSON instances - -instance FromJSON Template where - parseJSON (Object v) = Template <$> v .: "data" - -instance FromJSON Item where - parseJSON (Object v) = Item - <$> v .: "href" - <*> v .:? "data" .!= [] - <*> v .:? "links" .!= [] - -instance FromJSON Data where - parseJSON (Object v) = Data - <$> v .: "name" - <*> v .:? "value" - <*> v .:? "prompt" - -instance FromJSON Query where - parseJSON (Object v) = Query - <$> v .: "href" - <*> v .: "rel" - <*> v .:? "name" - <*> v .:? "prompt" - <*> v .:? "data" .!= [] - -instance FromJSON Link where - parseJSON (Object v) = Link - <$> v .: "href" - <*> v .: "rel" - <*> v .:? "name" - <*> v .:? "render" - <*> v .:? "prompt" - -instance FromJSON Error where - parseJSON (Object v) = Error - <$> v .: "title" - <*> v .:? "code" - <*> v .:? "message" - -instance FromJSON Collection where - parseJSON (Object v) = Collection - <$> v .: "version" - <*> v .: "href" - <*> v .:? "links" .!= [] - <*> v .:? "items" .!= [] - <*> v .:? "queries" .!= [] - <*> v .:? "template" - <*> v .:? "error" - ------------------------------------------------------------------------- - -instance ToJSON Template where - toJSON Template{..} = object [ "data" .= tData ] - -instance ToJSON Item where - toJSON Item{..} = object [ - "href" .= iHref - , "data" .= iData - , "links" .= iLinks - ] - -instance ToJSON Data where - toJSON Data{..} = object [ - "name" .= dName - , "data" .= dValue - , "prompt" .= dPrompt - ] - -instance ToJSON Query where - toJSON Query{..} = object [ - "href" .= qHref - , "rel" .= qRel - , "name" .= qName - , "prompt" .= qPrompt - , "data" .= qData - ] - -instance ToJSON Link where - toJSON Link{..} = object [ - "href" .= lHref - , "rel" .= lRel - , "name" .= lName - , "render" .= lRender - , "prompt" .= lPrompt - ] - -instance ToJSON Error where - toJSON Error{..} = object [ - "title" .= eTitle - , "code" .= eCode - , "message" .= eMessage - ] - -instance ToJSON Collection where - toJSON Collection{..} = object [ - "version" .= cVersion - , "href" .= cHref - , "links" .= cLinks - , "items" .= cItems - , "queries" .= cQueries - , "template" .= cTemplate - , "error" .= cError - ] diff --git a/collection-json.cabal b/collection-json.cabal --- a/collection-json.cabal +++ b/collection-json.cabal @@ -1,28 +1,88 @@ --- Initial collection-json.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: collection-json -version: 0.1.0.0 -synopsis: Collection+JSON hypermedia type tools -homepage: https://github.com/danchoi/collection-json.hs -description: Collection+JSON hypermedia type tools +version: 1.0.0.0 +synopsis: Collection+JSON—Hypermedia Type Tools + +description: + Types, classes, and functions for using the Collection+JSON—Hypermedia Type + in Haskell. + +homepage: https://github.com/alunduil/collection-json.hs +bug-reports: https://github.com/alunduil/collection-json.hs/issues license: MIT license-file: LICENSE -author: Daniel Choi -maintainer: dhchoi@gmail.com -copyright: 2015 Daniel Choi -category: Web +author: Alex Brandt +maintainer: alunduil@alunduil.com +copyright: (c) 2017 Alex Brandt +category: Data build-type: Simple --- extra-source-files: cabal-version: >=1.10 +tested-with: GHC ==8.0.2 +extra-source-files: + ChangeLog.md + , COPYRIGHT + , LICENSE + , README.md + , Setup.hs + , test/Data/CollectionJSON/Tests.hs + , test/Internal/Network/URI/Tests.hs + , test/Main.hs + +source-repository head + type: git + location: https://github.com/alunduil/collection+json.hs + branch: develop + library - exposed-modules: Text.JSON.CollectionJSON.Types - -- other-modules: - -- other-extensions: - build-depends: base >=4.6 && <4.8 - , aeson >= 0.8 - , text - , bytestring - -- hs-source-dirs: - default-language: Haskell2010 + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Data.CollectionJSON + + ghc-options: -Wall -fwarn-tabs -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + + other-modules: + Internal.Network.URI + + build-depends: + aeson >= 0.8 && < 1.1 + , base >= 4.6 && < 4.10 + , network-uri == 2.6.* + , text == 1.2.* + + other-extensions: + OverloadedStrings + , RecordWildCards + +test-suite Properties + default-language: Haskell2010 + hs-source-dirs: src test + + type: exitcode-stdio-1.0 + main-is: Main.hs + + ghc-options: -Wall -fwarn-tabs -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + + other-modules: + Data.CollectionJSON + Data.CollectionJSON.Tests + + Internal.Network.URI + Internal.Network.URI.Tests + + build-depends: + aeson >= 0.8 && < 1.1 + , base >= 4.6 && < 4.10 + , network-uri == 2.6.* + , QuickCheck == 2.9.* + , quickcheck-instances == 0.3.* + , test-invariant == 0.4.* + , text == 1.2.* + + other-extensions: + OverloadedStrings + , RecordWildCards + , TemplateHaskell diff --git a/src/Data/CollectionJSON.hs b/src/Data/CollectionJSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/CollectionJSON.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| +Module : Data.CollectionJSON +Description : Types and Instances for @application/vnd.collection+json@ +Copyright : (c) Alex Brandt, 2017 +License : MIT + +A collection of types and instances for @application/vnd.collection+json@. + +Full documentation for @application/vnd.collection+json@ can be found at +. +-} +module Data.CollectionJSON where + +import Data.Aeson ((.=), (.:?), (.!=), (.:), FromJSON (parseJSON), object, ToJSON (toJSON), withObject) +import Data.Text (Text) +import Network.URI (URI) + +import Internal.Network.URI () + +-- * Core Data Types + +-- | The top-level object for an @application/vnd.collection+json@ resource. +data Collection = Collection + { cVersion :: Text -- ^ Currently, always "1.0". + , cHref :: URI -- ^ Address used to retrieve the 'Collection' + -- and to add new elements. + , cLinks :: [Link] + , cItems :: [Item] + , cQueries :: [Query] + , cTemplate :: Maybe Template + , cError :: Maybe Error + } deriving (Eq, Show) + +instance FromJSON Collection where + parseJSON = withObject "Collection" $ \ c -> do + v <- c .: "collection" + + cVersion <- v .:? "version" .!= "1.0" + cHref <- v .: "href" + cLinks <- v .:? "links" .!= [] + cItems <- v .:? "items" .!= [] + cQueries <- v .:? "queries" .!= [] + cTemplate <- v .:? "template" + cError <- v .:? "error" + + return Collection{..} + +instance ToJSON Collection where + toJSON Collection{..} = object + [ "collection" .= object + [ "version" .= cVersion + , "href" .= cHref + , "links" .= cLinks + , "items" .= cItems + , "queries" .= cQueries + , "template" .= cTemplate + , "error" .= cError + ] + ] + +{-| +A link to a related resource (not necessarily an +@application/vnd.collection+json@ resource). +-} +data Link = Link + { lHref :: URI -- ^ Address of the resource. + , lRel :: Text -- ^ Relation---the following contain suggested + -- relation values: + -- + -- * [IANA Link Relations](http://www.iana.org/assignments/link-relations/link-relations.xml) + -- * [Microformat Existing Rel Values](http://microformats.org/wiki/existing-rel-values) + -- * [RFC5988](http://tools.ietf.org/html/rfc5988) + , lName :: Maybe Text + , lRender :: Maybe Text + , lPrompt :: Maybe Text + } deriving (Eq, Show) + +instance FromJSON Link where + parseJSON = withObject "Link" $ \ v -> do + lHref <- v .: "href" + lRel <- v .: "rel" + lName <- v .:? "name" + lRender <- v .:? "render" + lPrompt <- v .:? "prompt" + + return Link{..} + +instance ToJSON Link where + toJSON Link{..} = object + [ "href" .= lHref + , "rel" .= lRel + , "name" .= lName + , "render" .= lRender + , "prompt" .= lPrompt + ] + +-- | An element in the 'Collection' +data Item = Item + { iHref :: URI -- ^ Address of the resource used to retrieve, modify, or + -- delete the element. + , iData :: [Datum] + , iLinks :: [Link] + } deriving (Eq, Show) + +instance FromJSON Item where + parseJSON = withObject "Item" $ \ v -> do + iHref <- v .: "href" + iData <- v .:? "data" .!= [] + iLinks <- v .:? "links" .!= [] + + return Item{..} + +instance ToJSON Item where + toJSON Item{..} = object + [ "href" .= iHref + , "data" .= iData + , "links" .= iLinks + ] + +{-| +A template for possible queries related to this 'Collection'. + +A query should correspond to an associated HTTP GET request. + +The Query: +> Query "http://example.com/search" "search" Nothing (Just "Search:") [Datum "search" "" Nothing] + +Corresponds with the following URI for an HTTP GET: +> http://example.com/search?search={search_terms} +-} +data Query = Query + { qHref :: URI -- ^ Address of reqeust's target. + , qRel :: Text -- ^ Relation---the following contain suggested + -- relation values: + -- + -- * [IANA Link Relations](http://www.iana.org/assignments/link-relations/link-relations.xml) + -- * [Microformat Existing Rel Values](http://microformats.org/wiki/existing-rel-values) + -- * [RFC5988](http://tools.ietf.org/html/rfc5988) + , qName :: Maybe Text -- ^ Identifier for this 'Query'. + , qPrompt :: Maybe Text -- ^ Suggested user prompt. + , qData :: [Datum] -- ^ Query parameters for this 'Query'. + } deriving (Eq, Show) + +instance FromJSON Query where + parseJSON = withObject "Query" $ \ v -> do + qHref <- v .: "href" + qRel <- v .: "rel" + qName <- v .:? "name" + qPrompt <- v .:? "prompt" + qData <- v .:? "data" .!= [] + + return Query{..} + +instance ToJSON Query where + toJSON Query{..} = object + [ "href" .= qHref + , "rel" .= qRel + , "name" .= qName + , "prompt" .= qPrompt + , "data" .= qData + ] + +-- | A fillable template for creation of a new object in the 'Collection'. +newtype Template = Template + { tData :: [Datum] + } deriving (Eq, Show) + +instance FromJSON Template where + parseJSON = withObject "Template" $ \ v -> do + tData <- v .:? "data" .!= [] + + return Template{..} + +instance ToJSON Template where + toJSON Template{..} = object + [ "data" .= tData + ] + +-- | Information about latest error that occured when responding to a request. +data Error = Error + { eTitle :: Maybe Text + , eCode :: Maybe Text -- ^ Unique identifier (e.g. session identifier, + -- request tracker, etc). + , eMessage :: Maybe Text + } deriving (Eq, Show) + +instance FromJSON Error where + parseJSON = withObject "Error" $ \ v -> do + eTitle <- v .:? "title" + eCode <- v .:? "code" + eMessage <- v .:? "message" + + return Error{..} + +instance ToJSON Error where + toJSON Error{..} = object + [ "title" .= eTitle + , "code" .= eCode + , "message" .= eMessage + ] + +-- | Contents of a 'Collection' 'Item'. +data Datum = Datum + { dName :: Text -- ^ Identifier for this 'Datum'. + , dValue :: Maybe Text + , dPrompt :: Maybe Text -- ^ Suggested user prompt. + } deriving (Eq, Show) + +instance FromJSON Datum where + parseJSON = withObject "Datum" $ \ v -> do + dName <- v .: "name" + dValue <- v .:? "value" + dPrompt <- v .:? "prompt" + + return Datum{..} + +instance ToJSON Datum where + toJSON Datum{..} = object + [ "name" .= dName + , "value" .= dValue + , "prompt" .= dPrompt + ] + +-- * Type Conversion + +-- | A type that can be converted from 'Collection'. +class FromCollection a where + fromCollection :: Collection -> a + +-- | A type that can be converted to 'Collection'. +class ToCollection a where + toCollection :: a -> Collection diff --git a/src/Internal/Network/URI.hs b/src/Internal/Network/URI.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Network/URI.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Internal.Network.URI +Description : URI Helper Functions +Copyright : (c) Alex Brandt, 2017 +License : MIT + +URI utility functions that don't belong anywhere else. +-} +module Internal.Network.URI where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) +import Data.Text (unpack) +import Network.URI (parseURIReference, URI) + +instance FromJSON URI where + parseJSON = withText "URI" $ \ v -> + case parseURIReference (unpack v) of + Nothing -> fail "invalid URI" + Just x -> return x + +instance ToJSON URI where + toJSON = toJSON . show diff --git a/test/Data/CollectionJSON/Tests.hs b/test/Data/CollectionJSON/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Data/CollectionJSON/Tests.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Data.CollectionJSON.Tests +Description : Tests for Data.CollectionJSON +Copyright : (c) Alex Brandt, 2017 +License : MIT + +Tests for "Data.CollectionJSON". +-} +module Data.CollectionJSON.Tests (runTests) where + +import Data.Aeson (decode, encode) +import Data.Maybe (fromJust) +import Data.Text (pack) +import Test.Invariant ((<=>)) +import Test.QuickCheck (Arbitrary (arbitrary), quickCheckAll) +import Test.QuickCheck.Instances () + +import Data.CollectionJSON +import Internal.Network.URI.Tests () + +prop_id_c :: Collection -> Bool +prop_id_c = fromJust . decode . encode <=> id + +prop_id_l :: Link -> Bool +prop_id_l = fromJust . decode . encode <=> id + +prop_id_i :: Item -> Bool +prop_id_i = fromJust . decode . encode <=> id + +prop_id_q :: Query -> Bool +prop_id_q = fromJust . decode . encode <=> id + +prop_id_t :: Template -> Bool +prop_id_t = fromJust . decode . encode <=> id + +prop_id_e :: Error -> Bool +prop_id_e = fromJust . decode . encode <=> id + +prop_id_d :: Datum -> Bool +prop_id_d = fromJust . decode . encode <=> id + +return [] +runTests :: IO Bool +runTests = $quickCheckAll + +instance Arbitrary Collection where + arbitrary = + do let cVersion = pack "1.0" + cHref <- arbitrary + cLinks <- arbitrary + cItems <- arbitrary + cQueries <- arbitrary + cTemplate <- arbitrary + cError <- arbitrary + + return Collection{..} + +instance Arbitrary Link where + arbitrary = + do lHref <- arbitrary + lRel <- arbitrary + lName <- arbitrary + lRender <- arbitrary + lPrompt <- arbitrary + + return Link{..} + +instance Arbitrary Item where + arbitrary = + do iHref <- arbitrary + iData <- arbitrary + iLinks <- arbitrary + + return Item{..} + +instance Arbitrary Query where + arbitrary = + do qHref <- arbitrary + qRel <- arbitrary + qName <- arbitrary + qPrompt <- arbitrary + qData <- arbitrary + + return Query{..} + +instance Arbitrary Template where + arbitrary = + do tData <- arbitrary + + return Template{..} + +instance Arbitrary Error where + arbitrary = + do eTitle <- arbitrary + eCode <- arbitrary + eMessage <- arbitrary + + return Error{..} + +instance Arbitrary Datum where + arbitrary = + do dName <- arbitrary + dValue <- arbitrary + dPrompt <- arbitrary + + return Datum{..} diff --git a/test/Internal/Network/URI/Tests.hs b/test/Internal/Network/URI/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Internal/Network/URI/Tests.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE RecordWildCards #-} + +{-| +Module : Internal.Network.URI.Tests +Description : URI Arbitrary Instances +Copyright : (c) Alex Brandt, 2017 +License : MIT + +A collection of 'Arbitrary' instances for 'URI'. +-} +module Internal.Network.URI.Tests where + +import Data.Maybe (fromJust) +import Network.URI (parseURIReference, URI) +import Test.QuickCheck (Arbitrary (arbitrary), elements) + +-- | Not a general implementation. +-- +-- This implementation just returns a random URI from the +-- @application/vnd.collection+json@ examples. +instance Arbitrary URI where + arbitrary = fromJust . parseURIReference <$> elements uris + where uris = [ "http://example.org/friends/" + , "http://example.org/friends/" + , "http://example.org/friends/rss" + , "http://example.org/friends/jdoe" + , "http://examples.org/blogs/jdoe" + , "http://examples.org/images/jdoe" + , "http://example.org/friends/msmith" + , "http://examples.org/blogs/msmith" + , "http://examples.org/images/msmith" + , "http://example.org/friends/rwilliams" + , "http://examples.org/blogs/rwilliams" + , "http://examples.org/images/rwilliams" + , "http://example.org/friends/search" + , "http://example.org/friends/" + , "http://example.org/friends/rss" + , "http://example.org/friends/?queries" + , "http://example.org/friends/?template" + , "http://example.org/friends/jdoe" + , "http://examples.org/blogs/jdoe" + , "http://examples.org/images/jdoe" + , "http://example.org/friends/" + , "http://example.org/friends/search" + , "http://example.org/friends/" + , "http://example.org/friends/" + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,17 @@ +{-| +Module : Main +Copyright : (c) Alex Brandt, 2017 +License : MIT + +"Main" Module for collection-json property tests. +-} +module Main where + +import System.Exit (exitFailure, exitSuccess) + +import qualified Data.CollectionJSON.Tests + +main :: IO () +main = + do success <- and <$> sequence [ Data.CollectionJSON.Tests.runTests ] + if success then exitSuccess else exitFailure