{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- | This is a Haskell port of Ivan Akimov's Hashids library. This is /not/
--   a cryptographic hashing algorithm. Hashids is typically used to encode
--   numbers to a format suitable to appear in places like URLs.
--
-- See the official Hashids home page: <http://hashids.org>
--
-- Hashids is a small open-source library that generates short, unique,
-- non-sequential ids from numbers. It converts numbers like 347 into
-- strings like @yr8@, or a list of numbers like [27, 986] into @3kTMd@.
-- You can also decode those ids back. This is useful in bundling several
-- parameters into one or simply using them as short UIDs.

module Web.Hashids
    ( HashidsContext
    -- * How to use
    -- $howto

    -- ** Encoding
    -- $encoding

    -- ** Decoding
    -- $decoding

    -- ** Randomness
    -- $randomness

    -- *** Repeating numbers
    -- $repeating

    -- *** Incrementing number sequence
    -- $incrementing

    -- ** Curses\! \#\$\%\@
    -- $curses

    -- * API
    , version
    -- ** Context object constructors
    , createHashidsContext
    , hashidsSimple
    , hashidsMinimum
    -- ** Encoding and decoding
    , encodeHex
    , decodeHex
    , encode
    , encodeList
    , decode
    -- ** Convenience wrappers
    , encodeUsingSalt
    , encodeListUsingSalt
    , decodeUsingSalt
    , encodeHexUsingSalt
    , decodeHexUsingSalt
    ) where

import           Prelude               hiding (last, minimum, seq, tail)

import           Control.Monad         (foldM)
import           Data.ByteString       (ByteString)
import           Data.Foldable         (toList)
import           Data.List             (foldl', intersect, nub, (\\))
import           Data.List.Split       (chunksOf)
import           Data.Maybe            (fromMaybe)
import           Data.Sequence         (Seq)
import           Data.Word             (Word8)
import           Numeric               (readHex, showHex)

import qualified Data.ByteString       as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.Sequence         as Seq

-- $howto
--
-- Note that most of the examples on this page require the OverloadedStrings extension.

-- $encoding
--
-- Unless you require a minimum length for the generated hash, create a
-- context using 'hashidsSimple' and then call 'encode' and 'decode' with
-- this object.
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Web.Hashids
-- >
-- > main :: IO ()
-- > main = do
-- >     let context = hashidsSimple "oldsaltyswedishseadog"
-- >     print $ encode context 42
--
-- This program will output
--
-- > "kg"
--
-- To specify a minimum hash length, use 'hashidsMinimum' instead.
--
-- > main = do
-- >     let context = hashidsMinimum "oldsaltyswedishseadog" 12
-- >     print $ encode context 42
--
-- The output will now be
--
-- > "W3xbdkgdy42v"
--
-- If you only need the context once, you can use one of the provided wrappers
-- to simplify things.
--
-- > main :: IO ()
-- > main = print $ encodeUsingSalt "oldsaltyswedishseadog" 42
--
-- On the other hand, if your implementation invokes the hashing algorithm
-- frequently without changing the configuration, it is probably better to
-- define partially applied versions of 'encode', 'encodeList', and 'decode'.
--
-- > import Web.Hashids
-- >
-- > context :: HashidsContext
-- > context = createHashidsContext "oldsaltyswedishseadog" 12 "abcdefghijklmnopqrstuvwxyz"
-- >
-- > encode'     = encode context
-- > encodeList' = encodeList context
-- > decode'     = decode context
-- >
-- > main :: IO ()
-- > main = print $ encode' 12345
--
-- Use a custom alphabet and 'createHashidsContext' if you want to make your
-- hashes \"unique\".
--
-- > main = do
-- >     let context = createHashidsContext "oldsaltyswedishseadog" 0 "XbrNfdylm5qtnP19R"
-- >     print $ encode context 1
--
-- The output is now
--
-- > "Rd"
--
-- To encode a list of numbers, use `encodeList`.
--
-- > let context = hashidsSimple "this is my salt" in encodeList context [0, 1, 2]
--
-- > "yJUWHx"

-- $decoding
--
-- Decoding a hash returns a list of numbers,
--
-- > let context = hashidsSimple "this is my salt"
-- >      hash = decode context "rD"        -- == [5]
--
-- Decoding will not work if the salt is changed:
--
-- > main = do
-- >     let context = hashidsSimple "this is my salt"
-- >         hash = encode context 5
-- >
-- >     print $ decodeUsingSalt "this is my pepper" hash
--
-- When decoding fails, the empty list is returned.
--
-- > []
--

-- $randomness
--
-- Hashids is based on a modified version of the Fisher-Yates shuffle. The
-- primary purpose is to obfuscate ids, and it is not meant for security
-- purposes or compression. Having said that, the algorithm does try to make
-- hashes unguessable and unpredictable. See the official Hashids home page
-- for details: <http://hashids.org>

-- $repeating
--
-- > let context = hashidsSimple "this is my salt" in encodeList context $ replicate 4 5
--
-- There are no repeating patterns in the hash to suggest that four identical
-- numbers are used:
--
-- > "1Wc8cwcE"
--
-- The same is true for increasing numbers:
--
-- > let context = hashidsSimple "this is my salt" in encodeList context [1..10]
--
-- > "kRHnurhptKcjIDTWC3sx"

-- $incrementing
--
-- > let context = hashidsSimple "this is my salt" in map (encode context) [1..5]
--
-- > ["NV","6m","yD","2l","rD"]

-- $curses
--
-- The algorithm tries to avoid generating common curse words in English by
-- never placing the following letters next to each other:
--
-- > c, C, s, S, f, F, h, H, u, U, i, I, t, T

{-# INLINE (|>) #-}
(|>) :: a -> (a -> b) -> b
|> :: forall a b. a -> (a -> b) -> b
(|>) a
a a -> b
f = a -> b
f a
a

{-# INLINE splitOn #-}
splitOn :: ByteString -> ByteString -> [ByteString]
splitOn :: ByteString -> ByteString -> [ByteString]
splitOn = (Word8 -> Bool) -> ByteString -> [ByteString]
BS.splitWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Word8 -> ByteString -> Bool
BS.elem

-- | Opaque data type with various internals required for encoding and decoding.
data HashidsContext = Context
    { HashidsContext -> ByteString
guards        :: !ByteString
    , HashidsContext -> ByteString
seps          :: !ByteString
    , HashidsContext -> ByteString
salt          :: !ByteString
    , HashidsContext -> Int
minHashLength :: !Int
    , HashidsContext -> ByteString
alphabet      :: !ByteString
    } deriving (Int -> HashidsContext -> ShowS
[HashidsContext] -> ShowS
HashidsContext -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HashidsContext] -> ShowS
$cshowList :: [HashidsContext] -> ShowS
show :: HashidsContext -> [Char]
$cshow :: HashidsContext -> [Char]
showsPrec :: Int -> HashidsContext -> ShowS
$cshowsPrec :: Int -> HashidsContext -> ShowS
Show)

-- | Hashids version number.
version :: String
version :: [Char]
version = [Char]
"1.0.2"

-- | Create a context object using the given salt, a minimum hash length, and
--   a custom alphabet. If you only need to supply the salt, or the first two
--   arguments, use 'hashidsSimple' or 'hashidsMinimum' instead.
--
--   Changing the alphabet is useful if you want to make your hashes unique,
--   i.e., create hashes different from those generated by other applications
--   relying on the same algorithm.
createHashidsContext :: ByteString  -- ^ Salt
                     -> Int         -- ^ Minimum required hash length
                     -> String      -- ^ Alphabet
                     -> HashidsContext
createHashidsContext :: ByteString -> Int -> [Char] -> HashidsContext
createHashidsContext ByteString
salt Int
minHashLen [Char]
alphabet
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
uniqueAlphabet forall a. Ord a => a -> a -> Bool
< Int
minAlphabetLength
        = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"alphabet must contain at least " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
minAlphabetLength forall a. [a] -> [a] -> [a]
++ [Char]
" unique characters"
    | Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
uniqueAlphabet
        = forall a. HasCallStack => [Char] -> a
error [Char]
"alphabet cannot contain spaces"
    | ByteString -> Bool
BS.null ByteString
seps'' Bool -> Bool -> Bool
|| forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
alphabet') forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
seps'') forall a. Ord a => a -> a -> Bool
> Double
sepDiv
        = case Int
sepsLength forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
seps'' of
            Int
diff | Int
diff forall a. Ord a => a -> a -> Bool
> Int
0
                -> ByteString -> ByteString -> HashidsContext
res (Int -> ByteString -> ByteString
BS.drop Int
diff ByteString
alphabet') (ByteString
seps'' ByteString -> ByteString -> ByteString
`BS.append` Int -> ByteString -> ByteString
BS.take Int
diff ByteString
alphabet')
            Int
_   -> ByteString -> ByteString -> HashidsContext
res ByteString
alphabet' (Int -> ByteString -> ByteString
BS.take Int
sepsLength ByteString
seps'')
    | Bool
otherwise = ByteString -> ByteString -> HashidsContext
res ByteString
alphabet' ByteString
seps''
  where

    res :: ByteString -> ByteString -> HashidsContext
res ByteString
ab ByteString
_seps =
        let shuffled :: ByteString
shuffled = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
ab ByteString
salt
            guardCount :: Int
guardCount = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
shuffled) forall a. Fractional a => a -> a -> a
/ Double
guardDiv)
            context :: HashidsContext
