diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for yesod-filter + +## 0.1.0.0 (2020-10-06) + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,120 @@ +# yesod-filter + +[![Build Status](https://travis-ci.org/iij-ii/yesod-filter.svg?branch=master)](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. 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/src/Yesod/Filter/Builder.hs b/src/Yesod/Filter/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Filter/Builder.hs @@ -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 diff --git a/src/Yesod/Filter/Internal.hs b/src/Yesod/Filter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Filter/Internal.hs @@ -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 diff --git a/src/Yesod/Filter/Read.hs b/src/Yesod/Filter/Read.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Filter/Read.hs @@ -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 diff --git a/src/Yesod/Filter/TH.hs b/src/Yesod/Filter/TH.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Filter/TH.hs @@ -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) diff --git a/src/Yesod/Filter/Types.hs b/src/Yesod/Filter/Types.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Filter/Types.hs @@ -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 + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Yesod/Filter/InternalSpec.hs b/test/Yesod/Filter/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Yesod/Filter/InternalSpec.hs @@ -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 diff --git a/test/Yesod/Filter/ReadSpec.hs b/test/Yesod/Filter/ReadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Yesod/Filter/ReadSpec.hs @@ -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 diff --git a/test/Yesod/Filter/THSpec.hs b/test/Yesod/Filter/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Yesod/Filter/THSpec.hs @@ -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)) diff --git a/test/Yesod/Filter/TestTypes.hs b/test/Yesod/Filter/TestTypes.hs new file mode 100644 --- /dev/null +++ b/test/Yesod/Filter/TestTypes.hs @@ -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 diff --git a/test/doctest/doctest-driver.hs b/test/doctest/doctest-driver.hs new file mode 100644 --- /dev/null +++ b/test/doctest/doctest-driver.hs @@ -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" + ] diff --git a/yesod-filter.cabal b/yesod-filter.cabal new file mode 100644 --- /dev/null +++ b/yesod-filter.cabal @@ -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 +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