digestive-functors-aeson 1.0.2 → 1.1
raw patch · 5 files changed
+92/−25 lines, 5 filesdep +bytestringdep +vectordep ~aeson-lensdep ~digestive-functorsdep ~digestive-functors-aesonsetup-changed
Dependencies added: bytestring, vector
Dependency ranges changed: aeson-lens, digestive-functors, digestive-functors-aeson
Files
- Setup.hs +0/−2
- Setup.lhs +7/−0
- digestive-functors-aeson.cabal +8/−6
- src/Text/Digestive/Aeson.hs +11/−3
- test/Tests.hs +66/−14
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
digestive-functors-aeson.cabal view
@@ -1,6 +1,6 @@ name: digestive-functors-aeson category: Web, JSON-version: 1.0.2+version: 1.1 license: GPL-3 license-file: LICENSE author: Oliver Charles@@ -27,12 +27,13 @@ Text.Digestive.Aeson build-depends: aeson >= 0.6,- aeson-lens >= 0.4.1.0,+ aeson-lens >= 0.5.0.0, base >= 4.5 && < 4.7,- digestive-functors >= 0.5 && < 0.6,+ digestive-functors >= 0.6, lens >= 3.0, safe >= 0.3.3,- text >= 0.11+ text >= 0.11,+ vector >= 0.10 hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans -fno-warn-unused-do-bind@@ -44,8 +45,9 @@ build-depends: aeson, base >= 4.5 && < 4.7,- digestive-functors >= 0.5,- digestive-functors-aeson ==1.0.2,+ bytestring >= 0.9,+ digestive-functors >= 0.6,+ digestive-functors-aeson ==1.1, HUnit >= 1.2, mtl, test-framework >= 0.6,
src/Text/Digestive/Aeson.hs view
@@ -12,8 +12,10 @@ import Data.Maybe (fromMaybe) import Safe import Text.Digestive+import Text.Digestive.Form.List (unparseIndices) import qualified Data.Text as T+import qualified Data.Vector as V -------------------------------------------------------------------------------- {-| Given a JSON document and a form, attempt to use the JSON document to@@ -39,8 +41,12 @@ -> m (View v, Maybe a) digestJSON f json = postForm "" f (jsonEnv json) where jsonEnv :: Monad m => Value -> Env m- jsonEnv v p = return . maybe [] jsonToText $- Just v ^. pathToLens (filter (not . T.null) p)+ jsonEnv v p+ | head (reverse p) == "indices" = case Just v ^. pathToLens (init p) of+ Just (Array a) -> return $ return . TextInput $+ unparseIndices [0 .. (pred $ V.length a)]+ _ -> return [ TextInput "" ]+ | otherwise = return . maybe [] jsonToText $ Just v ^. pathToLens p jsonToText (String s) = [TextInput s] jsonToText (Bool b) = showPack b@@ -75,6 +81,8 @@ -> (Maybe Value -> f (Maybe Value)) -> Maybe Value -> f (Maybe Value)-pathToLens = foldl (.) id . map pathElem+pathToLens [p] = key p+pathToLens ps = let ps' = filter (not . T.null) ps+ in key (head ps') . (foldl (.) id . map pathElem $ tail ps') where pathElem p = maybe (key p) nth (readMay $ T.unpack p)
test/Tests.hs view
@@ -4,37 +4,38 @@ import Control.Applicative import Control.Monad.Identity (runIdentity) import Data.Aeson (decode)+import Data.ByteString.Lazy.Char8 () import Data.Text import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=))-import Text.Digestive (Form, (.:), check, text)+import Text.Digestive (Form, (.:), check, text, listOf) import Text.Digestive.Aeson (digestJSON, jsonErrors) import qualified Data.Text as T ---------------------------------------------------------------------------------tests :: [Test]-tests = [ testPokemon- ]+data Pokemon = Pokemon { pokemonName :: Text }+ deriving (Eq, Show) ----------------------------------------------------------------------------------data Pokemon = Pokemon { pokemonName :: Text }+pokeForm :: Monad m => Form Text m Pokemon+pokeForm = Pokemon <$> "name" .: nonEmptyText+ where+ nonEmptyText = check "Name cannot be empty" (not . T.null) $+ text Nothing+++data Pokedex = Pokedex [Pokemon] deriving (Eq, Show) +-------------------------------------------------------------------------------- testPokemon :: Test testPokemon = testGroup "Pokemon tests" [ testPokemonOk, testPokemonInvalid ] where- pokeForm :: Monad m => Form Text m Pokemon- pokeForm = Pokemon <$> "name" .: nonEmptyText- where- nonEmptyText = check "Name cannot be empty" (not . T.null) $- text Nothing- testPokemonOk = testCase "Submit pokeForm with valid data" $- Just expected @?= (runIdentity $ snd <$> digestJSON pokeForm json)+ (runIdentity $ snd <$> digestJSON pokeForm json) @?= Just expected where (Just json) = decode "{\"name\":\"Pikachu\"}" expected = Pokemon { pokemonName = "Pikachu" }@@ -52,5 +53,56 @@ --------------------------------------------------------------------------------+testPokedex :: Test+testPokedex = testGroup "Pokedex tests"+ [ testPokedexSingle+ , testPokedexMany+ , testPokedexFailHead+ , testPokedexFailLater+ ]+ where+ pokedexForm :: Monad m => Form Text m Pokedex+ pokedexForm = Pokedex <$> "pokemon" .: listOf (const pokeForm) Nothing++ testPokedexSingle = testCase "Valid pokedex with one pokemon" $+ (runIdentity $ snd <$> digestJSON pokedexForm json) @?= Just expected+ where+ (Just json) = decode "{\"pokemon\":[{\"name\": \"Pikachu\"}]}"+ expected = Pokedex [Pokemon { pokemonName = "Pikachu" }]++ testPokedexMany = testCase "Valid pokedex with many pokemon" $+ (runIdentity $ snd <$> digestJSON pokedexForm json) @?= Just expected+ where+ (Just json) = decode "{\"pokemon\":[{\"name\": \"Pikachu\"}, {\"name\":\"Clefable\"}, {\"name\":\"Gengar\"}]}"+ expected = Pokedex [ Pokemon { pokemonName = "Pikachu" }+ , Pokemon { pokemonName = "Clefable" }+ , Pokemon { pokemonName = "Gengar" }+ ]++ testPokedexFailHead =+ let (v, r) = runIdentity $ digestJSON pokedexForm json+ in testGroup "Submit pokedex with a single invalid item"+ [ testCase "Failed validation" $ r @?= Nothing+ , testCase "jsonErrors shows correct errors" $ jsonErrors v @?= errors+ ]+ where+ (Just json) = decode "{\"pokemon\":[{\"name\":\"\"}]}"+ (Just errors) = decode "{\"pokemon\":[{\"name\":\"Name cannot be empty\"}]}"++ testPokedexFailLater =+ let (v, r) = runIdentity $ digestJSON pokedexForm json+ in testGroup "Submit pokedex with a later invalid item"+ [ testCase "Failed validation" $ r @?= Nothing+ , testCase "jsonErrors shows correct errors" $ jsonErrors v @?= errors+ ]+ where+ (Just json) = decode "{\"pokemon\":[{\"name\": \"Pikachu\"}, {\"name\":\"\"}]}"+ (Just errors) = decode "{\"pokemon\":[null, {\"name\":\"Name cannot be empty\"}]}"+++-------------------------------------------------------------------------------- main :: IO ()-main = defaultMain tests+main = defaultMain [ testPokemon+ , testPokedex+ ]+