context = Context
                { guards :: ByteString
guards        = Int -> ByteString -> ByteString
BS.take Int
guardCount ByteString
_seps
                , seps :: ByteString
seps          = Int -> ByteString -> ByteString
BS.drop Int
guardCount ByteString
_seps
                , salt :: ByteString
salt          = ByteString
salt
                , minHashLength :: Int
minHashLength = Int
minHashLen
                , alphabet :: ByteString
alphabet      = ByteString
shuffled }

         in if ByteString -> Int
BS.length ByteString
shuffled forall a. Ord a => a -> a -> Bool
< Int
3
                then HashidsContext
context
                else HashidsContext
context{ guards :: ByteString
guards   = Int -> ByteString -> ByteString
BS.take Int
guardCount ByteString
shuffled
                            , seps :: ByteString
seps     = ByteString
_seps
                            , alphabet :: ByteString
alphabet = Int -> ByteString -> ByteString
BS.drop Int
guardCount ByteString
shuffled }

    seps' :: ByteString
seps'  = [Char] -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ [Char]
uniqueAlphabet forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Char]
seps
    seps'' :: ByteString
seps'' = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
seps' ByteString
salt

    sepsLength :: Int
sepsLength =
        case forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
alphabet') forall a. Fractional a => a -> a -> a
/ Double
sepDiv) of
          Int
