diff --git a/digestive-functors.cabal b/digestive-functors.cabal --- a/digestive-functors.cabal +++ b/digestive-functors.cabal @@ -1,5 +1,5 @@ Name: digestive-functors -Version: 0.6.0.0 +Version: 0.6.0.1 Synopsis: A practical formlet library Description: @@ -68,6 +68,11 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: src tests Main-is: TestSuite.hs + Other-modules: + Text.Digestive.Field.Tests + Text.Digestive.Form.Encoding.Tests + Text.Digestive.Tests.Fixtures + Text.Digestive.View.Tests Ghc-options: -Wall Build-depends: diff --git a/tests/Text/Digestive/Field/Tests.hs b/tests/Text/Digestive/Field/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Field/Tests.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Text.Digestive.Field.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import Text.Digestive.Form.Internal.Field +import Text.Digestive.Types + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Text.Digestive.Field.Tests" + [ testCase "evalField singleton" $ + 9160 @=? evalField undefined undefined (Singleton (9160 :: Int)) + + , testCase "evalField bool post without input" $ + False @=? evalField Post [] (Bool True) + + , testCase "evalField bool post strange input" $ + False @=? evalField Post [TextInput "herp"] (Bool True) + + , testCase "evalField bool post correct input" $ + True @=? evalField Post [TextInput "on"] (Bool True) + + , testCase "evalField bool get" $ + True @=? evalField Get [] (Bool True) + ] diff --git a/tests/Text/Digestive/Form/Encoding/Tests.hs b/tests/Text/Digestive/Form/Encoding/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Form/Encoding/Tests.hs @@ -0,0 +1,34 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Text.Digestive.Form.Encoding.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Identity (Identity(..)) +import Data.Text (Text) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import Text.Digestive.Form +import Text.Digestive.Form.Encoding + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Text.Digestive.Field.Tests" + [ testCase "formEncType url-encoded" $ + UrlEncoded @=? formEncType' ((,) <$> text Nothing <*> bool Nothing) + , testCase "formEncType multipart" $ + MultiPart @=? formEncType' ((,) <$> text Nothing <*> file) + , testCase "formEncType multipart" $ + MultiPart @=? formEncType' ((,) <$> file <*> bool Nothing) + ] + where + formEncType' :: Form Text Identity a -> FormEncType + formEncType' = runIdentity . formEncType diff --git a/tests/Text/Digestive/Tests/Fixtures.hs b/tests/Text/Digestive/Tests/Fixtures.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Tests/Fixtures.hs @@ -0,0 +1,200 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Text.Digestive.Tests.Fixtures + ( -- * Pokemon! + TrainerM + , runTrainerM + , Type (..) + , Pokemon (..) + , pokemonForm + , Ball (..) + , ballForm + , Catch (..) + , catchForm + + -- * Store/product + , Database + , runDatabase + , sector9 + , earthwing + , comet + , Product (..) + , productForm + , Order (..) + , orderForm + , ordersForm + + -- * Various + , floatForm + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Reader (Reader, ask, runReader) +import Data.Text (Text) +import qualified Data.Text as T + + +-------------------------------------------------------------------------------- +import Text.Digestive.Form +import Text.Digestive.Types + + +-------------------------------------------------------------------------------- +-- Maximum level +type TrainerM = Reader Int + + +-------------------------------------------------------------------------------- +-- Default max level: 20 +runTrainerM :: TrainerM a -> a +runTrainerM = flip runReader 20 + + +-------------------------------------------------------------------------------- +data Type = Water | Fire | Leaf + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +typeForm :: Monad m => Form Text m Type +typeForm = choice [(Water, "Water"), (Fire, "Fire"), (Leaf, "Leaf")] Nothing + + +-------------------------------------------------------------------------------- +data Pokemon = Pokemon + { pokemonName :: Text + , pokemonLevel :: Maybe Int + , pokemonType :: Type + , pokemonRare :: Bool + } deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +levelForm :: Form Text TrainerM (Maybe Int) +levelForm = + checkM "This pokemon will not obey you!" checkMaxLevel $ + check "Level should be at least 1" (maybe True (> 1)) $ + optionalStringRead "Cannot parse level" Nothing + where + checkMaxLevel Nothing = return True + checkMaxLevel (Just l) = do + maxLevel <- ask + return $ l <= maxLevel + + +-------------------------------------------------------------------------------- +pokemonForm :: Form Text TrainerM Pokemon +pokemonForm = Pokemon + <$> "name" .: validate isPokemon (text Nothing) + <*> "level" .: levelForm + <*> "type" .: typeForm + <*> "rare" .: bool Nothing + where + definitelyNoPokemon = ["dog", "cat"] + isPokemon name + | name `notElem` definitelyNoPokemon = Success name + | otherwise = + Error $ name `T.append` " is not a pokemon!" + + +-------------------------------------------------------------------------------- +data Ball = Poke | Great | Ultra | Master + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +ballForm :: Monad m => Form Text m Ball +ballForm = choice + [(Poke, "Poke"), (Great, "Great"), (Ultra, "Ultra"), (Master, "Master")] + Nothing + + +-------------------------------------------------------------------------------- +data Catch = Catch + { catchPokemon :: Pokemon + , catchBall :: Ball + } deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +catchForm :: Form Text TrainerM Catch +catchForm = check "You need a better ball" canCatch $ Catch + <$> "pokemon" .: pokemonForm + <*> "ball" .: ballForm + + +-------------------------------------------------------------------------------- +canCatch :: Catch -> Bool +canCatch (Catch (Pokemon _ _ _ False) _) = True +canCatch (Catch (Pokemon _ _ _ True) Ultra) = True +canCatch (Catch (Pokemon _ _ _ True) Master) = True +canCatch _ = False + + +-------------------------------------------------------------------------------- +type Database = Reader [Product] + + +-------------------------------------------------------------------------------- +runDatabase :: Database a -> a +runDatabase = flip runReader [sector9, earthwing, comet] + + +-------------------------------------------------------------------------------- +sector9 :: Product +sector9 = Product "s9_ao" "Sector 9 Agent Orange" + + +-------------------------------------------------------------------------------- +earthwing :: Product +earthwing = Product "ew_br" "Earthwing Belly Racer" + + +-------------------------------------------------------------------------------- +comet :: Product +comet = Product "cm_gs" "Comet Grease Shark" + + +-------------------------------------------------------------------------------- +data Product = Product + { productId :: Text + , productName :: Text + } deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +productForm :: Formlet Text Database Product +productForm def = monadic $ do + products <- ask + return $ choiceWith (map makeChoice products) def + where + makeChoice p = (productId p, (p, productName p)) + + +-------------------------------------------------------------------------------- +data Order = Order + { orderProduct :: Product + , orderQuantity :: Int + } deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +orderForm :: Formlet Text Database Order +orderForm def = Order + <$> "product" .: productForm (orderProduct <$> def) + <*> "quantity" .: stringRead "Can't parse" (orderQuantity <$> def) + + +-------------------------------------------------------------------------------- +ordersForm :: Formlet Text Database (Text, [Order]) +ordersForm def = (,) + <$> "name" .: text (fst <$> def) + -- id is here because of a regression + <*> (id <$> "orders" .: listOf orderForm (snd <$> def)) + + +-------------------------------------------------------------------------------- +floatForm :: Monad m => Form Text m Float +floatForm = "f" .: stringRead "Can't parse float" Nothing diff --git a/tests/Text/Digestive/View/Tests.hs b/tests/Text/Digestive/View/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/View/Tests.hs @@ -0,0 +1,177 @@ +------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Text.Digestive.View.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (SomeException, handle) +import Control.Monad.Identity (runIdentity) +import Data.Text (Text) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), (@?=)) +import qualified Test.HUnit as H + + +-------------------------------------------------------------------------------- +import Text.Digestive.Tests.Fixtures +import Text.Digestive.Types +import Text.Digestive.View + + +-------------------------------------------------------------------------------- +assertError :: Show a => a -> H.Assertion +assertError x = handle (\(_ :: SomeException) -> H.assert True) $ + x `seq` H.assertFailure $ "Should throw an error but gave: " ++ show x + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Text.Digestive.View.Tests" + [ testCase "Simple postForm" $ (@=?) + (Just (Pokemon "charmander" (Just 5) Fire False)) $ + snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv + [ ("f.name", "charmander") + , ("f.level", "5") + , ("f.type", "type.1") + ] + + , testCase "optional unspecified" $ (@=?) + (Just (Pokemon "magmar" Nothing Fire False)) $ + snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv + [ ("f.name", "magmar") + , ("f.type", "type.1") + ] + + , testCase "stringRead float" $ (@=?) + (Just 4.323 :: Maybe Float) $ + snd $ runIdentity $ postForm "f" floatForm $ testEnv + [("f.f", "4.323")] + + , testCase "Failing checkM" $ (@=?) + ["This pokemon will not obey you!"] $ + childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv + [ ("f.name", "charmander") + , ("f.level", "9000") + , ("f.type", "type.1") + ] + + , testCase "Failing validate" $ (@=?) + ["dog is not a pokemon!"] $ + childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv + [("f.name", "dog")] + + , testCase "Simple fieldInputChoice" $ (@=?) + "Leaf" $ + snd $ selection $ fieldInputChoice "type" $ fst $ runTrainerM $ + postForm "f" pokemonForm $ testEnv [("f.type", "type.2")] + + , testCase "Nested postForm" $ (@=?) + (Just (Catch (Pokemon "charmander" (Just 5) Fire False) Ultra)) $ + snd $ runTrainerM $ postForm "f" catchForm $ testEnv + [ ("f.pokemon.name", "charmander") + , ("f.pokemon.level", "5") + , ("f.pokemon.type", "type.1") + , ("f.ball", "ball.2") + ] + + , testCase "subView errors" $ (@=?) + ["Cannot parse level"] $ + errors "level" $ subView "pokemon" $ fst $ runTrainerM $ + postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")] + + , testCase "subView childErrors" $ (@=?) + ["Cannot parse level"] $ + childErrors "" $ subView "pokemon" $ fst $ runTrainerM $ + postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")] + + , testCase "subView input" $ (@=?) + "Leaf" $ + snd $ selection $ fieldInputChoice "type" $ subView "pokemon" $ fst $ + runTrainerM $ postForm "f" catchForm $ testEnv + [ ("f.pokemon.level", "hah.") + , ("f.pokemon.type", "type.2") + ] + + , testCase "subViews length" $ (@=?) + 4 $ + length $ subViews $ runTrainerM $ getForm "f" pokemonForm + + , testCase "subViews after subView length" $ (@=?) + 4 $ + length $ subViews $ subView "pokemon" $ + runTrainerM $ getForm "f" catchForm + + , testCase "Abusing Choice as Text" $ assertError $ + fieldInputText "type" $ runTrainerM $ getForm "f" pokemonForm + + , testCase "Abusing Bool as Choice" $ assertError $ + fieldInputChoice "rare" $ runTrainerM $ getForm "f" pokemonForm + + , testCase "Abusing Text as Bool" $ assertError $ + fieldInputBool "name" $ runTrainerM $ getForm "f" pokemonForm + + , testCase "monadic choiceWith" $ (@=?) + (Just (Order comet 2)) $ + snd $ runDatabase $ postForm "f" (orderForm Nothing) $ testEnv + -- We actually need f.product.cm_gs for the choice input, but this + -- must work as well! + [ ("f.product", "cm_gs") + , ("f.quantity", "2") + ] + + , testCase "monadic view query" $ (@=?) + "Earthwing Belly Racer" $ + snd $ selection $ fieldInputChoice "product" $ runDatabase $ + getForm "f" + -- With a default + (orderForm $ Just $ Order earthwing 10) + + , -- Let me just order 3 awesome skateboards here + testCase "Simple listOf" $ do + let (view, result) = runDatabase $ postForm "f" (ordersForm Nothing) $ + testEnv + [ ("f.name", "Jasper") + {- \ /\ -} , ("f.orders.indices", "0,10") + {- ) ( ') -} , ("f.orders.0.product", "cm_gs") + {- ( / ) -} , ("f.orders.0.quantity", "2") + {- \(__)| -} , ("f.orders.10.product", "s9_ao") + , ("f.orders.10.quantity", "1") + ] + + result @?= Just + ( "Jasper" + , [ Order (Product "cm_gs" "Comet Grease Shark") 2 + , Order (Product "s9_ao" "Sector 9 Agent Orange") 1 + ] + ) + + let subViews' = listSubViews "orders" view + fieldInputText "quantity" (head subViews') @?= "2" + + , testCase "listOf with defaults" $ do + let view = runDatabase $ getForm "f" $ ordersForm $ Just + ( "Jasper" + , [ Order comet 2 + , Order sector9 3 + ] + ) + + let subViews' = listSubViews "orders" view + fst (selection (fieldInputChoice "product" (subViews' !! 1))) @=? + "s9_ao" + ] + + +-------------------------------------------------------------------------------- +testEnv :: Monad m => [(Text, Text)] -> Env m +testEnv input key = return $ map (TextInput . snd) $ + filter ((== fromPath key) . fst) input + + +-------------------------------------------------------------------------------- +selection :: [(Text, v, Bool)] -> (Text, v) +selection fic = head [(t, v) | (t, v, s) <- fic, s]