From 073283b3c8720a9468fcdec4caeb103b50619f50 Mon Sep 17 00:00:00 2001 From: Johannes Hilden Date: Mon, 18 Sep 2023 11:27:24 +0300 Subject: [PATCH 01/17] Updates to reflect spec changes --- src/Web/Sqids/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index ddd06a3..001dc4a 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -83,7 +83,7 @@ emptySqidsContext = SqidsContext Text.empty 0 [] -- | Errors that can occur during encoding and decoding. data SqidsError = SqidsAlphabetTooShort - -- ^ The alphabet must be at least 5 characters long. + -- ^ The alphabet must be at least 3 characters long. | SqidsAlphabetRepeatedCharacters -- ^ The provided alphabet contains duplicate characters. E.g., "abcdefgg" is -- not a valid alphabet. @@ -115,7 +115,7 @@ sqidsOptions SqidsOptions{..} = do let alphabetLetterCount = letterCount alphabet -- Check the length of the alphabet - when (Text.length alphabet < 5) $ + when (Text.length alphabet < 3) $ throwError SqidsAlphabetTooShort -- Check that the alphabet has only unique characters From d4fab89c61043fa63cedcbb5708cccd12d648c66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Mon, 9 Oct 2023 08:05:27 +0300 Subject: [PATCH 02/17] Update package config --- package.yaml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/package.yaml b/package.yaml index d052305..e68798f 100644 --- a/package.yaml +++ b/package.yaml @@ -17,6 +17,10 @@ extra-source-files: dependencies: - base >= 4.7 && < 5 +- text >= 2.0.2 && < 2.1.0 +- containers >= 0.6.7 && < 0.7.0 +- mtl >= 2.2.2 && < 2.4.0 +- transformers >= 0.5.6.2 && < 0.7.0.0 ghc-options: - -Wall @@ -32,10 +36,7 @@ ghc-options: library: source-dirs: src dependencies: - - text >= 2.0.2 && < 2.1.0 - - containers >= 0.6.7 && < 0.7.0 - - mtl >= 2.2.2 && < 2.4.0 - - transformers >= 0.5.6.2 && < 0.7.0.0 + - sqids tests: sqids-test: @@ -47,8 +48,5 @@ tests: - -with-rtsopts=-N dependencies: - sqids - - text >= 2.0.2 && < 2.1.0 - - containers >= 0.6.7 && < 0.7.0 - - mtl >= 2.2.2 && < 2.4.0 - hspec >= 2.10.10 && < 2.12 - split >= 0.2.3.5 && < 0.3.0.0 From e73c65a78438a1a9a5de4e36e3fe56000b9801a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 11:16:23 +0300 Subject: [PATCH 03/17] Implement new spec --- src/Web/Sqids.hs | 27 +-- src/Web/Sqids/Internal.hs | 329 ++++++++++++++++++++----------- test/Spec.hs | 23 +-- test/Web/Sqids/AlphabetTests.hs | 60 ++++-- test/Web/Sqids/BlocklistTests.hs | 120 +++++------ test/Web/Sqids/EncodingTests.hs | 182 ++++++++--------- test/Web/Sqids/InternalTests.hs | 278 +++++++++++++------------- test/Web/Sqids/MinLengthTests.hs | 112 +++++------ test/Web/Sqids/ShuffleTests.hs | 78 ++++---- test/Web/Sqids/UniquesTests.hs | 54 ++--- 10 files changed, 708 insertions(+), 555 deletions(-) diff --git a/src/Web/Sqids.hs b/src/Web/Sqids.hs index 055a89c..946c643 100644 --- a/src/Web/Sqids.hs +++ b/src/Web/Sqids.hs @@ -1,16 +1,17 @@ module Web.Sqids - ( sqidsVersion - , defaultSqidsOptions - , SqidsOptions(..) - , SqidsError(..) - , MonadSqids(..) - , sqidsOptions - , SqidsT - , runSqidsT - , sqidsT - , Sqids - , runSqids - , sqids - ) where + where +-- ( sqidsVersion +-- , defaultSqidsOptions +-- , SqidsOptions(..) +-- , SqidsError(..) +-- , MonadSqids(..) +-- , sqidsOptions +-- , SqidsT +-- , runSqidsT +-- , sqidsT +-- , Sqids +-- , runSqids +-- , sqids +-- ) where import Web.Sqids.Internal diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index f81eb73..010dad0 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -1,32 +1,36 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} + +{-# LANGUAGE OverloadedStrings #-} + module Web.Sqids.Internal - ( sqidsVersion - , SqidsOptions(..) - , SqidsError(..) - , SqidsContext(..) - , emptySqidsContext - , defaultSqidsOptions - , SqidsStack - , MonadSqids(..) - , sqidsOptions - , SqidsT(..) - , Sqids(..) - , runSqidsT - , sqidsT - , runSqids - , sqids - , filteredBlocklist - , rearrangeAlphabet - , encodeNumbers - , decodeWithAlphabet - , decodeStep - , shuffle - , toId - , toNumber - , isBlockedId - ) where + where +-- ( sqidsVersion +-- , SqidsOptions(..) +-- , SqidsError(..) +-- , SqidsContext(..) +-- , emptySqidsContext +-- , defaultSqidsOptions +-- , SqidsStack +-- , MonadSqids(..) +-- , sqidsOptions +-- , SqidsT(..) +-- , Sqids(..) +-- , runSqidsT +-- , sqidsT +-- , runSqids +-- , sqids +-- , filteredBlocklist +-- , rearrangeAlphabet +-- , encodeNumbers +-- , decodeWithAlphabet +-- , decodeStep +-- , shuffle +-- , toId +-- , toNumber +-- , isBlockedId +-- ) where import Control.Monad (when, (>=>)) import Control.Monad.Except (ExceptT, runExceptT, MonadError, throwError) @@ -44,6 +48,7 @@ import Data.List (foldl', unfoldr) import Data.Text (Text) import Web.Sqids.Blocklist (defaultBlocklist) import Web.Sqids.Utils.Internal (letterCount, swapChars, wordsNoLongerThan, unsafeIndex, unsafeUncons) +import Debug.Trace import qualified Data.Text as Text @@ -79,30 +84,42 @@ data SqidsContext = SqidsContext emptySqidsContext :: SqidsContext emptySqidsContext = SqidsContext Text.empty 0 [] --- | Errors that can occur during encoding and decoding. data SqidsError - = SqidsAlphabetTooShort - -- ^ The alphabet must be at least 5 characters long. + = SqidsNegativeNumberInInput + | SqidsMaxAttempts + | SqidsAlphabetTooShort | SqidsAlphabetRepeatedCharacters - -- ^ The provided alphabet contains duplicate characters. E.g., "abcdefgg" is - -- not a valid alphabet. | SqidsInvalidMinLength - -- ^ The given `minLength` value is not within the valid range. - | SqidsNegativeNumberInInput - -- ^ One or more numbers in the list passed to `encode` are negative. Only - -- non-negative integers can be used as input. deriving (Show, Read, Eq, Ord) +---- | Errors that can occur during encoding and decoding. +--data SqidsError +-- = SqidsAlphabetTooShort +-- -- ^ The alphabet must be at least 5 characters long. +-- | SqidsAlphabetRepeatedCharacters +-- -- ^ The provided alphabet contains duplicate characters. E.g., "abcdefgg" is +-- -- not a valid alphabet. +-- | SqidsInvalidMinLength +-- -- ^ The given `minLength` value is not within the valid range. +-- | SqidsNegativeNumberInInput +-- -- ^ One or more numbers in the list passed to `encode` are negative. Only +-- -- non-negative integers can be used as input. +-- deriving (Show, Read, Eq, Ord) + type SqidsStack m = ReaderT SqidsContext (ExceptT SqidsError m) class (Monad m) => MonadSqids m where - -- | Encode a list of integers into an ID - encode :: [Int] -- ^ A list of non-negative integers to encode - -> m Text -- ^ Returns the generated ID + encode :: (Integral a) => [a] -> m Text + decode :: (Integral a) => Text -> m [a] - -- | Decode an ID back into a list of integers - decode :: Text -- ^ The encoded ID - -> m [Int] -- ^ Returns a list of integers +--class (Monad m) => MonadSqids m where +-- -- | Encode a list of integers into an ID +-- encode :: [Int] -- ^ A list of non-negative integers to encode +-- -> m Text -- ^ Returns the generated ID +-- +-- -- | Decode an ID back into a list of integers +-- decode :: Text -- ^ The encoded ID +-- -> m [Int] -- ^ Returns a list of integers -- | Sqids constructor sqidsOptions @@ -114,7 +131,7 @@ sqidsOptions SqidsOptions{..} = do let alphabetLetterCount = letterCount alphabet -- Check the length of the alphabet - when (Text.length alphabet < 5) $ + when (Text.length alphabet < 3) $ throwError SqidsAlphabetTooShort -- Check that the alphabet has only unique characters @@ -122,7 +139,7 @@ sqidsOptions SqidsOptions{..} = do throwError SqidsAlphabetRepeatedCharacters -- Validate min. length - when (minLength < 0 || minLength > alphabetLetterCount) $ + when (minLength < 0 || minLength > 255) $ throwError SqidsInvalidMinLength pure $ SqidsContext @@ -154,9 +171,10 @@ instance (Monad m) => MonadSqids (SqidsT m) where -- Don't allow negative integers throwError SqidsNegativeNumberInInput | otherwise = - encodeNumbers numbers False + encodeNumbers numbers 0 - decode sqid = asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid + decode sqid = + asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid newtype Sqids a = Sqids { unwrapSqids :: SqidsT Identity a } deriving @@ -228,39 +246,62 @@ filteredBlocklist alph ws = filter isValid (Text.map toLower <$> ws) where isValid w = Text.length w >= 3 && Text.all (`Text.elem` lowercaseAlphabet) w lowercaseAlphabet = Text.map toLower alph -decodeStep :: (Text, Text) -> Maybe (Int, (Text, Text)) +--decodeStep :: (Text, Text) -> Maybe (Int, (Text, Text)) +--decodeStep (sqid, alph) +-- | Text.null sqid = Nothing +-- | otherwise = +-- case Text.unsnoc alph of +-- Just (alphabetWithoutSeparator, separatorChar) -> +-- let separator = Text.singleton separatorChar +-- in case Text.splitOn separator sqid of +-- [] -> Nothing +-- (chunk : _) | not (Text.all (`Text.elem` alphabetWithoutSeparator) chunk) -> +-- Nothing +-- (chunk : chunks) -> Just +-- ( toNumber chunk alphabetWithoutSeparator +-- , (Text.intercalate separator chunks, shuffle alph) +-- ) +-- _ -> +-- error "decodeId: bad input" + +decodeStep :: (Integral a) => (Text, Text) -> Maybe (a, (Text, Text)) decodeStep (sqid, alph) | Text.null sqid = Nothing | otherwise = - case Text.unsnoc alph of - Just (alphabetWithoutSeparator, separatorChar) -> + case Text.uncons alph of + Just (separatorChar, alphabetWithoutSeparator) -> let separator = Text.singleton separatorChar in case Text.splitOn separator sqid of - [] -> Nothing - (chunk : _) | not (Text.all (`Text.elem` alphabetWithoutSeparator) chunk) -> + [] -> Nothing (chunk : chunks) -> Just ( toNumber chunk alphabetWithoutSeparator , (Text.intercalate separator chunks, shuffle alph) ) _ -> - error "decodeId: bad input" + error "decode: bad input" -decodeWithAlphabet :: Text -> Text -> [Int] +decodeWithAlphabet :: (Integral a) => Text -> Text -> [a] decodeWithAlphabet alph sqid | Text.null sqid || not (Text.all (`Text.elem` alph) sqid) = [] - | otherwise = unfoldr decodeStep initial + | otherwise = unfoldr decodeStep (slicedId, Text.reverse chars) where offset = unsafeIndex prefix alph - (prefix, next) = unsafeUncons sqid - (partition, chars) = - unsafeUncons (Text.drop (offset + 1) alph <> Text.take offset alph) - initial = - case Text.findIndex (== partition) next of - Just n | n > 0 && n < Text.length next - 1 -> - (Text.drop (n + 1) next, shuffle chars) - _ -> - (next, chars) + (prefix, slicedId) = unsafeUncons sqid + chars = Text.drop offset alph <> Text.take offset alph + +-- | otherwise = unfoldr decodeStep initial +-- where +-- offset = unsafeIndex prefix alph +-- (prefix, next) = unsafeUncons sqid +-- (partition, chars) = +-- unsafeUncons (Text.drop (offset + 1) alph <> Text.take offset alph) +-- initial = +-- case Text.findIndex (== partition) next of +-- Just n | n > 0 && n < Text.length next - 1 -> +-- (Text.drop (n + 1) next, shuffle chars) +-- _ -> +-- (next, chars) shuffle :: Text -> Text shuffle alph = @@ -272,22 +313,22 @@ shuffle alph = ordAt = ord . (chars `Text.index`) in swapChars i r chars -toId :: Int -> Text -> Text +toId :: (Integral a) => a -> Text -> Text toId num alph = Text.reverse (Text.unfoldr (fmap mu) (Just num)) where - len = Text.length alph + len = fromIntegral (Text.length alph) mu n = let (m, r) = n `divMod` len next = if m == 0 then Nothing else Just m - in (Text.index alph r, next) + in (Text.index alph (fromIntegral r), next) -toNumber :: Text -> Text -> Int +toNumber :: (Integral a) => Text -> Text -> a toNumber sqid alph = Text.foldl' mu 0 sqid where - len = Text.length alph + len = fromIntegral (Text.length alph) mu v c = case Text.findIndex (== c) alph of - Just n -> len * v + n + Just n -> len * v + fromIntegral n _ -> error "toNumber: bad input" isBlockedId :: [Text] -> Text -> Bool @@ -307,63 +348,123 @@ isBlockedId bls sqid = w `Text.isInfixOf` lowercaseSqid -- Rearrange alphabet so that second half goes in front of the first half -rearrangeAlphabet :: Text -> [Int] -> Text +rearrangeAlphabet :: (Integral a) => Text -> [a] -> Text rearrangeAlphabet alph numbers = - Text.drop offset alph <> Text.take offset alph + Text.drop offset alph <> Text.take offset alph where - len = Text.length alph offset = foldl' mu (length numbers) (zip numbers [0..]) `mod` len + len = Text.length alph + + mu :: (Integral a, Num b) => b -> (a, b) -> b mu a (v, i) = - let currentChar = Text.index alph (v `mod` len) - in ord currentChar + i + a + let currentChar = Text.index alph (fromIntegral (v `mod` fromIntegral len)) + in fromIntegral (ord currentChar) + i + a + +---- Rearrange alphabet so that second half goes in front of the first half +--rearrangeAlphabet :: Text -> [Int] -> Text +--rearrangeAlphabet alph numbers = +-- Text.drop offset alph <> Text.take offset alph +-- where +-- len = Text.length alph +-- offset = foldl' mu (length numbers) (zip numbers [0..]) `mod` len +-- mu a (v, i) = +-- let currentChar = Text.index alph (v `mod` len) +-- in ord currentChar + i + a encodeNumbers :: - ( MonadSqids m + ( Integral a + , MonadSqids m , MonadError SqidsError m , MonadReader SqidsContext m - ) => [Int] -> Bool -> m Text -encodeNumbers numbers partitioned = do + ) => [a] -> Int -> m Text +encodeNumbers numbers increment = do alph <- asks sqidsAlphabet - let (left, right) = Text.splitAt 2 (rearrangeAlphabet alph numbers) - case Text.unpack left of - prefix : partition : _ -> do - let run (r, chars) (n, i) - | i == length numbers - 1 = - (sqid, chars) - | otherwise = - (sqid <> Text.singleton delim, shuffle chars) - where - delim = if partitioned && i == 0 then partition else Text.last chars - sqid = r <> toId n (Text.init chars) - let (sqid, chars) = - foldl' run (Text.singleton prefix, right) (zip numbers [0..]) - (makeMinLength chars >=> checkAgainstBlocklist numbers) sqid - _ -> - error "encodeNumbers: implementation error" + when (increment > Text.length alph) $ + throwError SqidsMaxAttempts + let alphabet = rearrangeAlphabet alph numbers + let run (r, chars) (n, i) + | i == length numbers - 1 = + (sqid, chars) + | otherwise = + (sqid <> Text.singleton head_, shuffle chars) + where + (head_, tail_) = unsafeUncons chars + sqid = r <> toId n tail_ + let (sqid, chars) = + foldl' run (Text.singleton (Text.head alphabet), Text.reverse alphabet) (zip numbers [0..]) + (makeMinLength chars >=> checkAgainstBlocklist) sqid + where makeMinLength chars sqid = do minl <- asks sqidsMinLength - sqid' <- - if minl <= Text.length sqid || partitioned - then pure sqid - else encodeNumbers (0 : numbers) True - pure $ - if minl <= Text.length sqid' - then sqid' - else let extra = minl - Text.length sqid - in Text.cons (Text.head sqid') (Text.take extra chars <> Text.tail sqid') - - checkAgainstBlocklist nums sqid = do - bls <- asks sqidsBlocklist - if isBlockedId bls sqid then - case nums of - n : ns | partitioned -> - if n == maxBound - then error "encodeNumbers: out of range" - else encodeNumbers (n + 1 : ns) True - n : ns -> - encodeNumbers (0 : n : ns) True - _ -> - error "encodeNumbers: implementation error" - else + if minl > Text.length sqid + then + let len = Text.length chars + go (chars_, sqid_) = do + let diff = minl - Text.length sqid_ + shuffled = shuffle chars_ + aaa = Text.take (min diff len) shuffled + if diff > 0 + then go (shuffled, sqid_ <> aaa) + else sqid_ + in + pure (go (chars, Text.snoc sqid (Text.head chars))) + else pure sqid + + checkAgainstBlocklist sqid = do + blocklist <- asks sqidsBlocklist + if isBlockedId blocklist sqid + then encodeNumbers numbers (succ increment) + else pure sqid + +--encodeNumbers :: +-- ( MonadSqids m +-- , MonadError SqidsError m +-- , MonadReader SqidsContext m +-- ) => [Int] -> Bool -> m Text +--encodeNumbers numbers partitioned = do +-- alph <- asks sqidsAlphabet +-- let (left, right) = Text.splitAt 2 (rearrangeAlphabet alph numbers) +-- case Text.unpack left of +-- prefix : partition : _ -> do +-- let run (r, chars) (n, i) +-- | i == length numbers - 1 = +-- (sqid, chars) +-- | otherwise = +-- (sqid <> Text.singleton delim, shuffle chars) +-- where +-- delim = if partitioned && i == 0 then partition else Text.last chars +-- sqid = r <> toId n (Text.init chars) +-- let (sqid, chars) = +-- foldl' run (Text.singleton prefix, right) (zip numbers [0..]) +-- (makeMinLength chars >=> checkAgainstBlocklist numbers) sqid +-- _ -> +-- error "encodeNumbers: implementation error" +-- where +-- makeMinLength chars sqid = do +-- minl <- asks sqidsMinLength +-- sqid' <- +-- if minl <= Text.length sqid || partitioned +-- then pure sqid +-- else encodeNumbers (0 : numbers) True +-- pure $ +-- if minl <= Text.length sqid' +-- then sqid' +-- else let extra = minl - Text.length sqid +-- in Text.cons (Text.head sqid') (Text.take extra chars <> Text.tail sqid') +-- +-- checkAgainstBlocklist nums sqid = do +-- bls <- asks sqidsBlocklist +-- if isBlockedId bls sqid then +-- case nums of +-- n : ns | partitioned -> +-- if n == maxBound +-- then error "encodeNumbers: out of range" +-- else encodeNumbers (n + 1 : ns) True +-- n : ns -> +-- encodeNumbers (0 : n : ns) True +-- _ -> +-- error "encodeNumbers: implementation error" +-- else +-- pure sqid diff --git a/test/Spec.hs b/test/Spec.hs index bb0bd9f..150ee5b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,7 @@ import Test.Hspec (hspec, describe) import Web.Sqids.AlphabetTests (testAlphabet) import Web.Sqids.BlocklistTests (testBlocklist) import Web.Sqids.EncodingTests (testEncoding) -import Web.Sqids.InternalTests (testInternals) +--import Web.Sqids.InternalTests (testInternals) import Web.Sqids.MinLengthTests (testMinLength) import Web.Sqids.ShuffleTests (testShuffle) import Web.Sqids.UniquesTests (testUniques) @@ -10,15 +10,16 @@ import Web.Sqids.UniquesTests (testUniques) main :: IO () main = hspec $ do - describe "\nTest internals\n" $ do - testInternals - -- - -- Official tests from sqids-spec - -- + +-- describe "\nTest internals\n" $ do +-- testInternals +-- -- +-- -- Official tests from sqids-spec +-- -- describe "\nOfficial sqids-spec test cases\n" $ do testAlphabet - testBlocklist - testEncoding - testMinLength - testShuffle - testUniques +-- testBlocklist +-- testEncoding +-- testMinLength +-- testShuffle +-- testUniques diff --git a/test/Web/Sqids/AlphabetTests.hs b/test/Web/Sqids/AlphabetTests.hs index cffd20d..9ccd5c8 100644 --- a/test/Web/Sqids/AlphabetTests.hs +++ b/test/Web/Sqids/AlphabetTests.hs @@ -2,24 +2,24 @@ module Web.Sqids.AlphabetTests (testAlphabet) where import Control.Monad ((<=<)) +import Web.Sqids.Internal import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids testAlphabet :: SpecWith () testAlphabet = do + describe "alphabet" $ do it "simple" $ do let numbers = [1, 2, 3] - sqid = "4d9fd2" - - options = defaultSqidsOptions{ alphabet = "0123456789abcdef" } + let sqid = "489158" + let options = defaultSqidsOptions{ alphabet = "0123456789abcdef" } runSqids options (encode numbers) `shouldBe` Right sqid runSqids options (decode sqid) `shouldBe` Right numbers it "short alphabet" $ do let numbers = [1, 2, 3] - options = defaultSqidsOptions{ alphabet = "abcde" } + options = defaultSqidsOptions{ alphabet = "abc" } runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers @@ -29,10 +29,48 @@ testAlphabet = do runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers - it "repeating alphabet characters" $ - sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "aabcdefg" })) - `shouldBe` Left SqidsAlphabetRepeatedCharacters - - it "too short of an alphabet" $ - sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "abcd" })) + it "multibyte characters" $ do + sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "ë1092" })) `shouldBe` Left SqidsAlphabetTooShort + + + +--module Web.Sqids.AlphabetTests (testAlphabet) where +-- +--import Control.Monad ((<=<)) +--import Test.Hspec (SpecWith, describe, it, shouldBe) +--import Web.Sqids +-- +--testAlphabet :: SpecWith () +--testAlphabet = do +-- pure () +-- +-- describe "alphabet" $ do +-- it "simple" $ do +-- let numbers = [1, 2, 3] +-- sqid = "4d9fd2" +-- +-- options = defaultSqidsOptions{ alphabet = "0123456789abcdef" } +-- +-- runSqids options (encode numbers) `shouldBe` Right sqid +-- runSqids options (decode sqid) `shouldBe` Right numbers +-- +-- it "short alphabet" $ do +-- let numbers = [1, 2, 3] +-- options = defaultSqidsOptions{ alphabet = "abcde" } +-- +-- runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers +-- +-- it "long alphabet" $ do +-- let numbers = [1, 2, 3] +-- options = defaultSqidsOptions{ alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@#$%^&*()-_+|{}[];:'\"/?.>,<`~" } +-- +-- runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers +-- +-- it "repeating alphabet characters" $ +-- sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "aabcdefg" })) +-- `shouldBe` Left SqidsAlphabetRepeatedCharacters +-- +-- it "too short of an alphabet" $ +-- sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "abcd" })) +-- `shouldBe` Left SqidsAlphabetTooShort diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index 60d1e39..a4d3cdd 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -6,66 +6,68 @@ import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) import Web.Sqids -withEmptyBlocklist :: Sqids a -> Either SqidsError a -withEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = [] } - -withNonEmptyBlocklist :: Sqids a -> Either SqidsError a -withNonEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = ["AvTg"] } - -withCustomBlocklist :: [Text] -> Sqids a -> Either SqidsError a -withCustomBlocklist bls = runSqids defaultSqidsOptions { blocklist = bls } +--withEmptyBlocklist :: Sqids a -> Either SqidsError a +--withEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = [] } +-- +--withNonEmptyBlocklist :: Sqids a -> Either SqidsError a +--withNonEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = ["AvTg"] } +-- +--withCustomBlocklist :: [Text] -> Sqids a -> Either SqidsError a +--withCustomBlocklist bls = runSqids defaultSqidsOptions { blocklist = bls } testBlocklist :: SpecWith () testBlocklist = do - describe "blocklist" $ do - it "if no custom blocklist param, use the default blocklist" $ do - sqids (decode "sexy") `shouldBe` Right [ 200044 ] - sqids (encode [ 200044 ]) `shouldBe` Right "d171vI" - - it "if an empty blocklist param passed, don't use any blocklist" $ do - withEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] - withEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" - - it "if a non-empty blocklist param passed, use only that" $ do - withNonEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] - withNonEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" - - withNonEmptyBlocklist (decode "AvTg") `shouldBe` Right [ 100000 ] - withNonEmptyBlocklist (encode [ 100000 ]) `shouldBe` Right "7T1X8k" - withNonEmptyBlocklist (decode "7T1X8k") `shouldBe` Right [ 100000 ] - - it "blocklist" $ do - let bls = - [ "8QRLaD" -- Normal result of first encoding -- Let's block that word on purpose - , "7T1cd0dL" -- Result of second encoding - , "UeIe" -- Result of third encoding is `RA8UeIe7` - Let's block a substring - , "imhw" -- Result of 4th encoding is `WM3Limhw` - Let's block the postfix - , "LfUQ" -- Result of 4th encoding is `LfUQh4HN` - Let's block the prefix - ] - withCustomBlocklist bls (encode [1, 2, 3]) `shouldBe` Right "TM0x1Mxz" - withCustomBlocklist bls (decode "TM0x1Mxz") `shouldBe` Right [1, 2, 3] - - it "decoding blocklist words should still work" $ do - let bls = - [ "8QRLaD" - , "7T1cd0dL" - , "RA8UeIe7" - , "WM3Limhw" - , "LfUQh4HN" - ] - withCustomBlocklist bls (decode "8QRLaD") `shouldBe` Right [1, 2, 3] - withCustomBlocklist bls (decode "7T1cd0dL") `shouldBe` Right [1, 2, 3] - withCustomBlocklist bls (decode "RA8UeIe7") `shouldBe` Right [1, 2, 3] - withCustomBlocklist bls (decode "WM3Limhw") `shouldBe` Right [1, 2, 3] - withCustomBlocklist bls (decode "LfUQh4HN") `shouldBe` Right [1, 2, 3] - - it "match against a short blocklist word" $ - withCustomBlocklist [ "pPQ" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] + pure () - it "blocklist filtering in constructor" $ do - let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sqnmpn"] } - testFn = do - p <- encode [1, 2, 3] - q <- decode p - pure (p, q) - runSqids options testFn `shouldBe` Right ("ULPBZGBM", [1, 2, 3]) +-- describe "blocklist" $ do +-- it "if no custom blocklist param, use the default blocklist" $ do +-- sqids (decode "sexy") `shouldBe` Right [ 200044 ] +-- sqids (encode [ 200044 ]) `shouldBe` Right "d171vI" +-- +-- it "if an empty blocklist param passed, don't use any blocklist" $ do +-- withEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] +-- withEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" +-- +-- it "if a non-empty blocklist param passed, use only that" $ do +-- withNonEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] +-- withNonEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" +-- +-- withNonEmptyBlocklist (decode "AvTg") `shouldBe` Right [ 100000 ] +-- withNonEmptyBlocklist (encode [ 100000 ]) `shouldBe` Right "7T1X8k" +-- withNonEmptyBlocklist (decode "7T1X8k") `shouldBe` Right [ 100000 ] +-- +-- it "blocklist" $ do +-- let bls = +-- [ "8QRLaD" -- Normal result of first encoding -- Let's block that word on purpose +-- , "7T1cd0dL" -- Result of second encoding +-- , "UeIe" -- Result of third encoding is `RA8UeIe7` - Let's block a substring +-- , "imhw" -- Result of 4th encoding is `WM3Limhw` - Let's block the postfix +-- , "LfUQ" -- Result of 4th encoding is `LfUQh4HN` - Let's block the prefix +-- ] +-- withCustomBlocklist bls (encode [1, 2, 3]) `shouldBe` Right "TM0x1Mxz" +-- withCustomBlocklist bls (decode "TM0x1Mxz") `shouldBe` Right [1, 2, 3] +-- +-- it "decoding blocklist words should still work" $ do +-- let bls = +-- [ "8QRLaD" +-- , "7T1cd0dL" +-- , "RA8UeIe7" +-- , "WM3Limhw" +-- , "LfUQh4HN" +-- ] +-- withCustomBlocklist bls (decode "8QRLaD") `shouldBe` Right [1, 2, 3] +-- withCustomBlocklist bls (decode "7T1cd0dL") `shouldBe` Right [1, 2, 3] +-- withCustomBlocklist bls (decode "RA8UeIe7") `shouldBe` Right [1, 2, 3] +-- withCustomBlocklist bls (decode "WM3Limhw") `shouldBe` Right [1, 2, 3] +-- withCustomBlocklist bls (decode "LfUQh4HN") `shouldBe` Right [1, 2, 3] +-- +-- it "match against a short blocklist word" $ +-- withCustomBlocklist [ "pPQ" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] +-- +-- it "blocklist filtering in constructor" $ do +-- let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sqnmpn"] } +-- testFn = do +-- p <- encode [1, 2, 3] +-- q <- decode p +-- pure (p, q) +-- runSqids options testFn `shouldBe` Right ("ULPBZGBM", [1, 2, 3]) diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index 0a70641..c7b56cf 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -6,96 +6,98 @@ import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) import Web.Sqids -testEncodeDecodeAll :: [(Text, [Int])] -> IO () -testEncodeDecodeAll ss = - forM_ ss $ \(sqid, numbers) -> do - sqids (encode numbers) `shouldBe` Right sqid - sqids (decode sqid) `shouldBe` Right numbers +--testEncodeDecodeAll :: [(Text, [Int])] -> IO () +--testEncodeDecodeAll ss = +-- forM_ ss $ \(sqid, numbers) -> do +-- sqids (encode numbers) `shouldBe` Right sqid +-- sqids (decode sqid) `shouldBe` Right numbers testEncoding :: SpecWith () testEncoding = do - describe "encoding" $ do - it "simple" $ do - let numbers = [1, 2, 3] - sqid = "8QRLaD" - - sqids (encode numbers) `shouldBe` Right sqid - sqids (decode sqid) `shouldBe` Right numbers - - it "different inputs" $ do - let numbers = [0, 0, 0, 1, 2, 3, 100, 1000, 100000, 1000000, maxBound] - - sqids ((decode <=< encode) numbers) `shouldBe` Right numbers - - it "incremental numbers" $ do - testEncodeDecodeAll - [ ( "bV", [0] ) - , ( "U9", [1] ) - , ( "g8", [2] ) - , ( "Ez", [3] ) - , ( "V8", [4] ) - , ( "ul", [5] ) - , ( "O3", [6] ) - , ( "AF", [7] ) - , ( "ph", [8] ) - , ( "n8", [9] ) - ] - - it "incremental numbers, same index" $ do - testEncodeDecodeAll - [ ( "SrIu", [0, 0] ) - , ( "nZqE", [0, 1] ) - , ( "tJyf", [0, 2] ) - , ( "e86S", [0, 3] ) - , ( "rtC7", [0, 4] ) - , ( "sQ8R", [0, 5] ) - , ( "uz2n", [0, 6] ) - , ( "7Td9", [0, 7] ) - , ( "3nWE", [0, 8] ) - , ( "mIxM", [0, 9] ) - ] - - it "incremental numbers, same index 1" $ do - testEncodeDecodeAll - [ ( "SrIu", [0, 0] ) - , ( "nbqh", [1, 0] ) - , ( "t4yj", [2, 0] ) - , ( "eQ6L", [3, 0] ) - , ( "r4Cc", [4, 0] ) - , ( "sL82", [5, 0] ) - , ( "uo2f", [6, 0] ) - , ( "7Zdq", [7, 0] ) - , ( "36Wf", [8, 0] ) - , ( "m4xT", [9, 0] ) - ] - - it "multi input" $ do - let numbers = - [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 - , 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49 - , 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73 - , 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97 - , 98, 99 - ] - - Right numbers `shouldBe` sqids ((decode <=< encode) numbers) - - it "encoding no numbers" $ - - sqids (encode []) `shouldBe` Right "" - - it "decoding empty string" $ - - sqids (decode "") `shouldBe` Right [] - - it "decoding an ID with an invalid character" $ - - sqids (decode "*") `shouldBe` Right [] - - it "decoding an invalid ID with a repeating reserved character" $ - - sqids (decode "fff") `shouldBe` Right [] - - it "encoding out-of-range numbers" $ - - sqids (encode [-1]) `shouldBe` Left SqidsNegativeNumberInInput + pure () + +-- describe "encoding" $ do +-- it "simple" $ do +-- let numbers = [1, 2, 3] +-- sqid = "8QRLaD" +-- +-- sqids (encode numbers) `shouldBe` Right sqid +-- sqids (decode sqid) `shouldBe` Right numbers +-- +-- it "different inputs" $ do +-- let numbers = [0, 0, 0, 1, 2, 3, 100, 1000, 100000, 1000000, maxBound] +-- +-- sqids ((decode <=< encode) numbers) `shouldBe` Right numbers +-- +-- it "incremental numbers" $ do +-- testEncodeDecodeAll +-- [ ( "bV", [0] ) +-- , ( "U9", [1] ) +-- , ( "g8", [2] ) +-- , ( "Ez", [3] ) +-- , ( "V8", [4] ) +-- , ( "ul", [5] ) +-- , ( "O3", [6] ) +-- , ( "AF", [7] ) +-- , ( "ph", [8] ) +-- , ( "n8", [9] ) +-- ] +-- +-- it "incremental numbers, same index" $ do +-- testEncodeDecodeAll +-- [ ( "SrIu", [0, 0] ) +-- , ( "nZqE", [0, 1] ) +-- , ( "tJyf", [0, 2] ) +-- , ( "e86S", [0, 3] ) +-- , ( "rtC7", [0, 4] ) +-- , ( "sQ8R", [0, 5] ) +-- , ( "uz2n", [0, 6] ) +-- , ( "7Td9", [0, 7] ) +-- , ( "3nWE", [0, 8] ) +-- , ( "mIxM", [0, 9] ) +-- ] +-- +-- it "incremental numbers, same index 1" $ do +-- testEncodeDecodeAll +-- [ ( "SrIu", [0, 0] ) +-- , ( "nbqh", [1, 0] ) +-- , ( "t4yj", [2, 0] ) +-- , ( "eQ6L", [3, 0] ) +-- , ( "r4Cc", [4, 0] ) +-- , ( "sL82", [5, 0] ) +-- , ( "uo2f", [6, 0] ) +-- , ( "7Zdq", [7, 0] ) +-- , ( "36Wf", [8, 0] ) +-- , ( "m4xT", [9, 0] ) +-- ] +-- +-- it "multi input" $ do +-- let numbers = +-- [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 +-- , 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49 +-- , 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73 +-- , 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97 +-- , 98, 99 +-- ] +-- +-- Right numbers `shouldBe` sqids ((decode <=< encode) numbers) +-- +-- it "encoding no numbers" $ +-- +-- sqids (encode []) `shouldBe` Right "" +-- +-- it "decoding empty string" $ +-- +-- sqids (decode "") `shouldBe` Right [] +-- +-- it "decoding an ID with an invalid character" $ +-- +-- sqids (decode "*") `shouldBe` Right [] +-- +-- it "decoding an invalid ID with a repeating reserved character" $ +-- +-- sqids (decode "fff") `shouldBe` Right [] +-- +-- it "encoding out-of-range numbers" $ +-- +-- sqids (encode [-1]) `shouldBe` Left SqidsNegativeNumberInInput diff --git a/test/Web/Sqids/InternalTests.hs b/test/Web/Sqids/InternalTests.hs index 48910b2..33a92b5 100644 --- a/test/Web/Sqids/InternalTests.hs +++ b/test/Web/Sqids/InternalTests.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Web.Sqids.InternalTests (testInternals) where +module Web.Sqids.InternalTests where import Data.List (unfoldr) import Data.Text (Text, unpack) @@ -34,140 +34,142 @@ testSwapChars = do testSqidsOptions :: SpecWith () testSqidsOptions = - describe "sqidsOptions" $ do - it "too short alphabet" $ - sqids (sqidsOptions optionsWithShortAlphabet) `shouldBe` Left SqidsAlphabetTooShort - it "invalid alphabet" $ - sqids (sqidsOptions optionsWithInvalidAlphabet) `shouldBe` Left SqidsAlphabetRepeatedCharacters - it "invalid min length" $ - sqids (sqidsOptions optionsWithInvalidMinLength) `shouldBe` Left SqidsInvalidMinLength - it "valid options" $ - sqids (sqidsOptions optionsValid) `shouldBe` - Right (SqidsContext (shuffle (alphabet optionsValid)) (minLength optionsValid) (blocklist optionsValid)) - where - optionsWithShortAlphabet = SqidsOptions - { alphabet = "abc" - , minLength = 5 - , blocklist = [] - } - optionsWithInvalidAlphabet = SqidsOptions - { alphabet = "abcdefghijklmnopqrstuvwxyza" - , minLength = 5 - , blocklist = [] - } - optionsWithInvalidMinLength = SqidsOptions - { alphabet = "abcdefghijklmnopqrstuvwxyz" - , minLength = (-1) - , blocklist = [] - } - optionsValid = SqidsOptions - { alphabet = "abcdefghijklmnopqrstuvwxyz" - , minLength = 5 - , blocklist = [] - } - -testCuratedBlocklist :: SpecWith () -testCuratedBlocklist = - withTestData "filteredBlocklist" $ \case - alph : bls : result : _ -> - let msg = alph <> " " <> bls - ws = Text.splitOn "," bls - results = Text.splitOn "," result - in it msg (filteredBlocklist alph ws `shouldBe` results) - _ -> - error "testCuratedBlocklist: bad input" - -testShuffle :: SpecWith () -testShuffle = do - withTestData "shuffle" $ \case - input : result : _ -> - it input (shuffle input `shouldBe` result) - _ -> - error "testShuffle: bad input" - -testToId :: SpecWith () -testToId = do - withTestData "toId" $ \case - num : alph : result : _ -> - let msg = num <> " " <> alph - in it msg (toId (textRead num) alph `shouldBe` result) - _ -> - error "testToId: bad input" - -testToNumber :: SpecWith () -testToNumber = do - withTestData "toNumber" $ \case - sqid : alph : result : _ -> - let msg = sqid <> " " <> alph - in it msg (toNumber sqid alph `shouldBe` textRead result) - _ -> - error "testToNumber: bad input" - -testIsBlockedId :: SpecWith () -testIsBlockedId = do - withTestData "isBlockedId" $ \case - bls : sqid : result : _ -> - let msg = bls <> " " <> sqid - ws = Text.splitOn "," bls - in it msg (isBlockedId ws sqid == textRead result) - _ -> - error "testIsBlockedId: bad input" - -testEncode :: SpecWith () -testEncode = do - describe "encode" $ do - it "emtpy list" $ - sqids (encode []) `shouldBe` Right "" - it "list with negative values" $ - sqids (encode [1,2,3,-1,4]) `shouldBe` Left SqidsNegativeNumberInInput - - withTestData "encode" $ \case - alph : numbers : result : _ -> - let msg = alph <> " " <> numbers - nums = textRead <$> (Text.splitOn "," numbers) - in it msg (runSqids defaultSqidsOptions{ alphabet = alph } (encode nums) `shouldBe` Right result) - _ -> - error "testEncode: bad input" - -testEncodeWithMinLength :: SpecWith () -testEncodeWithMinLength = do - withTestData "encodeWithMinLength" $ \case - numbers : minlen : result : _ -> - let msg = numbers <> " " <> minlen - nums = textRead <$> (Text.splitOn "," numbers) - in it msg $ do - runSqids (defaultSqidsOptions{ minLength = textRead minlen }) (encode nums) `shouldBe` Right result - _ -> - error "testEncodeWithMinLength: bad input" - -testDecodeId :: SpecWith () -testDecodeId = do - withTestData "decodeId" $ \case - sqid : alph : result : _ -> - let msg = sqid <> " " <> alph - in it msg (unfoldr decodeStep (sqid, alph) `shouldBe` textRead result) - _ -> - error "testDecodeId: bad input" - -testDecodeWithAlphabet :: SpecWith () -testDecodeWithAlphabet = do - withTestData "decodeWithAlphabet" $ \case - alph : sqid : result : _ -> - let msg = alph <> " " <> sqid - in it msg (decodeWithAlphabet alph sqid `shouldBe` textRead result) - _ -> - error "testDecodeWithAlphabet: bad input" - -testInternals :: SpecWith () -testInternals = do - testSwapChars - testSqidsOptions - testToId - testToNumber - testShuffle - testCuratedBlocklist - testIsBlockedId - testEncode - testEncodeWithMinLength - testDecodeId - testDecodeWithAlphabet + pure () + +-- describe "sqidsOptions" $ do +-- it "too short alphabet" $ +-- sqids (sqidsOptions optionsWithShortAlphabet) `shouldBe` Left SqidsAlphabetTooShort +-- it "invalid alphabet" $ +-- sqids (sqidsOptions optionsWithInvalidAlphabet) `shouldBe` Left SqidsAlphabetRepeatedCharacters +-- it "invalid min length" $ +-- sqids (sqidsOptions optionsWithInvalidMinLength) `shouldBe` Left SqidsInvalidMinLength +-- it "valid options" $ +-- sqids (sqidsOptions optionsValid) `shouldBe` +-- Right (SqidsContext (shuffle (alphabet optionsValid)) (minLength optionsValid) (blocklist optionsValid)) +-- where +-- optionsWithShortAlphabet = SqidsOptions +-- { alphabet = "abc" +-- , minLength = 5 +-- , blocklist = [] +-- } +-- optionsWithInvalidAlphabet = SqidsOptions +-- { alphabet = "abcdefghijklmnopqrstuvwxyza" +-- , minLength = 5 +-- , blocklist = [] +-- } +-- optionsWithInvalidMinLength = SqidsOptions +-- { alphabet = "abcdefghijklmnopqrstuvwxyz" +-- , minLength = (-1) +-- , blocklist = [] +-- } +-- optionsValid = SqidsOptions +-- { alphabet = "abcdefghijklmnopqrstuvwxyz" +-- , minLength = 5 +-- , blocklist = [] +-- } +-- +--testCuratedBlocklist :: SpecWith () +--testCuratedBlocklist = +-- withTestData "filteredBlocklist" $ \case +-- alph : bls : result : _ -> +-- let msg = alph <> " " <> bls +-- ws = Text.splitOn "," bls +-- results = Text.splitOn "," result +-- in it msg (filteredBlocklist alph ws `shouldBe` results) +-- _ -> +-- error "testCuratedBlocklist: bad input" +-- +--testShuffle :: SpecWith () +--testShuffle = do +-- withTestData "shuffle" $ \case +-- input : result : _ -> +-- it input (shuffle input `shouldBe` result) +-- _ -> +-- error "testShuffle: bad input" +-- +--testToId :: SpecWith () +--testToId = do +-- withTestData "toId" $ \case +-- num : alph : result : _ -> +-- let msg = num <> " " <> alph +-- in it msg (toId (textRead num) alph `shouldBe` result) +-- _ -> +-- error "testToId: bad input" +-- +--testToNumber :: SpecWith () +--testToNumber = do +-- withTestData "toNumber" $ \case +-- sqid : alph : result : _ -> +-- let msg = sqid <> " " <> alph +-- in it msg (toNumber sqid alph `shouldBe` textRead result) +-- _ -> +-- error "testToNumber: bad input" +-- +--testIsBlockedId :: SpecWith () +--testIsBlockedId = do +-- withTestData "isBlockedId" $ \case +-- bls : sqid : result : _ -> +-- let msg = bls <> " " <> sqid +-- ws = Text.splitOn "," bls +-- in it msg (isBlockedId ws sqid == textRead result) +-- _ -> +-- error "testIsBlockedId: bad input" +-- +--testEncode :: SpecWith () +--testEncode = do +-- describe "encode" $ do +-- it "emtpy list" $ +-- sqids (encode []) `shouldBe` Right "" +-- it "list with negative values" $ +-- sqids (encode [1,2,3,-1,4]) `shouldBe` Left SqidsNegativeNumberInInput +-- +-- withTestData "encode" $ \case +-- alph : numbers : result : _ -> +-- let msg = alph <> " " <> numbers +-- nums = textRead <$> (Text.splitOn "," numbers) +-- in it msg (runSqids defaultSqidsOptions{ alphabet = alph } (encode nums) `shouldBe` Right result) +-- _ -> +-- error "testEncode: bad input" +-- +--testEncodeWithMinLength :: SpecWith () +--testEncodeWithMinLength = do +-- withTestData "encodeWithMinLength" $ \case +-- numbers : minlen : result : _ -> +-- let msg = numbers <> " " <> minlen +-- nums = textRead <$> (Text.splitOn "," numbers) +-- in it msg $ do +-- runSqids (defaultSqidsOptions{ minLength = textRead minlen }) (encode nums) `shouldBe` Right result +-- _ -> +-- error "testEncodeWithMinLength: bad input" +-- +--testDecodeId :: SpecWith () +--testDecodeId = do +-- withTestData "decodeId" $ \case +-- sqid : alph : result : _ -> +-- let msg = sqid <> " " <> alph +-- in it msg (unfoldr decodeStep (sqid, alph) `shouldBe` textRead result) +-- _ -> +-- error "testDecodeId: bad input" +-- +--testDecodeWithAlphabet :: SpecWith () +--testDecodeWithAlphabet = do +-- withTestData "decodeWithAlphabet" $ \case +-- alph : sqid : result : _ -> +-- let msg = alph <> " " <> sqid +-- in it msg (decodeWithAlphabet alph sqid `shouldBe` textRead result) +-- _ -> +-- error "testDecodeWithAlphabet: bad input" +-- +--testInternals :: SpecWith () +--testInternals = do +-- testSwapChars +-- testSqidsOptions +-- testToId +-- testToNumber +-- testShuffle +-- testCuratedBlocklist +-- testIsBlockedId +-- testEncode +-- testEncodeWithMinLength +-- testDecodeId +-- testDecodeWithAlphabet diff --git a/test/Web/Sqids/MinLengthTests.hs b/test/Web/Sqids/MinLengthTests.hs index ee52ccd..bc07afc 100644 --- a/test/Web/Sqids/MinLengthTests.hs +++ b/test/Web/Sqids/MinLengthTests.hs @@ -9,62 +9,64 @@ import Web.Sqids import qualified Data.Text as Text --- TODO: DRY -testEncodeDecodeAll :: [(Text, [Int])] -> IO () -testEncodeDecodeAll ss = do - let len = Text.length (defaultSqidsOptions & alphabet) - forM_ ss $ \(sqid, numbers) -> do - runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid - runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers +---- TODO: DRY +--testEncodeDecodeAll :: [(Text, [Int])] -> IO () +--testEncodeDecodeAll ss = do +-- let len = Text.length (defaultSqidsOptions & alphabet) +-- forM_ ss $ \(sqid, numbers) -> do +-- runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid +-- runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers testMinLength :: SpecWith () testMinLength = do - describe "minLength" $ do - it "simple" $ do - let numbers = [1, 2, 3] - sqid = "75JILToVsGerOADWmHlY38xvbaNZKQ9wdFS0B6kcMEtnRpgizhjU42qT1cd0dL" - len = Text.length (defaultSqidsOptions & alphabet) + pure () - runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid - runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers - - it "incremental numbers" $ - testEncodeDecodeAll - [ ( "jf26PLNeO5WbJDUV7FmMtlGXps3CoqkHnZ8cYd19yIiTAQuvKSExzhrRghBlwf", [0, 0] ) - , ( "vQLUq7zWXC6k9cNOtgJ2ZK8rbxuipBFAS10yTdYeRa3ojHwGnmMV4PDhESI2jL", [0, 1] ) - , ( "YhcpVK3COXbifmnZoLuxWgBQwtjsSaDGAdr0ReTHM16yI9vU8JNzlFq5Eu2oPp", [0, 2] ) - , ( "OTkn9daFgDZX6LbmfxI83RSKetJu0APihlsrYoz5pvQw7GyWHEUcN2jBqd4kJ9", [0, 3] ) - , ( "h2cV5eLNYj1x4ToZpfM90UlgHBOKikQFvnW36AC8zrmuJ7XdRytIGPawqYEbBe", [0, 4] ) - , ( "7Mf0HeUNkpsZOTvmcj836P9EWKaACBubInFJtwXR2DSzgYGhQV5i4lLxoT1qdU", [0, 5] ) - , ( "APVSD1ZIY4WGBK75xktMfTev8qsCJw6oyH2j3OnLcXRlhziUmpbuNEar05QCsI", [0, 6] ) - , ( "P0LUhnlT76rsWSofOeyRGQZv1cC5qu3dtaJYNEXwk8Vpx92bKiHIz4MgmiDOF7", [0, 7] ) - , ( "xAhypZMXYIGCL4uW0te6lsFHaPc3SiD1TBgw5O7bvodzjqUn89JQRfk2Nvm4JI", [0, 8] ) - , ( "94dRPIZ6irlXWvTbKywFuAhBoECQOVMjDJp53s2xeqaSzHY8nc17tmkLGwfGNl", [0, 9] ) - ] - - it "min lengths" $ do - let len = Text.length (defaultSqidsOptions & alphabet) - inputMinLengths = [0, 1, 5, 10, len] - inputNumbers = - [ [0] - , [0, 0, 0, 0, 0] - , [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] - , [100, 200, 300] - , [1000, 2000, 3000] - , [1000000] - , [maxBound :: Int] - ] - - forM_ ((,) <$> inputMinLengths <*> inputNumbers) $ \(mlen, numbers) -> do - let result = runSqids defaultSqidsOptions{ minLength = mlen } (encode numbers) - case result of - Left _ -> error "error: min lengths" - Right sqid -> do - sqid `shouldSatisfy` ((>= mlen) . Text.length) - sqids (decode sqid) `shouldBe` Right numbers - - it "out-of-range invalid min length" $ do - let len = Text.length (defaultSqidsOptions & alphabet) - - sqids (sqidsOptions defaultSqidsOptions{ minLength = (-1) }) `shouldBe` Left SqidsInvalidMinLength - sqids (sqidsOptions defaultSqidsOptions{ minLength = len + 1 }) `shouldBe` Left SqidsInvalidMinLength +-- describe "minLength" $ do +-- it "simple" $ do +-- let numbers = [1, 2, 3] +-- sqid = "75JILToVsGerOADWmHlY38xvbaNZKQ9wdFS0B6kcMEtnRpgizhjU42qT1cd0dL" +-- len = Text.length (defaultSqidsOptions & alphabet) +-- +-- runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid +-- runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers +-- +-- it "incremental numbers" $ +-- testEncodeDecodeAll +-- [ ( "jf26PLNeO5WbJDUV7FmMtlGXps3CoqkHnZ8cYd19yIiTAQuvKSExzhrRghBlwf", [0, 0] ) +-- , ( "vQLUq7zWXC6k9cNOtgJ2ZK8rbxuipBFAS10yTdYeRa3ojHwGnmMV4PDhESI2jL", [0, 1] ) +-- , ( "YhcpVK3COXbifmnZoLuxWgBQwtjsSaDGAdr0ReTHM16yI9vU8JNzlFq5Eu2oPp", [0, 2] ) +-- , ( "OTkn9daFgDZX6LbmfxI83RSKetJu0APihlsrYoz5pvQw7GyWHEUcN2jBqd4kJ9", [0, 3] ) +-- , ( "h2cV5eLNYj1x4ToZpfM90UlgHBOKikQFvnW36AC8zrmuJ7XdRytIGPawqYEbBe", [0, 4] ) +-- , ( "7Mf0HeUNkpsZOTvmcj836P9EWKaACBubInFJtwXR2DSzgYGhQV5i4lLxoT1qdU", [0, 5] ) +-- , ( "APVSD1ZIY4WGBK75xktMfTev8qsCJw6oyH2j3OnLcXRlhziUmpbuNEar05QCsI", [0, 6] ) +-- , ( "P0LUhnlT76rsWSofOeyRGQZv1cC5qu3dtaJYNEXwk8Vpx92bKiHIz4MgmiDOF7", [0, 7] ) +-- , ( "xAhypZMXYIGCL4uW0te6lsFHaPc3SiD1TBgw5O7bvodzjqUn89JQRfk2Nvm4JI", [0, 8] ) +-- , ( "94dRPIZ6irlXWvTbKywFuAhBoECQOVMjDJp53s2xeqaSzHY8nc17tmkLGwfGNl", [0, 9] ) +-- ] +-- +-- it "min lengths" $ do +-- let len = Text.length (defaultSqidsOptions & alphabet) +-- inputMinLengths = [0, 1, 5, 10, len] +-- inputNumbers = +-- [ [0] +-- , [0, 0, 0, 0, 0] +-- , [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] +-- , [100, 200, 300] +-- , [1000, 2000, 3000] +-- , [1000000] +-- , [maxBound :: Int] +-- ] +-- +-- forM_ ((,) <$> inputMinLengths <*> inputNumbers) $ \(mlen, numbers) -> do +-- let result = runSqids defaultSqidsOptions{ minLength = mlen } (encode numbers) +-- case result of +-- Left _ -> error "error: min lengths" +-- Right sqid -> do +-- sqid `shouldSatisfy` ((>= mlen) . Text.length) +-- sqids (decode sqid) `shouldBe` Right numbers +-- +-- it "out-of-range invalid min length" $ do +-- let len = Text.length (defaultSqidsOptions & alphabet) +-- +-- sqids (sqidsOptions defaultSqidsOptions{ minLength = (-1) }) `shouldBe` Left SqidsInvalidMinLength +-- sqids (sqidsOptions defaultSqidsOptions{ minLength = len + 1 }) `shouldBe` Left SqidsInvalidMinLength diff --git a/test/Web/Sqids/ShuffleTests.hs b/test/Web/Sqids/ShuffleTests.hs index db48ee7..2701057 100644 --- a/test/Web/Sqids/ShuffleTests.hs +++ b/test/Web/Sqids/ShuffleTests.hs @@ -7,41 +7,43 @@ import Web.Sqids.Internal (defaultSqidsOptions, alphabet, shuffle) testShuffle :: SpecWith () testShuffle = do - describe "shuffle" $ do - it "default shuffle, checking for randomness" $ - shuffle (defaultSqidsOptions & alphabet) - `shouldBe` "fwjBhEY2uczNPDiloxmvISCrytaJO4d71T0W3qnMZbXVHg6eR8sAQ5KkpLUGF9" - - it "numbers in the front, another check for randomness" $ - shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" - - it "swapping front 2 characters" $ do - shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" - shuffle "1023456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - `shouldBe` "xI3RUayk1MSolQK7e09zYmFpVXPwHiNrdfBJ6ZAT5uCWbntgcDsEqjv4hLG28O" - - it "swapping last 2 characters" $ do - shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" - shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXZY" - `shouldBe` "x038UaykZMSolIK7RzcbYmFpgXEPHiNr1d2VfGAT5uJWQetjvDswqn94hLC6BO" - - it "short alphabet" $ shuffle "0123456789" `shouldBe` "4086517392" - - it "really short alphabet" $ shuffle "12345" `shouldBe` "24135" - - it "lowercase alphabet" $ do - shuffle "abcdefghijklmnopqrstuvwxyz" - `shouldBe` "lbfziqvscptmyxrekguohwjand" - - it "uppercase alphabet" $ do - shuffle "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - `shouldBe` "ZXBNSIJQEDMCTKOHVWFYUPLRGA" - - it "bars" $ do - shuffle "▁▂▃▄▅▆▇█" `shouldBe` "▂▇▄▅▆▃▁█" - - it "bars with numbers" $ do - shuffle "▁▂▃▄▅▆▇█0123456789" `shouldBe` "14▅▂▇320▆75▄█96▃8▁" + pure () + +-- describe "shuffle" $ do +-- it "default shuffle, checking for randomness" $ +-- shuffle (defaultSqidsOptions & alphabet) +-- `shouldBe` "fwjBhEY2uczNPDiloxmvISCrytaJO4d71T0W3qnMZbXVHg6eR8sAQ5KkpLUGF9" +-- +-- it "numbers in the front, another check for randomness" $ +-- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +-- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" +-- +-- it "swapping front 2 characters" $ do +-- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +-- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" +-- shuffle "1023456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +-- `shouldBe` "xI3RUayk1MSolQK7e09zYmFpVXPwHiNrdfBJ6ZAT5uCWbntgcDsEqjv4hLG28O" +-- +-- it "swapping last 2 characters" $ do +-- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +-- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" +-- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXZY" +-- `shouldBe` "x038UaykZMSolIK7RzcbYmFpgXEPHiNr1d2VfGAT5uJWQetjvDswqn94hLC6BO" +-- +-- it "short alphabet" $ shuffle "0123456789" `shouldBe` "4086517392" +-- +-- it "really short alphabet" $ shuffle "12345" `shouldBe` "24135" +-- +-- it "lowercase alphabet" $ do +-- shuffle "abcdefghijklmnopqrstuvwxyz" +-- `shouldBe` "lbfziqvscptmyxrekguohwjand" +-- +-- it "uppercase alphabet" $ do +-- shuffle "ABCDEFGHIJKLMNOPQRSTUVWXYZ" +-- `shouldBe` "ZXBNSIJQEDMCTKOHVWFYUPLRGA" +-- +-- it "bars" $ do +-- shuffle "▁▂▃▄▅▆▇█" `shouldBe` "▂▇▄▅▆▃▁█" +-- +-- it "bars with numbers" $ do +-- shuffle "▁▂▃▄▅▆▇█0123456789" `shouldBe` "14▅▂▇320▆75▄█96▃8▁" diff --git a/test/Web/Sqids/UniquesTests.hs b/test/Web/Sqids/UniquesTests.hs index 4cf4399..50626c8 100644 --- a/test/Web/Sqids/UniquesTests.hs +++ b/test/Web/Sqids/UniquesTests.hs @@ -11,32 +11,34 @@ import Web.Sqids import qualified Data.Set as Set import qualified Data.Text as Text -upper :: Int -upper = 1000000 - -uniqueWithConfig :: SqidsOptions -> Int -> Int -> SpecWith () -uniqueWithConfig options offset n = do - let range = [offset .. offset + upper - 1] - ids = fromRight [] (runSqids options $ foldM f [] range) - it "count" $ - Set.size (foldl' (flip Set.insert) mempty ids) `shouldBe` upper - it "decode" $ - forM_ (zip (reverse ids) [offset ..]) $ \(sqid, i) -> - (runSqids options $ decode sqid) `shouldBe` Right (replicate n i) - where - f a i = (: a) <$> encode (replicate n i) +--upper :: Int +--upper = 1000000 +-- +--uniqueWithConfig :: SqidsOptions -> Int -> Int -> SpecWith () +--uniqueWithConfig options offset n = do +-- let range = [offset .. offset + upper - 1] +-- ids = fromRight [] (runSqids options $ foldM f [] range) +-- it "count" $ +-- Set.size (foldl' (flip Set.insert) mempty ids) `shouldBe` upper +-- it "decode" $ +-- forM_ (zip (reverse ids) [offset ..]) $ \(sqid, i) -> +-- (runSqids options $ decode sqid) `shouldBe` Right (replicate n i) +-- where +-- f a i = (: a) <$> encode (replicate n i) testUniques :: SpecWith () testUniques = do - describe "uniques" $ do - describe "with padding" $ - uniqueWithConfig defaultSqidsOptions { minLength = Text.length (defaultSqidsOptions & alphabet) } 0 1 - - describe "low ranges" $ - uniqueWithConfig defaultSqidsOptions 0 1 - - describe "high ranges" $ - uniqueWithConfig defaultSqidsOptions 100000000 1 - - describe "multi" $ - uniqueWithConfig defaultSqidsOptions 0 5 + pure () + +-- describe "uniques" $ do +-- describe "with padding" $ +-- uniqueWithConfig defaultSqidsOptions { minLength = Text.length (defaultSqidsOptions & alphabet) } 0 1 +-- +-- describe "low ranges" $ +-- uniqueWithConfig defaultSqidsOptions 0 1 +-- +-- describe "high ranges" $ +-- uniqueWithConfig defaultSqidsOptions 100000000 1 +-- +-- describe "multi" $ +-- uniqueWithConfig defaultSqidsOptions 0 5 From 624312ef5b7f1293e5f1cc618b52f904d6fb2ab3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 21:18:49 +0300 Subject: [PATCH 04/17] Update tests --- test/Spec.hs | 20 ++- test/Web/Sqids/AlphabetTests.hs | 50 ++----- test/Web/Sqids/BlocklistTests.hs | 148 +++++++++++-------- test/Web/Sqids/EncodingTests.hs | 181 ++++++++++++----------- test/Web/Sqids/InternalTests.hs | 239 +++++++++++++------------------ test/Web/Sqids/MinLengthTests.hs | 116 +++++++-------- test/Web/Sqids/ShuffleTests.hs | 49 ------- test/Web/Sqids/UniquesTests.hs | 44 ------ 8 files changed, 347 insertions(+), 500 deletions(-) delete mode 100644 test/Web/Sqids/ShuffleTests.hs delete mode 100644 test/Web/Sqids/UniquesTests.hs diff --git a/test/Spec.hs b/test/Spec.hs index 150ee5b..2963c72 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,7 @@ import Test.Hspec (hspec, describe) import Web.Sqids.AlphabetTests (testAlphabet) import Web.Sqids.BlocklistTests (testBlocklist) import Web.Sqids.EncodingTests (testEncoding) ---import Web.Sqids.InternalTests (testInternals) +import Web.Sqids.InternalTests (testInternals) import Web.Sqids.MinLengthTests (testMinLength) import Web.Sqids.ShuffleTests (testShuffle) import Web.Sqids.UniquesTests (testUniques) @@ -11,15 +11,13 @@ main :: IO () main = hspec $ do --- describe "\nTest internals\n" $ do --- testInternals --- -- --- -- Official tests from sqids-spec --- -- + describe "\nTest internals\n" $ do + testInternals + -- + -- Official tests from sqids-spec + -- describe "\nOfficial sqids-spec test cases\n" $ do testAlphabet --- testBlocklist --- testEncoding --- testMinLength --- testShuffle --- testUniques + testBlocklist + testEncoding + testMinLength diff --git a/test/Web/Sqids/AlphabetTests.hs b/test/Web/Sqids/AlphabetTests.hs index 9ccd5c8..49f8d3a 100644 --- a/test/Web/Sqids/AlphabetTests.hs +++ b/test/Web/Sqids/AlphabetTests.hs @@ -2,8 +2,8 @@ module Web.Sqids.AlphabetTests (testAlphabet) where import Control.Monad ((<=<)) -import Web.Sqids.Internal import Test.Hspec (SpecWith, describe, it, shouldBe) +import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) testAlphabet :: SpecWith () testAlphabet = do @@ -31,46 +31,12 @@ testAlphabet = do it "multibyte characters" $ do sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "ë1092" })) - `shouldBe` Left SqidsAlphabetTooShort - + `shouldBe` Left SqidsAlphabetContainsMultibyteCharacters + it "repeating characters" $ do + sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "aabcdefg" })) + `shouldBe` Left SqidsAlphabetRepeatedCharacters ---module Web.Sqids.AlphabetTests (testAlphabet) where --- ---import Control.Monad ((<=<)) ---import Test.Hspec (SpecWith, describe, it, shouldBe) ---import Web.Sqids --- ---testAlphabet :: SpecWith () ---testAlphabet = do --- pure () --- --- describe "alphabet" $ do --- it "simple" $ do --- let numbers = [1, 2, 3] --- sqid = "4d9fd2" --- --- options = defaultSqidsOptions{ alphabet = "0123456789abcdef" } --- --- runSqids options (encode numbers) `shouldBe` Right sqid --- runSqids options (decode sqid) `shouldBe` Right numbers --- --- it "short alphabet" $ do --- let numbers = [1, 2, 3] --- options = defaultSqidsOptions{ alphabet = "abcde" } --- --- runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers --- --- it "long alphabet" $ do --- let numbers = [1, 2, 3] --- options = defaultSqidsOptions{ alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@#$%^&*()-_+|{}[];:'\"/?.>,<`~" } --- --- runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers --- --- it "repeating alphabet characters" $ --- sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "aabcdefg" })) --- `shouldBe` Left SqidsAlphabetRepeatedCharacters --- --- it "too short of an alphabet" $ --- sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "abcd" })) --- `shouldBe` Left SqidsAlphabetTooShort + it "too short of an alphabet" $ do + sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "ab" })) + `shouldBe` Left SqidsAlphabetTooShort diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index a4d3cdd..17eb79d 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -4,70 +4,92 @@ module Web.Sqids.BlocklistTests (testBlocklist) where import Control.Monad ((>=>)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids +import Web.Sqids (SqidsOptions(..), SqidsError(..), Sqids(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) +import Web.Sqids.Internal (sqidsAlphabet, sqidsBlocklist) +import qualified Data.Text as Text ---withEmptyBlocklist :: Sqids a -> Either SqidsError a ---withEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = [] } --- ---withNonEmptyBlocklist :: Sqids a -> Either SqidsError a ---withNonEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = ["AvTg"] } --- ---withCustomBlocklist :: [Text] -> Sqids a -> Either SqidsError a ---withCustomBlocklist bls = runSqids defaultSqidsOptions { blocklist = bls } +withEmptyBlocklist :: Sqids a -> Either SqidsError a +withEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = [] } + +withNonEmptyBlocklist :: Sqids a -> Either SqidsError a +withNonEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = ["ArUO"] } + +withCustomBlocklist :: [Text] -> Sqids a -> Either SqidsError a +withCustomBlocklist bls = runSqids defaultSqidsOptions { blocklist = bls } testBlocklist :: SpecWith () testBlocklist = do - pure () - --- describe "blocklist" $ do --- it "if no custom blocklist param, use the default blocklist" $ do --- sqids (decode "sexy") `shouldBe` Right [ 200044 ] --- sqids (encode [ 200044 ]) `shouldBe` Right "d171vI" --- --- it "if an empty blocklist param passed, don't use any blocklist" $ do --- withEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] --- withEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" --- --- it "if a non-empty blocklist param passed, use only that" $ do --- withNonEmptyBlocklist (decode "sexy") `shouldBe` Right [ 200044 ] --- withNonEmptyBlocklist (encode [ 200044 ]) `shouldBe` Right "sexy" --- --- withNonEmptyBlocklist (decode "AvTg") `shouldBe` Right [ 100000 ] --- withNonEmptyBlocklist (encode [ 100000 ]) `shouldBe` Right "7T1X8k" --- withNonEmptyBlocklist (decode "7T1X8k") `shouldBe` Right [ 100000 ] --- --- it "blocklist" $ do --- let bls = --- [ "8QRLaD" -- Normal result of first encoding -- Let's block that word on purpose --- , "7T1cd0dL" -- Result of second encoding --- , "UeIe" -- Result of third encoding is `RA8UeIe7` - Let's block a substring --- , "imhw" -- Result of 4th encoding is `WM3Limhw` - Let's block the postfix --- , "LfUQ" -- Result of 4th encoding is `LfUQh4HN` - Let's block the prefix --- ] --- withCustomBlocklist bls (encode [1, 2, 3]) `shouldBe` Right "TM0x1Mxz" --- withCustomBlocklist bls (decode "TM0x1Mxz") `shouldBe` Right [1, 2, 3] --- --- it "decoding blocklist words should still work" $ do --- let bls = --- [ "8QRLaD" --- , "7T1cd0dL" --- , "RA8UeIe7" --- , "WM3Limhw" --- , "LfUQh4HN" --- ] --- withCustomBlocklist bls (decode "8QRLaD") `shouldBe` Right [1, 2, 3] --- withCustomBlocklist bls (decode "7T1cd0dL") `shouldBe` Right [1, 2, 3] --- withCustomBlocklist bls (decode "RA8UeIe7") `shouldBe` Right [1, 2, 3] --- withCustomBlocklist bls (decode "WM3Limhw") `shouldBe` Right [1, 2, 3] --- withCustomBlocklist bls (decode "LfUQh4HN") `shouldBe` Right [1, 2, 3] --- --- it "match against a short blocklist word" $ --- withCustomBlocklist [ "pPQ" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] --- --- it "blocklist filtering in constructor" $ do --- let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sqnmpn"] } --- testFn = do --- p <- encode [1, 2, 3] --- q <- decode p --- pure (p, q) --- runSqids options testFn `shouldBe` Right ("ULPBZGBM", [1, 2, 3]) + + describe "blocklist" $ do + it "if no custom blocklist param, use the default blocklist" $ do + sqids (decode "aho1e") `shouldBe` Right [ 4572721 ] + sqids (encode [ 4572721 ]) `shouldBe` Right "JExTR" + + it "if an empty blocklist param passed, don't use any blocklist" $ do + withEmptyBlocklist (decode "aho1e") `shouldBe` Right [ 4572721 ] + withEmptyBlocklist (encode [ 4572721 ]) `shouldBe` Right "aho1e" + + it "if a non-empty blocklist param passed, use only that" $ do + -- Make sure we don't use the default blocklist + withNonEmptyBlocklist (decode "aho1e") `shouldBe` Right [ 4572721 ] + withNonEmptyBlocklist (encode [ 4572721 ]) `shouldBe` Right "aho1e" + + -- Make sure we are using the passed blocklist + withNonEmptyBlocklist (decode "ArUO") `shouldBe` Right [ 100000 ] + withNonEmptyBlocklist (encode [ 100000 ]) `shouldBe` Right "QyG4" + withNonEmptyBlocklist (decode "QyG4") `shouldBe` Right [ 100000 ] + + it "blocklist" $ do + let bls = + [ "JSwXFaosAN" -- Normal result of 1st encoding. Let's block that word on purpose + , "OCjV9JK64o" -- Result of 2nd encoding + , "rBHf" -- Result of 3rd encoding is `4rBHfOiqd3`. Let's block a substring + , "79SM" -- Result of 4th encoding is `dyhgw479SM`. Let's block the postfix + , "7tE6" -- Result of 4th encoding is `7tE6jdAHLe`. Let's block the prefix + ] + + withCustomBlocklist bls (encode [1000000, 2000000]) `shouldBe` Right "1aYeB7bRUt" + withCustomBlocklist bls (decode "1aYeB7bRUt") `shouldBe` Right [1000000, 2000000] + + it "decoding blocklist words should still work" $ do + let bls = + [ "86Rf07" + , "se8ojk" + , "ARsz1p" + , "Q8AI49" + , "5sQRZO" + ] + + withNonEmptyBlocklist (decode "86Rf07") `shouldBe` Right [ 1, 2, 3 ] + withNonEmptyBlocklist (decode "se8ojk") `shouldBe` Right [ 1, 2, 3 ] + withNonEmptyBlocklist (decode "ARsz1p") `shouldBe` Right [ 1, 2, 3 ] + withNonEmptyBlocklist (decode "Q8AI49") `shouldBe` Right [ 1, 2, 3 ] + withNonEmptyBlocklist (decode "5sQRZO") `shouldBe` Right [ 1, 2, 3 ] + + it "match against a short blocklist word" $ + withCustomBlocklist [ "pnd" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] + + it "blocklist filtering in constructor" $ do + let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sxnzkl"] } + testFn = do + p <- encode [1, 2, 3] + q <- decode p + pure (p, q) + runSqids options testFn `shouldBe` Right ("IBSHOZ", [1, 2, 3]) + + it "max encoding attempts" $ do + let alphabet = "abc" + blocklist = [ "cab", "abc", "bca" ] + minLength = 3 + options = defaultSqidsOptions + { alphabet = alphabet + , blocklist = blocklist + , minLength = minLength + } + + let Right config = runSqids defaultSqidsOptions (sqidsOptions options) + + Text.length (sqidsAlphabet config) `shouldBe` minLength + length (sqidsBlocklist config) `shouldBe` minLength + + runSqids options ((encode >=> decode) [0]) `shouldBe` Left SqidsMaxAttempts diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index c7b56cf..6c0f6e5 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -4,100 +4,95 @@ module Web.Sqids.EncodingTests (testEncoding) where import Control.Monad (forM_, (<=<)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids +import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) ---testEncodeDecodeAll :: [(Text, [Int])] -> IO () ---testEncodeDecodeAll ss = --- forM_ ss $ \(sqid, numbers) -> do --- sqids (encode numbers) `shouldBe` Right sqid --- sqids (decode sqid) `shouldBe` Right numbers +testEncodeDecodeAll :: [(Text, [Int])] -> IO () +testEncodeDecodeAll ss = + forM_ ss $ \(sqid, numbers) -> do + sqids (encode numbers) `shouldBe` Right sqid + sqids (decode sqid) `shouldBe` Right numbers testEncoding :: SpecWith () testEncoding = do - pure () - --- describe "encoding" $ do --- it "simple" $ do --- let numbers = [1, 2, 3] --- sqid = "8QRLaD" --- --- sqids (encode numbers) `shouldBe` Right sqid --- sqids (decode sqid) `shouldBe` Right numbers --- --- it "different inputs" $ do --- let numbers = [0, 0, 0, 1, 2, 3, 100, 1000, 100000, 1000000, maxBound] --- --- sqids ((decode <=< encode) numbers) `shouldBe` Right numbers --- --- it "incremental numbers" $ do --- testEncodeDecodeAll --- [ ( "bV", [0] ) --- , ( "U9", [1] ) --- , ( "g8", [2] ) --- , ( "Ez", [3] ) --- , ( "V8", [4] ) --- , ( "ul", [5] ) --- , ( "O3", [6] ) --- , ( "AF", [7] ) --- , ( "ph", [8] ) --- , ( "n8", [9] ) --- ] --- --- it "incremental numbers, same index" $ do --- testEncodeDecodeAll --- [ ( "SrIu", [0, 0] ) --- , ( "nZqE", [0, 1] ) --- , ( "tJyf", [0, 2] ) --- , ( "e86S", [0, 3] ) --- , ( "rtC7", [0, 4] ) --- , ( "sQ8R", [0, 5] ) --- , ( "uz2n", [0, 6] ) --- , ( "7Td9", [0, 7] ) --- , ( "3nWE", [0, 8] ) --- , ( "mIxM", [0, 9] ) --- ] --- --- it "incremental numbers, same index 1" $ do --- testEncodeDecodeAll --- [ ( "SrIu", [0, 0] ) --- , ( "nbqh", [1, 0] ) --- , ( "t4yj", [2, 0] ) --- , ( "eQ6L", [3, 0] ) --- , ( "r4Cc", [4, 0] ) --- , ( "sL82", [5, 0] ) --- , ( "uo2f", [6, 0] ) --- , ( "7Zdq", [7, 0] ) --- , ( "36Wf", [8, 0] ) --- , ( "m4xT", [9, 0] ) --- ] --- --- it "multi input" $ do --- let numbers = --- [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 --- , 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49 --- , 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73 --- , 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97 --- , 98, 99 --- ] --- --- Right numbers `shouldBe` sqids ((decode <=< encode) numbers) --- --- it "encoding no numbers" $ --- --- sqids (encode []) `shouldBe` Right "" --- --- it "decoding empty string" $ --- --- sqids (decode "") `shouldBe` Right [] --- --- it "decoding an ID with an invalid character" $ --- --- sqids (decode "*") `shouldBe` Right [] --- --- it "decoding an invalid ID with a repeating reserved character" $ --- --- sqids (decode "fff") `shouldBe` Right [] --- --- it "encoding out-of-range numbers" $ --- --- sqids (encode [-1]) `shouldBe` Left SqidsNegativeNumberInInput + + describe "encoding" $ do + it "simple" $ do + let numbers = [1, 2, 3] + sqid = "86Rf07" + + sqids (encode numbers) `shouldBe` Right sqid + sqids (decode sqid) `shouldBe` Right numbers + + it "different inputs" $ do + let numbers = [0, 0, 0, 1, 2, 3, 100, 1000, 100000, 1000000, maxBound] + + sqids ((decode <=< encode) numbers) `shouldBe` Right numbers + + it "incremental numbers" $ do + testEncodeDecodeAll + [ ( "bM", [0] ) + , ( "Uk", [1] ) + , ( "gb", [2] ) + , ( "Ef", [3] ) + , ( "Vq", [4] ) + , ( "uw", [5] ) + , ( "OI", [6] ) + , ( "AX", [7] ) + , ( "p6", [8] ) + , ( "nJ", [9] ) + ] + + it "incremental numbers, same index" $ do + testEncodeDecodeAll + [ ( "SvIz", [0, 0] ) + , ( "n3qa", [0, 1] ) + , ( "tryF", [0, 2] ) + , ( "eg6q", [0, 3] ) + , ( "rSCF", [0, 4] ) + , ( "sR8x", [0, 5] ) + , ( "uY2M", [0, 6] ) + , ( "74dI", [0, 7] ) + , ( "30WX", [0, 8] ) + , ( "moxr", [0, 9] ) + ] + + it "incremental numbers, same index 1" $ do + testEncodeDecodeAll + [ ( "SvIz", [0, 0] ) + , ( "nWqP", [1, 0] ) + , ( "tSyw", [2, 0] ) + , ( "eX68", [3, 0] ) + , ( "rxCY", [4, 0] ) + , ( "sV8a", [5, 0] ) + , ( "uf2K", [6, 0] ) + , ( "7Cdk", [7, 0] ) + , ( "3aWP", [8, 0] ) + , ( "m2xn", [9, 0] ) + ] + + it "multi input" $ do + let numbers = + [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 + , 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49 + , 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73 + , 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97 + , 98, 99 + ] + + Right numbers `shouldBe` sqids ((decode <=< encode) numbers) + + it "encoding no numbers" $ + + sqids (encode []) `shouldBe` Right "" + + it "decoding empty string" $ + + sqids (decode "") `shouldBe` Right [] + + it "decoding an ID with an invalid character" $ + + sqids (decode "*") `shouldBe` Right [] + + it "encoding out-of-range numbers" $ + + sqids (encode [-1]) `shouldBe` Left SqidsNegativeNumberInInput diff --git a/test/Web/Sqids/InternalTests.hs b/test/Web/Sqids/InternalTests.hs index 33a92b5..285770e 100644 --- a/test/Web/Sqids/InternalTests.hs +++ b/test/Web/Sqids/InternalTests.hs @@ -2,10 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Sqids.InternalTests where -import Data.List (unfoldr) import Data.Text (Text, unpack) import Test.Hspec hiding (it) -import Web.Sqids.Internal (toId, toNumber, shuffle, filteredBlocklist, sqidsOptions, sqids, runSqids, encode, decodeStep, decodeWithAlphabet, isBlockedId, defaultSqidsOptions, SqidsOptions(..), SqidsError(..), SqidsContext(..)) +import Web.Sqids (sqidsOptions, sqids, runSqids, encode, defaultSqidsOptions, SqidsOptions(..), SqidsError(..)) +import Web.Sqids.Internal (shuffle, toNumber, toId, isBlockedId, decodeWithAlphabet, decodeStep, filteredBlocklist, SqidsContext(..)) import Web.Sqids.Utils.Internal (swapChars) import qualified Data.Text as Text @@ -34,142 +34,101 @@ testSwapChars = do testSqidsOptions :: SpecWith () testSqidsOptions = - pure () --- describe "sqidsOptions" $ do --- it "too short alphabet" $ --- sqids (sqidsOptions optionsWithShortAlphabet) `shouldBe` Left SqidsAlphabetTooShort --- it "invalid alphabet" $ --- sqids (sqidsOptions optionsWithInvalidAlphabet) `shouldBe` Left SqidsAlphabetRepeatedCharacters --- it "invalid min length" $ --- sqids (sqidsOptions optionsWithInvalidMinLength) `shouldBe` Left SqidsInvalidMinLength --- it "valid options" $ --- sqids (sqidsOptions optionsValid) `shouldBe` --- Right (SqidsContext (shuffle (alphabet optionsValid)) (minLength optionsValid) (blocklist optionsValid)) --- where --- optionsWithShortAlphabet = SqidsOptions --- { alphabet = "abc" --- , minLength = 5 --- , blocklist = [] --- } --- optionsWithInvalidAlphabet = SqidsOptions --- { alphabet = "abcdefghijklmnopqrstuvwxyza" --- , minLength = 5 --- , blocklist = [] --- } --- optionsWithInvalidMinLength = SqidsOptions --- { alphabet = "abcdefghijklmnopqrstuvwxyz" --- , minLength = (-1) --- , blocklist = [] --- } --- optionsValid = SqidsOptions --- { alphabet = "abcdefghijklmnopqrstuvwxyz" --- , minLength = 5 --- , blocklist = [] --- } --- ---testCuratedBlocklist :: SpecWith () ---testCuratedBlocklist = --- withTestData "filteredBlocklist" $ \case --- alph : bls : result : _ -> --- let msg = alph <> " " <> bls --- ws = Text.splitOn "," bls --- results = Text.splitOn "," result --- in it msg (filteredBlocklist alph ws `shouldBe` results) --- _ -> --- error "testCuratedBlocklist: bad input" --- ---testShuffle :: SpecWith () ---testShuffle = do --- withTestData "shuffle" $ \case --- input : result : _ -> --- it input (shuffle input `shouldBe` result) --- _ -> --- error "testShuffle: bad input" --- ---testToId :: SpecWith () ---testToId = do --- withTestData "toId" $ \case --- num : alph : result : _ -> --- let msg = num <> " " <> alph --- in it msg (toId (textRead num) alph `shouldBe` result) --- _ -> --- error "testToId: bad input" --- ---testToNumber :: SpecWith () ---testToNumber = do --- withTestData "toNumber" $ \case --- sqid : alph : result : _ -> --- let msg = sqid <> " " <> alph --- in it msg (toNumber sqid alph `shouldBe` textRead result) --- _ -> --- error "testToNumber: bad input" --- ---testIsBlockedId :: SpecWith () ---testIsBlockedId = do --- withTestData "isBlockedId" $ \case --- bls : sqid : result : _ -> --- let msg = bls <> " " <> sqid --- ws = Text.splitOn "," bls --- in it msg (isBlockedId ws sqid == textRead result) --- _ -> --- error "testIsBlockedId: bad input" --- ---testEncode :: SpecWith () ---testEncode = do --- describe "encode" $ do --- it "emtpy list" $ --- sqids (encode []) `shouldBe` Right "" --- it "list with negative values" $ --- sqids (encode [1,2,3,-1,4]) `shouldBe` Left SqidsNegativeNumberInInput --- --- withTestData "encode" $ \case --- alph : numbers : result : _ -> --- let msg = alph <> " " <> numbers --- nums = textRead <$> (Text.splitOn "," numbers) --- in it msg (runSqids defaultSqidsOptions{ alphabet = alph } (encode nums) `shouldBe` Right result) --- _ -> --- error "testEncode: bad input" --- ---testEncodeWithMinLength :: SpecWith () ---testEncodeWithMinLength = do --- withTestData "encodeWithMinLength" $ \case --- numbers : minlen : result : _ -> --- let msg = numbers <> " " <> minlen --- nums = textRead <$> (Text.splitOn "," numbers) --- in it msg $ do --- runSqids (defaultSqidsOptions{ minLength = textRead minlen }) (encode nums) `shouldBe` Right result --- _ -> --- error "testEncodeWithMinLength: bad input" --- ---testDecodeId :: SpecWith () ---testDecodeId = do --- withTestData "decodeId" $ \case --- sqid : alph : result : _ -> --- let msg = sqid <> " " <> alph --- in it msg (unfoldr decodeStep (sqid, alph) `shouldBe` textRead result) --- _ -> --- error "testDecodeId: bad input" --- ---testDecodeWithAlphabet :: SpecWith () ---testDecodeWithAlphabet = do --- withTestData "decodeWithAlphabet" $ \case --- alph : sqid : result : _ -> --- let msg = alph <> " " <> sqid --- in it msg (decodeWithAlphabet alph sqid `shouldBe` textRead result) --- _ -> --- error "testDecodeWithAlphabet: bad input" --- ---testInternals :: SpecWith () ---testInternals = do --- testSwapChars --- testSqidsOptions --- testToId --- testToNumber --- testShuffle --- testCuratedBlocklist --- testIsBlockedId --- testEncode --- testEncodeWithMinLength --- testDecodeId --- testDecodeWithAlphabet + describe "sqidsOptions" $ do + it "too short alphabet" $ + sqids (sqidsOptions optionsWithShortAlphabet) `shouldBe` Left SqidsAlphabetTooShort + it "invalid alphabet" $ + sqids (sqidsOptions optionsWithInvalidAlphabet) `shouldBe` Left SqidsAlphabetRepeatedCharacters + it "invalid min length" $ + sqids (sqidsOptions optionsWithInvalidMinLength) `shouldBe` Left SqidsInvalidMinLength + it "valid options" $ + sqids (sqidsOptions optionsValid) `shouldBe` + Right (SqidsContext (shuffle (alphabet optionsValid)) (minLength optionsValid) (blocklist optionsValid)) + where + optionsWithShortAlphabet = SqidsOptions + { alphabet = "ab" + , minLength = 5 + , blocklist = [] + } + optionsWithInvalidAlphabet = SqidsOptions + { alphabet = "abcdefghijklmnopqrstuvwxyza" + , minLength = 5 + , blocklist = [] + } + optionsWithInvalidMinLength = SqidsOptions + { alphabet = "abcdefghijklmnopqrstuvwxyz" + , minLength = -1 + , blocklist = [] + } + optionsValid = SqidsOptions + { alphabet = "abcdefghijklmnopqrstuvwxyz" + , minLength = 5 + , blocklist = [] + } + +testCuratedBlocklist :: SpecWith () +testCuratedBlocklist = + withTestData "filteredBlocklist" $ \case + alph : bls : result : _ -> + let msg = alph <> " " <> bls + ws = Text.splitOn "," bls + results = Text.splitOn "," result + in it msg (filteredBlocklist alph ws `shouldBe` results) + _ -> + error "testCuratedBlocklist: bad input" + +testShuffle :: SpecWith () +testShuffle = do + withTestData "shuffle" $ \case + input : result : _ -> + it input (shuffle input `shouldBe` result) + _ -> + error "testShuffle: bad input" + +testToId :: SpecWith () +testToId = do + withTestData "toId" $ \case + num : alph : result : _ -> + let msg = num <> " " <> alph + in it msg (toId (textRead num) alph `shouldBe` result) + _ -> + error "testToId: bad input" + +testToNumber :: SpecWith () +testToNumber = do + withTestData "toNumber" $ \case + sqid : alph : result : _ -> + let msg = sqid <> " " <> alph + in it msg (toNumber sqid alph `shouldBe` textRead result) + _ -> + error "testToNumber: bad input" + +testIsBlockedId :: SpecWith () +testIsBlockedId = do + withTestData "isBlockedId" $ \case + bls : sqid : result : _ -> + let msg = bls <> " " <> sqid + ws = Text.splitOn "," bls + in it msg (isBlockedId ws sqid == textRead result) + _ -> + error "testIsBlockedId: bad input" + +testEncode :: SpecWith () +testEncode = do + describe "encode" $ do + it "emtpy list" $ + sqids (encode []) `shouldBe` Right "" + it "list with negative values" $ + sqids (encode [1,2,3,-1,4]) `shouldBe` Left SqidsNegativeNumberInInput + +testInternals :: SpecWith () +testInternals = do + testSwapChars + testSqidsOptions + testToId + testToNumber + testShuffle + testCuratedBlocklist + testIsBlockedId + testEncode diff --git a/test/Web/Sqids/MinLengthTests.hs b/test/Web/Sqids/MinLengthTests.hs index bc07afc..9d5b62b 100644 --- a/test/Web/Sqids/MinLengthTests.hs +++ b/test/Web/Sqids/MinLengthTests.hs @@ -5,68 +5,68 @@ import Control.Monad (forM_) import Data.Function ((&)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) -import Web.Sqids +import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) import qualified Data.Text as Text ----- TODO: DRY ---testEncodeDecodeAll :: [(Text, [Int])] -> IO () ---testEncodeDecodeAll ss = do --- let len = Text.length (defaultSqidsOptions & alphabet) --- forM_ ss $ \(sqid, numbers) -> do --- runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid --- runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers +testEncodeDecodeAll :: [(Int, Text)] -> IO () +testEncodeDecodeAll ss = + forM_ ss $ \(len, sqid) -> do + runSqids defaultSqidsOptions{ minLength = len } (encode [1, 2, 3]) `shouldBe` Right sqid + runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right [1, 2, 3] testMinLength :: SpecWith () testMinLength = do - pure () --- describe "minLength" $ do --- it "simple" $ do --- let numbers = [1, 2, 3] --- sqid = "75JILToVsGerOADWmHlY38xvbaNZKQ9wdFS0B6kcMEtnRpgizhjU42qT1cd0dL" --- len = Text.length (defaultSqidsOptions & alphabet) --- --- runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid --- runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers --- --- it "incremental numbers" $ --- testEncodeDecodeAll --- [ ( "jf26PLNeO5WbJDUV7FmMtlGXps3CoqkHnZ8cYd19yIiTAQuvKSExzhrRghBlwf", [0, 0] ) --- , ( "vQLUq7zWXC6k9cNOtgJ2ZK8rbxuipBFAS10yTdYeRa3ojHwGnmMV4PDhESI2jL", [0, 1] ) --- , ( "YhcpVK3COXbifmnZoLuxWgBQwtjsSaDGAdr0ReTHM16yI9vU8JNzlFq5Eu2oPp", [0, 2] ) --- , ( "OTkn9daFgDZX6LbmfxI83RSKetJu0APihlsrYoz5pvQw7GyWHEUcN2jBqd4kJ9", [0, 3] ) --- , ( "h2cV5eLNYj1x4ToZpfM90UlgHBOKikQFvnW36AC8zrmuJ7XdRytIGPawqYEbBe", [0, 4] ) --- , ( "7Mf0HeUNkpsZOTvmcj836P9EWKaACBubInFJtwXR2DSzgYGhQV5i4lLxoT1qdU", [0, 5] ) --- , ( "APVSD1ZIY4WGBK75xktMfTev8qsCJw6oyH2j3OnLcXRlhziUmpbuNEar05QCsI", [0, 6] ) --- , ( "P0LUhnlT76rsWSofOeyRGQZv1cC5qu3dtaJYNEXwk8Vpx92bKiHIz4MgmiDOF7", [0, 7] ) --- , ( "xAhypZMXYIGCL4uW0te6lsFHaPc3SiD1TBgw5O7bvodzjqUn89JQRfk2Nvm4JI", [0, 8] ) --- , ( "94dRPIZ6irlXWvTbKywFuAhBoECQOVMjDJp53s2xeqaSzHY8nc17tmkLGwfGNl", [0, 9] ) --- ] --- --- it "min lengths" $ do --- let len = Text.length (defaultSqidsOptions & alphabet) --- inputMinLengths = [0, 1, 5, 10, len] --- inputNumbers = --- [ [0] --- , [0, 0, 0, 0, 0] --- , [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] --- , [100, 200, 300] --- , [1000, 2000, 3000] --- , [1000000] --- , [maxBound :: Int] --- ] --- --- forM_ ((,) <$> inputMinLengths <*> inputNumbers) $ \(mlen, numbers) -> do --- let result = runSqids defaultSqidsOptions{ minLength = mlen } (encode numbers) --- case result of --- Left _ -> error "error: min lengths" --- Right sqid -> do --- sqid `shouldSatisfy` ((>= mlen) . Text.length) --- sqids (decode sqid) `shouldBe` Right numbers --- --- it "out-of-range invalid min length" $ do --- let len = Text.length (defaultSqidsOptions & alphabet) --- --- sqids (sqidsOptions defaultSqidsOptions{ minLength = (-1) }) `shouldBe` Left SqidsInvalidMinLength --- sqids (sqidsOptions defaultSqidsOptions{ minLength = len + 1 }) `shouldBe` Left SqidsInvalidMinLength + describe "minLength" $ do + it "simple" $ do + let numbers = [1, 2, 3] + sqid = "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTM" + len = Text.length (defaultSqidsOptions & alphabet) + + runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid + runSqids defaultSqidsOptions{ minLength = len } (decode sqid) `shouldBe` Right numbers + + it "incremental numbers" $ do + let len = Text.length (defaultSqidsOptions & alphabet) + testEncodeDecodeAll + [ ( 6, "86Rf07" ) + , ( 7, "86Rf07x" ) + , ( 8, "86Rf07xd" ) + , ( 9, "86Rf07xd4" ) + , ( 10, "86Rf07xd4z" ) + , ( 11, "86Rf07xd4zB" ) + , ( 12, "86Rf07xd4zBm" ) + , ( 13, "86Rf07xd4zBmi" ) + , ( len + 0, "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTM" ) + , ( len + 1, "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTMy" ) + , ( len + 2, "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTMyf" ) + , ( len + 3, "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTMyf1" ) + ] + + it "min lengths" $ do + let len = Text.length (defaultSqidsOptions & alphabet) + inputMinLengths = [0, 1, 5, 10, len] + inputNumbers = + [ [0] + , [0, 0, 0, 0, 0] + , [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] + , [100, 200, 300] + , [1000, 2000, 3000] + , [1000000] + , [maxBound :: Int] + ] + + forM_ ((,) <$> inputMinLengths <*> inputNumbers) $ \(mlen, numbers) -> do + let result = runSqids defaultSqidsOptions{ minLength = mlen } (encode numbers) + case result of + Left _ -> error "error: min lengths" + Right sqid -> do + sqid `shouldSatisfy` ((>= mlen) . Text.length) + sqids (decode sqid) `shouldBe` Right numbers + + it "out-of-range invalid min length" $ do + let len = Text.length (defaultSqidsOptions & alphabet) + + sqids (sqidsOptions defaultSqidsOptions{ minLength = -1 }) `shouldBe` Left SqidsInvalidMinLength + sqids (sqidsOptions defaultSqidsOptions{ minLength = 256 }) `shouldBe` Left SqidsInvalidMinLength diff --git a/test/Web/Sqids/ShuffleTests.hs b/test/Web/Sqids/ShuffleTests.hs deleted file mode 100644 index 2701057..0000000 --- a/test/Web/Sqids/ShuffleTests.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Web.Sqids.ShuffleTests (testShuffle) where - -import Test.Hspec (SpecWith, describe, it, shouldBe) -import Data.Function ((&)) -import Web.Sqids.Internal (defaultSqidsOptions, alphabet, shuffle) - -testShuffle :: SpecWith () -testShuffle = do - pure () - --- describe "shuffle" $ do --- it "default shuffle, checking for randomness" $ --- shuffle (defaultSqidsOptions & alphabet) --- `shouldBe` "fwjBhEY2uczNPDiloxmvISCrytaJO4d71T0W3qnMZbXVHg6eR8sAQ5KkpLUGF9" --- --- it "numbers in the front, another check for randomness" $ --- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" --- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" --- --- it "swapping front 2 characters" $ do --- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" --- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" --- shuffle "1023456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" --- `shouldBe` "xI3RUayk1MSolQK7e09zYmFpVXPwHiNrdfBJ6ZAT5uCWbntgcDsEqjv4hLG28O" --- --- it "swapping last 2 characters" $ do --- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" --- `shouldBe` "ec38UaynYXvoxSK7RV9uZ1D2HEPw6isrdzAmBNGT5OCJLk0jlFbtqWQ4hIpMgf" --- shuffle "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXZY" --- `shouldBe` "x038UaykZMSolIK7RzcbYmFpgXEPHiNr1d2VfGAT5uJWQetjvDswqn94hLC6BO" --- --- it "short alphabet" $ shuffle "0123456789" `shouldBe` "4086517392" --- --- it "really short alphabet" $ shuffle "12345" `shouldBe` "24135" --- --- it "lowercase alphabet" $ do --- shuffle "abcdefghijklmnopqrstuvwxyz" --- `shouldBe` "lbfziqvscptmyxrekguohwjand" --- --- it "uppercase alphabet" $ do --- shuffle "ABCDEFGHIJKLMNOPQRSTUVWXYZ" --- `shouldBe` "ZXBNSIJQEDMCTKOHVWFYUPLRGA" --- --- it "bars" $ do --- shuffle "▁▂▃▄▅▆▇█" `shouldBe` "▂▇▄▅▆▃▁█" --- --- it "bars with numbers" $ do --- shuffle "▁▂▃▄▅▆▇█0123456789" `shouldBe` "14▅▂▇320▆75▄█96▃8▁" diff --git a/test/Web/Sqids/UniquesTests.hs b/test/Web/Sqids/UniquesTests.hs deleted file mode 100644 index 50626c8..0000000 --- a/test/Web/Sqids/UniquesTests.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Web.Sqids.UniquesTests (testUniques) where - -import Control.Monad (foldM, forM_) -import Data.Either (fromRight) -import Data.Function ((&)) -import Data.List (foldl') -import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids - -import qualified Data.Set as Set -import qualified Data.Text as Text - ---upper :: Int ---upper = 1000000 --- ---uniqueWithConfig :: SqidsOptions -> Int -> Int -> SpecWith () ---uniqueWithConfig options offset n = do --- let range = [offset .. offset + upper - 1] --- ids = fromRight [] (runSqids options $ foldM f [] range) --- it "count" $ --- Set.size (foldl' (flip Set.insert) mempty ids) `shouldBe` upper --- it "decode" $ --- forM_ (zip (reverse ids) [offset ..]) $ \(sqid, i) -> --- (runSqids options $ decode sqid) `shouldBe` Right (replicate n i) --- where --- f a i = (: a) <$> encode (replicate n i) - -testUniques :: SpecWith () -testUniques = do - pure () - --- describe "uniques" $ do --- describe "with padding" $ --- uniqueWithConfig defaultSqidsOptions { minLength = Text.length (defaultSqidsOptions & alphabet) } 0 1 --- --- describe "low ranges" $ --- uniqueWithConfig defaultSqidsOptions 0 1 --- --- describe "high ranges" $ --- uniqueWithConfig defaultSqidsOptions 100000000 1 --- --- describe "multi" $ --- uniqueWithConfig defaultSqidsOptions 0 5 From ac396da9579187aa493c4573f669962e5b16b11f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 21:20:16 +0300 Subject: [PATCH 05/17] Add bytestring dependency --- package.yaml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index e68798f..ac289f9 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ dependencies: - containers >= 0.6.7 && < 0.7.0 - mtl >= 2.2.2 && < 2.4.0 - transformers >= 0.5.6.2 && < 0.7.0.0 +- bytestring >= 0.11.4.0 && < 0.12.0.0 ghc-options: - -Wall @@ -35,8 +36,6 @@ ghc-options: library: source-dirs: src - dependencies: - - sqids tests: sqids-test: From 2dbdba2f05eefd5628d8d17a1d6135335ff94546 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 21:23:05 +0300 Subject: [PATCH 06/17] Remove trailing white spaces --- test/Web/Sqids/BlocklistTests.hs | 14 +++++++------- test/Web/Sqids/EncodingTests.hs | 2 +- test/Web/Sqids/MinLengthTests.hs | 4 ++-- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index 17eb79d..e225542 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -40,7 +40,7 @@ testBlocklist = do withNonEmptyBlocklist (decode "QyG4") `shouldBe` Right [ 100000 ] it "blocklist" $ do - let bls = + let bls = [ "JSwXFaosAN" -- Normal result of 1st encoding. Let's block that word on purpose , "OCjV9JK64o" -- Result of 2nd encoding , "rBHf" -- Result of 3rd encoding is `4rBHfOiqd3`. Let's block a substring @@ -52,12 +52,12 @@ testBlocklist = do withCustomBlocklist bls (decode "1aYeB7bRUt") `shouldBe` Right [1000000, 2000000] it "decoding blocklist words should still work" $ do - let bls = + let bls = [ "86Rf07" , "se8ojk" , "ARsz1p" , "Q8AI49" - , "5sQRZO" + , "5sQRZO" ] withNonEmptyBlocklist (decode "86Rf07") `shouldBe` Right [ 1, 2, 3 ] @@ -70,7 +70,7 @@ testBlocklist = do withCustomBlocklist [ "pnd" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] it "blocklist filtering in constructor" $ do - let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sxnzkl"] } + let options = defaultSqidsOptions { alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", blocklist = ["sxnzkl"] } testFn = do p <- encode [1, 2, 3] q <- decode p @@ -79,13 +79,13 @@ testBlocklist = do it "max encoding attempts" $ do let alphabet = "abc" - blocklist = [ "cab", "abc", "bca" ] + blocklist = [ "cab", "abc", "bca" ] minLength = 3 - options = defaultSqidsOptions + options = defaultSqidsOptions { alphabet = alphabet , blocklist = blocklist , minLength = minLength - } + } let Right config = runSqids defaultSqidsOptions (sqidsOptions options) diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index 6c0f6e5..7bb9184 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -71,7 +71,7 @@ testEncoding = do ] it "multi input" $ do - let numbers = + let numbers = [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 , 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49 , 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73 diff --git a/test/Web/Sqids/MinLengthTests.hs b/test/Web/Sqids/MinLengthTests.hs index 9d5b62b..bc82174 100644 --- a/test/Web/Sqids/MinLengthTests.hs +++ b/test/Web/Sqids/MinLengthTests.hs @@ -20,8 +20,8 @@ testMinLength = do describe "minLength" $ do it "simple" $ do - let numbers = [1, 2, 3] - sqid = "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTM" + let numbers = [1, 2, 3] + sqid = "86Rf07xd4zBmiJXQG6otHEbew02c3PWsUOLZxADhCpKj7aVFv9I8RquYrNlSTM" len = Text.length (defaultSqidsOptions & alphabet) runSqids defaultSqidsOptions{ minLength = len } (encode numbers) `shouldBe` Right sqid From 7e5c6623208801e95b348d319eea7eb47133398d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 21:24:28 +0300 Subject: [PATCH 07/17] Update tests --- test/data/shuffle.txt | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 test/data/shuffle.txt diff --git a/test/data/shuffle.txt b/test/data/shuffle.txt deleted file mode 100644 index 5f32db3..0000000 --- a/test/data/shuffle.txt +++ /dev/null @@ -1,5 +0,0 @@ -abcd|bcad -abcdefghijklmnopqrstuvwxyz|lbfziqvscptmyxrekguohwjand -a|a -000|000 -aabbcc|acabbc From 0e166e060b3282940fc2e70be74e23aa8c99ae6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Wed, 11 Oct 2023 21:32:25 +0300 Subject: [PATCH 08/17] Update tests --- test/Spec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 2963c72..906f9b6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,8 +4,6 @@ import Web.Sqids.BlocklistTests (testBlocklist) import Web.Sqids.EncodingTests (testEncoding) import Web.Sqids.InternalTests (testInternals) import Web.Sqids.MinLengthTests (testMinLength) -import Web.Sqids.ShuffleTests (testShuffle) -import Web.Sqids.UniquesTests (testUniques) main :: IO () main = From b598f815fd51edaff84be11f7b4bbe5badd6cd3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Thu, 12 Oct 2023 10:30:33 +0300 Subject: [PATCH 09/17] Align implementation with latest spec --- sqids.cabal | 8 +- src/Web/Sqids.hs | 51 ++++-- src/Web/Sqids/Integer.hs | 40 +++++ src/Web/Sqids/Internal.hs | 275 ++++++++++--------------------- src/Web/Sqids/Utils/Internal.hs | 7 + test/Web/Sqids/BlocklistTests.hs | 36 ++-- test/Web/Sqids/EncodingTests.hs | 2 +- test/Web/Sqids/InternalTests.hs | 12 +- test/Web/Sqids/MinLengthTests.hs | 2 - test/data/shuffle.txt | 5 + 10 files changed, 209 insertions(+), 229 deletions(-) create mode 100644 src/Web/Sqids/Integer.hs create mode 100644 test/data/shuffle.txt diff --git a/sqids.cabal b/sqids.cabal index 37f16b0..5ba2d3f 100644 --- a/sqids.cabal +++ b/sqids.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack @@ -30,6 +30,7 @@ library exposed-modules: Web.Sqids Web.Sqids.Blocklist + Web.Sqids.Integer Web.Sqids.Internal Web.Sqids.Utils.Internal other-modules: @@ -39,6 +40,7 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , bytestring >=0.11.4.0 && <0.12.0.0 , containers >=0.6.7 && <0.7.0 , mtl >=2.2.2 && <2.4.0 , text >=2.0.2 && <2.1.0 @@ -54,18 +56,18 @@ test-suite sqids-test Web.Sqids.EncodingTests Web.Sqids.InternalTests Web.Sqids.MinLengthTests - Web.Sqids.ShuffleTests - Web.Sqids.UniquesTests Paths_sqids hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , bytestring >=0.11.4.0 && <0.12.0.0 , containers >=0.6.7 && <0.7.0 , hspec >=2.10.10 && <2.12 , mtl >=2.2.2 && <2.4.0 , split >=0.2.3.5 && <0.3.0.0 , sqids , text >=2.0.2 && <2.1.0 + , transformers >=0.5.6.2 && <0.7.0.0 default-language: Haskell2010 diff --git a/src/Web/Sqids.hs b/src/Web/Sqids.hs index 946c643..138c42f 100644 --- a/src/Web/Sqids.hs +++ b/src/Web/Sqids.hs @@ -1,17 +1,40 @@ module Web.Sqids - where --- ( sqidsVersion --- , defaultSqidsOptions --- , SqidsOptions(..) --- , SqidsError(..) --- , MonadSqids(..) --- , sqidsOptions --- , SqidsT --- , runSqidsT --- , sqidsT --- , Sqids --- , runSqids --- , sqids --- ) where + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsOptions + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + , encode + , decode + ) where import Web.Sqids.Internal + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsOptions + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + ) + +import Data.Text (Text) +import qualified Web.Sqids.Internal as Sqids + +encode :: (MonadSqids m) => [Int] -> m Text +encode = Sqids.encode + +decode :: (MonadSqids m) => Text -> m [Int] +decode = Sqids.decode diff --git a/src/Web/Sqids/Integer.hs b/src/Web/Sqids/Integer.hs new file mode 100644 index 0000000..a1ad9d1 --- /dev/null +++ b/src/Web/Sqids/Integer.hs @@ -0,0 +1,40 @@ +module Web.Sqids.Integer + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsOptions + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + , encode + , decode + ) where + +import Web.Sqids.Internal + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsOptions + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + ) + +import Data.Text (Text) +import qualified Web.Sqids.Internal as Sqids + +encode :: (MonadSqids m) => [Integer] -> m Text +encode = Sqids.encode + +decode :: (MonadSqids m) => Text -> m [Integer] +decode = Sqids.decode diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index 010dad0..4a188fb 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -1,56 +1,53 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Web.Sqids.Internal - where --- ( sqidsVersion --- , SqidsOptions(..) --- , SqidsError(..) --- , SqidsContext(..) --- , emptySqidsContext --- , defaultSqidsOptions --- , SqidsStack --- , MonadSqids(..) --- , sqidsOptions --- , SqidsT(..) --- , Sqids(..) --- , runSqidsT --- , sqidsT --- , runSqids --- , sqids --- , filteredBlocklist --- , rearrangeAlphabet --- , encodeNumbers --- , decodeWithAlphabet --- , decodeStep --- , shuffle --- , toId --- , toNumber --- , isBlockedId --- ) where + ( sqidsVersion + , SqidsOptions (..) + , SqidsError (..) + , SqidsContext (..) + , emptySqidsContext + , defaultSqidsOptions + , SqidsStack + , MonadSqids (..) + , sqidsOptions + , SqidsT (..) + , Sqids (..) + , runSqidsT + , sqidsT + , runSqids + , sqids + , filteredBlocklist + , rearrangeAlphabet + , encodeNumbers + , decodeWithAlphabet + , decodeStep + , shuffle + , toId + , toNumber + , isBlockedId + ) +where import Control.Monad (when, (>=>)) -import Control.Monad.Except (ExceptT, runExceptT, MonadError, throwError) +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks, local) +import Control.Monad.Reader (MonadReader, ReaderT, asks, local, runReaderT) import Control.Monad.State.Strict (StateT) import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Trans.Select (SelectT) import Control.Monad.Writer (WriterT) -import Data.Char (ord, toLower, isDigit) +import Data.Char (isDigit, ord, toLower) import Data.List (foldl', unfoldr) import Data.Text (Text) -import Web.Sqids.Blocklist (defaultBlocklist) -import Web.Sqids.Utils.Internal (letterCount, swapChars, wordsNoLongerThan, unsafeIndex, unsafeUncons) -import Debug.Trace - import qualified Data.Text as Text +import Web.Sqids.Blocklist (defaultBlocklist) +import Web.Sqids.Utils.Internal (containsMultibyteChars, letterCount, swapChars, unsafeIndex, unsafeUncons, wordsNoLongerThan) -- | Sqids spec. version sqidsVersion :: String @@ -86,40 +83,32 @@ emptySqidsContext = SqidsContext Text.empty 0 [] data SqidsError = SqidsNegativeNumberInInput - | SqidsMaxAttempts + -- ^ One or more numbers in the list passed to `encode` are negative. Only + -- non-negative integers can be used as input. + | SqidsMaxEncodingAttempts + -- ^ Maximum allowed attemps was reached during encoding + | SqidsAlphabetContainsMultibyteCharacters + -- ^ The alphabet cannot contain multi-byte characters. | SqidsAlphabetTooShort + -- ^ The alphabet must be at least 3 characters long. | SqidsAlphabetRepeatedCharacters + -- ^ The provided alphabet contains duplicate characters. E.g., "abcdefgg" is + -- not a valid alphabet. | SqidsInvalidMinLength + -- ^ The given `minLength` value is not within the valid range. deriving (Show, Read, Eq, Ord) ----- | Errors that can occur during encoding and decoding. ---data SqidsError --- = SqidsAlphabetTooShort --- -- ^ The alphabet must be at least 5 characters long. --- | SqidsAlphabetRepeatedCharacters --- -- ^ The provided alphabet contains duplicate characters. E.g., "abcdefgg" is --- -- not a valid alphabet. --- | SqidsInvalidMinLength --- -- ^ The given `minLength` value is not within the valid range. --- | SqidsNegativeNumberInInput --- -- ^ One or more numbers in the list passed to `encode` are negative. Only --- -- non-negative integers can be used as input. --- deriving (Show, Read, Eq, Ord) - type SqidsStack m = ReaderT SqidsContext (ExceptT SqidsError m) class (Monad m) => MonadSqids m where - encode :: (Integral a) => [a] -> m Text - decode :: (Integral a) => Text -> m [a] - ---class (Monad m) => MonadSqids m where --- -- | Encode a list of integers into an ID --- encode :: [Int] -- ^ A list of non-negative integers to encode --- -> m Text -- ^ Returns the generated ID --- --- -- | Decode an ID back into a list of integers --- decode :: Text -- ^ The encoded ID --- -> m [Int] -- ^ Returns a list of integers + -- | Encode a list of integers into an ID + encode :: (Integral a) + => [a] -- ^ A list of non-negative numbers to encode + -> m Text -- ^ Returns the generated ID + -- | Decode an ID back into a list of integers + decode :: (Integral a) + => Text -- ^ The encoded ID + -> m [a] -- ^ Returns a list of numbers -- | Sqids constructor sqidsOptions @@ -130,6 +119,10 @@ sqidsOptions SqidsOptions{..} = do let alphabetLetterCount = letterCount alphabet + -- Check the alphabet doesn't contain multibyte characters + when (containsMultibyteChars alphabet) $ + throwError SqidsAlphabetContainsMultibyteCharacters + -- Check the length of the alphabet when (Text.length alphabet < 3) $ throwError SqidsAlphabetTooShort @@ -149,7 +142,7 @@ sqidsOptions SqidsOptions{..} = do } -- | Sqids monad transformer -newtype SqidsT m a = SqidsT { unwrapSqidsT :: SqidsStack m a } +newtype SqidsT m a = SqidsT {unwrapSqidsT :: SqidsStack m a} deriving ( Functor , Applicative @@ -173,10 +166,10 @@ instance (Monad m) => MonadSqids (SqidsT m) where | otherwise = encodeNumbers numbers 0 - decode sqid = + decode sqid = asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid -newtype Sqids a = Sqids { unwrapSqids :: SqidsT Identity a } +newtype Sqids a = Sqids {unwrapSqids :: SqidsT Identity a} deriving ( Functor , Applicative @@ -242,42 +235,28 @@ instance (MonadSqids m) => MonadSqids (SelectT r m) where -- 3. Remove words that contain characters that are not in the alphabet -- filteredBlocklist :: Text -> [Text] -> [Text] -filteredBlocklist alph ws = filter isValid (Text.map toLower <$> ws) where - isValid w = Text.length w >= 3 && Text.all (`Text.elem` lowercaseAlphabet) w - lowercaseAlphabet = Text.map toLower alph - ---decodeStep :: (Text, Text) -> Maybe (Int, (Text, Text)) ---decodeStep (sqid, alph) --- | Text.null sqid = Nothing --- | otherwise = --- case Text.unsnoc alph of --- Just (alphabetWithoutSeparator, separatorChar) -> --- let separator = Text.singleton separatorChar --- in case Text.splitOn separator sqid of --- [] -> Nothing --- (chunk : _) | not (Text.all (`Text.elem` alphabetWithoutSeparator) chunk) -> --- Nothing --- (chunk : chunks) -> Just --- ( toNumber chunk alphabetWithoutSeparator --- , (Text.intercalate separator chunks, shuffle alph) --- ) --- _ -> --- error "decodeId: bad input" +filteredBlocklist alph ws = filter isValid (Text.map toLower <$> ws) + where + isValid w = Text.length w >= 3 && Text.all (`Text.elem` lowercaseAlphabet) w + lowercaseAlphabet = Text.map toLower alph decodeStep :: (Integral a) => (Text, Text) -> Maybe (a, (Text, Text)) decodeStep (sqid, alph) | Text.null sqid = Nothing - | otherwise = + | otherwise = do case Text.uncons alph of Just (separatorChar, alphabetWithoutSeparator) -> let separator = Text.singleton separatorChar in case Text.splitOn separator sqid of [] -> Nothing - (chunk : chunks) -> Just - ( toNumber chunk alphabetWithoutSeparator - , (Text.intercalate separator chunks, shuffle alph) - ) + (chunk : chunks) + | Text.null chunk -> + Nothing + | otherwise -> Just + ( toNumber chunk alphabetWithoutSeparator + , (Text.intercalate separator chunks, shuffle alph) + ) _ -> error "decode: bad input" @@ -290,22 +269,9 @@ decodeWithAlphabet alph sqid (prefix, slicedId) = unsafeUncons sqid chars = Text.drop offset alph <> Text.take offset alph --- | otherwise = unfoldr decodeStep initial --- where --- offset = unsafeIndex prefix alph --- (prefix, next) = unsafeUncons sqid --- (partition, chars) = --- unsafeUncons (Text.drop (offset + 1) alph <> Text.take offset alph) --- initial = --- case Text.findIndex (== partition) next of --- Just n | n > 0 && n < Text.length next - 1 -> --- (Text.drop (n + 1) next, shuffle chars) --- _ -> --- (next, chars) - shuffle :: Text -> Text shuffle alph = - foldl' mu alph [ (i, j) | i <- [ 0 .. len - 2 ], let j = len - i - 1 ] + foldl' mu alph [(i, j) | i <- [0 .. len - 2], let j = len - i - 1] where len = Text.length alph mu chars (i, j) = @@ -338,21 +304,21 @@ isBlockedId bls sqid = lowercaseSqid = Text.map toLower sqid disallowed w | Text.length sqid <= 3 || Text.length w <= 3 = - -- Short words have to match exactly - w == lowercaseSqid + -- Short words have to match exactly + w == lowercaseSqid | Text.any isDigit w = - -- Look for "leetspeak" words - w `Text.isPrefixOf` lowercaseSqid || w `Text.isSuffixOf` lowercaseSqid + -- Look for "leetspeak" words + w `Text.isPrefixOf` lowercaseSqid || w `Text.isSuffixOf` lowercaseSqid | otherwise = - -- Check if word appears anywhere in the string - w `Text.isInfixOf` lowercaseSqid + -- Check if word appears anywhere in the string + w `Text.isInfixOf` lowercaseSqid -- Rearrange alphabet so that second half goes in front of the first half -rearrangeAlphabet :: (Integral a) => Text -> [a] -> Text -rearrangeAlphabet alph numbers = - Text.drop offset alph <> Text.take offset alph +rearrangeAlphabet :: (Integral a) => Int -> Text -> [a] -> Text +rearrangeAlphabet increment alph numbers = + Text.drop offset alph <> Text.take offset alph where - offset = foldl' mu (length numbers) (zip numbers [0..]) `mod` len + offset = (increment + foldl' mu (length numbers) (zip numbers [0 ..])) `mod` len len = Text.length alph mu :: (Integral a, Num b) => b -> (a, b) -> b @@ -360,17 +326,6 @@ rearrangeAlphabet alph numbers = let currentChar = Text.index alph (fromIntegral (v `mod` fromIntegral len)) in fromIntegral (ord currentChar) + i + a ----- Rearrange alphabet so that second half goes in front of the first half ---rearrangeAlphabet :: Text -> [Int] -> Text ---rearrangeAlphabet alph numbers = --- Text.drop offset alph <> Text.take offset alph --- where --- len = Text.length alph --- offset = foldl' mu (length numbers) (zip numbers [0..]) `mod` len --- mu a (v, i) = --- let currentChar = Text.index alph (v `mod` len) --- in ord currentChar + i + a - encodeNumbers :: ( Integral a , MonadSqids m @@ -380,8 +335,8 @@ encodeNumbers :: encodeNumbers numbers increment = do alph <- asks sqidsAlphabet when (increment > Text.length alph) $ - throwError SqidsMaxAttempts - let alphabet = rearrangeAlphabet alph numbers + throwError SqidsMaxEncodingAttempts + let alphabet = rearrangeAlphabet increment alph numbers let run (r, chars) (n, i) | i == length numbers - 1 = (sqid, chars) @@ -391,25 +346,22 @@ encodeNumbers numbers increment = do (head_, tail_) = unsafeUncons chars sqid = r <> toId n tail_ let (sqid, chars) = - foldl' run (Text.singleton (Text.head alphabet), Text.reverse alphabet) (zip numbers [0..]) + foldl' run (Text.singleton (Text.head alphabet), Text.reverse alphabet) (zip numbers [0 ..]) (makeMinLength chars >=> checkAgainstBlocklist) sqid - where makeMinLength chars sqid = do minl <- asks sqidsMinLength if minl > Text.length sqid - then + then let len = Text.length chars go (chars_, sqid_) = do let diff = minl - Text.length sqid_ shuffled = shuffle chars_ - aaa = Text.take (min diff len) shuffled - if diff > 0 - then go (shuffled, sqid_ <> aaa) + if diff > 0 + then go (shuffled, sqid_ <> Text.take (min diff len) shuffled) else sqid_ - in - pure (go (chars, Text.snoc sqid (Text.head chars))) - else + in pure (go (chars, Text.snoc sqid (Text.head chars))) + else pure sqid checkAgainstBlocklist sqid = do @@ -417,54 +369,3 @@ encodeNumbers numbers increment = do if isBlockedId blocklist sqid then encodeNumbers numbers (succ increment) else pure sqid - ---encodeNumbers :: --- ( MonadSqids m --- , MonadError SqidsError m --- , MonadReader SqidsContext m --- ) => [Int] -> Bool -> m Text ---encodeNumbers numbers partitioned = do --- alph <- asks sqidsAlphabet --- let (left, right) = Text.splitAt 2 (rearrangeAlphabet alph numbers) --- case Text.unpack left of --- prefix : partition : _ -> do --- let run (r, chars) (n, i) --- | i == length numbers - 1 = --- (sqid, chars) --- | otherwise = --- (sqid <> Text.singleton delim, shuffle chars) --- where --- delim = if partitioned && i == 0 then partition else Text.last chars --- sqid = r <> toId n (Text.init chars) --- let (sqid, chars) = --- foldl' run (Text.singleton prefix, right) (zip numbers [0..]) --- (makeMinLength chars >=> checkAgainstBlocklist numbers) sqid --- _ -> --- error "encodeNumbers: implementation error" --- where --- makeMinLength chars sqid = do --- minl <- asks sqidsMinLength --- sqid' <- --- if minl <= Text.length sqid || partitioned --- then pure sqid --- else encodeNumbers (0 : numbers) True --- pure $ --- if minl <= Text.length sqid' --- then sqid' --- else let extra = minl - Text.length sqid --- in Text.cons (Text.head sqid') (Text.take extra chars <> Text.tail sqid') --- --- checkAgainstBlocklist nums sqid = do --- bls <- asks sqidsBlocklist --- if isBlockedId bls sqid then --- case nums of --- n : ns | partitioned -> --- if n == maxBound --- then error "encodeNumbers: out of range" --- else encodeNumbers (n + 1 : ns) True --- n : ns -> --- encodeNumbers (0 : n : ns) True --- _ -> --- error "encodeNumbers: implementation error" --- else --- pure sqid diff --git a/src/Web/Sqids/Utils/Internal.hs b/src/Web/Sqids/Utils/Internal.hs index 9e3b5f8..b00e3f7 100644 --- a/src/Web/Sqids/Utils/Internal.hs +++ b/src/Web/Sqids/Utils/Internal.hs @@ -6,6 +6,7 @@ module Web.Sqids.Utils.Internal , wordsNoLongerThan , unsafeIndex , unsafeUncons + , containsMultibyteChars ) where import Data.Maybe (fromJust) @@ -14,6 +15,8 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Set as Set +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.ByteString as ByteString {-# INLINE letterCount #-} letterCount :: Text -> Int @@ -46,3 +49,7 @@ unsafeIndex c = fromJust . Text.findIndex (== c) {-# INLINE unsafeUncons #-} unsafeUncons :: Text -> (Char, Text) unsafeUncons = fromJust . Text.uncons + +containsMultibyteChars :: Text -> Bool +containsMultibyteChars input = + Text.length input /= ByteString.length (TextEncoding.encodeUtf8 input) diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index e225542..0cc5110 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -4,7 +4,7 @@ module Web.Sqids.BlocklistTests (testBlocklist) where import Control.Monad ((>=>)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsOptions(..), SqidsError(..), Sqids(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) +import Web.Sqids (SqidsOptions(..), SqidsError(..), Sqids, defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) import Web.Sqids.Internal (sqidsAlphabet, sqidsBlocklist) import qualified Data.Text as Text @@ -60,11 +60,11 @@ testBlocklist = do , "5sQRZO" ] - withNonEmptyBlocklist (decode "86Rf07") `shouldBe` Right [ 1, 2, 3 ] - withNonEmptyBlocklist (decode "se8ojk") `shouldBe` Right [ 1, 2, 3 ] - withNonEmptyBlocklist (decode "ARsz1p") `shouldBe` Right [ 1, 2, 3 ] - withNonEmptyBlocklist (decode "Q8AI49") `shouldBe` Right [ 1, 2, 3 ] - withNonEmptyBlocklist (decode "5sQRZO") `shouldBe` Right [ 1, 2, 3 ] + withCustomBlocklist bls (decode "86Rf07") `shouldBe` Right [ 1, 2, 3 ] + withCustomBlocklist bls (decode "se8ojk") `shouldBe` Right [ 1, 2, 3 ] + withCustomBlocklist bls (decode "ARsz1p") `shouldBe` Right [ 1, 2, 3 ] + withCustomBlocklist bls (decode "Q8AI49") `shouldBe` Right [ 1, 2, 3 ] + withCustomBlocklist bls (decode "5sQRZO") `shouldBe` Right [ 1, 2, 3 ] it "match against a short blocklist word" $ withCustomBlocklist [ "pnd" ] ((encode >=> decode) [1000]) `shouldBe` Right [1000] @@ -78,18 +78,20 @@ testBlocklist = do runSqids options testFn `shouldBe` Right ("IBSHOZ", [1, 2, 3]) it "max encoding attempts" $ do - let alphabet = "abc" - blocklist = [ "cab", "abc", "bca" ] - minLength = 3 + let _alphabet = "abc" + _blocklist = [ "cab", "abc", "bca" ] + _minLength = 3 options = defaultSqidsOptions - { alphabet = alphabet - , blocklist = blocklist - , minLength = minLength + { alphabet = _alphabet + , blocklist = _blocklist + , minLength = _minLength } - let Right config = runSqids defaultSqidsOptions (sqidsOptions options) + case runSqids defaultSqidsOptions (sqidsOptions options) of + Left _ -> + error "Unexpected failure" + Right config -> do + Text.length (sqidsAlphabet config) `shouldBe` _minLength + length (sqidsBlocklist config) `shouldBe` _minLength - Text.length (sqidsAlphabet config) `shouldBe` minLength - length (sqidsBlocklist config) `shouldBe` minLength - - runSqids options ((encode >=> decode) [0]) `shouldBe` Left SqidsMaxAttempts + runSqids options ((encode >=> decode) [0]) `shouldBe` Left SqidsMaxAttempts diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index 7bb9184..9a72116 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -4,7 +4,7 @@ module Web.Sqids.EncodingTests (testEncoding) where import Control.Monad (forM_, (<=<)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) +import Web.Sqids (SqidsError(..), sqids, decode, encode) testEncodeDecodeAll :: [(Text, [Int])] -> IO () testEncodeDecodeAll ss = diff --git a/test/Web/Sqids/InternalTests.hs b/test/Web/Sqids/InternalTests.hs index 285770e..fda6220 100644 --- a/test/Web/Sqids/InternalTests.hs +++ b/test/Web/Sqids/InternalTests.hs @@ -1,11 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Web.Sqids.InternalTests where +module Web.Sqids.InternalTests + ( testInternals + ) where import Data.Text (Text, unpack) import Test.Hspec hiding (it) -import Web.Sqids (sqidsOptions, sqids, runSqids, encode, defaultSqidsOptions, SqidsOptions(..), SqidsError(..)) -import Web.Sqids.Internal (shuffle, toNumber, toId, isBlockedId, decodeWithAlphabet, decodeStep, filteredBlocklist, SqidsContext(..)) +import Web.Sqids (sqidsOptions, sqids, encode, SqidsOptions(..), SqidsError(..)) +import Web.Sqids.Internal (SqidsContext(..), filteredBlocklist, isBlockedId, toId, toNumber, shuffle) import Web.Sqids.Utils.Internal (swapChars) import qualified Data.Text as Text @@ -91,7 +93,7 @@ testToId = do withTestData "toId" $ \case num : alph : result : _ -> let msg = num <> " " <> alph - in it msg (toId (textRead num) alph `shouldBe` result) + in it msg (toId (textRead num :: Int) alph `shouldBe` result) _ -> error "testToId: bad input" @@ -100,7 +102,7 @@ testToNumber = do withTestData "toNumber" $ \case sqid : alph : result : _ -> let msg = sqid <> " " <> alph - in it msg (toNumber sqid alph `shouldBe` textRead result) + in it msg ((toNumber sqid alph :: Int) `shouldBe` textRead result) _ -> error "testToNumber: bad input" diff --git a/test/Web/Sqids/MinLengthTests.hs b/test/Web/Sqids/MinLengthTests.hs index bc82174..d6567bf 100644 --- a/test/Web/Sqids/MinLengthTests.hs +++ b/test/Web/Sqids/MinLengthTests.hs @@ -66,7 +66,5 @@ testMinLength = do sqids (decode sqid) `shouldBe` Right numbers it "out-of-range invalid min length" $ do - let len = Text.length (defaultSqidsOptions & alphabet) - sqids (sqidsOptions defaultSqidsOptions{ minLength = -1 }) `shouldBe` Left SqidsInvalidMinLength sqids (sqidsOptions defaultSqidsOptions{ minLength = 256 }) `shouldBe` Left SqidsInvalidMinLength diff --git a/test/data/shuffle.txt b/test/data/shuffle.txt new file mode 100644 index 0000000..5f32db3 --- /dev/null +++ b/test/data/shuffle.txt @@ -0,0 +1,5 @@ +abcd|bcad +abcdefghijklmnopqrstuvwxyz|lbfziqvscptmyxrekguohwjand +a|a +000|000 +aabbcc|acabbc From eb77e52a24c7bdd2e9edb88f0a1c46f445334cb5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Thu, 12 Oct 2023 10:34:16 +0300 Subject: [PATCH 10/17] Update tests --- test/Web/Sqids/BlocklistTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index 0cc5110..111e8cc 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -94,4 +94,4 @@ testBlocklist = do Text.length (sqidsAlphabet config) `shouldBe` _minLength length (sqidsBlocklist config) `shouldBe` _minLength - runSqids options ((encode >=> decode) [0]) `shouldBe` Left SqidsMaxAttempts + runSqids options ((encode >=> decode) [0]) `shouldBe` Left SqidsMaxEncodingAttempts From be5aa0d1104071c484b58cfd5c61910431162249 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Thu, 12 Oct 2023 11:37:15 +0300 Subject: [PATCH 11/17] Add test for big integers --- sqids.cabal | 1 - src/Web/Sqids.hs | 15 ++++++++++--- src/Web/Sqids/Integer.hs | 40 --------------------------------- src/Web/Sqids/Internal.hs | 36 ++++++++++++++--------------- test/Web/Sqids/EncodingTests.hs | 7 +++++- 5 files changed, 36 insertions(+), 63 deletions(-) delete mode 100644 src/Web/Sqids/Integer.hs diff --git a/sqids.cabal b/sqids.cabal index 5ba2d3f..c10e579 100644 --- a/sqids.cabal +++ b/sqids.cabal @@ -30,7 +30,6 @@ library exposed-modules: Web.Sqids Web.Sqids.Blocklist - Web.Sqids.Integer Web.Sqids.Internal Web.Sqids.Utils.Internal other-modules: diff --git a/src/Web/Sqids.hs b/src/Web/Sqids.hs index 138c42f..c54aa7a 100644 --- a/src/Web/Sqids.hs +++ b/src/Web/Sqids.hs @@ -13,6 +13,8 @@ module Web.Sqids , sqids , encode , decode + , encode_ + , decode_ ) where import Web.Sqids.Internal @@ -28,13 +30,20 @@ import Web.Sqids.Internal , Sqids , runSqids , sqids + , sqidsEncode + , sqidsDecode ) import Data.Text (Text) -import qualified Web.Sqids.Internal as Sqids encode :: (MonadSqids m) => [Int] -> m Text -encode = Sqids.encode +encode = sqidsEncode decode :: (MonadSqids m) => Text -> m [Int] -decode = Sqids.decode +decode = sqidsDecode + +encode_ :: (MonadSqids m) => [Integer] -> m Text +encode_ = sqidsEncode + +decode_ :: (MonadSqids m) => Text -> m [Integer] +decode_ = sqidsDecode diff --git a/src/Web/Sqids/Integer.hs b/src/Web/Sqids/Integer.hs deleted file mode 100644 index a1ad9d1..0000000 --- a/src/Web/Sqids/Integer.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Web.Sqids.Integer - ( sqidsVersion - , defaultSqidsOptions - , SqidsOptions(..) - , SqidsError(..) - , MonadSqids - , sqidsOptions - , SqidsT - , runSqidsT - , sqidsT - , Sqids - , runSqids - , sqids - , encode - , decode - ) where - -import Web.Sqids.Internal - ( sqidsVersion - , defaultSqidsOptions - , SqidsOptions(..) - , SqidsError(..) - , MonadSqids - , sqidsOptions - , SqidsT - , runSqidsT - , sqidsT - , Sqids - , runSqids - , sqids - ) - -import Data.Text (Text) -import qualified Web.Sqids.Internal as Sqids - -encode :: (MonadSqids m) => [Integer] -> m Text -encode = Sqids.encode - -decode :: (MonadSqids m) => Text -> m [Integer] -decode = Sqids.decode diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index 4a188fb..a3901a7 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -102,11 +102,11 @@ type SqidsStack m = ReaderT SqidsContext (ExceptT SqidsError m) class (Monad m) => MonadSqids m where -- | Encode a list of integers into an ID - encode :: (Integral a) + sqidsEncode :: (Integral a) => [a] -- ^ A list of non-negative numbers to encode -> m Text -- ^ Returns the generated ID -- | Decode an ID back into a list of integers - decode :: (Integral a) + sqidsDecode :: (Integral a) => Text -- ^ The encoded ID -> m [a] -- ^ Returns a list of numbers @@ -156,7 +156,7 @@ instance MonadTrans SqidsT where lift = SqidsT . lift . lift instance (Monad m) => MonadSqids (SqidsT m) where - encode numbers + sqidsEncode numbers | null numbers = -- If no numbers passed, return an empty string pure Text.empty @@ -166,7 +166,7 @@ instance (Monad m) => MonadSqids (SqidsT m) where | otherwise = encodeNumbers numbers 0 - decode sqid = + sqidsDecode sqid = asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid newtype Sqids a = Sqids {unwrapSqids :: SqidsT Identity a} @@ -201,32 +201,32 @@ sqids :: Sqids a -> Either SqidsError a sqids = runSqids defaultSqidsOptions instance (MonadSqids m) => MonadSqids (StateT s m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m) => MonadSqids (ExceptT e m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m) => MonadSqids (ReaderT r m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m, Monoid w) => MonadSqids (WriterT w m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m) => MonadSqids (MaybeT m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m) => MonadSqids (ContT r m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode instance (MonadSqids m) => MonadSqids (SelectT r m) where - encode = lift . encode - decode = lift . decode + sqidsEncode = lift . sqidsEncode + sqidsDecode = lift . sqidsDecode -- Clean up blocklist: -- diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index 9a72116..d6042d6 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -4,7 +4,7 @@ module Web.Sqids.EncodingTests (testEncoding) where import Control.Monad (forM_, (<=<)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsError(..), sqids, decode, encode) +import Web.Sqids (SqidsError(..), sqids, decode, encode, decode_, encode_) testEncodeDecodeAll :: [(Text, [Int])] -> IO () testEncodeDecodeAll ss = @@ -96,3 +96,8 @@ testEncoding = do it "encoding out-of-range numbers" $ sqids (encode [-1]) `shouldBe` Left SqidsNegativeNumberInInput + + it "big int" $ do + let numbers = [ 11119223372036854775807 ] + + sqids ((decode_ <=< encode_) numbers) `shouldBe` Right numbers From c0b90e9a3b2e0e5b7a6bd9b9d06358276e45d962 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 05:48:55 +0300 Subject: [PATCH 12/17] Update comments --- src/Web/Sqids/Internal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index a3901a7..4c35bb8 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -119,7 +119,7 @@ sqidsOptions SqidsOptions{..} = do let alphabetLetterCount = letterCount alphabet - -- Check the alphabet doesn't contain multibyte characters + -- Check that the alphabet doesn't contain multibyte characters when (containsMultibyteChars alphabet) $ throwError SqidsAlphabetContainsMultibyteCharacters @@ -169,6 +169,7 @@ instance (Monad m) => MonadSqids (SqidsT m) where sqidsDecode sqid = asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid +-- | Sqids monad newtype Sqids a = Sqids {unwrapSqids :: SqidsT Identity a} deriving ( Functor From fe7347c6617e80054720c8650eb00e7dec3e47d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 10:59:08 +0300 Subject: [PATCH 13/17] Implement big int support --- sqids.cabal | 1 + src/Web/Sqids.hs | 19 +++---- src/Web/Sqids/Integer.hs | 44 +++++++++++++++++ src/Web/Sqids/Internal.hs | 85 +++++++++++++++----------------- test/Web/Sqids/AlphabetTests.hs | 12 +++-- test/Web/Sqids/BlocklistTests.hs | 15 +++--- test/Web/Sqids/EncodingTests.hs | 5 +- test/Web/Sqids/InternalTests.hs | 15 +++--- test/Web/Sqids/MinLengthTests.hs | 10 ++-- 9 files changed, 126 insertions(+), 80 deletions(-) create mode 100644 src/Web/Sqids/Integer.hs diff --git a/sqids.cabal b/sqids.cabal index c10e579..5ba2d3f 100644 --- a/sqids.cabal +++ b/sqids.cabal @@ -30,6 +30,7 @@ library exposed-modules: Web.Sqids Web.Sqids.Blocklist + Web.Sqids.Integer Web.Sqids.Internal Web.Sqids.Utils.Internal other-modules: diff --git a/src/Web/Sqids.hs b/src/Web/Sqids.hs index c54aa7a..08d88cc 100644 --- a/src/Web/Sqids.hs +++ b/src/Web/Sqids.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + module Web.Sqids ( sqidsVersion , defaultSqidsOptions , SqidsOptions(..) , SqidsError(..) , MonadSqids - , sqidsOptions + , sqidsContext , SqidsT , runSqidsT , sqidsT @@ -13,8 +16,6 @@ module Web.Sqids , sqids , encode , decode - , encode_ - , decode_ ) where import Web.Sqids.Internal @@ -23,7 +24,7 @@ import Web.Sqids.Internal , SqidsOptions(..) , SqidsError(..) , MonadSqids - , sqidsOptions + , sqidsContext , SqidsT , runSqidsT , sqidsT @@ -36,14 +37,8 @@ import Web.Sqids.Internal import Data.Text (Text) -encode :: (MonadSqids m) => [Int] -> m Text +encode :: (MonadSqids Int m) => [Int] -> m Text encode = sqidsEncode -decode :: (MonadSqids m) => Text -> m [Int] +decode :: (MonadSqids Int m) => Text -> m [Int] decode = sqidsDecode - -encode_ :: (MonadSqids m) => [Integer] -> m Text -encode_ = sqidsEncode - -decode_ :: (MonadSqids m) => Text -> m [Integer] -decode_ = sqidsDecode diff --git a/src/Web/Sqids/Integer.hs b/src/Web/Sqids/Integer.hs new file mode 100644 index 0000000..e459d21 --- /dev/null +++ b/src/Web/Sqids/Integer.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +module Web.Sqids.Integer + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsContext + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + , encode + , decode + ) where + +import Web.Sqids.Internal + ( sqidsVersion + , defaultSqidsOptions + , SqidsOptions(..) + , SqidsError(..) + , MonadSqids + , sqidsContext + , SqidsT + , runSqidsT + , sqidsT + , Sqids + , runSqids + , sqids + , sqidsEncode + , sqidsDecode + ) + +import Data.Text (Text) + +encode :: (MonadSqids Integer m) => [Integer] -> m Text +encode = sqidsEncode + +decode :: (MonadSqids Integer m) => Text -> m [Integer] +decode = sqidsDecode diff --git a/src/Web/Sqids/Internal.hs b/src/Web/Sqids/Internal.hs index 4c35bb8..831ec6a 100644 --- a/src/Web/Sqids/Internal.hs +++ b/src/Web/Sqids/Internal.hs @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} module Web.Sqids.Internal ( sqidsVersion @@ -12,9 +15,9 @@ module Web.Sqids.Internal , defaultSqidsOptions , SqidsStack , MonadSqids (..) - , sqidsOptions + , sqidsContext , SqidsT (..) - , Sqids (..) + , Sqids , runSqidsT , sqidsT , runSqids @@ -71,14 +74,14 @@ defaultSqidsOptions = SqidsOptions , blocklist = defaultBlocklist } -data SqidsContext = SqidsContext +data SqidsContext s = SqidsContext { sqidsAlphabet :: !Text , sqidsMinLength :: !Int , sqidsBlocklist :: ![Text] } deriving (Show, Eq, Ord) {-# INLINE emptySqidsContext #-} -emptySqidsContext :: SqidsContext +emptySqidsContext :: SqidsContext s emptySqidsContext = SqidsContext Text.empty 0 [] data SqidsError @@ -98,24 +101,22 @@ data SqidsError -- ^ The given `minLength` value is not within the valid range. deriving (Show, Read, Eq, Ord) -type SqidsStack m = ReaderT SqidsContext (ExceptT SqidsError m) +type SqidsStack s m = ReaderT (SqidsContext s) (ExceptT SqidsError m) -class (Monad m) => MonadSqids m where +class (Monad m) => MonadSqids s m | m -> s where -- | Encode a list of integers into an ID - sqidsEncode :: (Integral a) - => [a] -- ^ A list of non-negative numbers to encode - -> m Text -- ^ Returns the generated ID + sqidsEncode :: [s] -- ^ A list of non-negative numbers to encode + -> m Text -- ^ Returns the generated ID -- | Decode an ID back into a list of integers - sqidsDecode :: (Integral a) - => Text -- ^ The encoded ID - -> m [a] -- ^ Returns a list of numbers + sqidsDecode :: Text -- ^ The encoded ID + -> m [s] -- ^ Returns a list of numbers -- | Sqids constructor -sqidsOptions - :: (MonadSqids m, MonadError SqidsError m) +sqidsContext + :: (MonadSqids s m, MonadError SqidsError m) => SqidsOptions - -> m SqidsContext -sqidsOptions SqidsOptions{..} = do + -> m (SqidsContext s) +sqidsContext SqidsOptions{..} = do let alphabetLetterCount = letterCount alphabet @@ -142,20 +143,20 @@ sqidsOptions SqidsOptions{..} = do } -- | Sqids monad transformer -newtype SqidsT m a = SqidsT {unwrapSqidsT :: SqidsStack m a} +newtype SqidsT s m a = SqidsT { unwrapSqidsT :: SqidsStack s m a } deriving ( Functor , Applicative , Monad - , MonadReader SqidsContext + , MonadReader (SqidsContext s) , MonadError SqidsError , MonadIO ) -instance MonadTrans SqidsT where +instance MonadTrans (SqidsT s) where lift = SqidsT . lift . lift -instance (Monad m) => MonadSqids (SqidsT m) where +instance (Integral s, Monad m) => MonadSqids s (SqidsT s m) where sqidsEncode numbers | null numbers = -- If no numbers passed, return an empty string @@ -170,62 +171,54 @@ instance (Monad m) => MonadSqids (SqidsT m) where asks (decodeWithAlphabet . sqidsAlphabet) <*> pure sqid -- | Sqids monad -newtype Sqids a = Sqids {unwrapSqids :: SqidsT Identity a} - deriving - ( Functor - , Applicative - , Monad - , MonadReader SqidsContext - , MonadError SqidsError - , MonadSqids - ) +type Sqids s = SqidsT s Identity -- | Evaluate a `SqidsT` computation with the given options. -runSqidsT :: (Monad m) => SqidsOptions -> SqidsT m a -> m (Either SqidsError a) +runSqidsT :: (Integral s, Monad m) => SqidsOptions -> SqidsT s m a -> m (Either SqidsError a) runSqidsT options value = runExceptT (runReaderT (unwrapSqidsT withOptions) emptySqidsContext) where - withOptions = sqidsOptions options >>= (`local` value) . const + withOptions = sqidsContext options >>= (`local` value) . const -- | Evaluate a `SqidsT` computation with the default options. This is a short -- form for `runSqidsT defaultSqidsOptions`. -sqidsT :: (Monad m) => SqidsT m a -> m (Either SqidsError a) +sqidsT :: (Integral s, Monad m) => SqidsT s m a -> m (Either SqidsError a) sqidsT = runSqidsT defaultSqidsOptions -- | Evaluate a `Sqids` computation with the given options. -runSqids :: SqidsOptions -> Sqids a -> Either SqidsError a -runSqids options = runIdentity . runSqidsT options . unwrapSqids +runSqids :: (Integral s) => SqidsOptions -> Sqids s a -> Either SqidsError a +runSqids options = runIdentity . runSqidsT options -- . unwrapSqidsT -- | Evaluate a `Sqids` computation with the default options. This is a short -- form for `runSqids defaultSqidsOptions`. -sqids :: Sqids a -> Either SqidsError a +sqids :: (Integral s) => Sqids s a -> Either SqidsError a sqids = runSqids defaultSqidsOptions -instance (MonadSqids m) => MonadSqids (StateT s m) where +instance (MonadSqids s m) => MonadSqids s (StateT s m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m) => MonadSqids (ExceptT e m) where +instance (MonadSqids s m) => MonadSqids s (ExceptT e m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m) => MonadSqids (ReaderT r m) where +instance (MonadSqids s m) => MonadSqids s (ReaderT r m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m, Monoid w) => MonadSqids (WriterT w m) where +instance (MonadSqids s m, Monoid w) => MonadSqids s (WriterT w m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m) => MonadSqids (MaybeT m) where +instance (MonadSqids s m) => MonadSqids s (MaybeT m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m) => MonadSqids (ContT r m) where +instance (MonadSqids s m) => MonadSqids s (ContT r m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode -instance (MonadSqids m) => MonadSqids (SelectT r m) where +instance (MonadSqids s m) => MonadSqids s (SelectT r m) where sqidsEncode = lift . sqidsEncode sqidsDecode = lift . sqidsDecode @@ -328,11 +321,11 @@ rearrangeAlphabet increment alph numbers = in fromIntegral (ord currentChar) + i + a encodeNumbers :: - ( Integral a - , MonadSqids m + ( Integral s + , MonadSqids s m , MonadError SqidsError m - , MonadReader SqidsContext m - ) => [a] -> Int -> m Text + , MonadReader (SqidsContext s) m + ) => [s] -> Int -> m Text encodeNumbers numbers increment = do alph <- asks sqidsAlphabet when (increment > Text.length alph) $ diff --git a/test/Web/Sqids/AlphabetTests.hs b/test/Web/Sqids/AlphabetTests.hs index 49f8d3a..915a724 100644 --- a/test/Web/Sqids/AlphabetTests.hs +++ b/test/Web/Sqids/AlphabetTests.hs @@ -3,7 +3,11 @@ module Web.Sqids.AlphabetTests (testAlphabet) where import Control.Monad ((<=<)) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) +import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsContext, runSqids, sqids, decode, encode) +import Web.Sqids.Internal (SqidsContext(..)) + +createContext :: SqidsOptions -> Either SqidsError (SqidsContext Int) +createContext options = sqids (sqidsContext options) testAlphabet :: SpecWith () testAlphabet = do @@ -30,13 +34,13 @@ testAlphabet = do runSqids options ((decode <=< encode) numbers) `shouldBe` Right numbers it "multibyte characters" $ do - sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "ë1092" })) + createContext (defaultSqidsOptions{ alphabet = "ë1092" }) `shouldBe` Left SqidsAlphabetContainsMultibyteCharacters it "repeating characters" $ do - sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "aabcdefg" })) + createContext (defaultSqidsOptions{ alphabet = "aabcdefg" }) `shouldBe` Left SqidsAlphabetRepeatedCharacters it "too short of an alphabet" $ do - sqids (sqidsOptions (defaultSqidsOptions{ alphabet = "ab" })) + createContext (defaultSqidsOptions{ alphabet = "ab" }) `shouldBe` Left SqidsAlphabetTooShort diff --git a/test/Web/Sqids/BlocklistTests.hs b/test/Web/Sqids/BlocklistTests.hs index 111e8cc..5ede3cf 100644 --- a/test/Web/Sqids/BlocklistTests.hs +++ b/test/Web/Sqids/BlocklistTests.hs @@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Web.Sqids.BlocklistTests (testBlocklist) where import Control.Monad ((>=>)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsOptions(..), SqidsError(..), Sqids, defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) -import Web.Sqids.Internal (sqidsAlphabet, sqidsBlocklist) +import Web.Sqids (SqidsOptions(..), SqidsError(..), Sqids, defaultSqidsOptions, sqidsContext, runSqids, sqids, decode, encode) +import Web.Sqids.Internal (sqidsAlphabet, sqidsBlocklist, SqidsContext) import qualified Data.Text as Text -withEmptyBlocklist :: Sqids a -> Either SqidsError a +withEmptyBlocklist :: Sqids Int a -> Either SqidsError a withEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = [] } -withNonEmptyBlocklist :: Sqids a -> Either SqidsError a +withNonEmptyBlocklist :: Sqids Int a -> Either SqidsError a withNonEmptyBlocklist = runSqids defaultSqidsOptions{ blocklist = ["ArUO"] } -withCustomBlocklist :: [Text] -> Sqids a -> Either SqidsError a +withCustomBlocklist :: [Text] -> Sqids Int a -> Either SqidsError a withCustomBlocklist bls = runSqids defaultSqidsOptions { blocklist = bls } testBlocklist :: SpecWith () @@ -87,10 +88,10 @@ testBlocklist = do , minLength = _minLength } - case runSqids defaultSqidsOptions (sqidsOptions options) of + case runSqids defaultSqidsOptions (sqidsContext options) of Left _ -> error "Unexpected failure" - Right config -> do + Right (config :: SqidsContext Int) -> do Text.length (sqidsAlphabet config) `shouldBe` _minLength length (sqidsBlocklist config) `shouldBe` _minLength diff --git a/test/Web/Sqids/EncodingTests.hs b/test/Web/Sqids/EncodingTests.hs index d6042d6..9913058 100644 --- a/test/Web/Sqids/EncodingTests.hs +++ b/test/Web/Sqids/EncodingTests.hs @@ -4,7 +4,8 @@ module Web.Sqids.EncodingTests (testEncoding) where import Control.Monad (forM_, (<=<)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe) -import Web.Sqids (SqidsError(..), sqids, decode, encode, decode_, encode_) +import Web.Sqids (SqidsError(..), sqids, decode, encode) +import qualified Web.Sqids.Integer as BigSqids testEncodeDecodeAll :: [(Text, [Int])] -> IO () testEncodeDecodeAll ss = @@ -100,4 +101,4 @@ testEncoding = do it "big int" $ do let numbers = [ 11119223372036854775807 ] - sqids ((decode_ <=< encode_) numbers) `shouldBe` Right numbers + sqids ((BigSqids.decode <=< BigSqids.encode) numbers) `shouldBe` Right numbers diff --git a/test/Web/Sqids/InternalTests.hs b/test/Web/Sqids/InternalTests.hs index fda6220..75bf538 100644 --- a/test/Web/Sqids/InternalTests.hs +++ b/test/Web/Sqids/InternalTests.hs @@ -6,7 +6,7 @@ module Web.Sqids.InternalTests import Data.Text (Text, unpack) import Test.Hspec hiding (it) -import Web.Sqids (sqidsOptions, sqids, encode, SqidsOptions(..), SqidsError(..)) +import Web.Sqids (sqidsContext, sqids, encode, SqidsOptions(..), SqidsError(..)) import Web.Sqids.Internal (SqidsContext(..), filteredBlocklist, isBlockedId, toId, toNumber, shuffle) import Web.Sqids.Utils.Internal (swapChars) @@ -34,18 +34,21 @@ testSwapChars = do _ -> error "testSwapChars: bad input" +createContext :: SqidsOptions -> Either SqidsError (SqidsContext Int) +createContext options = sqids (sqidsContext options) + testSqidsOptions :: SpecWith () testSqidsOptions = - describe "sqidsOptions" $ do + describe "sqidsContext" $ do it "too short alphabet" $ - sqids (sqidsOptions optionsWithShortAlphabet) `shouldBe` Left SqidsAlphabetTooShort + createContext optionsWithShortAlphabet `shouldBe` Left SqidsAlphabetTooShort it "invalid alphabet" $ - sqids (sqidsOptions optionsWithInvalidAlphabet) `shouldBe` Left SqidsAlphabetRepeatedCharacters + createContext optionsWithInvalidAlphabet `shouldBe` Left SqidsAlphabetRepeatedCharacters it "invalid min length" $ - sqids (sqidsOptions optionsWithInvalidMinLength) `shouldBe` Left SqidsInvalidMinLength + createContext optionsWithInvalidMinLength `shouldBe` Left SqidsInvalidMinLength it "valid options" $ - sqids (sqidsOptions optionsValid) `shouldBe` + createContext optionsValid `shouldBe` Right (SqidsContext (shuffle (alphabet optionsValid)) (minLength optionsValid) (blocklist optionsValid)) where optionsWithShortAlphabet = SqidsOptions diff --git a/test/Web/Sqids/MinLengthTests.hs b/test/Web/Sqids/MinLengthTests.hs index d6567bf..e778d80 100644 --- a/test/Web/Sqids/MinLengthTests.hs +++ b/test/Web/Sqids/MinLengthTests.hs @@ -5,10 +5,14 @@ import Control.Monad (forM_) import Data.Function ((&)) import Data.Text (Text) import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) -import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsOptions, runSqids, sqids, decode, encode) +import Web.Sqids (SqidsOptions(..), SqidsError(..), defaultSqidsOptions, sqidsContext, runSqids, sqids, decode, encode) +import Web.Sqids.Internal (SqidsContext) import qualified Data.Text as Text +createContext :: SqidsOptions -> Either SqidsError (SqidsContext Int) +createContext options = sqids (sqidsContext options) + testEncodeDecodeAll :: [(Int, Text)] -> IO () testEncodeDecodeAll ss = forM_ ss $ \(len, sqid) -> do @@ -66,5 +70,5 @@ testMinLength = do sqids (decode sqid) `shouldBe` Right numbers it "out-of-range invalid min length" $ do - sqids (sqidsOptions defaultSqidsOptions{ minLength = -1 }) `shouldBe` Left SqidsInvalidMinLength - sqids (sqidsOptions defaultSqidsOptions{ minLength = 256 }) `shouldBe` Left SqidsInvalidMinLength + createContext (defaultSqidsOptions{ minLength = -1 }) `shouldBe` Left SqidsInvalidMinLength + createContext (defaultSqidsOptions{ minLength = 256 }) `shouldBe` Left SqidsInvalidMinLength From 69be7c92ab79ae6d6d93131cc94f40082b75ab4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 12:30:19 +0300 Subject: [PATCH 14/17] Update README-file --- README.md | 109 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 77 insertions(+), 32 deletions(-) diff --git a/README.md b/README.md index cc7d136..f3212fe 100644 --- a/README.md +++ b/README.md @@ -59,29 +59,51 @@ stack install sqids ### Usage -Use `encode` to translate a list of non-negative integers into an ID, and -`decode` to retrieve back the list of numbers encoded by an ID. +The library exposes two versions of the API; + +- `Web.Sqids` relies on Haskell's `Int` data type, whereas +- `Web.Sqids.Integer` uses `Integer`s, which support arbitrarily large integers. + +If you need to work with (i.e., encode and decode) large numbers, it is +recommened to choose the latter option, in which case you would import the +library as: ``` -encode :: [Int] -> Sqids Text -decode:: Text -> Sqids [Int] +import Web.Sqids.Integer ``` -These functions return (monadic) values of type `Sqids a`. Calling `sqids` or -`runSqids` (see below) is the most straightforward way to extract the `something` -from a `Sqids something` value. +The Haskell standard (see [here](https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#dx13-135009)) +guarantees the range supported by `Int` to have an upper bound of at least +229 - 1 (= 536,870,911). If this does not present a problem for your +use case, instead use: ``` -sqids :: Sqids a -> Either SqidsError a +import Web.Sqids +``` + +Use `encode` to translate a list of non-negative integers into an ID, and +`decode` to retrieve back the list of numbers encoded by an ID. + +```haskell +encode :: (Integral a) => [a] -> Sqids Text +decode:: (Integral a) => Text -> Sqids [a] ``` -To be more accurate, this gives you a value of type `Either SqidsError a`, where -`a` is the ID in the case of `encode`. If encoding fails for some reason, then -the `Left` constructor [contains the error](#error-handling). -For some use cases, directly calling `sqids` or `runSqids` in this way is -sufficient. If you do this in multiple locations in your code, however, -especially when IO or other effects are involved, the -[`SqidsT` monad transformer](#monad-transformer) is a better choice. +These functions return (monadic) values of type `Sqids Int a` or `Sqids Integer a`. +Calling `sqids`, which uses the default configuration, or `runSqids` (see below) +is the most straightforward way to extract the `something` from a `Sqids s something` +value. + +```haskell +sqids :: Sqids s a -> Either SqidsError a +``` + +This gives you a value of type `Either SqidsError a`, where `a` is the ID in the +case of `encode`. If encoding fails for some reason, then the `Left` constructor +[contains the error](#error-handling). For some use cases, directly calling +`sqids` or `runSqids` in this way is sufficient. If you do this in multiple +locations in your code, however, especially when IO or other effects are +involved, the [`SqidsT` monad transformer](#monad-transformer) is a better choice. #### Encoding @@ -100,7 +122,7 @@ main = > The output of this program is: > > ``` -> "8QRLaD" +> "86Rf07xd4zBmiJXQG6otHEbe" > ``` #### Decoding @@ -113,7 +135,7 @@ import Web.Sqids main :: IO () main = - case sqids (decode "8QRLaD") of + case sqids (decode "86Rf07") of Left {} -> print "Something went wrong." Right nums -> print nums ``` @@ -126,14 +148,17 @@ main = ##### A note about the `OverloadedStrings` language extension -`decode` takes a `Text` value as input. If you are not compiling with `OverloadedStrings` enabled, the `"8QRLaD"` string literal in the previous example would need to be explicitly converted, using the `pack` function from `Data.Text`. +`decode` takes a `Text` value as input. If you are not compiling with +`OverloadedStrings` enabled, the `"86Rf07"` string literal in the previous +example would need to be explicitly converted, using the `pack` function from +`Data.Text`. ```haskell import Data.Text (pack) ``` ```haskell -decode (pack "8QRLaD") +decode (pack "86Rf07") ``` ### Setting options @@ -141,8 +166,8 @@ decode (pack "8QRLaD") To pass custom options to `encode` and `decode`, use `runSqids` which takes an additional `SqidsOptions` argument. -``` -runSqids :: SqidsOptions -> Sqids a -> Either SqidsError a +```haskell +runSqids :: SqidsOptions -> Sqids s a -> Either SqidsError a ``` See [here](#options) for available options. You can override the default values using @@ -173,7 +198,7 @@ main = > The output of this program is: > > ``` -> "oq6TCg" +> "oz6E9F" > ``` Or, you can set all options at once: @@ -193,7 +218,7 @@ main = do > The output of this program is: > > ``` -> "31764540" +> "38494176" > ``` ### Monad transformer @@ -204,13 +229,13 @@ you probably want to create your `SqidsOptions` once, and then do things with the IDs across the code without having to pass the options object along every time. Assuming your application relies on a transformer stack to combine effects from different monads, then this implies adding the `SqidsT` transformer at -some suitable layer of the stack. Instead of `sqids` and `runSqids`, there are +some suitable layer of the stack. Instead of `sqids` and `runSqids`, there are two corresponding functions to fish out :fishing_pole_and_fish: the value from inside of `SqidsT`: -``` -sqidsT :: Monad m => SqidsT m a -> m (Either SqidsError a) -runSqidsT :: Monad m => SqidsOptions -> SqidsT m a -> m (Either SqidsError a) +```haskell +sqidsT :: Monad m => SqidsT s m a -> m (Either SqidsError a) +runSqidsT :: Monad m => SqidsOptions -> SqidsT s m a -> m (Either SqidsError a) ``` Below is an example where `SqidsT` is used in combination with the `Writer` and @@ -233,7 +258,7 @@ main = do Left err -> print ("Error: " <> show err) Right ids -> print ids -makeIds :: WriterT [Text] (SqidsT IO) () +makeIds :: WriterT [Text] (SqidsT Int IO) () makeIds = do liftIO $ print "Generating IDs" forM_ [1 .. 50] $ \n -> do @@ -245,7 +270,7 @@ makeIds = do > > ``` > "Generating IDs" -> ["QkA3AmAC","fh9rtRtv","a7totm7V","KF5Z5l4X","ngqSq2b3","pjkCJlJf","yTrOSYSQ","HKVia9J2","0gTF2Zr3","jiw7wbw1","PtNNFWFA","I0vlvGvD","08TV2Sr5","UPLILMlD","ut2A2D20","Inv5vZvK","pDkBJTJJ","P1N8FRFr","R2eqeYeY","Ki5o5Q4U","1k70bzbD","dK4cE6Es","1L7XbJbZ","FyGjG1G0","ZEMReNre","aKtMte79","UtLNL9li","o6lElt2f","1w7ebtbl","nuqNqqbk","HlVSaOJ9","IKvdvave","3cWkDSD9","oQlzlc2C","RrezeDeC","OhJcJoVR","OEJFJzVJ","oplJlm2F","u8292F2H","FZGiGzGI","dN40E9EO","Q0AdAhAR","HJVzaaJC","s08YCUdX","sW8UCadW","ZaMNekrp","X4bsWS4Z","OoJIJEVj","Rqe1eTey","3aWYDXDs"] +> ["Q8Ac4uf3","fU9zWydl","aStUNEra","KR5zQbHB","n7qefHP0","pRkWlenI","ylr03cjE","H0V1tEjl","0rTYteaW","jQw6pcuZ","P9NfMbEk","IYvhBx6l","0vTGthaI","UXLhWExs","u52hY2FK","IjvHBv6e","pqk3lJnQ","PKNDMnEj","RJepNxTd","K15yQcHf","1c72LltW","dY4YwC0z","127FLStT","F0GBXRKm","ZDMTUa09","aFtHNir0","U4LiWBxu","oRltrlxW","1w7ULqtK","nYq5fnPa","HNVMtQjF","IRv4B26F","3wWEpjeF","oXlIrpxD","RNeTNnTN","OQJXLTbo","OAJwLube","onlgrbxt","u42vYoFH","FmGvXwKx","d84vwS0K","QuAl41fQ","H9VRtOjU","sh80jrCd","sB8CjqC3","ZKMzUJ0a","XkbEbTzD","OZJnL3bj","RGevNZTU","36WapueZ"] > ``` ### Error handling @@ -276,7 +301,7 @@ import Data.Text (unpack) import Text.Read (readMaybe) import Web.Sqids -repl :: SqidsT IO () +repl :: SqidsT Int IO () repl = do input <- liftIO $ do putStrLn "Enter a comma-separated list of non-negative integers, or \"exit\"." @@ -304,7 +329,7 @@ main :: IO () main = fromRight () <$> runRepl ``` -> Program example output: +> Program example output: > > ![Example](readme/example.gif) @@ -333,7 +358,7 @@ A list of words that must never appear in IDs. ### `SqidsAlphabetTooShort` -The alphabet must be at least 5 characters long. +The alphabet must be at least 3 characters long. ### `SqidsAlphabetRepeatedCharacters` @@ -349,6 +374,26 @@ The given `minLength` value is not within the valid range. One or more numbers in the list passed to `encode` are negative. Only non-negative integers can be used as input. +### `SqidsMaxEncodingAttempts` + +Encoding failed after too many recursive attempts. This happens if the +blocklist is too restrictive. Consider the following example: + +```haskell + let options = defaultSqidsOptions + { alphabet = "abc" + , blocklist = [ "cab", "abc", "bca" ] + , minLength = 3 + } + in + runSqids options (encode [0]) +``` + +### `SqidsAlphabetContainsMultibyteCharacters` + +The alphabet must consist of only characters in the standard single-byte +character set. + ## Notes - **Do not encode sensitive data.** These IDs can be easily decoded. From 86812b12f248404b46bcbe071d5455cb8702fc25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 12:33:08 +0300 Subject: [PATCH 15/17] Update README-file --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f3212fe..e7a8ee1 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ ### Installation -Sqids is available on Hackage ([hackage.haskell.org/package/sqids](https://hackage.haskell.org/package/sqids)). To install this package, run: +Sqids is available on Hackage ([hackage.haskell.org/package/sqids](https://hackage.haskell.org/package/sqids)). To install it, run: ``` cabal install sqids From 67874d13901193eb37ade43eb18c501c99ac1ae5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 12:40:11 +0300 Subject: [PATCH 16/17] Update README-file --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index e7a8ee1..4b0e9ef 100644 --- a/README.md +++ b/README.md @@ -122,7 +122,7 @@ main = > The output of this program is: > > ``` -> "86Rf07xd4zBmiJXQG6otHEbe" +> "86Rf07" > ``` #### Decoding @@ -183,7 +183,7 @@ main = > The output of this program is: > > ``` -> "75JILToVsGerOADWmT1cd0dL" +> "86Rf07xd4zBmiJXQG6otHEbe" > ``` To set a custom alphabet: From 1602b114063f9ed073bc9c5ee5ea1bb3796a4be1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Heikki=20Johannes=20Hild=C3=A9n?= Date: Fri, 13 Oct 2023 12:46:40 +0300 Subject: [PATCH 17/17] Fix typo --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 4b0e9ef..c2b5544 100644 --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ The library exposes two versions of the API; - `Web.Sqids.Integer` uses `Integer`s, which support arbitrarily large integers. If you need to work with (i.e., encode and decode) large numbers, it is -recommened to choose the latter option, in which case you would import the +recommended to choose the latter option, in which case you would import the library as: ```