1 -> Int
2
          Int
n -> Int
n

    uniqueAlphabet :: [Char]
uniqueAlphabet    = forall a. Eq a => [a] -> [a]
nub [Char]
alphabet
    alphabet' :: ByteString
alphabet'         = [Char] -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ [Char]
uniqueAlphabet forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
seps
    minAlphabetLength :: Int
minAlphabetLength = Int
16
    sepDiv :: Double
sepDiv            = Double
3.5 :: Double
    guardDiv :: Double
guardDiv          = Double
12 :: Double
    seps :: [Char]
seps              = [Char]
"cfhistuCFHISTU"

defaultAlphabet :: String
defaultAlphabet :: [Char]
defaultAlphabet = [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char]
"1234567890"

-- | Create a context object using the default alphabet and the provided salt,
--   without any minimum required length.
hashidsSimple :: ByteString       -- ^ Salt
              -> HashidsContext
hashidsSimple :: ByteString -> HashidsContext
hashidsSimple ByteString
salt = ByteString -> Int -> [Char] -> HashidsContext
createHashidsContext ByteString
salt Int
0 [Char]
defaultAlphabet

-- | Create a context object using the default alphabet and the provided salt.
--   The generated hashes will have a minimum length as specified by the second
--   argument.
hashidsMinimum :: ByteString      -- ^ Salt
               -> Int             -- ^ Minimum required hash length
               -> HashidsContext
hashidsMinimum :: ByteString -> Int -> HashidsContext
hashidsMinimum ByteString
salt Int
minimum = ByteString -> Int -> [Char] -> HashidsContext
createHashidsContext ByteString
salt Int
minimum [Char]
defaultAlphabet

-- | Decode a hash generated with 'encodeHex'.
--
-- /Example use:/
--
-- > decodeHex context "yzgwD"
--
decodeHex :: HashidsContext     -- ^ A Hashids context object
          -> ByteString         -- ^ Hash
          -> String
decodeHex :: HashidsContext -> ByteString -> [Char]
decodeHex HashidsContext
context ByteString
hashDigest = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Integral a, Show a) => a -> ShowS
showHex [Char]
"") [Int]
numbers
  where
    numbers :: [Int]
