{-# 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 f = f a

{-# INLINE splitOn #-}
splitOn :: ByteString -> ByteString -> [ByteString]
splitOn = BS.splitWith . flip BS.elem

-- | Opaque data type with various internals required for encoding and decoding.
data HashidsContext = Context
    { guards        :: !ByteString
    , seps          :: !ByteString
    , salt          :: !ByteString
    , minHashLength :: !Int
    , alphabet      :: !ByteString
    } deriving (Show)

-- | Hashids version number.
version :: String
version = "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 salt minHashLen alphabet
    | length uniqueAlphabet < minAlphabetLength
        = error $ "alphabet must contain at least " ++ show minAlphabetLength ++ " unique characters"
    | ' ' `elem` uniqueAlphabet
        = error "alphabet cannot contain spaces"
    | BS.null seps'' || fromIntegral (BS.length alphabet') / fromIntegral (BS.length seps'') > sepDiv
        = case sepsLength - BS.length seps'' of
            diff | diff > 0
                -> res (BS.drop diff alphabet') (seps'' `BS.append` BS.take diff alphabet')
            _   -> res alphabet' (BS.take sepsLength seps'')
    | otherwise = res alphabet' seps''
  where

    res ab _seps =
        let shuffled = consistentShuffle ab salt
            guardCount = ceiling (fromIntegral (BS.length shuffled) / guardDiv)
            context = Context
                { guards        = BS.take guardCount _seps
                , seps          = BS.drop guardCount _seps
                , salt          = salt
                , minHashLength = minHashLen
                , alphabet      = shuffled }

         in if BS.length shuffled < 3
                then context
                else context{ guards   = BS.take guardCount shuffled
                            , seps     = _seps
                            , alphabet = BS.drop guardCount shuffled }

    seps'  = C8.pack $ uniqueAlphabet `intersect` seps
    seps'' = consistentShuffle seps' salt

    sepsLength =
        case ceiling (fromIntegral (BS.length alphabet') / sepDiv) of
          1 -> 2
          n -> n

    uniqueAlphabet    = nub alphabet
    alphabet'         = C8.pack $ uniqueAlphabet \\ seps
    minAlphabetLength = 16
    sepDiv            = 3.5 :: Double
    guardDiv          = 12 :: Double
    seps              = "cfhistuCFHISTU"

defaultAlphabet :: String
defaultAlphabet = ['a'..'z'] ++ ['A'..'Z'] ++ "1234567890"

-- | Create a context object using the default alphabet and the provided salt,
--   without any minimum required length.
hashidsSimple :: ByteString       -- ^ Salt
              -> HashidsContext
hashidsSimple salt = createHashidsContext salt 0 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 salt minimum = createHashidsContext salt minimum defaultAlphabet

-- | Decode a hash generated with 'encodeHex'.
--
-- /Example use:/
--
-- > decodeHex context "yzgwD"
--
decodeHex :: HashidsContext     -- ^ A Hashids context object
          -> ByteString         -- ^ Hash
          -> String
decodeHex context hashDigest = concatMap (drop 1 . flip showHex "") numbers
  where
    numbers = decode context 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 context hexStr
    | not (all hexChar hexStr) = ""
    | otherwise = encodeList context $ map go $ chunksOf 12 hexStr
  where
    go str = let [(a,_)] = readHex ('1':str) in a
    hexChar c = c `elem` ("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 ctx@Context{..} hashDigest
    | BS.null hashDigest = []
    | res == [] = []
    | any (< 0) res = []
    | encodeList ctx res /= hashDigest = []
    | otherwise = res
  where
    res = fromMaybe [] $ do
      (lottery, tail) <- mLotteryAndTail
      let prefix = BS.cons lottery salt
      res' <- foldM (go prefix) ([], alphabet) (splitOn seps tail)
      return $ reverse $ fst res'

    hashArray = splitOn guards hashDigest

    mLotteryAndTail =
         BS.uncons $ hashArray !! case length hashArray of
            0 -> error "Internal error."
            2 -> 1
            3 -> 1
            _ -> 0

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

numbersHashInt :: [Int] -> Int
numbersHashInt xs = foldr ((+) . uncurry mod) 0 $ zip xs [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 context n = encodeList context [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 _ [] = error "encodeList: empty list"
encodeList Context{..} numbers =
    res |> expand False |> BS.reverse
        |> expand True  |> BS.reverse
        |> expand' alphabet'
  where
    (res, alphabet') = foldl' go (BS.singleton lottery, alphabet) (zip [0 .. ] numbers)

    expand rep str
        | BS.length str < minHashLength
            = let ix = if rep then BS.length str - 3 else 0
                  jx = fromIntegral (BS.index str ix) + hashInt
               in BS.index guards (jx `mod` guardsLength) `BS.cons` str
        | otherwise = str

    expand' ab str
        | BS.length str < minHashLength
            = let ab'  = consistentShuffle ab ab
                  str' = BS.concat [BS.drop halfLength ab', str, BS.take halfLength ab']
               in expand' ab' $ case BS.length str' - minHashLength of
                    n | n > 0
                      -> BS.take minHashLength $ BS.drop (div n 2) str'
                    _ -> str'
        | otherwise = str

    hashInt = numbersHashInt numbers
    lottery = alphabet `BS.index` (hashInt `mod` alphabetLength)
    prefix  = BS.cons lottery salt
    numLast = length numbers - 1
    guardsLength   = BS.length guards
    alphabetLength = BS.length alphabet
    halfLength     = div alphabetLength 2

    go (r, ab) (i, number)
        | number < 0 = error "all numbers must be non-negative"
        | otherwise =
            let shuffled = consistentShuffle ab (BS.append prefix ab)
                last = hash number shuffled
                n = number `mod` (fromIntegral (BS.head last) + i) `mod` BS.length seps
                suffix = if i < numLast
                            then BS.singleton (seps `BS.index` n)
                            else BS.empty
             in (BS.concat [r,last,suffix], shuffled)

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

consistentShuffle :: ByteString -> ByteString -> ByteString
consistentShuffle alphabet salt
    | 0 == saltLength = alphabet
    | otherwise = BS.pack $ toList x
  where
    (_,x) = zip3 [len, pred len .. 1] xs ys |> foldl' go (0, toSeq alphabet)

    xs = cycle [0 .. saltLength - 1]
    ys = map (fromIntegral . saltLookup) xs

    saltLookup ix = BS.index salt (ix `mod` saltLength)
    saltLength = BS.length salt

    toSeq = BS.foldl' (Seq.|>) Seq.empty
    len = BS.length alphabet - 1

    go (p, ab) (i, v, ch) =
        let shuffled = exchange i j ab
            p' = p + ch
            j  = mod (ch + v + p') i
         in (p', shuffled)

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

hash :: Int -> ByteString -> ByteString
hash input alphabet
    | 0 == input = BS.take 1 alphabet
    | otherwise = BS.reverse $ BS.unfoldr go input
  where
    len = BS.length alphabet
    go 0 = Nothing
    go i = Just (alphabet `BS.index` (i `mod` len), div i 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 = encode . 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 = encodeList . 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 = decode . hashidsSimple

-- | Shortcut for 'encodeHex'.
encodeHexUsingSalt :: ByteString  -- ^ Salt
                   -> String      -- ^ Hexadecimal number represented as a string
                   -> ByteString
encodeHexUsingSalt = encodeHex . hashidsSimple

-- | Shortcut for 'decodeHex'.
decodeHexUsingSalt :: ByteString  -- ^ Salt
                   -> ByteString  -- ^ Hash
                   -> String
decodeHexUsingSalt = decodeHex . hashidsSimple