{-# 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
|> :: 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 ((Word8 -> Bool) -> ByteString -> [ByteString])
-> (ByteString -> Word8 -> Bool)
-> ByteString
-> ByteString
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ByteString -> Bool) -> ByteString -> Word8 -> Bool
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 -> String
(Int -> HashidsContext -> ShowS)
-> (HashidsContext -> String)
-> ([HashidsContext] -> ShowS)
-> Show HashidsContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HashidsContext] -> ShowS
$cshowList :: [HashidsContext] -> ShowS
show :: HashidsContext -> String
$cshow :: HashidsContext -> String
showsPrec :: Int -> HashidsContext -> ShowS
$cshowsPrec :: Int -> HashidsContext -> ShowS
Show)

-- | Hashids version number.
version :: String
version :: String
version = String
"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 -> String -> HashidsContext
createHashidsContext ByteString
salt Int
minHashLen String
alphabet
    | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
uniqueAlphabet Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minAlphabetLength
        = String -> HashidsContext
forall a. HasCallStack => String -> a
error (String -> HashidsContext) -> String -> HashidsContext
forall a b. (a -> b) -> a -> b
$ String
"alphabet must contain at least " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
minAlphabetLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" unique characters"
    | Char
' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
uniqueAlphabet
        = String -> HashidsContext
forall a. HasCallStack => String -> a
error String
"alphabet cannot contain spaces"
    | ByteString -> Bool
BS.null ByteString
seps'' Bool -> Bool -> Bool
|| Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
alphabet') Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
seps'') Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
sepDiv
        = case Int
sepsLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
seps'' of
            Int
diff | Int
diff Int -> Int -> Bool
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 = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
shuffled) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
guardDiv)
            context :: HashidsContext
context = Context :: ByteString
-> ByteString -> ByteString -> Int -> ByteString -> HashidsContext
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 Int -> Int -> Bool
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'  = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
uniqueAlphabet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
`intersect` String
seps
    seps'' :: ByteString
seps'' = ByteString -> ByteString -> ByteString
consistentShuffle ByteString
seps' ByteString
salt

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

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

defaultAlphabet :: String
defaultAlphabet :: String
defaultAlphabet = [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"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 -> String -> HashidsContext
createHashidsContext ByteString
salt Int
0 String
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 -> String -> HashidsContext
createHashidsContext ByteString
salt Int
minimum String
defaultAlphabet

-- | Decode a hash generated with 'encodeHex'.
--
-- /Example use:/
--
-- > decodeHex context "yzgwD"
--
decodeHex :: HashidsContext     -- ^ A Hashids context object
          -> ByteString         -- ^ Hash
          -> String
decodeHex :: HashidsContext -> ByteString -> String
decodeHex HashidsContext
context ByteString
hashDigest = (Int -> String) -> [Int] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ShowS) -> String -> Int -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex String
"") [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 -> String -> ByteString
encodeHex HashidsContext
context String
hexStr
    | Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
hexChar String
hexStr) = ByteString
""
    | Bool
otherwise = HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
context ([Int] -> ByteString) -> [Int] -> ByteString
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. (Eq a, Num a) => String -> a
go ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf Int
12 String
hexStr
  where
    go :: String -> a
go String
str = let [(a
a,String
_)] = ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex (Char
'1'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str) in a
a
    hexChar :: Char -> Bool
hexChar Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"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 [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [] = []
    | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) [Int]
res = []
    | HashidsContext -> [Int] -> ByteString
encodeList HashidsContext
ctx [Int]
res ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
hashDigest = []
    | Bool
otherwise = [Int]
res
  where
    res :: [Int]