numbers = HashidsContext -> ByteString -> [Int]
decode HashidsContext
context ByteString
hashDigest

-- | Encode a hexadecimal number.
--
-- /Example use:/
--
-- > encodeHex context "ff83"
--
encodeHex :: HashidsContext     -- ^ A Hashids context object
          -> String             -- ^ Hexadecimal number represented as a string
          -> ByteString
encodeHex :: HashidsContext -> [Char] -> ByteString
encodeHex HashidsContext
context [Char]
hexStr
    | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
hexChar [Char]
hexStr) = ByteString
""
    | Bool
otherwise = HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
context forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Eq a, Num a) => [Char] -> a
go forall a b. (a -> b) -> a -> b
$ forall e. Int -> [e] -> [[e]]
chunksOf Int
12 [Char]
hexStr
  where
    go :: [Char] -> a
go [Char]
str = let [(a
a,[Char]
_)] = forall a. (Eq a, Num a) => ReadS a
readHex (Char
'1'forall a. a -> [a] -> [a]
:[Char]
str) in a
a
    hexChar :: Char -> Bool
hexChar Char
c = Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"0123456789abcdefABCDEF" :: String)

-- | Decode a hash.
--
-- /Example use:/
--
-- > let context = hashidsSimple "this is my salt"
-- >     hash = decode context "rD"        -- == [5]
--
decode :: HashidsContext     -- ^ A Hashids context object
       -> ByteString         -- ^ Hash
       -> [Int]
decode :: HashidsContext -> ByteString -> [Int]
decode ctx :: HashidsContext
ctx@Context{Int
ByteString
alphabet :: ByteString
minHashLength :: Int
salt :: ByteString
seps :: ByteString
guards :: ByteString
alphabet :: HashidsContext -> ByteString
minHashLength :: HashidsContext -> Int
salt :: HashidsContext -> ByteString
seps :: HashidsContext -> ByteString
guards :: HashidsContext -> ByteString
..} ByteString
hashDigest
    | ByteString -> Bool
BS.null ByteString
hashDigest = []
    | [Int]
res forall a. Eq a => a -> a -> Bool
== [] = []
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> a -> Bool
< Int
0) [Int]
res = []
    | HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
ctx [Int]
res forall a. Eq a => a -> a -> Bool
/= ByteString
hashDigest = []
    | Bool
otherwise = [Int]
res
  where
    res :: [Int]
res = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
      (Word8
lottery, ByteString
tail) <- Maybe (Word8, ByteString)
mLotteryAndTail
      let prefix :: ByteString
prefix = Word8 -> ByteString -> ByteString
BS.cons Word8
lottery ByteString
salt
      ([Int], ByteString)
res' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (ByteString
-> ([Int], ByteString) -> ByteString -> Maybe ([Int], ByteString)
go ByteString
prefix) ([], ByteString
alphabet) (ByteString -> ByteString -> [ByteString]
splitOn ByteString
seps ByteString
tail)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst ([Int], ByteString)
res'

    hashArray :: [ByteString]
hashArray = ByteString -> ByteString -> [ByteString]
splitOn ByteString
guards ByteString
hashDigest

    mLotteryAndTail :: Maybe (Word8, ByteString)
mLotteryAndTail =
         ByteString -> Maybe (Word8, ByteString)
BS.uncons forall a b. (a -> b) -> a -> b
$ [ByteString]
hashArray forall a. [a] -> Int -> a
!! case forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
hashArray of
            Int
0 -> forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error."
            Int
2 -> Int
1
            Int
3 -> Int
1
            Int
_ -> Int
0

    go :: ByteString
       -> ([Int], ByteString)
       -> ByteString
       -> Maybe ([Int], ByteString)
    go :: ByteString
-> ([Int], ByteString) -> ByteString -> Maybe ([Int], ByteString)
go ByteString
prefix ([Int]
xs, ByteString
ab) ByteString
ssh = do
        let buffer :: ByteString
buffer = ByteString
prefix ByteString -> ByteString -> ByteString
`BS.append` ByteString
ab
            ab' :: ByteString
ab'    = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
ab ByteString
buffer
        Int
unh <- ByteString -> ByteString -> Maybe Int
unhash ByteString
ssh ByteString
ab'
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int
unhforall a. a -> [a] -> [a]
:[Int]
xs, ByteString
ab')

