aeson-decode (empty) → 0.1.0.0
raw patch · 6 files changed
+495/−0 lines, 6 filesdep +aesondep +aeson-decodedep +aeson-qqsetup-changed
Dependencies added: aeson, aeson-decode, aeson-qq, base, containers, data-default, hedgehog, text, time, unordered-containers, vector
Files
- Setup.hs +2/−0
- aeson-decode.cabal +64/−0
- license.txt +13/−0
- readme.md +5/−0
- src/AesonDecode.hs +244/−0
- test/hedgehog.hs +167/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-decode.cabal view
@@ -0,0 +1,64 @@+name: aeson-decode+version: 0.1.0.0+category: JSON++synopsis: Easy functions for converting from Aeson.Value++description: A small and simple library for interpreting JSON after it has+ been parsed by @aeson@ into the @Value@ type.+ .+ Decoding failures do not come with any error messages; results+ are all @Maybe@.++homepage: https://github.com/typeclasses/aeson-decode+bug-reports: https://github.com/typeclasses/aeson-decode/issues++author: Chris Martin+maintainer: Chris Martin, Julie Moronuki++copyright: 2018 Typeclass Consulting, LLC+license: Apache-2.0+license-file: license.txt++build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ readme.md++source-repository head+ type: git+ location: https://github.com/typeclasses/aeson-decode++library+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src++ exposed-modules:+ AesonDecode++ build-depends:+ aeson+ , base >=4.7 && <5+ , containers+ , data-default+ , text+ , unordered-containers+ , vector++test-suite hedgehog+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: hedgehog.hs+ hs-source-dirs: test+ ghc-options: -Wall -threaded++ build-depends:+ aeson-decode+ , aeson-qq+ , base >=4.9 && <4.12+ , containers+ , hedgehog+ , text+ , time
+ license.txt view
@@ -0,0 +1,13 @@+Copyright 2018 Typeclass Consulting, LLC++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ readme.md view
@@ -0,0 +1,5 @@+# aeson-decode++A small and simple library for interpreting JSON after it has been parsed by `aeson` into the `Value` type.++Decoding failures do not come with any error messages; results are all `Maybe`.
+ src/AesonDecode.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++module AesonDecode+ (+ -- * Decoder+ Decoder (..), defaultDecoder, is+ -- * Path+ , Path (..), here, at, only+ -- * Text+ , text, textIs+ -- * Integer+ , integer, integerIs+ -- * Boolean+ , bool, boolIs, true, false+ -- * List+ , listOf+ -- * Vector+ , vectorOf+ -- * Ord map+ , ordMapOf+ -- * Hash map+ , hashMapOf+ -- * Null+ , null++ ) where++-- aeson+import Data.Aeson (FromJSON, Value (..))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson++-- base+import Control.Applicative (Alternative (..))+import Control.Monad (guard, (>=>))+import Data.Foldable (toList)+import Data.Semigroup (Semigroup (..))+import Data.String (IsString (..))+import Prelude hiding (null)++-- containers+import Data.Map (Map)+import qualified Data.Map as Map++-- data-default+import qualified Data.Default as Def++-- text+import Data.Text (Text)+import qualified Data.Text as Text++-- unordered-containers+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++-- vector+import Data.Vector (Vector)+++--------------------------------------------------------------------------------+-- Decoder+--------------------------------------------------------------------------------++newtype Decoder a = Decoder { decodeMaybe :: Value -> Maybe a }++instance Functor Decoder+ where+ fmap f (Decoder d) = Decoder $ (fmap . fmap) f d++instance Applicative Decoder+ where+ pure x = Decoder $ (pure . pure) x+ Decoder ff <*> Decoder fx = Decoder $ \v ->+ ff v >>= \f -> fx v >>= \x -> Just (f x)++instance Monad Decoder+ where+ Decoder f >>= df = Decoder $ \v ->+ f v >>= \x -> let Decoder g = df x in g v++instance Alternative Decoder+ where+ empty = Decoder $ const Nothing+ Decoder a <|> Decoder b = Decoder $ \v -> a v <|> b v++instance FromJSON a => Def.Default (Decoder a)+ where+ def = defaultDecoder++defaultDecoder :: FromJSON a => Decoder a+defaultDecoder = Decoder $ \v -> Aeson.parseMaybe Aeson.parseJSON v++-- | @'is' x@ produces @'Just' ()@ if the JSON value decodes to @x@,+-- or 'Nothing' otherwise.++is :: (Eq a, FromJSON a) => a -> Decoder ()+is x = defaultDecoder >>= \y -> guard (x == y)+++--------------------------------------------------------------------------------+-- Path+--------------------------------------------------------------------------------++newtype Path = Path { getAt :: Value -> Maybe Value }++instance Semigroup Path+ where+ Path a <> Path b = Path (a >=> b)++instance Monoid Path+ where+ mappend = (<>)+ mempty = here++instance IsString Path+ where+ fromString x = Path $ \case+ Object m -> HashMap.lookup (Text.pack x) m+ _ -> Nothing++-- | The empty path.++here :: Path+here = Path Just++at :: Path -> Decoder a -> Decoder a+at (Path f1) (Decoder f2) = Decoder (f1 >=> f2)++-- | Selects the only element from an array of length 1.++only :: Path+only = Path $ \case+ Array (toList -> [x]) -> Just x+ _ -> Nothing+++--------------------------------------------------------------------------------+-- Text+--------------------------------------------------------------------------------++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the value @null@,+-- or 'Nothing' otherwise.++null :: Decoder ()+null = Decoder $ \case+ Null -> Just ()+ _ -> Nothing+++--------------------------------------------------------------------------------+-- Text+--------------------------------------------------------------------------------++-- | Decodes a JSON string as 'Text'.++text :: Decoder Text+text = defaultDecoder++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the string @x@,+-- or 'Nothing' otherwise.++textIs :: Text -> Decoder ()+textIs = is+++--------------------------------------------------------------------------------+-- Integer+--------------------------------------------------------------------------------++-- | Decodes a JSON number as an 'Integer'.++integer :: Decoder Integer+integer = defaultDecoder++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the integer @x@,+-- or 'Nothing' otherwise.++integerIs :: Integer -> Decoder ()+integerIs = is+++--------------------------------------------------------------------------------+-- Boolean+--------------------------------------------------------------------------------++-- | Decodes a JSON boolean as a 'Bool'.++bool :: Decoder Bool+bool = defaultDecoder++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the boolean @x@,+-- or 'Nothing' otherwise.++boolIs :: Bool -> Decoder ()+boolIs = is++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the value @true@,+-- or 'Nothing' otherwise.++true :: Decoder ()+true = is True++-- | @'is' x@ produces @'Just' ()@ if the JSON value is the value @false@,+-- or 'Nothing' otherwise.++false :: Decoder ()+false = is False+++--------------------------------------------------------------------------------+-- Vector+--------------------------------------------------------------------------------++vectorOf :: Decoder a -> Decoder (Vector a)+vectorOf d = Decoder $ \case+ Array xs -> traverse (decodeMaybe d) xs+ _ -> Nothing+++--------------------------------------------------------------------------------+-- List+--------------------------------------------------------------------------------++listOf :: Decoder a -> Decoder [a]+listOf d = toList <$> vectorOf d+++--------------------------------------------------------------------------------+-- Hash map+--------------------------------------------------------------------------------++hashMapOf :: Decoder a -> Decoder (HashMap Text a)+hashMapOf d = Decoder $ \case+ Object xs -> traverse (decodeMaybe d) xs+ _ -> Nothing+++--------------------------------------------------------------------------------+-- Ord map+--------------------------------------------------------------------------------++ordMapOf :: Decoder a -> Decoder (Map Text a)+ordMapOf d = Map.fromList . HashMap.toList <$> hashMapOf d
+ test/hedgehog.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++import AesonDecode++-- aeson-qq+import Data.Aeson.QQ (aesonQQ)++-- base+import Control.Applicative (Alternative (..), optional)+import Control.Monad (when)+import Data.Semigroup ((<>))+import System.Exit (exitFailure)+import System.IO (hSetEncoding, stderr, stdout, utf8)++-- hedgehog+import Hedgehog++-- text+import Data.Text (Text)++-- time+import Data.Time.Clock.POSIX (POSIXTime)++(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as+infixl 1 <&>++main :: IO ()+main = do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ ok <- checkParallel $$(discover)+ when (not ok) exitFailure++prop_either :: Property+prop_either = withTests 1 $ property $ do+ let+ d :: Decoder (Either Text Integer) = (text <&> Left) <|> (integer <&> Right)++ decodeMaybe d [aesonQQ|"x"|] === Just (Left "x")+ decodeMaybe d [aesonQQ|5|] === Just (Right 5)+ decodeMaybe d [aesonQQ|null|] === Nothing++prop_eitherTagged :: Property+prop_eitherTagged = withTests 1 $ property $ do+ let+ d :: Decoder (Either Integer Integer) =+ (at "type" (textIs "x") *> at "value" integer <&> Left) <|>+ (at "type" (textIs "y") *> at "value" integer <&> Right)++ decodeMaybe d [aesonQQ|{"type": "x", "value": 1}|] === Just (Left 1)+ decodeMaybe d [aesonQQ|{"type": "y", "value": 2}|] === Just (Right 2)+ decodeMaybe d [aesonQQ|{"type": "z", "value": 3}|] === Nothing++data Asset+ = Asset'Image Text+ | Asset'Video Text Text+ deriving (Eq, Show)++prop_asset :: Property+prop_asset = withTests 1 $ property $ do+ let+ d'image, d'video :: Decoder Asset+ d :: Decoder [Asset]++ d'image = do+ at "type" (textIs "image")+ Asset'Image <$> at "url" text++ d'video = do+ at "type" (textIs "video")+ Asset'Video <$> at "url" text+ <*> at "poster" text++ d = at "assets" $ listOf (d'image <|> d'video)++ json =+ [aesonQQ|+ {+ "assets": [+ {+ "type": "video",+ "url": "https://subscriber.typeclasses.com/video/js-operators-2/dash/manifest.mpd",+ "poster": "/_/static/operators-video.jpg"+ },+ {+ "type": "image",+ "url": "/_/static/acme.jpg"+ }+ ]+ }+ |]++ decodeMaybe d json === Just+ [ Asset'Video "https://subscriber.typeclasses.com/video/js-operators-2/dash/manifest.mpd"+ "/_/static/operators-video.jpg"+ , Asset'Image "/_/static/acme.jpg"+ ]++newtype Resource = Resource Text+ deriving (Eq, Show)++data StartTime = StartImmediately | StartTime POSIXTime+ deriving (Eq, Show)++newtype EndTime = EndTime POSIXTime+ deriving (Eq, Show)++data IpAddress = AnyIp | IpAddress Text+ deriving (Eq, Show)++data Policy =+ Policy+ { policyResource :: Resource+ , policyStart :: StartTime+ , policyEnd :: EndTime+ , policyIpAddress :: IpAddress+ }+ deriving (Eq, Show)++prop_cloudFrontPolicy :: Property+prop_cloudFrontPolicy = withTests 1 $ property $ do+ let+ json =+ [aesonQQ|+ {+ "Statement": [+ {+ "Resource": "http://d111111abcdef8.cloudfront.net/game_download.zip",+ "Condition": {+ "IpAddress": {"AWS:SourceIp": "192.0.2.0/24"},+ "DateLessThan": {"AWS:EpochTime": 1357034400}+ }+ }+ ]+ }+ |]++ d'time :: Decoder POSIXTime = at "AWS:EpochTime" integer <&> fromInteger++ d :: Decoder Policy =+ at ("Statement" <> only) $ do++ res <- Resource <$> at "Resource" text++ start <- maybe StartImmediately StartTime <$>+ (optional $ at ("Condition" <> "DateGreaterThan") d'time)++ end <- EndTime <$> at ("Condition" <> "DateLessThan") d'time++ ip <- maybe AnyIp IpAddress <$>+ (optional $ at ("Condition" <> "IpAddress")+ (at "AWS:SourceIp" text))++ pure $ Policy res start end ip++ p =+ Policy+ (Resource "http://d111111abcdef8.cloudfront.net/game_download.zip")+ StartImmediately+ (EndTime 1357034400)+ (IpAddress "192.0.2.0/24")++ decodeMaybe d json === Just p