diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Samuel Protas (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Samuel Protas nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# composable-associations-aeson + +[![Build Status](https://travis-ci.org/SamProtas/composable-associations.svg?branch=master)](https://travis-ci.org/SamProtas/composable-associations) +[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) +[![Hackage](https://img.shields.io/hackage/v/composable-associations-aeson.svg)](https://hackage.haskell.org/package/composable-associations-aeson) + +This package re-exports `composable-associations` and implements serialization/deserialization for JSON (via Aeson). + +Documentation available on Hackage. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/composable-associations-aeson.cabal b/composable-associations-aeson.cabal new file mode 100644 --- /dev/null +++ b/composable-associations-aeson.cabal @@ -0,0 +1,53 @@ +name: composable-associations-aeson +version: 0.1.0.0 +synopsis: Aeson ToJSON/FromJSON implementation for the types of composable-associations +description: + This library provides the orphan instances implementation JSON serialization for the types in + composiable-associations, as well as any other Aeson-specific implementation details. +homepage: https://github.com/SamProtas/composable-associations#readme +license: BSD3 +license-file: LICENSE +author: Sam Protas +maintainer: sam.protas@gmail.com +copyright: 2017 Samuel Protas +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.ComposableAssociation.Aeson + build-depends: base >= 4.7 && < 5 + , composable-associations + , text + , unordered-containers + , aeson + default-language: Haskell2010 + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , aeson + , composable-associations-aeson + , tasty + , tasty-quickcheck + , tasty-hunit + , bytestring + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: doctest + main-is: Main.hs + build-depends: base >= 4.7 && < 5 + , composable-associations-aeson + , doctest >= 0.9.12 + , bytestring + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/SamProtas/composable-associations/tree/master/composable-associations-aeson diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ "-XOverloadedStrings", "-XDeriveGeneric", "-XDataKinds", "-XTypeOperators", + "src/Data/ComposableAssociation/Aeson.hs" ] diff --git a/src/Data/ComposableAssociation/Aeson.hs b/src/Data/ComposableAssociation/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/ComposableAssociation/Aeson.hs @@ -0,0 +1,151 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +module Data.ComposableAssociation.Aeson + ( -- * Quickstart + -- $quickstart + + -- * Re-Exported Core Types\/Functions\/Lens + module Data.ComposableAssociation + + -- * Invalid JSON Encoding Exception + , JsonObjectEncodingException (..) + ) where + + +import GHC.TypeLits +import Data.Proxy +import Data.Typeable +import Control.Exception + +import qualified Data.Text as T +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Lazy as HashMap + +import Data.ComposableAssociation + + +-- | More specific version of @ObjectEncodingException@ to only Aeson encoding issues. +newtype JsonObjectEncodingException = JsonObjectEncodingException Value deriving (Show, Typeable) +instance Exception JsonObjectEncodingException where + toException = toException . ObjectEncodingException + fromException x = do + ObjectEncodingException e <- fromException x + cast e + + + +instance (ToJSON obj, KnownSymbol key) => ToJSON (Association key obj) where + toJSON (Association key obj) = object [keyName .= toJSON obj] + where keyName = T.pack $ symbolVal key + +instance (FromJSON obj, KnownSymbol key) => FromJSON (Association key obj) where + parseJSON = withObject "Association" $ \v' -> Association proxy <$> (v' .:? key .!= Null >>= parseJSON) + where proxy = Proxy :: Proxy key + key = T.pack $ symbolVal proxy + + +-- | Throws a @JsonObjectEncodingException@ if the base value isn't encoded as a JSON object +instance (ToJSON base, ToJSON obj, KnownSymbol key) => ToJSON (base :<> Association key obj) where + toJSON (base :<> Association key obj) = Object $ HashMap.insert keyName objJson baseJsonMap + where keyName = T.pack $ symbolVal key + baseJsonMap = case toJSON base of (Object jsonObjVal) -> jsonObjVal + notAnObject -> throw $ JsonObjectEncodingException notAnObject + objJson = toJSON obj + +instance (FromJSON base, FromJSON obj, KnownSymbol key) => FromJSON (base :<> Association key obj) where + parseJSON = withObject "base :<> assoc" $ \v' -> (:<>) <$> + parseJSON (Object $ HashMap.delete key v') <*> + fmap (Association proxy) (v' .:? key .!= Null >>= parseJSON) + where proxy = Proxy :: Proxy key + key = T.pack $ symbolVal proxy + +-- $setup +-- >>> import GHC.Generics + +-- $quickstart +-- Assume some example data below: +-- +-- >>> data ExampleUser = ExampleUser { name :: String, age :: Int } deriving (Show, Eq, Generic) +-- >>> instance ToJSON ExampleUser +-- >>> instance FromJSON ExampleUser +-- +-- >>> let alice = ExampleUser { name = "Alice", age = 25 } +-- >>> encode alice +-- "{\"age\":25,\"name\":\"Alice\"}" +-- +-- >>> let messageIds = [102, 305, 410] +-- >>> encode messageIds +-- "[102,305,410]" +-- +-- Let's add those messages to the user JSON object without bothering to define another type. +-- +-- >>> let aliceWithMessages = alice :<> (asValue messageIds :: Association "messages" [Int]) +-- >>> encode aliceWithMessages +-- "{\"age\":25,\"name\":\"Alice\",\"messages\":[102,305,410]}" +-- +-- Since "messages" is type (not value) information, we can decode as well. +-- +-- >>> decode "{\"age\":25,\"name\":\"Alice\",\"messages\":[102,305,410]}" :: Maybe (ExampleUser :<> Association "messages" [Int]) +-- Just (ExampleUser {name = "Alice", age = 25} :<> Association Proxy [102,305,410]) +-- +-- In the above, "Proxy" is the value of type "messages". +-- +-- @Association Proxy a@ has a stand-alone encoding/decoding too +-- +-- >>> encode $ Association (Proxy :: Proxy "one-off-key") [1, 2, 3] +-- "{\"one-off-key\":[1,2,3]}" +-- +-- >>> decode "{\"one-off-key\":[1,2,3]}" :: Maybe (Association "one-off-key" [Int]) +-- Just (Association Proxy [1,2,3]) +-- +-- These are chainable too! +-- +-- >>> :{ +-- let manyAssociations :: ExampleUser :<> Association "numbers" [Int] :<> Association "bools" [Bool] +-- manyAssociations = alice :<> asValue [1,2,3] :<> asValue [True, False] +-- in encode manyAssociations +-- :} +-- "{\"age\":25,\"name\":\"Alice\",\"bools\":[true,false],\"numbers\":[1,2,3]}" +-- +-- You can build JSON objects from just values! +-- +-- >>> :{ +-- let allValues :: Association "a-bool" Bool :<> Association "a-string" String :<> Association "an-alice" ExampleUser +-- allValues = asValue True :<> asValue "Hello" :<> asValue alice +-- in encode allValues +-- :} +-- "{\"a-bool\":true,\"an-alice\":{\"age\":25,\"name\":\"Alice\"},\"a-string\":\"Hello\"}" +-- +-- Decoding fails if you specify a non-existent key (standard Aeson behavior for failed decoding). +-- +-- >>> decode "{\"one-off-key\":[1,2,3]}" :: Maybe (Association "wrong-key" [Int]) +-- Nothing +-- +-- If you try encoding with a "base" value that is itself not encoded to a JSON object you'll get a runtime exception. +-- +-- >>> encode $ True :<> (asValue [1,2,3] :: Association "this-ends-poorly" [Int]) +-- "*** Exception: JsonObjectEncodingException (Bool True) +-- >>> encode $ [1,2,3] :<> (asValue "will not work" :: Association "still" String) +-- "*** Exception: JsonObjectEncodingException (Array [Number 1.0,Number 2.0,Number 3.0]) +-- +-- GHC Extension Note: +-- +-- * You'll need @DataKinds@ for this library (type level literals, no getting around this). +-- +-- * You'll probably want @TypeOperators@ as well (although you can use @WithAssociation@ instead of @:<>@ to avoid this). +-- +-- * You can avoid @PolyKinds@ if you use @asValue True :: Association "key" Bool@ or type inference instead of +-- @Association (Proxy :: Proxy "key") True@. + + + + + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import GHC.Generics +import Data.Maybe +import Data.Either + +import Data.Proxy +import Data.Aeson +import Data.ByteString.Lazy +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit +import Control.Exception + +import Data.ComposableAssociation.Aeson + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [properties, unitTests] + +properties :: TestTree +properties = testGroup "Properties" + [ testProperty "Just (x :: Association \"Some Key\" TestUser) == decode . encode x" $ \user -> + let userAsKey = asValue user :: Association "user" TestUser + in Just userAsKey == (decode . encode) userAsKey + , testProperty "Just (x :: TestUser :<> Association \"Some Key\" [Int]) == decode . encode x" $ + \(user :: TestUser, messageIds) -> + let userWithMessages = user :<> (asValue messageIds :: Association "message_ids" [Int]) + in Just userWithMessages == (decode . encode) userWithMessages + , testProperty "Association encode/decode order doesn't matter" $ \(ids, results) -> + let idsAndMessages = asValue ids :<> asValue results :: Association "ids" [Int] :<> Association "results" [Bool] + in isJust ((decode . encode) idsAndMessages :: Maybe (Association "results" [Bool] :<> Association "ids" [Int])) + , testProperty "Nested Association work" $ \(user :: TestUser, messageIds, results) -> + let userWithMessagesAndResults :: TestUser :<> Association "messages" [Int] :<> Association "results" [Bool] + userWithMessagesAndResults = user :<> asValue messageIds :<> asValue results + in Just userWithMessagesAndResults == (decode . encode) userWithMessagesAndResults ] + +unitTests :: TestTree +unitTests = testGroup "Unit Tests" + [ testCase "Association ToJSON Instance" $ encode testUser1FriendsAssoc @?= "{\"message_ids\":[1,2,3]}" + , testCase "Association FromJSON Instance" $ decode "{\"message_ids\":[1,2,3]}" @?= Just testUser1FriendsAssoc + , testCase ":<> ToJSON" $ + encode (testUser1 :<> testUser1FriendsAssoc) @?= "{\"message_ids\":[1,2,3],\"userId\":1,\"name\":\"Sam\"}" + , testCase ":<> FromJSON" $ + decode "{\"message_ids\":[1,2,3],\"userId\":1,\"name\":\"Sam\"}" @?= Just (testUser1 :<> testUser1FriendsAssoc) + , testCase ":<> Invalid Encoding1" $ do + res <- try (evaluate $ encode ([1 :: Int] :<> testUser1FriendsAssoc)) :: IO (Either JsonObjectEncodingException ByteString) + assertBool "Non-Json-Obj base throws JsonObjectEncodingException" (isLeft res) + , testCase ":<> Invalid Encoding2" $ do + res <- try (evaluate $ encode ([1 :: Int] :<> testUser1FriendsAssoc)) :: IO (Either ObjectEncodingException ByteString) + assertBool "Non-Json-Obj base throws ObjectEncodingException" (isLeft res) + , testCase "Encode Association Null" $ encode testMissingMessages @?= "{\"message_ids\":null}" + , testCase "Decode Association Null" $ decode "{\"message_ids\":null}" @?= Just testMissingMessages + , testCase "Decode Association Missing Key" $ decode "{}" @?= Just testMissingMessages + , testCase "Encode :<> Missing Association" $ + encode (testUser1 :<> testMissingMessages) @?= "{\"message_ids\":null,\"userId\":1,\"name\":\"Sam\"}" + , testCase "Decode :<> Missing Association" $ + decode "{\"message_ids\":null,\"userId\":1,\"name\":\"Sam\"}" @?= Just (testUser1 :<> testMissingMessages) + , testCase "Decode :<> Missing Association Key" $ + decode "{\"userId\":1,\"name\":\"Sam\"}" @?= Just (testUser1 :<> testMissingMessages)] + + +-- Test Data: + +data TestUser = TestUser { userId :: Int + , name :: String } + deriving (Show, Eq, Generic) +instance ToJSON TestUser +instance FromJSON TestUser + +testUser1 :: TestUser +testUser1 = TestUser { userId = 1, name = "Sam" } + +testUser1FriendsAssoc :: Association "message_ids" [Int] +testUser1FriendsAssoc = Association Proxy [1, 2, 3] + +testAssoc :: TestUser :<> Association "message_ids" [Int] :<> Association "results" [Bool] +testAssoc = testUser1 :<> testUser1FriendsAssoc :<> Association Proxy [True, False, True] + +testMissingMessages :: Association "message_ids" (Maybe [Int]) +testMissingMessages = asValue Nothing + + +instance Arbitrary TestUser where + arbitrary = TestUser <$> arbitrary <*> arbitrary