numbersHashInt :: [Int] -> Int
numbersHashInt :: [Int] -> Int
numbersHashInt [Int]
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Integral a => a -> a -> a
mod) Int
0 forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
xs [Int
100 .. ]

-- | Encode a single number.
--
-- /Example use:/
--
-- > let context = hashidsSimple "this is my salt"
-- >     hash = encode context 5        -- == "rD"
--
encode :: HashidsContext        -- ^ A Hashids context object
       -> Int                   -- ^ Number to encode
       -> ByteString
encode :: HashidsContext -> Int -> ByteString
encode HashidsContext
context Int
n = HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
context [Int
n]

-- | Encode a list of numbers.
--
-- /Example use:/
--
-- > let context = hashidsSimple "this is my salt"
-- >     hash = encodeList context [2, 3, 5, 7, 11]          -- == "EOurh6cbTD"
--
encodeList :: HashidsContext    -- ^ A Hashids context object
           -> [Int]             -- ^ List of numbers
           -> ByteString
encodeList :: HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
_ [] = forall a. HasCallStack => [Char] -> a
error [Char]
"encodeList: empty list"
encodeList Context{Int
ByteString
alphabet :: ByteString
minHashLength :: Int
salt :: ByteString
seps :: ByteString
guards :: ByteString
alphabet :: HashidsContext -> ByteString
minHashLength :: HashidsContext -> Int
salt :: HashidsContext -> ByteString
seps :: HashidsContext -> ByteString
guards :: HashidsContext -> ByteString
..} [Int]
numbers =
    ByteString
res forall a b. a -> (a -> b) -> b
|> Bool -> ByteString -> ByteString
expand Bool
False forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
BS.reverse
        forall a b. a -> (a -> b) -> b
|> Bool -> ByteString -> ByteString
expand Bool
True  forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
BS.reverse
        forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString -> ByteString
expand' ByteString
alphabet'
  where
    (ByteString
res, ByteString
alphabet') = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ByteString, ByteString) -> (Int, Int) -> (ByteString, ByteString)
go (Word8 -> ByteString
BS.singleton Word8
lottery, ByteString
alphabet) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. ] [Int]
numbers)

    expand :: Bool -> ByteString -> ByteString
expand Bool
rep ByteString
str
        | ByteString -> Int
BS.length ByteString
str forall a. Ord a => a -> a -> Bool
< Int
minHashLength
            = let ix :: Int
ix = if Bool
rep then ByteString -> Int
BS.length ByteString
str forall a. Num a => a -> a -> a
- Int
3 else Int
0
                  jx :: Int
jx = forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
BS.index ByteString
str Int
ix) forall a. Num a => a -> a -> a
+ Int
hashInt
               in HasCallStack => ByteString -> Int -> Word8
BS.index ByteString
guards (Int
jx forall a. Integral a => a -> a -> a
`mod` Int
guardsLength) Word8 -> ByteString -> ByteString
`BS.cons` ByteString
str
        | Bool
otherwise = ByteString
str

    expand' :: ByteString -> ByteString -> ByteString
expand' ByteString
ab ByteString
str
        | ByteString -> Int
BS.length ByteString
str forall a. Ord a => a -> a -> Bool
< Int
minHashLength
            = let ab' :: ByteString
ab'  = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
ab ByteString
ab
                  str' :: ByteString
str' = [ByteString] -> ByteString
BS.concat [Int -> ByteString -> ByteString
BS.drop Int
halfLength ByteString
ab', ByteString
str, Int -> ByteString -> ByteString
BS.take Int
halfLength ByteString
ab']
               in ByteString -> ByteString -> ByteString
expand' ByteString
ab' forall a b. (a -> b) -> a -> b
$ case ByteString -> Int
BS.length ByteString
str' forall a. Num a => a -> a -> a
- Int
minHashLength of
                    Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
0
                      -> Int -> ByteString -> ByteString
BS.take Int
minHashLength forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (forall a. Integral a => a -> a -> a
div Int
n Int
2) ByteString
str'
                    Int
_ -> ByteString
str'
        | Bool
otherwise = ByteString
str

    hashInt :: Int
hashInt = [Int] -> Int
numbersHashInt [Int]
numbers
    lottery :: Word8
lottery = ByteString
alphabet HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
hashInt forall a. Integral a => a -> a -> a
`mod` Int
alphabetLength)
    prefix :: ByteString
