yesod-filter (empty) → 0.1.0.0
raw patch · 16 files changed
+1535/−0 lines, 16 filesdep +QuickCheckdep +basedep +doctestsetup-changed
Dependencies added: QuickCheck, base, doctest, hspec, persistent, persistent-template, template-haskell, text, time, yesod-core, yesod-filter, yesod-persistent
Files
- ChangeLog.md +5/−0
- LICENSE +29/−0
- README.md +120/−0
- Setup.hs +2/−0
- src/Yesod/Filter/Builder.hs +68/−0
- src/Yesod/Filter/Internal.hs +48/−0
- src/Yesod/Filter/Read.hs +102/−0
- src/Yesod/Filter/TH.hs +174/−0
- src/Yesod/Filter/Types.hs +128/−0
- test/Spec.hs +1/−0
- test/Yesod/Filter/InternalSpec.hs +328/−0
- test/Yesod/Filter/ReadSpec.hs +136/−0
- test/Yesod/Filter/THSpec.hs +152/−0
- test/Yesod/Filter/TestTypes.hs +169/−0
- test/doctest/doctest-driver.hs +8/−0
- yesod-filter.cabal +65/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for yesod-filter++## 0.1.0.0 (2020-10-06)++- Initial release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,120 @@+# yesod-filter++[](https://travis-ci.org/iij-ii/yesod-filter)++yesod-filter is a library that automatically generates [Filter](https://hackage.haskell.org/package/persistent-2.10.5.2/docs/Database-Persist-Types.html#t:Filter) and [SelectOpt](https://hackage.haskell.org/package/persistent-2.10.5.2/docs/Database-Persist-Types.html#t:SelectOpt) from URL query string.+yesod-filter is inspired by [django-filter](https://github.com/carltongibson/django-filter).++## Usage++### Example++```haskell+{-+# Suppose the model is defined as follows:+Pet json+ name Text+ age Int+ deriving Eq+ deriving Show++# And the route is defined as follows:+/pets PetsR GET+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Handler.Pet where++import Import+import Yesod.Filter.TH++-- Define the query options to be available.+$(mkFilterGenerator "Pet" defaultOptions+ { filtering = defaultFiltering+ { filterDefs =+ [ FilterDef "name" defaultFilterParams+ , FilterDef "age" defaultFilterParams+ ]+ }+ , sorting = defaultSorting+ { sortFields = ["name", "age"]+ , defaultOrdering = ORDERBY "id" ASC+ }+ }+ )++getPetsR :: Handler Value+getPetsR = do+ -- The list of Filter and SelectOpts are automatically converted from query parameters.+ filters' <- $(mkFilters)+ selectOpts <- $(mkSelectOpts)+ pets <- runDB $ selectList filters' selectOpts+ returnJson pets+```++The above handler definition generates the following endpoint.++```sh+# Without query strings+$ curl -s "http://localhost:3000/pets" | jq .+[+ {+ "age": 5,+ "name": "John",+ "id": 1+ },+ {+ "age": 3,+ "name": "Charlie",+ "id": 2+ },+ {+ "age": 10,+ "name": "Jack",+ "id": 3+ }+]++# Filter: WHERE AGE >= 3+$ curl -s "http://localhost:3000/pets?age__gt=3" | jq .+[+ {+ "age": 5,+ "name": "John",+ "id": 1+ },+ {+ "age": 10,+ "name": "Jack",+ "id": 3+ }+]++# SelectOpt: ORDER BY name+$ curl -s "http://localhost:3000/pets?sort=name" | jq .+[+ {+ "age": 3,+ "name": "Charlie",+ "id": 2+ },+ {+ "age": 10,+ "name": "Jack",+ "id": 3+ },+ {+ "age": 5,+ "name": "John",+ "id": 1+ }+]+```++## LICENCE++Copyright (c) IIJ Innovation Institute Inc.++Licensed under The 3-Clause BSD License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Yesod/Filter/Builder.hs view
@@ -0,0 +1,68 @@+module Yesod.Filter.Builder where++import Control.Exception (throwIO)+import Data.Either (lefts, rights)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Yesod.Core (ErrorResponse (InvalidArgs), MonadHandler, getRequest,+ liftIO, lookupGetParam, reqGetParams)+import Yesod.Core.Types (HandlerContents (HCError))+import Yesod.Persist (Filter, SelectOpt)++import Yesod.Filter.Internal (getFilters, getLimitTo, getOffsetBy, getOrderBy)+import Yesod.Filter.Types+++buildFiltersFromGetParams+ :: MonadHandler m+ => [(Text, Text -> Maybe (Filter record))]+ -> Options+ -> m [Filter record]+buildFiltersFromGetParams availableFilters options = do+ request <- getRequest+ let+ otherParams = sortParams (sorting options) ++ pageParams (pagination options)+ filterParams = filter ((`notElem` otherParams) . fst) $ reqGetParams request+ efilters = getFilters availableFilters filterParams+ case lefts efilters of+ [] -> pure $ rights efilters+ msg : _ -> liftIO $ throwIO $ HCError $ InvalidArgs [msg]+ where+ sortParams (AllowSorting sortParam' _ _) = [sortParam']+ sortParams _ = []+ pageParams (OffsetPagination offsetParam' _ limitParam' _) = [offsetParam', limitParam']+ pageParams _ = []+++buildSelectOptsFromGetParams+ :: MonadHandler m+ => Maybe (SelectOpt record)+ -> [(Text, SelectOpt record)]+ -> Options+ -> m [SelectOpt record]+buildSelectOptsFromGetParams defaultOrderBy availableOrderBys options = do+ orderBy <- getOrderByFromGetParams $ sorting options+ offsetBy <- getOffsetByFromGetParams $ pagination options+ limitTo <- getLimitToFromGetParams $ pagination options+ pure $ catMaybes [orderBy, offsetBy, limitTo]+ where+ getOrderByFromGetParams (AllowSorting sortParam' _ _) = do+ msort <- lookupGetParam sortParam'+ case getOrderBy defaultOrderBy availableOrderBys msort of+ Right morderBy -> pure morderBy+ Left msg -> liftIO $ throwIO $ HCError $ InvalidArgs [msg]+ getOrderByFromGetParams _ = pure Nothing++ getOffsetByFromGetParams (OffsetPagination offsetParam' defaultOffset' _ _) = do+ moffset <- lookupGetParam offsetParam'+ case getOffsetBy defaultOffset' moffset of+ Right moffsetBy -> pure moffsetBy+ Left msg -> liftIO $ throwIO $ HCError $ InvalidArgs [msg]+ getOffsetByFromGetParams _ = pure Nothing++ getLimitToFromGetParams (OffsetPagination _ _ limitParam' defaultLimit') = do+ mlimit <- lookupGetParam limitParam'+ case getLimitTo defaultLimit' mlimit of+ Right mlimitTo -> pure mlimitTo+ Left msg -> liftIO $ throwIO $ HCError $ InvalidArgs [msg]+ getLimitToFromGetParams _ = pure Nothing
+ src/Yesod/Filter/Internal.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Filter.Internal where++import Data.Text (Text, unpack)+import Yesod.Persist (Filter, SelectOpt (LimitTo, OffsetBy))++import Yesod.Filter.Read (readMaybeInt)+import Yesod.Filter.Types+++getFilters :: [(Text, Text -> Maybe (Filter record))] -> [(Text, Text)] -> [Either Text (Filter record)]+getFilters availableFilters = map (uncurry getFilter)+ where+ getFilter paramName paramValue = case lookup paramName availableFilters of+ Just filterBuilder -> case filterBuilder paramValue of+ Just filt -> Right filt+ Nothing -> Left $ "Invalid filter value: " <> paramValue+ Nothing -> Left $ "Invalid filter name: " <> paramName++getOrderBy+ :: Maybe (SelectOpt record)+ -> [(Text, SelectOpt record)]+ -> Maybe Text+ -> Either Text (Maybe (SelectOpt record))+getOrderBy defaultOrderBy availableOrderBys msort = case msort of+ Just sort' -> case lookup sort' availableOrderBys of+ Just orderBy -> Right $ Just orderBy+ Nothing -> Left $ "Invalid sort option: " <> sort'+ Nothing -> Right defaultOrderBy++getOffsetBy :: PageOffset -> Maybe Text -> Either Text (Maybe (SelectOpt record))+getOffsetBy defaultOffset' moffset = case moffset of+ Just offset -> case readMaybeInt (unpack offset) of+ Just n -> Right $ Just $ OffsetBy n+ Nothing -> Left $ "Invalid offset option: " <> offset+ Nothing -> case defaultOffset' of+ OFFSET n -> Right $ Just $ OffsetBy n+ NoOffset -> Right Nothing++getLimitTo :: PageLimit -> Maybe Text -> Either Text (Maybe (SelectOpt record))+getLimitTo defaultLimit' mlimit = case mlimit of+ Just limit -> case readMaybeInt (unpack limit) of+ Just n -> Right $ Just $ LimitTo n+ Nothing -> Left $ "Invalid limit option: " <> limit+ Nothing -> case defaultLimit' of+ LIMIT n -> Right $ Just $ LimitTo n+ NoLimit -> Right Nothing
+ src/Yesod/Filter/Read.hs view
@@ -0,0 +1,102 @@+module Yesod.Filter.Read where++import Data.Char (isSpace, toLower, toUpper)+import Data.Time (Day, TimeOfDay, UTCTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Text.Read (readMaybe)+++-- | Parse a string to Int.+--+-- >>> readMaybeInt "1"+-- Just 1+--+-- >>> readMaybeInt "one"+-- Nothing+--+readMaybeInt :: String -> Maybe Int+readMaybeInt = readMaybe'++-- | Parse a string to Double.+--+-- >>> readMaybeDouble "1.0"+-- Just 1.0+--+-- >>> readMaybeDouble "1"+-- Just 1.0+--+readMaybeDouble :: String -> Maybe Double+readMaybeDouble = readMaybe'++-- | Parse a string to Bool.+--+-- >>> readMaybeBool "true"+-- Just True+--+-- >>> readMaybeBool "FALSE"+-- Just False+--+readMaybeBool :: String -> Maybe Bool+readMaybeBool = readMaybe' . capitalize++-- | Parse a string to Day.+--+-- >>> readMaybeDay "2020-01-01"+-- Just 2020-01-01+--+-- >>> readMaybeDay "2020/01/01"+-- Nothing+--+readMaybeDay :: String -> Maybe Day+readMaybeDay = readMaybe'++-- | Parse a string to TimeOfDay.+--+-- >>> readMaybeTimeOfDay "12:34:56"+-- Just 12:34:56+--+-- >>> readMaybeTimeOfDay "12:34:56.789"+-- Just 12:34:56.789+--+readMaybeTimeOfDay :: String -> Maybe TimeOfDay+readMaybeTimeOfDay = readMaybe'++-- | Parse a string to UTCTime.+--+-- >>> readMaybeUTCTime "2020-01-01T12:34:56Z"+-- Just 2020-01-01 12:34:56 UTC+--+-- >>> readMaybeUTCTime "2020-01-01T12:34:56+09:00"+-- Nothing+--+readMaybeUTCTime :: String -> Maybe UTCTime+readMaybeUTCTime = iso8601ParseM++-- | Wrapper function of `readMaybe` that returns Nothing if a string has leading/trailing whitespaces.+--+-- >>> readMaybe' "1" :: Maybe Int+-- Just 1+--+-- >>> readMaybe' " 1" :: Maybe Int+-- Nothing+--+-- >>> readMaybe' "1 " :: Maybe Int+-- Nothing+--+readMaybe' :: Read a => String -> Maybe a+readMaybe' "" = readMaybe ""+readMaybe' s+ | isSpace (head s) || isSpace (last s) = Nothing+ | otherwise = readMaybe s++-- | Capitalize a string.+--+-- >>> capitalize "foo"+-- "Foo"+--+-- >>> capitalize "FOO"+-- "Foo"+--+capitalize :: String -> String+capitalize [] = []+capitalize (x : xs) = toUpper x : map toLower xs
+ src/Yesod/Filter/TH.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Filter.TH+ ( mkFilterGenerator+ , mkFilters+ , mkSelectOpts+ -- Types+ , Options (..)+ , Filtering (..)+ , FilterDef (..)+ , FilterParam (..)+ , FilterOp (..)+ , Sorting (..)+ , SortOrdering (..)+ , SortDirection (..)+ , Pagination (..)+ , PageLimit (..)+ , PageOffset (..)+ , defaultOptions+ , defaultFiltering+ , defaultFilterParams+ , defaultSorting+ , defaultPagination+ -- for testing+ , mkToFilterValueInstances+ , availableFiltersE+ , defaultOrderByE+ , availableOrderBysE+ ) where++import Control.Monad ((>=>))+import Data.Text (Text, cons, pack, unpack)+import Data.Time (Day, TimeOfDay, UTCTime)+import Database.Persist (BackendKey)+import Database.Persist.Sql (SqlBackend)+import Language.Haskell.TH (DecsQ, ExpQ, conE, conT, listE, mkName)+import Text.Read (readMaybe)+import Yesod.Core (MonadHandler)+import Yesod.Persist (Filter, Key, SelectOpt (Asc, Desc), (!=.), (<.), (<=.),+ (==.), (>.), (>=.))++import Yesod.Filter.Builder (buildFiltersFromGetParams, buildSelectOptsFromGetParams)+import Yesod.Filter.Read (capitalize, readMaybeBool, readMaybeDay, readMaybeDouble,+ readMaybeInt, readMaybeTimeOfDay, readMaybeUTCTime)+import Yesod.Filter.Types+++-- ExpQ: [| [Filter record] |]+-- | Generates the list of `Filter`.+mkFilters :: ExpQ+mkFilters = [| filtersFromGetParams |]++-- ExpQ: [| [SelectOpt record] |]+-- | Generates the list of `SelectOpt`.+mkSelectOpts :: ExpQ+mkSelectOpts = [| selectOptsFromGetParams |]++-- | Generates the function that creates the list of `Filter` and the list of `SelectOpt` from query parameters.+mkFilterGenerator :: Text -> Options -> DecsQ+mkFilterGenerator model options = concat <$> sequence+ [ mkToFilterValueInstances model+ , mkFiltersFromGetParams model options+ , mkSelectOptsFromGetParams model options+ ]++mkToFilterValueInstances :: Text -> DecsQ+mkToFilterValueInstances model = [d|+ class ToKey a where+ toKey :: BackendKey SqlBackend -> Key a++ instance ToKey $(conT $ mkName (unpack model)) where+ toKey = $(conE $ mkName $ unpack model ++ "Key")++ class ToFilterValue a where+ toFilterValue :: Text -> Maybe a++ instance ToKey record => ToFilterValue (Key record) where+ toFilterValue v = case readMaybe (unpack v) of+ Just n -> Just (toKey n)+ Nothing -> Nothing++ instance ToFilterValue Text where+ toFilterValue = Just++ instance ToFilterValue Int where+ toFilterValue = readMaybeInt . unpack++ instance ToFilterValue Double where+ toFilterValue = readMaybeDouble . unpack++ instance ToFilterValue Bool where+ toFilterValue = readMaybeBool . unpack++ instance ToFilterValue Day where+ toFilterValue = readMaybeDay . unpack++ instance ToFilterValue TimeOfDay where+ toFilterValue = readMaybeTimeOfDay . unpack++ instance ToFilterValue UTCTime where+ toFilterValue = readMaybeUTCTime . unpack++ instance ToFilterValue a => ToFilterValue (Maybe a) where+ toFilterValue = toFilterValue >=> Just . Just+ |]++mkFiltersFromGetParams :: Text -> Options -> DecsQ+mkFiltersFromGetParams model options = [d|+ filtersFromGetParams :: MonadHandler m => m [Filter $(conT $ mkName (unpack model))]+ filtersFromGetParams = buildFiltersFromGetParams+ $(availableFiltersE model $ filtering options)+ $([| options |])+ |]++-- ExpQ: [| [(Text, Text -> Maybe (Filter record))] |]+availableFiltersE :: Text -> Filtering -> ExpQ+availableFiltersE model (SimpleFiltering defs) = [| $(listE $ concatMap availableFilterE' defs) |]+ where+ availableFilterE' (FilterDef field filterParams) = map (availableFilterE model field) filterParams+availableFiltersE _ _ = [| [] |]++-- ExpQ: [| (Text, Text -> Maybe (Filter record)) |]+availableFilterE :: Text -> Text -> FilterParam -> ExpQ+availableFilterE model field (CustomParam op param) = [| (param, $(filterBuilderE model field op)) |]+availableFilterE model field (AutoParam op) = [| (defaultParam, $(filterBuilderE model field op)) |]+ where+ defaultParam = case op of+ EqOp -> field+ NeOp -> field <> pack "__ne"+ GtOp -> field <> pack "__gt"+ LtOp -> field <> pack "__lt"+ GeOp -> field <> pack "__ge"+ LeOp -> field <> pack "__le"+ IsNullOp -> field <> pack "__isnull"++-- ExpQ: [| Text -> Maybe (Filter record) |]+filterBuilderE :: Text -> Text -> FilterOp -> ExpQ+filterBuilderE model field EqOp = [| toFilterValue >=> (Just . (==.) $(entityFieldE model field)) |]+filterBuilderE model field NeOp = [| toFilterValue >=> (Just . (!=.) $(entityFieldE model field)) |]+filterBuilderE model field GtOp = [| toFilterValue >=> (Just . (>.) $(entityFieldE model field)) |]+filterBuilderE model field LtOp = [| toFilterValue >=> (Just . (<.) $(entityFieldE model field)) |]+filterBuilderE model field GeOp = [| toFilterValue >=> (Just . (>=.) $(entityFieldE model field)) |]+filterBuilderE model field LeOp = [| toFilterValue >=> (Just . (<=.) $(entityFieldE model field)) |]+filterBuilderE model field IsNullOp = [|+ toFilterValue >=> (\b -> Just $ (if b then (==.) else (!=.)) $(entityFieldE model field) Nothing)+ |]++mkSelectOptsFromGetParams :: Text -> Options -> DecsQ+mkSelectOptsFromGetParams model options = [d|+ selectOptsFromGetParams :: MonadHandler m => m [SelectOpt $(conT $ mkName (unpack model))]+ selectOptsFromGetParams = buildSelectOptsFromGetParams+ $(defaultOrderByE model $ sorting options)+ $(availableOrderBysE model $ sorting options)+ $([| options |])+ |]++-- ExpQ: [| Maybe (SelectOpt record) |]+defaultOrderByE :: Text -> Sorting -> ExpQ+defaultOrderByE model (AllowSorting _ _ (ORDERBY field ASC)) = [| Just $ Asc $(entityFieldE model field) |]+defaultOrderByE model (AllowSorting _ _ (ORDERBY field DESC)) = [| Just $ Desc $(entityFieldE model field) |]+defaultOrderByE _ _ = [| Nothing |]++-- ExpQ: [| [(Text, SelectOpt record)] |]+availableOrderBysE :: Text -> Sorting -> ExpQ+availableOrderBysE model (AllowSorting _ fields _) = [| $(listE $ map asc fields) ++ $(listE $ map desc fields) |]+ where+ asc field = [| (field, Asc $(entityFieldE model field)) |]+ desc field = [| (cons '-' field, Desc $(entityFieldE model field)) |]+availableOrderBysE _ _ = [| [] |]++-- ExpQ: [| EntityField record typ |]+entityFieldE :: Text -> Text-> ExpQ+entityFieldE model field = conE $ mkName $ unpack model ++ capitalize (unpack field)
+ src/Yesod/Filter/Types.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Filter.Types where++import Data.Text (Text)+import Language.Haskell.TH.Syntax (Lift)+++-- | A comparison operator to apply to the filter.+data FilterOp+ = EqOp -- ^ =+ | NeOp -- ^ \<\>+ | GtOp -- ^ \>+ | LtOp -- ^ \<+ | GeOp -- ^ \>=+ | LeOp -- ^ \<=+ | IsNullOp -- ^ IS NULL+ deriving (Lift, Show)++-- | A parameter name used to specify the filter.+data FilterParam+ -- | Use automatically generated parameter names.+ = AutoParam FilterOp+ -- | Use custom parameter name.+ | CustomParam FilterOp Text deriving (Lift, Show)++-- | A filter defintion.+data FilterDef+ = FilterDef+ Text -- ^ A field name used for the filter.+ [FilterParam] -- ^ Parameters used to specify the filter.+ deriving (Lift, Show)++-- | A filtering setting.+data Filtering+ -- | Allow users to specify filtering by query parameters.+ = SimpleFiltering+ { filterDefs :: [FilterDef]+ }+ -- TODO: add ComplexFiltering+ -- | Disable filtering.+ | NoFiltering+ deriving (Lift, Show)++data SortDirection = ASC | DESC deriving (Lift, Show)++-- | A value that becomes the SQL ORDER BY clause.+data SortOrdering = NaturalOrdering | ORDERBY Text SortDirection deriving (Lift, Show)++-- | A sorting setting.+data Sorting+ -- | Allow users to specify sort order by query parameters.+ = AllowSorting+ { sortParam :: Text -- ^ A parameter name to specify the field name as a sort key.+ , sortFields :: [Text] -- ^ Field names that can be used as sort keys.+ , defaultOrdering :: SortOrdering -- ^ A default order setting.+ }+ -- | Disable sorting.+ | DisallowSorting+ deriving (Lift, Show)++-- | A value that becomes the SQL OFFSET clause.+data PageOffset = NoOffset | OFFSET Int deriving (Lift, Show)++-- | A value that becomes the SQL LIMIT clause.+data PageLimit = NoLimit | LIMIT Int deriving (Lift, Show)++-- | A pagination setting. Currently, only offset pagination is available.+data Pagination+ -- | Allow users to specify offset pagination by query parameters.+ = OffsetPagination+ { offsetParam :: Text -- ^ A parameter name to specify the offset value.+ , defaultOffset :: PageOffset -- ^ A default offset setting.+ , limitParam :: Text -- ^ A parameter name to specify the limit value.+ , defaultLimit :: PageLimit -- ^ A default limit setting.+ }+ -- TODO: add CursorPagination+ -- | Disable pagination.+ | NoPagination+ deriving (Lift, Show)++-- | Options to specify filtering, sorting, and pagination settings to generate.+data Options = Options+ { filtering :: Filtering+ , sorting :: Sorting+ , pagination :: Pagination+ } deriving (Lift, Show)++-- | Default filter parameters.+defaultFilterParams :: [FilterParam]+defaultFilterParams =+ [ AutoParam EqOp+ , AutoParam NeOp+ , AutoParam GtOp+ , AutoParam LtOp+ , AutoParam GeOp+ , AutoParam LeOp+ ]++-- | A default filtering setting.+defaultFiltering :: Filtering+defaultFiltering = SimpleFiltering []++-- | A default sorting setting.+defaultSorting :: Sorting+defaultSorting = AllowSorting+ { sortParam = "sort"+ , sortFields = []+ , defaultOrdering = NaturalOrdering+ }++-- | A default pagination setting.+defaultPagination :: Pagination+defaultPagination = OffsetPagination+ { offsetParam = "offset"+ , defaultOffset = NoOffset+ , limitParam = "limit"+ , defaultLimit = NoLimit+ }++-- | Default options.+defaultOptions :: Options+defaultOptions = Options+ { filtering = defaultFiltering+ , sorting = defaultSorting+ , pagination = defaultPagination+ }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Yesod/Filter/InternalSpec.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Filter.InternalSpec (spec) where++import Control.Monad (forM_, (>=>))+import Data.Either (isLeft, partitionEithers)+import Data.Text (Text)+import Data.Time (TimeOfDay (TimeOfDay), UTCTime (UTCTime), fromGregorian,+ timeOfDayToTime)+import Database.Persist (Filter, SelectOpt (Asc, Desc, LimitTo, OffsetBy), (!=.),+ (<.), (<=.), (==.), (>.), (>=.))+import Test.Hspec++import Yesod.Filter.Internal+import Yesod.Filter.TH (PageLimit (LIMIT, NoLimit), PageOffset (NoOffset, OFFSET),+ mkToFilterValueInstances)++import Yesod.Filter.TestTypes+++$(mkToFilterValueInstances "Foo")++spec :: Spec+spec = do+ describe "getFilters" $ do+ context "for not nullable fields" $ do+ let tests =+ [ ( [("ctxt", toFilterValue >=> (Just . (==.) FooCtxt))]+ , [("ctxt", "foo")]+ , [Right (FooCtxt ==. "foo")]+ )+ , ( [("cint", toFilterValue >=> (Just . (==.) FooCint))]+ , [("cint", "1")]+ , [Right (FooCint ==. 1)]+ )+ , ( [("cdbl", toFilterValue >=> (Just . (==.) FooCdbl))]+ , [("cdbl", "1.0")]+ , [Right (FooCdbl ==. 1.0)]+ )+ , ( [("cbol", toFilterValue >=> (Just . (==.) FooCbol))]+ , [("cbol", "true")]+ , [Right (FooCbol ==. True)]+ )+ , ( [("cday", toFilterValue >=> (Just . (==.) FooCday))]+ , [("cday", "2020-01-01")]+ , [Right (FooCday ==. fromGregorian 2020 1 1)]+ )+ , ( [("ctod", toFilterValue >=> (Just . (==.) FooCtod))]+ , [("ctod", "12:34:56")]+ , [Right (FooCtod ==. TimeOfDay 12 34 56)]+ )+ , ( [("cutm", toFilterValue >=> (Just . (==.) FooCutm))]+ , [("cutm", "2020-01-01T12:34:56Z")]+ , [Right (FooCutm ==. UTCTime (fromGregorian 2020 1 1 ) (timeOfDayToTime $ TimeOfDay 12 34 56))]+ )+ ]+ forM_ tests $ \(availableFilters, params, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show params) $+ getFilters availableFilters params `shouldBe` ret++ context "for nullable fields" $ do+ let tests =+ [ ( [("mtxt", toFilterValue >=> (Just . (==.) FooMtxt))]+ , [("mtxt", "foo")]+ , [Right (FooMtxt ==. Just "foo")]+ )+ , ( [("mint", toFilterValue >=> (Just . (==.) FooMint))]+ , [("mint", "1")]+ , [Right (FooMint ==. Just 1)]+ )+ , ( [("mdbl", toFilterValue >=> (Just . (==.) FooMdbl))]+ , [("mdbl", "1.0")]+ , [Right (FooMdbl ==. Just 1.0)]+ )+ , ( [("mbol", toFilterValue >=> (Just . (==.) FooMbol))]+ , [("mbol", "true")]+ , [Right (FooMbol ==. Just True)]+ )+ , ( [("mday", toFilterValue >=> (Just . (==.) FooMday))]+ , [("mday", "2020-01-01")]+ , [Right (FooMday ==. (Just $ fromGregorian 2020 1 1))]+ )+ , ( [("mtod", toFilterValue >=> (Just . (==.) FooMtod))]+ , [("mtod", "12:34:56")]+ , [Right (FooMtod ==. (Just $ TimeOfDay 12 34 56))]+ )+ , ( [("mutm", toFilterValue >=> (Just . (==.) FooMutm))]+ , [("mutm", "2020-01-01T12:34:56Z")]+ , [Right (FooMutm ==. (Just $ UTCTime (fromGregorian 2020 1 1 ) (timeOfDayToTime $ TimeOfDay 12 34 56)))]+ )+ ]+ forM_ tests $ \(availableFilters, params, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show params) $+ getFilters availableFilters params `shouldBe` ret++ context "for not nullable fields with various operators" $ do+ let tests =+ [ ( [("cint", toFilterValue >=> (Just . (==.) FooCint))]+ , [("cint", "1")]+ , [Right (FooCint ==. 1)]+ )+ , ( [("cint__ne", toFilterValue >=> (Just . (!=.) FooCint))]+ , [("cint__ne", "1")]+ , [Right (FooCint !=. 1)]+ )+ , ( [("cint__gt", toFilterValue >=> (Just . (>.) FooCint))]+ , [("cint__gt", "1")]+ , [Right (FooCint >. 1)]+ )+ , ( [("cint__lt", toFilterValue >=> (Just . (<.) FooCint))]+ , [("cint__lt", "1")]+ , [Right (FooCint <. 1)]+ )+ , ( [("cint__ge", toFilterValue >=> (Just . (>=.) FooCint))]+ , [("cint__ge", "1")]+ , [Right (FooCint >=. 1)]+ )+ , ( [("cint__le", toFilterValue >=> (Just . (<=.) FooCint))]+ , [("cint__le", "1")]+ , [Right (FooCint <=. 1)]+ )+ ]+ forM_ tests $ \(availableFilters, params, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show params) $+ getFilters availableFilters params `shouldBe` ret++ context "for not nullable fields with various operators" $ do+ let tests =+ [ ( [("mint", toFilterValue >=> (Just . (==.) FooMint))]+ , [("mint", "1")]+ , [Right (FooMint ==. Just 1)]+ )+ , ( [("mint__ne", toFilterValue >=> (Just . (!=.) FooMint))]+ , [("mint__ne", "1")]+ , [Right (FooMint !=. Just 1)]+ )+ , ( [("mint__gt", toFilterValue >=> (Just . (>.) FooMint))]+ , [("mint__gt", "1")]+ , [Right (FooMint >. Just 1)]+ )+ , ( [("mint__lt", toFilterValue >=> (Just . (<.) FooMint))]+ , [("mint__lt", "1")]+ , [Right (FooMint <. Just 1)]+ )+ , ( [("mint__ge", toFilterValue >=> (Just . (>=.) FooMint))]+ , [("mint__ge", "1")]+ , [Right (FooMint >=. Just 1)]+ )+ , ( [("mint__le", toFilterValue >=> (Just . (<=.) FooMint))]+ , [("mint__le", "1")]+ , [Right (FooMint <=. Just 1)]+ )+ , ( [("mint__isnull", toFilterValue >=> (\b -> Just $ (if b then (==.) else (!=.)) FooMint Nothing))]+ , [("mint__isnull", "true")]+ , [Right (FooMint ==. Nothing)]+ )+ ]+ forM_ tests $ \(availableFilters, params, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show params) $+ getFilters availableFilters params `shouldBe` ret++ context "for invalid value type" $ do+ let tests =+ [ ( [("cint", toFilterValue >=> (Just . (==.) FooCint))]+ , [("cint", "foo")]+ )+ , ( [("cdbl", toFilterValue >=> (Just . (==.) FooCdbl))]+ , [("cdbl", "foo")]+ )+ , ( [("cbol", toFilterValue >=> (Just . (==.) FooCbol))]+ , [("cbol", "foo")]+ )+ , ( [("cday", toFilterValue >=> (Just . (==.) FooCday))]+ , [("cday", "foo")]+ )+ , ( [("ctod", toFilterValue >=> (Just . (==.) FooCtod))]+ , [("ctod", "foo")]+ )+ , ( [("cutm", toFilterValue >=> (Just . (==.) FooCutm))]+ , [("cutm", "foo")]+ )+ , ( [("mint", toFilterValue >=> (Just . (==.) FooMint))]+ , [("mint", "foo")]+ )+ , ( [("mdbl", toFilterValue >=> (Just . (==.) FooMdbl))]+ , [("mdbl", "foo")]+ )+ , ( [("mbol", toFilterValue >=> (Just . (==.) FooMbol))]+ , [("mbol", "foo")]+ )+ , ( [("mday", toFilterValue >=> (Just . (==.) FooMday))]+ , [("mday", "foo")]+ )+ , ( [("mtod", toFilterValue >=> (Just . (==.) FooMtod))]+ , [("mtod", "foo")]+ )+ , ( [("mutm", toFilterValue >=> (Just . (==.) FooMutm))]+ , [("mutm", "foo")]+ )+ ]+ forM_ tests $ \(availableFilters, params) ->+ it ("returns Left for " ++ show params) $+ getFilters availableFilters params `shouldSatisfy` isALeft++ it "returns [] if params is []" $+ getFilters [("ctxt", toFilterValue >=> (Just . (==.) FooCtxt))] []+ `shouldBe` []++ it "returns Left if the field has no available filter" $+ getFilters [("ctxt", toFilterValue >=> (Just . (==.) FooCtxt))] [("cint", "1")]+ `shouldSatisfy` isALeft++ it "returns multiple filters for multiple parameters" $ do+ let+ availableFilters =+ [ ("ctxt", toFilterValue >=> (Just . (==.) FooCtxt))+ , ("cdbl", toFilterValue >=> (Just . (==.) FooCdbl))+ , ("mint__isnull", toFilterValue >=> (\b -> Just $ (if b then (==.) else (!=.)) FooMint Nothing))+ ]+ params =+ [ ("ctxt", "foo")+ , ("cdbl", "1.0")+ , ("mint__isnull", "true")+ ]+ getFilters availableFilters params `shouldMatchList`+ [ Right (FooCtxt ==. "foo")+ , Right (FooCdbl ==. 1.0)+ , Right (FooMint ==. Nothing)+ ]++ it "returns a list of mixed Right and Left if the parameters contain an invalid value" $ do+ let+ availableFilters =+ [ ("ctxt", toFilterValue >=> (Just . (==.) FooCtxt))+ , ("cdbl", toFilterValue >=> (Just . (==.) FooCdbl))+ , ("mint__isnull", toFilterValue >=> (\b -> Just $ (if b then (==.) else (!=.)) FooMint Nothing))+ ]+ params =+ [ ("ctxt", "foo")+ , ("cdbl", "foo")+ , ("mint__isnull", "true")+ ]+ result = getFilters availableFilters params+ (ls, rs) = partitionEithers result++ rs `shouldMatchList`+ [ FooCtxt ==. "foo"+ , FooMint ==. Nothing+ ]+ ls `shouldSatisfy` (1 ==) . length++ describe "getOrderBy" $ do+ context "Right cases" $ do+ let tests =+ [ (Just $ Asc FooCtxt, [("cint", Asc FooCint)], Just "cint", Right $ Just $ Asc FooCint)+ , (Nothing, [("cint", Asc FooCint)], Just "cint", Right $ Just $ Asc FooCint)+ , (Just $ Asc FooCtxt, [("cint", Asc FooCint)], Nothing, Right $ Just $ Asc FooCtxt)+ , (Just $ Asc FooCtxt, [], Nothing, Right $ Just $ Asc FooCtxt)+ , (Nothing, [("cint", Asc FooCint)], Nothing, Right Nothing)+ , (Just $ Desc FooCtxt, [("-cint", Desc FooCint)], Just "-cint", Right $ Just $ Desc FooCint)+ , (Nothing, [("-cint", Desc FooCint)], Just "-cint", Right $ Just $ Desc FooCint)+ , (Just $ Desc FooCtxt, [("-cint", Desc FooCint)], Nothing, Right $ Just $ Desc FooCtxt)+ , (Just $ Desc FooCtxt, [], Nothing, Right $ Just $ Desc FooCtxt)+ , (Nothing, [("-cint", Desc FooCint)], Nothing, Right Nothing)+ , (Nothing, [], Nothing, Right Nothing)+ ]+ forM_ tests $ \(defaultOrderBy, availableOrderBys, msort, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show defaultOrderBy ++ ", " ++ show availableOrderBys ++ ", " ++ show msort) $+ getOrderBy defaultOrderBy availableOrderBys msort `shouldBe` ret++ context "Left cases" $ do+ let tests =+ [ (Just $ Asc FooCtxt, [], Just "cint")+ , (Nothing, [], Just "cint")+ , (Just $ Asc FooCtxt, [("ctxt", Asc FooCtxt)], Just "cint")+ , (Nothing, [("ctxt", Asc FooCtxt)], Just "cint")+ ]+ forM_ tests $ \(defaultOrderBy, availableOrderBys, msort) ->+ it ("returns Left for " ++ show defaultOrderBy ++ ", " ++ show availableOrderBys ++ ", " ++ show msort) $+ getOrderBy defaultOrderBy availableOrderBys msort `shouldSatisfy` isLeft++ describe "getOffsetBy" $ do+ context "Right cases" $ do+ let tests =+ [ (OFFSET 0, Just "1", Right $ Just $ OffsetBy 1)+ , (NoOffset, Just "1", Right $ Just $ OffsetBy 1)+ , (OFFSET 0, Nothing, Right $ Just $ OffsetBy 0)+ , (NoOffset, Nothing, Right Nothing)+ ]+ forM_ tests $ \(defaultOffset', moffset, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show defaultOffset' ++ ", " ++ show moffset) $+ getOffsetBy defaultOffset' moffset `shouldBe` (ret :: Either Text (Maybe (SelectOpt Foo)))++ context "Left cases" $ do+ let tests =+ [ (OFFSET 0, Just "foo")+ , (NoOffset, Just "foo")+ ]+ forM_ tests $ \(defaultOffset', moffset) ->+ it ("returns Left for " ++ show defaultOffset' ++ ", " ++ show moffset) $+ (getOffsetBy defaultOffset' moffset :: Either Text (Maybe (SelectOpt Foo))) `shouldSatisfy` isLeft++ describe "getLimitTo" $ do+ context "Right cases" $ do+ let tests =+ [ (LIMIT 0, Just "1", Right $ Just $ LimitTo 1)+ , (NoLimit, Just "1", Right $ Just $ LimitTo 1)+ , (LIMIT 0, Nothing, Right $ Just $ LimitTo 0)+ , (NoLimit, Nothing, Right Nothing)+ ]+ forM_ tests $ \(defaultLimit', mlimit, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show defaultLimit' ++ ", " ++ show mlimit) $+ getLimitTo defaultLimit' mlimit `shouldBe` (ret :: Either Text (Maybe (SelectOpt Foo)))++ context "Left cases" $ do+ let tests =+ [ (LIMIT 0, Just "foo")+ , (NoLimit, Just "foo")+ ]+ forM_ tests $ \(defaultLimit', mlimit) ->+ it ("returns Left for " ++ show defaultLimit' ++ ", " ++ show mlimit) $+ (getLimitTo defaultLimit' mlimit :: Either Text (Maybe (SelectOpt Foo))) `shouldSatisfy` isLeft+++isALeft :: [Either Text (Filter record)] -> Bool+isALeft [x] = isLeft x+isALeft _ = False
+ test/Yesod/Filter/ReadSpec.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Filter.ReadSpec (spec) where++import Control.Monad (forM_)+import Data.Char (isAlpha, isAscii, isLower, isUpper, toLower)+import Data.Time (TimeOfDay (TimeOfDay), UTCTime (UTCTime), fromGregorian,+ timeOfDayToTime)+import Test.Hspec+import Test.QuickCheck++import Yesod.Filter.Read+++spec :: Spec+spec = do+ describe "readMaybeInt" $ do+ let tests =+ [ ("1", Just 1)+ , ("-1", Just (-1))+ , ("01", Just 1)+ , ("0x0a", Just 10)+ , ("1.0", Nothing)+ , (" 1", Nothing)+ , ("1 ", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeInt arg `shouldBe` ret++ describe "readMaybeDouble" $ do+ let tests =+ [ ("1.0", Just 1.0)+ , ("-1.0", Just (-1.0))+ , ("1", Just 1.0)+ , ("01", Just 1.0)+ , ("0x0a", Just 10.0)+ , (" 1.0", Nothing)+ , ("1.0 ", Nothing)+ , (".1", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeDouble arg `shouldBe` ret++ describe "readMaybeBool" $ do+ let tests =+ [ ("True", Just True)+ , ("true", Just True)+ , ("TRUE", Just True)+ , ("False", Just False)+ , ("fALSE", Just False)+ , ("Tru", Nothing)+ , (" True", Nothing)+ , ("True ", Nothing)+ , ("0", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeBool arg `shouldBe` ret++ describe "readMaybeDay" $ do+ let tests =+ [ ("2020-01-01", Just $ fromGregorian 2020 1 1)+ , ("2020/01/01", Nothing)+ , ("2020-04-31", Nothing)+ , ("January 1st 2020", Nothing)+ , (" 2020-01-01", Nothing)+ , ("2020-01-01 ", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeDay arg `shouldBe` ret++ describe "readMaybeTimeOfDay" $ do+ let tests =+ [ ("12:34:56", Just $ TimeOfDay 12 34 56)+ , ("12:34:56.7", Just $ TimeOfDay 12 34 56.7)+ , ("12:34:56.789", Just $ TimeOfDay 12 34 56.789)+ , ("12:34", Nothing)+ , ("24:34:56", Nothing)+ , (" 12:34:56", Nothing)+ , ("12:34:56 ", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeTimeOfDay arg `shouldBe` ret++ describe "readMaybeUTCTime" $ do+ let day = fromGregorian 2020 1 1+ let tests =+ [ ("2020-01-01T12:34:56Z", Just $ UTCTime day (timeOfDayToTime $ TimeOfDay 12 34 56))+ , ("2020-01-01T12:34:56.789Z", Just $ UTCTime day (timeOfDayToTime $ TimeOfDay 12 34 56.789))+ , ("2020-01-01T12:34:56+09:00", Nothing)+ , ("2020-1-1 12:34:56Z", Nothing)+ , ("2020-1-1T12:34:56Z", Nothing)+ , (" 2020-01-01T12:34:56Z", Nothing)+ , ("2020-01-01T12:34:56Z ", Nothing)+ , ("", Nothing)+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ readMaybeUTCTime arg `shouldBe` ret++ describe "capitalize" $ do+ let tests =+ [ ("foo", "Foo")+ , ("BAR", "Bar")+ , (" BAZ", " baz")+ , ("", "")+ ]+ forM_ tests $ \(arg, ret) ->+ it ("returns " ++ show ret ++ " for " ++ show arg) $+ capitalize arg `shouldBe` ret++ context "when used with strings" $+ it "returns a string with the first character converted to uppercase and the rest to lowercase" $+ property prop_Capitalize++prop_Capitalize :: String -> Bool+prop_Capitalize s = case s of+ [] -> null cs+ _ -> (map toLower s == map toLower cs) && isUpper' (head cs) && all isLower' (tail cs)+ where+ cs = capitalize s+ isUpper' c+ | isAscii c && isAlpha c = isUpper c+ | otherwise = True+ isLower' c+ | isAscii c && isAlpha c = isLower c+ | otherwise = True
+ test/Yesod/Filter/THSpec.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Filter.THSpec (spec) where++import Data.Text (Text)+import Test.Hspec+import Yesod.Persist (Filter, SelectOpt (Asc, Desc), (!=.), (<.), (<=.), (==.),+ (>.), (>=.))++import Yesod.Filter.TH++import Yesod.Filter.TestTypes+++$(mkToFilterValueInstances "Foo")++spec :: Spec+spec = do+ describe "availableFiltersE" $ do+ it "returns [] for defaultFiltering" $ do+ let availableFilters = $(availableFiltersE "Foo" defaultFiltering)+ buildFilters "foo" availableFilters `shouldSatisfy` null++ it "returns [(\"ctxt\", Just $ FooCtxt ==. \"foo\")] for defaultFiltering {filterDefs = [FilterDef \"ctxt\" [AutoParam EqOp]]}" $ do+ let availableFilters = $(availableFiltersE "Foo" $ defaultFiltering {filterDefs = [FilterDef "ctxt" [AutoParam EqOp]]})+ buildFilters "foo" availableFilters `shouldBe` [("ctxt", Just $ FooCtxt ==. "foo")]++ it "returns [(\"ctxt\", Just $ FooCtxt ==. \"foo\")] for SimpleFiltering [FilterDef \"ctxt\" [AutoParam EqOp]" $ do+ let availableFilters = $(availableFiltersE "Foo" $ SimpleFiltering [FilterDef "ctxt" [AutoParam EqOp]])+ buildFilters "foo" availableFilters `shouldBe` [("ctxt", Just $ FooCtxt ==. "foo")]++ it "returns [] for NoFiltering" $ do+ let availableFilters = $(availableFiltersE "Foo" NoFiltering)+ buildFilters "foo" availableFilters `shouldSatisfy` null++ it "returns filters consists of all operators other than IsNullOp for defaultFilterParams" $ do+ let availableFilters = $(availableFiltersE "Foo" $ defaultFiltering { filterDefs =+ [ FilterDef "ctxt" defaultFilterParams+ , FilterDef "mtxt" defaultFilterParams+ ]})+ buildFilters "foo" availableFilters `shouldMatchList`+ [ ("ctxt", Just $ FooCtxt ==. "foo")+ , ("ctxt__ne", Just $ FooCtxt !=. "foo")+ , ("ctxt__gt", Just $ FooCtxt >. "foo")+ , ("ctxt__lt", Just $ FooCtxt <. "foo")+ , ("ctxt__ge", Just $ FooCtxt >=. "foo")+ , ("ctxt__le", Just $ FooCtxt <=. "foo")+ , ("mtxt", Just $ FooMtxt ==. Just "foo")+ , ("mtxt__ne", Just $ FooMtxt !=. Just "foo")+ , ("mtxt__gt", Just $ FooMtxt >. Just "foo")+ , ("mtxt__lt", Just $ FooMtxt <. Just "foo")+ , ("mtxt__ge", Just $ FooMtxt >=. Just "foo")+ , ("mtxt__le", Just $ FooMtxt <=. Just "foo")+ ]++ it "returns filters with the parameter name appended with the default suffix for AutoParam" $ do+ let availableFilters = $(availableFiltersE "Foo" $ defaultFiltering { filterDefs =+ [ FilterDef "mbol"+ [ AutoParam EqOp+ , AutoParam NeOp+ , AutoParam GtOp+ , AutoParam LtOp+ , AutoParam GeOp+ , AutoParam LeOp+ , AutoParam IsNullOp+ ]]})+ buildFilters "True" availableFilters `shouldBe`+ [ ("mbol", Just $ FooMbol ==. Just True)+ , ("mbol__ne", Just $ FooMbol !=. Just True)+ , ("mbol__gt", Just $ FooMbol >. Just True)+ , ("mbol__lt", Just $ FooMbol <. Just True)+ , ("mbol__ge", Just $ FooMbol >=. Just True)+ , ("mbol__le", Just $ FooMbol <=. Just True)+ , ("mbol__isnull", Just $ FooMbol ==. Nothing)+ ]++ it "returns filters with the specified parameter name for CustomParam" $ do+ let availableFilters = $(availableFiltersE "Foo" $ defaultFiltering { filterDefs =+ [ FilterDef "mbol"+ [ CustomParam EqOp "foo"+ , CustomParam NeOp "bar"+ , CustomParam GtOp "baz"+ , CustomParam LtOp "qux"+ , CustomParam GeOp "quux"+ , CustomParam LeOp "corge"+ , CustomParam IsNullOp "grault"+ ]]})+ buildFilters "True" availableFilters `shouldBe`+ [ ("foo", Just $ FooMbol ==. Just True)+ , ("bar", Just $ FooMbol !=. Just True)+ , ("baz", Just $ FooMbol >. Just True)+ , ("qux", Just $ FooMbol <. Just True)+ , ("quux", Just $ FooMbol >=. Just True)+ , ("corge", Just $ FooMbol <=. Just True)+ , ("grault", Just $ FooMbol ==. Nothing)+ ]++ describe "defaultOrderByE" $ do+ it "returns Nothing for defaultSorting" $ do+ let defaultOrderBy = $(defaultOrderByE "Foo" defaultSorting)+ defaultOrderBy `shouldBe` (Nothing :: Maybe (SelectOpt Foo))++ it "returns Just (Asc FooCtxt) for defaultSorting {ORDERBY \"ctxt\" ASC}" $ do+ let defaultOrderBy = $(defaultOrderByE "Foo" defaultSorting { defaultOrdering = ORDERBY "ctxt" ASC })+ defaultOrderBy `shouldBe` Just (Asc FooCtxt)++ it "returns Just (Desc FooCtxt) for AllowSorting \"\" [] $ ORDERBY \"ctxt\" DESC" $ do+ let defaultOrderBy = $(defaultOrderByE "Foo" $ AllowSorting "" [] $ ORDERBY "ctxt" DESC)+ defaultOrderBy `shouldBe` Just (Desc FooCtxt)++ it "returns Nothing for AllowSorting \"\" [] NaturalOrdering" $ do+ let defaultOrderBy = $(defaultOrderByE "Foo" $ AllowSorting "" [] NaturalOrdering)+ defaultOrderBy `shouldBe` (Nothing :: Maybe (SelectOpt Foo))++ it "returns Nothing for DisallowSorting" $ do+ let defaultOrderBy = $(defaultOrderByE "Foo" DisallowSorting)+ defaultOrderBy `shouldBe` (Nothing :: Maybe (SelectOpt Foo))++ describe "availableOrderBysE" $ do+ it "returns [] for defaultSorting" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" defaultSorting)+ availableOrderBys `shouldBe` ([] :: [(Text, SelectOpt Foo)])++ it "returns [(\"ctxt\", Asc FooCtxt), (\"-ctxt\", Desc FooCtxt)] for defaultSorting { sortFields = [\"ctxt\"] }" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" defaultSorting { sortFields = ["ctxt"] })+ availableOrderBys `shouldBe` [("ctxt", Asc FooCtxt), ("-ctxt", Desc FooCtxt)]++ it "returns [(\"ctxt\", Asc FooCtxt), (\"-ctxt\", Desc FooCtxt)] for AllowSorting \"\" [\"ctxt\"] NaturalOrdering" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" $ AllowSorting "" ["ctxt"] NaturalOrdering)+ availableOrderBys `shouldBe` [("ctxt", Asc FooCtxt), ("-ctxt", Desc FooCtxt)]++ it "returns [] for sortFields = []" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" defaultSorting { sortFields = [] })+ availableOrderBys `shouldBe` ([] :: [(Text, SelectOpt Foo)])++ it "returns multiple orderBys for multiple sort fields" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" defaultSorting { sortFields = ["ctxt", "cint", "mday"] })+ availableOrderBys `shouldMatchList`+ [ ("ctxt", Asc FooCtxt), ("-ctxt", Desc FooCtxt)+ , ("cint", Asc FooCint), ("-cint", Desc FooCint)+ , ("mday", Asc FooMday), ("-mday", Desc FooMday)+ ]++ it "returns [] for DisallowSorting" $ do+ let availableOrderBys = $(availableOrderBysE "Foo" DisallowSorting)+ availableOrderBys `shouldBe` ([] :: [(Text, SelectOpt Foo)])++++buildFilters :: Text -> [(Text, Text -> Maybe (Filter Foo))] -> [(Text, Maybe (Filter Foo))]+buildFilters v = map (\(p, f) -> (p, f v))
+ test/Yesod/Filter/TestTypes.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Yesod.Filter.TestTypes where++import Data.Text (Text)+import Data.Time (Day, TimeOfDay, UTCTime)+import Database.Persist (Filter (Filter), FilterValue (FilterValue),+ PersistFilter (Eq, Ge, Gt, Le, Lt, Ne),+ SelectOpt (Asc, Desc, LimitTo, OffsetBy))+import Database.Persist.TH (mkPersist, persistLowerCase, sqlSettings)+++newtype FV typ = FV (FilterValue typ)++instance Eq typ => Eq (FV typ) where+ (==) (FV (FilterValue v1)) (FV (FilterValue v2)) = v1 == v2+ (==) _ _ = undefined++instance Show typ => Show (FV typ) where+ show (FV (FilterValue v)) = "FilterValue " ++ show v+ show _ = undefined++newtype PF = PF PersistFilter++instance Eq PF where+ (==) (PF Eq) (PF Eq) = True+ (==) (PF Ne) (PF Ne) = True+ (==) (PF Gt) (PF Gt) = True+ (==) (PF Lt) (PF Lt) = True+ (==) (PF Ge) (PF Ge) = True+ (==) (PF Le) (PF Le) = True+ (==) _ _ = False++mkPersist sqlSettings [persistLowerCase|+Foo json+ ctxt Text+ cint Int+ cdbl Double+ cbol Bool+ cday Day+ ctod TimeOfDay+ cutm UTCTime+ mtxt Text Maybe+ mint Int Maybe+ mdbl Double Maybe+ mbol Bool Maybe+ mday Day Maybe+ mtod TimeOfDay Maybe+ mutm UTCTime Maybe+ deriving Eq+ deriving Show+|]++-- The following was generated by TestTypes/geninst.hs++instance Eq (Filter Foo) where+ (==) (Filter FooId v1 f1) (Filter FooId v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCtxt v1 f1) (Filter FooCtxt v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCint v1 f1) (Filter FooCint v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCdbl v1 f1) (Filter FooCdbl v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCbol v1 f1) (Filter FooCbol v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCday v1 f1) (Filter FooCday v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCtod v1 f1) (Filter FooCtod v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooCutm v1 f1) (Filter FooCutm v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMtxt v1 f1) (Filter FooMtxt v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMint v1 f1) (Filter FooMint v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMdbl v1 f1) (Filter FooMdbl v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMbol v1 f1) (Filter FooMbol v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMday v1 f1) (Filter FooMday v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMtod v1 f1) (Filter FooMtod v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) (Filter FooMutm v1 f1) (Filter FooMutm v2 f2) = (FV v1, PF f1) == (FV v2, PF f2)+ (==) _ _ = undefined++instance Show (Filter Foo) where+ show (Filter FooId v f) = "Filter FooId (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCtxt v f) = "Filter FooCtxt (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCint v f) = "Filter FooCint (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCdbl v f) = "Filter FooCdbl (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCbol v f) = "Filter FooCbol (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCday v f) = "Filter FooCday (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCtod v f) = "Filter FooCtod (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooCutm v f) = "Filter FooCutm (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMtxt v f) = "Filter FooMtxt (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMint v f) = "Filter FooMint (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMdbl v f) = "Filter FooMdbl (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMbol v f) = "Filter FooMbol (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMday v f) = "Filter FooMday (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMtod v f) = "Filter FooMtod (" ++ show (FV v) ++ ") " ++ show f+ show (Filter FooMutm v f) = "Filter FooMutm (" ++ show (FV v) ++ ") " ++ show f+ show _ = undefined++instance Eq (SelectOpt Foo) where+ (==) (Asc FooId) (Asc FooId) = True+ (==) (Desc FooId) (Desc FooId) = True+ (==) (Asc FooCtxt) (Asc FooCtxt) = True+ (==) (Desc FooCtxt) (Desc FooCtxt) = True+ (==) (Asc FooCint) (Asc FooCint) = True+ (==) (Desc FooCint) (Desc FooCint) = True+ (==) (Asc FooCdbl) (Asc FooCdbl) = True+ (==) (Desc FooCdbl) (Desc FooCdbl) = True+ (==) (Asc FooCbol) (Asc FooCbol) = True+ (==) (Desc FooCbol) (Desc FooCbol) = True+ (==) (Asc FooCday) (Asc FooCday) = True+ (==) (Desc FooCday) (Desc FooCday) = True+ (==) (Asc FooCtod) (Asc FooCtod) = True+ (==) (Desc FooCtod) (Desc FooCtod) = True+ (==) (Asc FooCutm) (Asc FooCutm) = True+ (==) (Desc FooCutm) (Desc FooCutm) = True+ (==) (Asc FooMtxt) (Asc FooMtxt) = True+ (==) (Desc FooMtxt) (Desc FooMtxt) = True+ (==) (Asc FooMint) (Asc FooMint) = True+ (==) (Desc FooMint) (Desc FooMint) = True+ (==) (Asc FooMdbl) (Asc FooMdbl) = True+ (==) (Desc FooMdbl) (Desc FooMdbl) = True+ (==) (Asc FooMbol) (Asc FooMbol) = True+ (==) (Desc FooMbol) (Desc FooMbol) = True+ (==) (Asc FooMday) (Asc FooMday) = True+ (==) (Desc FooMday) (Desc FooMday) = True+ (==) (Asc FooMtod) (Asc FooMtod) = True+ (==) (Desc FooMtod) (Desc FooMtod) = True+ (==) (Asc FooMutm) (Asc FooMutm) = True+ (==) (Desc FooMutm) (Desc FooMutm) = True+ (==) (OffsetBy n1) (OffsetBy n2) = n1 == n2+ (==) (LimitTo n1) (LimitTo n2) = n1 == n2+ (==) _ _ = False++instance Show (SelectOpt Foo) where+ show (Asc FooId) = "Asc FooId"+ show (Desc FooId) = "Desc FooId"+ show (Asc FooCtxt) = "Asc FooCtxt"+ show (Desc FooCtxt) = "Desc FooCtxt"+ show (Asc FooCint) = "Asc FooCint"+ show (Desc FooCint) = "Desc FooCint"+ show (Asc FooCdbl) = "Asc FooCdbl"+ show (Desc FooCdbl) = "Desc FooCdbl"+ show (Asc FooCbol) = "Asc FooCbol"+ show (Desc FooCbol) = "Desc FooCbol"+ show (Asc FooCday) = "Asc FooCday"+ show (Desc FooCday) = "Desc FooCday"+ show (Asc FooCtod) = "Asc FooCtod"+ show (Desc FooCtod) = "Desc FooCtod"+ show (Asc FooCutm) = "Asc FooCutm"+ show (Desc FooCutm) = "Desc FooCutm"+ show (Asc FooMtxt) = "Asc FooMtxt"+ show (Desc FooMtxt) = "Desc FooMtxt"+ show (Asc FooMint) = "Asc FooMint"+ show (Desc FooMint) = "Desc FooMint"+ show (Asc FooMdbl) = "Asc FooMdbl"+ show (Desc FooMdbl) = "Desc FooMdbl"+ show (Asc FooMbol) = "Asc FooMbol"+ show (Desc FooMbol) = "Desc FooMbol"+ show (Asc FooMday) = "Asc FooMday"+ show (Desc FooMday) = "Desc FooMday"+ show (Asc FooMtod) = "Asc FooMtod"+ show (Desc FooMtod) = "Desc FooMtod"+ show (Asc FooMutm) = "Asc FooMutm"+ show (Desc FooMutm) = "Desc FooMutm"+ show (OffsetBy n) = "OffsetBy " ++ show n+ show (LimitTo n) = "LimitTo " ++ show n
+ test/doctest/doctest-driver.hs view
@@ -0,0 +1,8 @@+-- {-# OPTIONS_GHC -F -pgmF doctest-driver -optF config.json #-}+import Test.DocTest++main :: IO ()+main = doctest+ [ "-isrc"+ , "src/Yesod/Filter/Read.hs"+ ]
+ yesod-filter.cabal view
@@ -0,0 +1,65 @@+name: yesod-filter+version: 0.1.0.0+synopsis: Automatic filter generator for Yesod+description: Please see the README on GitHub at <https://github.com/iij-ii/yesod-filter#readme>+homepage: https://github.com/iij-ii/yesod-filter#readme+license: BSD3+license-file: LICENSE+author: Kenzo Yotsuya+maintainer: kyotsuya@iij-ii.co.jp+copyright: IIJ Innovation Institute Inc.+category: Web+build-type: Simple+extra-source-files: README.md+ , ChangeLog.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Yesod.Filter.TH+ Yesod.Filter.Read+ Yesod.Filter.Internal+ other-modules: Yesod.Filter.Builder+ Yesod.Filter.Types+ build-depends: base >= 4.7 && < 5+ , persistent+ , template-haskell+ , text+ , time+ , yesod-core+ , yesod-persistent+ default-language: Haskell2010++test-suite yesod-filter-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: Yesod.Filter.InternalSpec+ Yesod.Filter.ReadSpec+ Yesod.Filter.TestTypes+ Yesod.Filter.THSpec+ hs-source-dirs: test+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , hspec+ , persistent+ , persistent-template+ , QuickCheck+ , template-haskell+ , text+ , time+ , yesod-filter+ , yesod-persistent+ default-language: Haskell2010++test-suite yesod-filter-doctest+ type: exitcode-stdio-1.0+ main-is: doctest-driver.hs+ hs-source-dirs: test/doctest+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , doctest+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/iij-ii/yesod-filter