res = [Int] -> Maybe [Int] -> [Int]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Int] -> [Int]) -> Maybe [Int] -> [Int]
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' <- (([Int], ByteString) -> ByteString -> Maybe ([Int], ByteString))
-> ([Int], ByteString) -> [ByteString] -> Maybe ([Int], ByteString)
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)
      [Int] -> Maybe [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ ([Int], ByteString) -> [Int]
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 (ByteString -> Maybe (Word8, ByteString))
-> ByteString -> Maybe (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString]
hashArray [ByteString] -> Int -> ByteString
forall a. [a] -> Int -> a
!! case [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
hashArray of
            Int
0 -> String -> Int
forall a. HasCallStack => String -> a
error String
"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'
        ([Int], ByteString) -> Maybe ([Int], ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
unhInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs, ByteString
ab')

numbersHashInt :: [Int] -> Int
numbersHashInt :: [Int] -> Int
numbersHashInt [Int]
xs = ((Int, Int) -> Int -> Int) -> Int -> [(Int, Int)] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int)
-> ((Int, Int) -> Int) -> (Int, Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> (Int, Int) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod) Int
0 ([(Int, Int)] -> Int) -> [(Int, Int)] -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
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
_ [] = String -> ByteString
forall a. HasCallStack => String -> a
error String
"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 ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Bool -> ByteString -> ByteString
expand Bool
False ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
BS.reverse
        ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Bool -> ByteString -> ByteString
expand Bool
True  ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
BS.reverse
        ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString -> ByteString
expand' ByteString
alphabet'
  where
    (ByteString
res, ByteString
alphabet') = ((ByteString, ByteString)
 -> (Int, Int) -> (ByteString, ByteString))
-> (ByteString, ByteString)
-> [(Int, Int)]
-> (ByteString, ByteString)
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) ([Int] -> [Int] -> [(Int, Int)]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minHashLength
            = let ix :: Int
ix = if Bool
rep then ByteString -> Int
BS.length ByteString
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3 else Int
0
                  jx :: Int
jx = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word8
BS.index ByteString
str Int
ix) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hashInt
               in ByteString -> Int -> Word8
BS.index ByteString
guards (Int
jx Int -> Int -> Int
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 Int -> Int -> Bool
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' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ case ByteString -> Int
BS.length ByteString
str' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minHashLength of
                    Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                      -> Int -> ByteString -> ByteString
BS.take Int
minHashLength (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (Int -> Int -> Int
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 ByteString -> Int -> Word8
`BS.index` (Int
hashInt Int -> Int -> Int
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 = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
numbers Int -> Int -> Int
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     = Int -> Int -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> (ByteString, ByteString)
forall a. HasCallStack => String -> a
error String
"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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Word8
BS.head ByteString
last) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` ByteString -> Int
BS.length ByteString
seps
                suffix :: ByteString
suffix = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
numLast
                            then Word8 -> ByteString
BS.singleton (ByteString
seps 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 :: Int -> Int -> Seq a -> Seq a
exchange Int
i Int
j Seq a
seq = Int
i Int -> Int -> Seq a -> Seq a
<--> Int
j (Seq a -> Seq a) -> Seq a -> Seq a
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Seq a -> Seq a
<--> Int
i (Seq a -> Seq a) -> Seq a -> Seq a
forall a b. (a -> b) -> a -> b
$ Seq a
seq
  where
    Int
a <--> :: Int -> Int -> Seq a -> Seq a
<--> Int
b = Int -> a -> Seq a -> Seq a
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
a (a -> Seq a -> Seq a) -> a -> Seq a -> Seq a
forall a b. (a -> b) -> a -> b
$ Seq a -> Int -> a
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
saltLength = ByteString
alphabet
    | Bool
otherwise = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Seq Word8 -> [Word8]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Word8
x
  where
    (Int
_,Seq Word8
x) = [Int] -> [Int] -> [Int] -> [(Int, Int, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
len, Int -> Int
forall a. Enum a => a -> a
pred Int
len .. Int
1] [Int]
xs [Int]
ys [(Int, Int, Int)]
-> ([(Int, Int, Int)] -> (Int, Seq Word8)) -> (Int, Seq Word8)
forall a b. a -> (a -> b) -> b
|> ((Int, Seq Word8) -> (Int, Int, Int) -> (Int, Seq Word8))
-> (Int, Seq Word8) -> [(Int, Int, Int)] -> (Int, Seq Word8)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Seq Word8) -> (Int, Int, Int) -> (Int, Seq Word8)
forall a. (Int, Seq a) -> (Int, Int, Int) -> (Int, Seq a)
go (Int
0, ByteString -> Seq Word8
toSeq ByteString
alphabet)

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

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

    toSeq :: ByteString -> Seq Word8
toSeq = (Seq Word8 -> Word8 -> Seq Word8)
-> Seq Word8 -> ByteString -> Seq Word8
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Seq Word8 -> Word8 -> Seq Word8
forall a. Seq a -> a -> Seq a
(Seq.|>) Seq Word8
forall a. Seq a
Seq.empty
    len :: Int
len = ByteString -> Int
BS.length ByteString
alphabet Int -> Int -> Int
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 = Int -> Int -> Seq a -> Seq a
forall a. Int -> Int -> Seq a -> Seq a
exchange Int
i Int
j Seq a
ab
            p' :: Int
p' = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ch
            j :: Int
j  = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Int
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
v Int -> Int -> Int
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 = (Maybe Int -> Word8 -> Maybe Int)
-> Maybe Int -> ByteString -> Maybe Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Maybe Int -> Word8 -> Maybe Int
go (Int -> Maybe Int
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
_ = Maybe Int
forall a. Maybe a
Nothing
    go (Just Int
carry) Word8
item = do
      Int
index <- Word8 -> ByteString -> Maybe Int
BS.elemIndex Word8
item ByteString
alphabet
      Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
carry Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
alphabetLength Int -> Int -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
input = Int -> ByteString -> ByteString
BS.take Int
1 ByteString
alphabet
    | Bool
otherwise = ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe (Word8, Int)) -> Int -> ByteString
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 = Maybe (Word8, Int)
forall a. Maybe a
Nothing
    go Int
i = (Word8, Int) -> Maybe (Word8, Int)
forall a. a -> Maybe a
Just (ByteString
alphabet ByteString -> Int -> Word8
`BS.index` (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len), Int -> Int -> Int
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 (HashidsContext -> Int -> ByteString)
-> (ByteString -> HashidsContext)
-> ByteString
-> Int
-> ByteString
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 (HashidsContext -> [Int] -> ByteString)
-> (ByteString -> HashidsContext)
-> ByteString
-> [Int]
-> ByteString
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 (HashidsContext -> ByteString -> [Int])
-> (ByteString -> HashidsContext)
-> ByteString
-> ByteString
-> [Int]
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 -> String -> ByteString
encodeHexUsingSalt = HashidsContext -> String -> ByteString
encodeHex (HashidsContext -> String -> ByteString)
-> (ByteString -> HashidsContext)
-> ByteString
-> String
-> ByteString
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 -> String
decodeHexUsingSalt = HashidsContext -> ByteString -> String
decodeHex (HashidsContext -> ByteString -> String)
-> (ByteString -> HashidsContext)
-> ByteString
-> ByteString
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HashidsContext
hashidsSimple