prefix  = Word8 -> ByteString -> ByteString
BS.cons Word8
lottery ByteString
salt
    numLast :: Int
numLast = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
numbers forall a. Num a => a -> a -> a
- Int
1
    guardsLength :: Int
guardsLength   = ByteString -> Int
BS.length ByteString
guards
    alphabetLength :: Int
alphabetLength = ByteString -> Int
BS.length ByteString
alphabet
    halfLength :: Int
halfLength     = forall a. Integral a => a -> a -> a
div Int
alphabetLength Int
2

    go :: (ByteString, ByteString) -> (Int, Int) -> (ByteString, ByteString)
go (ByteString
r, ByteString
ab) (Int
i, Int
number)
        | Int
number forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"all numbers must be non-negative"
        | Bool
otherwise =
            let shuffled :: ByteString
shuffled = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
ab (ByteString -> ByteString -> ByteString
BS.append ByteString
prefix ByteString
ab)
                last :: ByteString
last = Int -> ByteString -> ByteString
hash Int
number ByteString
shuffled
                n :: Int
n = Int
number forall a. Integral a => a -> a -> a
`mod` (forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Word8
BS.head ByteString
last) forall a. Num a => a -> a -> a
+ Int
i) forall a. Integral a => a -> a -> a
`mod` ByteString -> Int
BS.length ByteString
seps
                suffix :: ByteString
suffix = if Int
i forall a. Ord a => a -> a -> Bool
< Int
numLast
                            then Word8 -> ByteString
BS.singleton (ByteString
seps HasCallStack => ByteString -> Int -> Word8
`BS.index` Int
n)
                            else ByteString
BS.empty
             in ([ByteString] -> ByteString
BS.concat [ByteString
r,ByteString
last,ByteString
suffix], ByteString
shuffled)

-- Exchange elements at positions i and j in a sequence.
exchange :: Int -> Int -> Seq a -> Seq a
exchange :: forall a. Int -> Int -> Seq a -> Seq a
exchange Int
i Int
j Seq a
seq = Int
i Int -> Int -> Seq a -> Seq a
<--> Int
j forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Seq a -> Seq a
<--> Int
i forall a b. (a -> b) -> a -> b
$ Seq a
seq
  where
    Int
a <--> :: Int -> Int -> Seq a -> Seq a
<--> Int
b = forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
a forall a b. (a -> b) -> a -> b
$ forall a. Seq a -> Int -> a
Seq.index Seq a
seq Int
b

consistentShuffle :: ByteString -> ByteString -> ByteString
consistentShuffle :: ByteString -> ByteString -> ByteString
consistentShuffle ByteString
alphabet ByteString
salt
    | Int
0 forall a. Eq a => a -> a -> Bool
== Int
saltLength = ByteString
alphabet
    | Bool
otherwise = [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Word8
x
  where
    (Int
_,Seq Word8
x) = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
len, forall a. Enum a => a -> a
pred Int
len .. Int
1] [Int]
xs [Int]
ys forall a b. a -> (a -> b) -> b
|> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. (Int, Seq a) -> (Int, Int, Int) -> (Int, Seq a)
go (Int
0, ByteString -> Seq Word8
toSeq ByteString
alphabet)

    xs :: [Int]
xs = forall a. [a] -> [a]
cycle [Int
0 .. Int
saltLength forall a. Num a => a -> a -> a
- Int
1]
    ys :: [Int]
ys = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
saltLookup) [Int]
xs

    saltLookup :: Int -> Word8
saltLookup Int
ix = HasCallStack => ByteString -> Int -> Word8
BS.index ByteString
salt (Int
ix forall a. Integral a => a -> a -> a
`mod` Int
saltLength)
    saltLength :: Int
saltLength = ByteString -> Int
BS.length ByteString
salt

    toSeq :: ByteString -> Seq Word8
toSeq = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' forall a. Seq a -> a -> Seq a
(Seq.|>) forall a. Seq a
Seq.empty
    len :: Int
len = ByteString -> Int
BS.length ByteString
alphabet forall a. Num a => a -> a -> a
- Int
1

    go :: (Int, Seq a) -> (Int, Int, Int) -> (Int, Seq a)
go (Int
p, Seq a
ab) (Int
i, Int
v, Int
ch) =
        let shuffled :: Seq a
shuffled = forall a. Int -> Int -> Seq a -> Seq a
exchange Int
i Int
j Seq a
ab
            p' :: Int
