redis-glob (empty) → 0.1.0.0
raw patch · 10 files changed
+734/−0 lines, 10 filesdep +QuickCheckdep +ascii-chardep +ascii-supersetsetup-changed
Dependencies added: QuickCheck, ascii-char, ascii-superset, base, bytestring, doctest, hspec, megaparsec, redis-glob
Files
- ChangeLog.md +9/−0
- LICENSE +30/−0
- README.md +52/−0
- Setup.hs +4/−0
- doctest/Main.hs +6/−0
- redis-glob.cabal +79/−0
- src/Redis/Glob.hs +71/−0
- src/Redis/Glob/Internal.hs +275/−0
- test/Redis/GlobSpec.hs +186/−0
- test/Spec.hs +22/−0
+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for redis-glob++`redis-glob` uses [PVP Versioning][1].++## 0.1.0.0 -- 2022-11-21++* Initial version.++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, Tim Emiola++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Tim Emiola nor the names of other+ 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+OWNER 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,52 @@+# redis-glob++[](https://github.com/adetokunbo/redis-glob/actions)+[](http://stackage.org/nightly/package/redis-glob)+[![Hackage][hackage-badge]][hackage]+[![Hackage Dependencies][hackage-deps-badge]][hackage-deps]+[](https://github.com/adetokunbo/redis-glob/blob/master/LICENSE)++`redis-glob` checks that glob expressions for use with Redis are valid.+Redis commands like [KEYS] use glob expressions to match keys in redis.++If the glob expression is invalid, the command returns an empty result, which+unfortunately is the same as if the expression was valid but had no results.++Use `validate` to confirm if a glob expression is valid. It parses the+expression in the same way as the actual [redis glob] implementation, returning+`Nothing` for invalid expressions.++`matches` can be used to confirm that a bytestring matches a glob expression if+the the glob expression is valid.++## Example++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Redis.Glob+import qualified Data.ByteString.Lazy.Char8 as CL+++isOK :: CL.ByteString -> IO ()+isOk b = do+ CL.putStrLn $ "Is " <> b <> " ok? " <> maybe "n" (const "y") (validate b)+ CL.putStrLn $ "Does it match hello? " <> if (b `matches` "hello") then "y" else "n"++main :: IO()+main = do+ isOK "h?llo" -- Is h?llo ok? y+ -- Does it match hello? y+ isOK "y[a-b]llo" -- Is y[a-b]llo ok? y"+ -- Does it match hello? n+ isOK "h[a-]llo" -- Is h[a-]llo ok? n+ -- Does it match hello? n+```++[1]: https://hackage.haskell.org/package/wai+[hackage-deps-badge]: <https://img.shields.io/hackage-deps/v/redis-glob.svg>+[hackage-deps]: <http://packdeps.haskellers.com/feed?needle=redis-glob>+[hackage-badge]: <https://img.shields.io/hackage/v/redis-glob.svg>+[hackage]: <https://hackage.haskell.org/package/redis-glob>+[KEYS]: <https://redis.io/commands/keys>+[redis glob]: <https://github.com/redis/redis/blob/203b12e41ff7981f0fae5b23819f072d61594813/src/util.c#L54>
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple+++main = defaultMain
+ doctest/Main.hs view
@@ -0,0 +1,6 @@+-- file doctests.hs+import Test.DocTest+++main :: IO ()+main = doctest ["src"]
+ redis-glob.cabal view
@@ -0,0 +1,79 @@+cabal-version: 3.0+name: redis-glob+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+maintainer: adetokunbo@emio.la+author: Tim Emiola+tested-with: ghc ==8.10.7 ghc ==9.0.2 ghc ==9.2.4 ghc ==9.4.1+homepage: https://github.com/adetokunbo/redis-glob#readme+bug-reports: https://github.com/adetokunbo/redis-glob/issues+synopsis: Specify valid redis globs+description:+ Supplies functions that parse and use redis glob patterns+ I.e, glob-matching works as it does in redis commands like+ [KEYS](https://redis.io/commands/keys/)++category: Web+build-type: Simple+extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/adetokunbo/redis-glob.git++flag use-doc-tests+ description: Run the doctests+ default: False++library+ exposed-modules:+ Redis.Glob.Internal+ Redis.Glob++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wincomplete-uni-patterns -fwarn-tabs+ build-depends:+ base >=4.11 && <5.0,+ ascii-char >=1.0 && <1.1,+ ascii-superset >=1.0 && <1.1,+ bytestring >=0.10 && <0.13,+ megaparsec >=9.2.1 && <9.4++ if impl(ghc >=8.4)+ ghc-options: -Wpartial-fields++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules: Redis.GlobSpec+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs+ build-depends:+ base,+ QuickCheck,+ redis-glob,+ hspec >=2.1,+ bytestring,+ ascii-char,+ ascii-superset++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: doctest+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs+ build-depends:+ base,+ doctest >=0.8,+ redis-glob++ if flag(use-doc-tests)++ else+ buildable: False
+ src/Redis/Glob.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Module : Redis.Glob+Copyright : (c) 2022 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++Provides functions to validate and use redis @glob@ patterns.++Assumes that the non-printable ASCII characters are __not__ matched.+-}+module Redis.Glob (+ -- * validate and match using redis globs+ validate,+ matches,+) where++import Data.ByteString.Lazy (ByteString)+import Redis.Glob.Internal (fromParts, matchParts, parseParts)+++{- $setup+ >>> import Data.ByteString.Lazy (ByteString)+ >>> import Redis.Glob.Internal+ >>> :set -XOverloadedStrings+-}+++{- | Confirm that a glob @pattern@ is valid++the result is:+- @Nothing@ when the pattern is invalid+- Just @norm@, where norm is a normalized version of the @pattern@+++==== __Examples__++>>> validate "hel?o"+Just "hel?o"++>>> validate "hel[i-m]o"+Just "hel[i-m]o"++>>> validate "hell[i-]o"+Nothing+-}+validate :: ByteString -> Maybe ByteString+validate = fmap fromParts . parseParts+++{- | Confirm that a @target@ 'ByteString' matches the @pattern@ defined by another.++the result is:+- 'False' when the pattern is invalid or does not match @target@+- otherwise it's 'True'+++==== __Examples__++>>> "hello" `matches` "hel?o"+True++>>> "hello world" `matches` "[^m-z]el[i-m]o w*"+True++>>> "yello world" `matches` "[^m-z]el[i-m]o w???d"+False+-}+matches :: ByteString -> ByteString -> Bool+matches target patt = maybe False (matchParts target) $ parseParts patt
+ src/Redis/Glob/Internal.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Module : Redis.Glob.Internal+Copyright : (c) 2022 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3++Provides types that model redis @glob@ patterns and combinators that can be used+to validate and interpret them.++Assumes that @glob@ do __not__ match the non-printable ASCII characters.+-}+module Redis.Glob.Internal (+ -- * modelling @Globs@+ Part (..),+ InSquare (..),++ -- * parse / print valid @Globs@+ parseParts,+ parsePart,+ fromParts,+ fromPart,++ -- * useful combinators+ reduceMany,+ matchParts,+) where++import qualified ASCII.Char as A+import qualified ASCII.Superset as A+import Data.ByteString.Builder (Builder, toLazyByteString, word8)+import Data.ByteString.Lazy (ByteString)+import Data.Functor (($>))+import Data.Maybe (isJust, mapMaybe)+import Data.Void (Void)+import Data.Word (Word8)+import Text.Megaparsec+import qualified Text.Megaparsec.Byte as P+++-- | Parse type for parsing @'ByteString'-like@+type Parser s m = (MonadParsec Void s m, Token s ~ Word8)+++parseInSquare :: (Parser s m, Token s ~ Word8) => m a -> m a+parseInSquare = between (P.char leftSquare) (P.char rightSquare)+++notLeftSquare :: Parser s m => m Word8+notLeftSquare = satisfy (\x -> not $ hasRole x && x < 128)+++notRightSquare :: Parser s m => m Word8+notRightSquare = satisfy (\x -> x /= rightSquare && x < 128)+++escapedChar :: Parser s m => m Word8+escapedChar = P.char backslash *> P.asciiChar+++matchable :: Parser s m => m Word8+matchable = try escapedChar <|> notLeftSquare+++parseInRange :: Parser s m => m InSquare+parseInRange = do+ start <- notRightSquare+ _dash <- P.char dash+ InRange start <$> P.asciiChar+++parseAnyInSquare :: Parser s m => m InSquare+parseAnyInSquare =+ choice+ [ try $ Single <$> escapedChar+ , try parseInRange+ , Single <$> notRightSquare+ ]+++parseSquared :: Parser s m => m Part+parseSquared = parseInSquare $ do+ isNegated <- optional $ P.char hat+ x <- parseAnyInSquare+ xs <- many parseAnyInSquare+ pure $ maybe (Squared x xs) (const $ Negated x xs) isNegated+++parseUnescaped :: Parser s m => m Part+parseUnescaped = do+ choice1 <- matchable+ others <- many matchable+ pure $ Unescaped choice1 others+++parseAnyPart :: Parser s m => m Part+parseAnyPart =+ choice+ [ P.char star $> Many+ , P.char qmark $> Any+ , parseSquared+ , parseUnescaped+ ]+++-- | Parse several @'Part'@ from a glob @pattern@+parseParts :: ByteString -> Maybe [Part]+parseParts = parseMaybe $ many parseAnyPart+++-- | Parse a single @'Part'@ from a glob @pattern@+parsePart :: ByteString -> Maybe Part+parsePart = parseMaybe parseAnyPart+++-- | Represents part of a valid redis glob pattern.+data Part+ = Any+ | Many+ | GenerousMany+ | Unescaped Word8 [Word8]+ | Squared InSquare [InSquare]+ | Negated InSquare [InSquare]+ deriving (Eq, Show)+++-- | Represents part of a valid redis glob pattern.+data InSquare+ = Single Word8+ | InRange Word8 Word8+ deriving (Eq, Show)+++-- | Confirm that a @target@ 'ByteString' matches the pattern provided as @['Part']@.+matchParts :: ByteString -> [Part] -> Bool+matchParts target = isJust . flip parseAsMatcher target+++parseAsMatcher :: [Part] -> ByteString -> Maybe [Word8]+parseAsMatcher parts = parseMaybe $ matcher parts+++matcher :: Parser s m => [Part] -> m [Word8]+matcher = foldr matcherStep (pure mempty) . reduceMany+++{- | Normalise parsed @'Part's@++All but a terminating @Many@ are replaced with GenerousMany;+Consecutive @Many@s are replaced by a single GenerousMany+-}+reduceMany :: [Part] -> [Part]+reduceMany =+ let step Many [] = [Many]+ step Many (Many : xs) = GenerousMany : xs+ step Many (GenerousMany : xs) = GenerousMany : xs+ step Many xs = GenerousMany : xs+ step x xs = x : xs+ in foldr step []+++matcherStep :: Parser s m => Part -> m [Word8] -> m [Word8]+-- assumes the Part comes from the output of reduceMany; then only the last+-- element will be Many and the accumulator can be replaced in this way+matcherStep Many _ = many P.asciiChar+matcherStep GenerousMany acc = innerStar_ acc+matcherStep (Unescaped x xs) acc = mapM P.char (x : xs) `thenParse` acc+matcherStep (Squared x xs) acc = squaredParser x xs `thenParse'` acc+matcherStep (Negated x xs) acc = negatedParser x xs `thenParse'` acc+matcherStep Any acc = P.asciiChar `thenParse'` acc+++thenParse :: Parser s m => m [Word8] -> m [Word8] -> m [Word8]+thenParse x y = foldr (:) <$> x <*> y+++thenParse' :: Parser s m => m Word8 -> m [Word8] -> m [Word8]+thenParse' x y = (:) <$> x <*> y+++innerStar_ :: (Parser s m, Token s ~ Word8) => m a -> m a+innerStar_ = fmap snd . innerStar+++innerStar :: (Parser s m, Token s ~ Word8) => m a -> m ([Word8], a)+innerStar parser = do+ (a, b) <- someTill_ P.asciiChar parser+ pure (a, b)+++singleOf :: InSquare -> Maybe Word8+singleOf (Single x) = Just x+singleOf _ = Nothing+++rangeOf :: InSquare -> Maybe (Word8, Word8)+rangeOf (InRange x y) | x <= y = Just (x, y)+rangeOf (InRange x y) = Just (y, x)+rangeOf _ = Nothing+++boundedBy :: (Bool -> Bool) -> [Word8] -> [(Word8, Word8)] -> Word8 -> Bool+boundedBy orNor ys xs z = orNor $ z `elem` ys || any (\(x, y) -> z >= x && z <= y) xs+++squaredParser :: Parser s m => InSquare -> [InSquare] -> m Word8+squaredParser x xs =+ let xs' = x : xs+ in satisfy $ boundedBy id (mapMaybe singleOf xs') (mapMaybe rangeOf xs')+++negatedParser :: Parser s m => InSquare -> [InSquare] -> m Word8+negatedParser x xs =+ let xs' = x : xs+ in satisfy $ boundedBy not (mapMaybe singleOf xs') (mapMaybe rangeOf xs')+++-- | Convert a @'Part'@ to the form it would be parsed from+fromPart :: Part -> ByteString+fromPart = toLazyByteString . builderOf+++-- | Convert several @'Part's@ to the form they can be parsed from.+fromParts :: [Part] -> ByteString+fromParts = toLazyByteString . mconcat . map builderOf+++class BuilderOf a where+ builderOf :: a -> Builder+++instance BuilderOf InSquare where+ builderOf (Single x) = escaped8 x+ builderOf (InRange x y) = word8 x <> word8 dash <> word8 y+++instance BuilderOf Part where+ builderOf Any = word8 qmark+ builderOf Many = word8 star+ builderOf GenerousMany = word8 star+ builderOf (Unescaped x xs) = escaped8 x <> mconcat (map escaped8 xs)+ builderOf (Squared x xs) = inSquare $ builderOf x <> mconcat (map builderOf xs)+ builderOf (Negated x xs) = inSquare $ word8 hat <> builderOf x <> mconcat (map builderOf xs)+++escaped8 :: Word8 -> Builder+escaped8 x | hasRole x = escaped x+escaped8 x = word8 x+++escaped :: Word8 -> Builder+escaped = (word8 backslash <>) . word8+++hasRole :: Word8 -> Bool+hasRole x = x == star || x == backslash || x == leftSquare || x == qmark+++inSquare :: Builder -> Builder+inSquare inside = word8 leftSquare <> inside <> word8 rightSquare+++hat, qmark, star, leftSquare, rightSquare, dash, backslash :: Word8+hat = A.fromChar A.Caret+qmark = A.fromChar A.QuestionMark+star = A.fromChar A.Asterisk+leftSquare = A.fromChar A.LeftSquareBracket+rightSquare = A.fromChar A.RightSquareBracket+dash = A.fromChar A.HyphenMinus+backslash = A.fromChar A.Backslash
+ test/Redis/GlobSpec.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_HADDOCK prune not-home #-}++{- |+Module : Redis.GlobSpec+Copyright : (c) 2022 Tim Emiola+Maintainer : Tim Emiola <adetokunbo@emio.la>+SPDX-License-Identifier: BSD3+-}+module Redis.GlobSpec (spec, genWithOkPatterns) where++import qualified ASCII.Char as A+import qualified ASCII.Superset as A+import qualified Data.ByteString.Lazy as BL+import Data.Word (Word8)+import Redis.Glob+import Redis.Glob.Internal+import Test.Hspec+import Test.QuickCheck+++spec :: Spec+spec = describe "Glob" $ do+ context "parsePart" $+ it "should roundtrip with 'fromPart'" prop_trip++ context "parseParts" $+ it "should roundtrip with 'fromParts'" prop_multi_trip++ context "matches" $ do+ context "generated targets" $ do+ it "should match patterns" prop_match+++prop_multi_trip :: Property+prop_multi_trip =+ withMaxSuccess 15000 $+ forAll (listOf genTwoParts) $ \ps -> do+ let allParts = concat ps+ parseParts (fromParts allParts) == Just allParts+++prop_trip :: Property+prop_trip =+ withMaxSuccess 15000 $+ forAll genParts $+ \p -> parsePart (fromPart p) == Just p+++prop_match :: Property+prop_match = forAll genWithOkPatterns checkOkPatterns+++-- Avoid generating:+-- An InRange that starts with hat; this parses correctly except when it's the first item+-- A single that just contains a dash; surrounded by other singles this mimicks InRange+-- An InRange with that starts with a dash, when preceded by a single this parses as the wrong InRange+-- A single 'hat', when it is first char, it changes a Squared to a Negated+genInSquare :: Gen InSquare+genInSquare =+ frequency+ [ (3, Single <$> avoidElem [A.Caret, A.HyphenMinus] genInnerChar)+ , (1, InRange <$> avoidElem [A.Caret, A.HyphenMinus, A.Backslash] genInnerChar <*> genInnerChar)+ ]+++genParts :: Gen Part+genParts =+ frequency+ [ (3, pure Any)+ , (1, pure Many)+ , (1, Squared <$> genInSquare <*> smallListOf genInSquare)+ , (1, Negated <$> genInSquare <*> smallListOf genInSquare)+ , (10, Unescaped <$> genPrintable <*> smallListOf genPrintable)+ ]+++-- when testing the parsing of list of parts, to ensure that no two succesive+-- parts are unescaped, the list of parts is generated in twos, where the first+-- part cannot be unescaped+genTwoParts :: Gen [Part]+genTwoParts = do+ part <- genParts+ special <- genSpecials+ pure [special, part]+++checkOkPatterns :: (BL.ByteString, [BL.ByteString]) -> Bool+checkOkPatterns (target, patterns) = all (target `matches`) patterns+++genWithOkPatterns :: Gen (BL.ByteString, [BL.ByteString])+genWithOkPatterns = do+ target <- genTarget+ isThisOk <- listOf1 $ replaceUsing' replacers target+ pure (BL.pack target, map BL.pack isThisOk)+++-- TODO: Ideally, to test matches:+-- generate target, a [Word8] of length n that will be packed into a ByteString+-- determine m < n+-- generate m [Part]+-- changedIndices <- shuffle the list [0..n], pick the first m+-- zip changeIndices with type of replacement+-- yield the pattern bytes obtained by applying each replacement in turn+--+-- At the moment, only one Word8 is changed at a time, i.e, each pattern has+-- just one match++replaceUsing' :: [Word8 -> Gen Part] -> [Word8] -> Gen [Word8]+replaceUsing' fs xs = do+ n <- chooseInt (0, length xs - 1)+ f <- elements fs+ ys <- f $ xs !! n+ pure $ take n xs <> BL.unpack (fromPart ys) <> drop (n + 1) xs+++goodChoice :: Word8 -> Gen Part+goodChoice x = Squared (Single x) <$> smallListOf genInSquare+++goodRange :: Word8 -> Gen Part+goodRange x = Squared <$> goodInRange x <*> smallListOf genInSquare+++smallListOf :: Gen a -> Gen [a]+smallListOf aGen = do+ small <- choose (1, 5)+ resize small (listOf aGen)+++goodInRange :: Word8 -> Gen InSquare+goodInRange x = do+ start <- genSimpleChar `suchThat` (<= x)+ end <- genSimpleChar `suchThat` (>= x)+ pure $ InRange start end+++replacers :: [Word8 -> Gen Part]+replacers = [goodChoice, goodRange, const $ pure Many, const $ pure Any]+++genTarget :: Gen [Word8]+genTarget = BL.unpack . fromPart <$> genBase+++genBase :: Gen Part+genBase = Unescaped <$> genSimpleChar <*> listOf genSimpleChar+++genSpecials :: Gen Part+genSpecials =+ frequency+ [ (3, pure Any)+ , (1, pure Many)+ , (1, Squared <$> genInSquare <*> smallListOf genInSquare)+ , (1, Negated <$> genInSquare <*> smallListOf genInSquare)+ ]+++genPrintable :: Gen Word8+genPrintable = chooseEnum (32, 127)+++genInnerChar :: Gen Word8+genInnerChar = genPrintable `suchThat` (/= A.fromChar A.RightSquareBracket)+++genSimpleChar :: Gen Word8+genSimpleChar = avoidElem notSimpleChars genInnerChar+++notSimpleChars :: [A.Char]+notSimpleChars =+ [ A.Backslash+ , A.LeftSquareBracket+ , A.QuestionMark+ , A.Caret+ , A.HyphenMinus+ , A.Asterisk+ ]+++avoidElem :: [A.Char] -> Gen Word8 -> Gen Word8+avoidElem xs = (`suchThat` (\x -> x `notElem` map A.fromChar xs))
+ test/Spec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified Redis.GlobSpec as Glob+import System.IO (+ BufferMode (..),+ hSetBuffering,+ stderr,+ stdout,+ )+import Test.Hspec+++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering+ hspec $ do+ Glob.spec