diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,52 @@ +# redis-glob + +[![GitHub CI](https://github.com/adetokunbo/redis-glob/actions/workflows/ci.yml/badge.svg)](https://github.com/adetokunbo/redis-glob/actions) +[![Stackage Nightly](http://stackage.org/package/redis-glob/badge/nightly)](http://stackage.org/nightly/package/redis-glob) +[![Hackage][hackage-badge]][hackage] +[![Hackage Dependencies][hackage-deps-badge]][hackage-deps] +[![BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](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]: +[hackage-deps]: +[hackage-badge]: +[hackage]: +[KEYS]: +[redis glob]: diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + + +main = defaultMain diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,6 @@ +-- file doctests.hs +import Test.DocTest + + +main :: IO () +main = doctest ["src"] diff --git a/redis-glob.cabal b/redis-glob.cabal new file mode 100644 --- /dev/null +++ b/redis-glob.cabal @@ -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 diff --git a/src/Redis/Glob.hs b/src/Redis/Glob.hs new file mode 100644 --- /dev/null +++ b/src/Redis/Glob.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_HADDOCK prune not-home #-} + +{- | +Module : Redis.Glob +Copyright : (c) 2022 Tim Emiola +Maintainer : Tim Emiola +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 diff --git a/src/Redis/Glob/Internal.hs b/src/Redis/Glob/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Redis/Glob/Internal.hs @@ -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 +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 diff --git a/test/Redis/GlobSpec.hs b/test/Redis/GlobSpec.hs new file mode 100644 --- /dev/null +++ b/test/Redis/GlobSpec.hs @@ -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 +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)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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