p' = Int
p forall a. Num a => a -> a -> a
+ Int
ch
            j :: Int
j  = forall a. Integral a => a -> a -> a
mod (Int
ch forall a. Num a => a -> a -> a
+ Int
v forall a. Num a => a -> a -> a
+ Int
p') Int
i
         in (Int
p', Seq a
shuffled)

unhash :: ByteString -> ByteString -> Maybe Int
unhash :: ByteString -> ByteString -> Maybe Int
unhash ByteString
input ByteString
alphabet = forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Maybe Int -> Word8 -> Maybe Int
go (forall a. a -> Maybe a
Just Int
0) ByteString
input
  where
    go :: Maybe Int -> Word8 -> Maybe Int
    go :: Maybe Int -> Word8 -> Maybe Int
go Maybe Int
Nothing Word8
_ = forall a. Maybe a
Nothing
    go (Just Int
carry) Word8
item = do
      Int
index <- Word8 -> ByteString -> Maybe Int
BS.elemIndex Word8
item ByteString
alphabet
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
carry forall a. Num a => a -> a -> a
* Int
alphabetLength forall a. Num a => a -> a -> a
+ Int
index
    alphabetLength :: Int
alphabetLength = ByteString -> Int
BS.length ByteString
alphabet

hash :: Int -> ByteString -> ByteString
hash :: Int -> ByteString -> ByteString
hash Int
input ByteString
alphabet
    | Int
0 forall a. Eq a => a -> a -> Bool
== Int
input = Int -> ByteString -> ByteString
BS.take Int
1 ByteString
alphabet
    | Bool
otherwise = ByteString -> ByteString
BS.reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr Int -> Maybe (Word8, Int)
go Int
input
  where
    len :: Int
len = ByteString -> Int
BS.length ByteString
alphabet
    go :: Int -> Maybe (Word8, Int)
go Int
0 = forall a. Maybe a
Nothing
    go Int
i = forall a. a -> Maybe a
Just (ByteString
alphabet HasCallStack => ByteString -> Int -> Word8
`BS.index` (Int
i forall a. Integral a => a -> a -> a
`mod` Int
len), forall a. Integral a => a -> a -> a
div Int
i Int
len)

-- | Encode a number using the provided salt.
--
--   This convenience function creates a context with the default alphabet.
--   If the same context is used repeatedly, use 'encode' with one of the
--   constructors instead.
encodeUsingSalt :: ByteString     -- ^ Salt
                -> Int            -- ^ Number
                -> ByteString
encodeUsingSalt :: ByteString -> Int -> ByteString
encodeUsingSalt = HashidsContext -> Int -> ByteString
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple

-- | Encode a list of numbers using the provided salt.
--
--   This function wrapper creates a context with the default alphabet.
--   If the same context is used repeatedly, use 'encodeList' with one of the
--   constructors instead.
encodeListUsingSalt :: ByteString -- ^ Salt
                    -> [Int]      -- ^ Numbers
                    -> ByteString
encodeListUsingSalt :: ByteString -> [Int] -> ByteString
encodeListUsingSalt = HashidsContext -> [Int] -> ByteString
encodeList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple

-- | Decode a hash using the provided salt.
--
--   This convenience function creates a context with the default alphabet.
--   If the same context is used repeatedly, use 'decode' with one of the
--   constructors instead.
decodeUsingSalt :: ByteString     -- ^ Salt
                -> ByteString     -- ^ Hash
                -> [Int]
decodeUsingSalt :: ByteString -> ByteString -> [Int]
decodeUsingSalt = HashidsContext -> ByteString -> [Int]
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple

-- | Shortcut for 'encodeHex'.
encodeHexUsingSalt :: ByteString  -- ^ Salt
                   -> String      -- ^ Hexadecimal number represented as a string
                   -> ByteString
encodeHexUsingSalt :: ByteString -> [Char] -> ByteString
encodeHexUsingSalt = HashidsContext -> [Char] -> ByteString
encodeHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple

-- | Shortcut for 'decodeHex'.
decodeHexUsingSalt :: ByteString  -- ^ Salt
                   -> ByteString  -- ^ Hash
                   -> String
decodeHexUsingSalt :: ByteString -> ByteString -> [Char]
decodeHexUsingSalt = HashidsContext -> ByteString -> [Char]
decodeHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple