{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Sqids.Internal
  ( sqidsVersion
  , SqidsOptions (..)
  , SqidsError (..)
  , SqidsContext (..)
  , emptySqidsContext
  , defaultSqidsOptions
  , SqidsStack
  , MonadSqids (..)
  , sqidsContext
  , 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, MonadError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Identity (Identity, runIdentity)
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 (isDigit, ord, toLower)
import Data.List (foldl', unfoldr)
import Data.Text (Text)
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
sqidsVersion :: String
sqidsVersion = String
"0.0.1"

-- | Options that can be passed to `runSqids` or `runSqidsT`.
data SqidsOptions = SqidsOptions
  { SqidsOptions -> Text
alphabet  :: !Text
  -- ^ The set of characters to use for encoding and decoding IDs.
  , SqidsOptions -> Int
minLength :: !Int
  -- ^ The minimum allowed length of IDs.
  , SqidsOptions -> [Text]
blocklist :: ![Text]
  -- ^ A list of words that must never appear in IDs.
  } deriving (Int -> SqidsOptions -> ShowS
[SqidsOptions] -> ShowS
SqidsOptions -> String
(Int -> SqidsOptions -> ShowS)
-> (SqidsOptions -> String)
-> ([SqidsOptions] -> ShowS)
-> Show SqidsOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SqidsOptions -> ShowS
showsPrec :: Int -> SqidsOptions -> ShowS
$cshow :: SqidsOptions -> String
show :: SqidsOptions -> String
$cshowList :: [SqidsOptions] -> ShowS
showList :: [SqidsOptions] -> ShowS
Show, SqidsOptions -> SqidsOptions -> Bool
(SqidsOptions -> SqidsOptions -> Bool)
-> (SqidsOptions -> SqidsOptions -> Bool) -> Eq SqidsOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SqidsOptions -> SqidsOptions -> Bool
== :: SqidsOptions -> SqidsOptions -> Bool
$c/= :: SqidsOptions -> SqidsOptions -> Bool
/= :: SqidsOptions -> SqidsOptions -> Bool
Eq, Eq SqidsOptions
Eq SqidsOptions =>
(SqidsOptions -> SqidsOptions -> Ordering)
-> (SqidsOptions -> SqidsOptions -> Bool)
-> (SqidsOptions -> SqidsOptions -> Bool)
-> (SqidsOptions -> SqidsOptions -> Bool)
-> (SqidsOptions -> SqidsOptions -> Bool)
-> (SqidsOptions -> SqidsOptions -> SqidsOptions)
-> (SqidsOptions -> SqidsOptions -> SqidsOptions)
-> Ord SqidsOptions
SqidsOptions -> SqidsOptions -> Bool
SqidsOptions -> SqidsOptions -> Ordering
SqidsOptions -> SqidsOptions -> SqidsOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SqidsOptions -> SqidsOptions -> Ordering
compare :: SqidsOptions -> SqidsOptions -> Ordering
$c< :: SqidsOptions -> SqidsOptions -> Bool
< :: SqidsOptions -> SqidsOptions -> Bool
$c<= :: SqidsOptions -> SqidsOptions -> Bool
<= :: SqidsOptions -> SqidsOptions -> Bool
$c> :: SqidsOptions -> SqidsOptions -> Bool
> :: SqidsOptions -> SqidsOptions -> Bool
$c>= :: SqidsOptions -> SqidsOptions -> Bool
>= :: SqidsOptions -> SqidsOptions -> Bool
$cmax :: SqidsOptions -> SqidsOptions -> SqidsOptions
max :: SqidsOptions -> SqidsOptions -> SqidsOptions
$cmin :: SqidsOptions -> SqidsOptions -> SqidsOptions
min :: SqidsOptions -> SqidsOptions -> SqidsOptions
Ord)

-- | Default options
defaultSqidsOptions :: SqidsOptions
defaultSqidsOptions :: SqidsOptions
defaultSqidsOptions = SqidsOptions
  { alphabet :: Text
alphabet  = String -> Text
Text.pack String
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
  , minLength :: Int
minLength = Int
0
  , blocklist :: [Text]
blocklist = [Text]
defaultBlocklist
  }

data SqidsContext s = SqidsContext
  { forall s. SqidsContext s -> Text
sqidsAlphabet  :: !Text
  , forall s. SqidsContext s -> Int
sqidsMinLength :: !Int
  , forall s. SqidsContext s -> [Text]
sqidsBlocklist :: ![Text]
  } deriving (Int -> SqidsContext s -> ShowS
[SqidsContext s] -> ShowS
SqidsContext s -> String
(Int -> SqidsContext s -> ShowS)
-> (SqidsContext s -> String)
-> ([SqidsContext s] -> ShowS)
-> Show (SqidsContext s)
forall s. Int -> SqidsContext s -> ShowS
forall s. [SqidsContext s] -> ShowS
forall s. SqidsContext s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall s. Int -> SqidsContext s -> ShowS
showsPrec :: Int -> SqidsContext s -> ShowS
$cshow :: forall s. SqidsContext s -> String
show :: SqidsContext s -> String
$cshowList :: forall s. [SqidsContext s] -> ShowS
showList :: [SqidsContext s] -> ShowS
Show, SqidsContext s -> SqidsContext s -> Bool
(SqidsContext s -> SqidsContext s -> Bool)
-> (SqidsContext s -> SqidsContext s -> Bool)
-> Eq (SqidsContext s)
forall s. SqidsContext s -> SqidsContext s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall s. SqidsContext s -> SqidsContext s -> Bool
== :: SqidsContext s -> SqidsContext s -> Bool
$c/= :: forall s. SqidsContext s -> SqidsContext s -> Bool
/= :: SqidsContext s -> SqidsContext s -> Bool
Eq, Eq (SqidsContext s)
Eq (SqidsContext s) =>
(SqidsContext s -> SqidsContext s -> Ordering)
-> (SqidsContext s -> SqidsContext s -> Bool)
-> (SqidsContext s -> SqidsContext s -> Bool)
-> (SqidsContext s -> SqidsContext s -> Bool)
-> (SqidsContext s -> SqidsContext s -> Bool)
-> (SqidsContext s -> SqidsContext s -> SqidsContext s)
-> (SqidsContext s -> SqidsContext s -> SqidsContext s)
-> Ord (SqidsContext s)
SqidsContext s -> SqidsContext s -> Bool
SqidsContext s -> SqidsContext s -> Ordering
SqidsContext s -> SqidsContext s -> SqidsContext s
forall s. Eq (SqidsContext s)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall s. SqidsContext s -> SqidsContext s -> Bool
forall s. SqidsContext s -> SqidsContext s -> Ordering
forall s. SqidsContext s -> SqidsContext s -> SqidsContext s
$ccompare :: forall s. SqidsContext s -> SqidsContext s -> Ordering
compare :: SqidsContext s -> SqidsContext s -> Ordering
$c< :: forall s. SqidsContext s -> SqidsContext s -> Bool
< :: SqidsContext s -> SqidsContext s -> Bool
$c<= :: forall s. SqidsContext s -> SqidsContext s -> Bool
<= :: SqidsContext s -> SqidsContext s -> Bool
$c> :: forall s. SqidsContext s -> SqidsContext s -> Bool
> :: SqidsContext s -> SqidsContext s -> Bool
$c>= :: forall s. SqidsContext s -> SqidsContext s -> Bool
>= :: SqidsContext s -> SqidsContext s -> Bool
$cmax :: forall s. SqidsContext s -> SqidsContext s -> SqidsContext s
max :: SqidsContext s -> SqidsContext s -> SqidsContext s
$cmin :: forall s. SqidsContext s -> SqidsContext s -> SqidsContext s
min :: SqidsContext s -> SqidsContext s -> SqidsContext s
Ord)

{-# INLINE emptySqidsContext #-}
emptySqidsContext :: SqidsContext s
emptySqidsContext :: forall s. SqidsContext s
emptySqidsContext = Text -> Int -> [Text] -> SqidsContext s
forall s. Text -> Int -> [Text] -> SqidsContext s
SqidsContext Text
Text.empty Int
0 []

data SqidsError
  = SqidsNegativeNumberInInput
  -- ^ 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 (Int -> SqidsError -> ShowS
[SqidsError] -> ShowS
SqidsError -> String
(Int -> SqidsError -> ShowS)
-> (SqidsError -> String)
-> ([SqidsError] -> ShowS)
-> Show SqidsError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SqidsError -> ShowS
showsPrec :: Int -> SqidsError -> ShowS
$cshow :: SqidsError -> String
show :: SqidsError -> String
$cshowList :: [SqidsError] -> ShowS
showList :: [SqidsError] -> ShowS
Show, ReadPrec [SqidsError]
ReadPrec SqidsError
Int -> ReadS SqidsError
ReadS [SqidsError]
(Int -> ReadS SqidsError)
-> ReadS [SqidsError]
-> ReadPrec SqidsError
-> ReadPrec [SqidsError]
-> Read SqidsError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SqidsError
readsPrec :: Int -> ReadS SqidsError
$creadList :: ReadS [SqidsError]
readList :: ReadS [SqidsError]
$creadPrec :: ReadPrec SqidsError
readPrec :: ReadPrec SqidsError
$creadListPrec :: ReadPrec [SqidsError]
readListPrec :: ReadPrec [SqidsError]
Read, SqidsError -> SqidsError -> Bool
(SqidsError -> SqidsError -> Bool)
-> (SqidsError -> SqidsError -> Bool) -> Eq SqidsError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SqidsError -> SqidsError -> Bool
== :: SqidsError -> SqidsError -> Bool
$c/= :: SqidsError -> SqidsError -> Bool
/= :: SqidsError -> SqidsError -> Bool
Eq, Eq SqidsError
Eq SqidsError =>
(SqidsError -> SqidsError -> Ordering)
-> (SqidsError -> SqidsError -> Bool)
-> (SqidsError -> SqidsError -> Bool)
-> (SqidsError -> SqidsError -> Bool)
-> (SqidsError -> SqidsError -> Bool)
-> (SqidsError -> SqidsError -> SqidsError)
-> (SqidsError -> SqidsError -> SqidsError)
-> Ord SqidsError
SqidsError -> SqidsError -> Bool
SqidsError -> SqidsError -> Ordering
SqidsError -> SqidsError -> SqidsError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SqidsError -> SqidsError -> Ordering
compare :: SqidsError -> SqidsError -> Ordering
$c< :: SqidsError -> SqidsError -> Bool
< :: SqidsError -> SqidsError -> Bool
$c<= :: SqidsError -> SqidsError -> Bool
<= :: SqidsError -> SqidsError -> Bool
$c> :: SqidsError -> SqidsError -> Bool
> :: SqidsError -> SqidsError -> Bool
$c>= :: SqidsError -> SqidsError -> Bool
>= :: SqidsError -> SqidsError -> Bool
$cmax :: SqidsError -> SqidsError -> SqidsError
max :: SqidsError -> SqidsError -> SqidsError
$cmin :: SqidsError -> SqidsError -> SqidsError
min :: SqidsError -> SqidsError -> SqidsError
Ord)

type SqidsStack s m = ReaderT (SqidsContext s) (ExceptT SqidsError m)

class (Monad m) => MonadSqids s m | m -> s where
  -- | Encode a list of integers into an 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 :: Text    -- ^ The encoded ID
              -> m [s]   -- ^ Returns a list of numbers

-- | Sqids constructor
sqidsContext
  :: (MonadSqids s m, MonadError SqidsError m)
  => SqidsOptions
  -> m (SqidsContext s)
sqidsContext :: forall s (m :: * -> *).
(MonadSqids s m, MonadError SqidsError m) =>
SqidsOptions -> m (SqidsContext s)
sqidsContext SqidsOptions{Int
[Text]
Text
alphabet :: SqidsOptions -> Text
minLength :: SqidsOptions -> Int
blocklist :: SqidsOptions -> [Text]
alphabet :: Text
minLength :: Int
blocklist :: [Text]
..} = do

  let alphabetLetterCount :: Int
alphabetLetterCount = Text -> Int
letterCount Text
alphabet

  -- Check that the alphabet doesn't contain multibyte characters
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
containsMultibyteChars Text
alphabet) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SqidsError -> m ()
forall a. SqidsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsAlphabetContainsMultibyteCharacters

  -- Check the length of the alphabet
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Int
Text.length Text
alphabet Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SqidsError -> m ()
forall a. SqidsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsAlphabetTooShort

  -- Check that the alphabet has only unique characters
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
alphabetLetterCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Int
Text.length Text
alphabet) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SqidsError -> m ()
forall a. SqidsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsAlphabetRepeatedCharacters

  -- Validate min. length
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
minLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
minLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SqidsError -> m ()
forall a. SqidsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsInvalidMinLength

  SqidsContext s -> m (SqidsContext s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SqidsContext s -> m (SqidsContext s))
-> SqidsContext s -> m (SqidsContext s)
forall a b. (a -> b) -> a -> b
$ SqidsContext
    { sqidsAlphabet :: Text
sqidsAlphabet  = Text -> Text
shuffle Text
alphabet
    , sqidsMinLength :: Int
sqidsMinLength = Int
minLength
    , sqidsBlocklist :: [Text]
sqidsBlocklist = Text -> [Text] -> [Text]
filteredBlocklist Text
alphabet [Text]
blocklist
    }

-- | Sqids monad transformer
newtype SqidsT s m a = SqidsT { forall s (m :: * -> *) a. SqidsT s m a -> SqidsStack s m a
unwrapSqidsT :: SqidsStack s m a }
  deriving
    ( (forall a b. (a -> b) -> SqidsT s m a -> SqidsT s m b)
-> (forall a b. a -> SqidsT s m b -> SqidsT s m a)
-> Functor (SqidsT s m)
forall a b. a -> SqidsT s m b -> SqidsT s m a
forall a b. (a -> b) -> SqidsT s m a -> SqidsT s m b
forall s (m :: * -> *) a b.
Functor m =>
a -> SqidsT s m b -> SqidsT s m a
forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqidsT s m a -> SqidsT s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqidsT s m a -> SqidsT s m b
fmap :: forall a b. (a -> b) -> SqidsT s m a -> SqidsT s m b
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> SqidsT s m b -> SqidsT s m a
<$ :: forall a b. a -> SqidsT s m b -> SqidsT s m a
Functor
    , Functor (SqidsT s m)
Functor (SqidsT s m) =>
(forall a. a -> SqidsT s m a)
-> (forall a b.
    SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b)
-> (forall a b c.
    (a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c)
-> (forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b)
-> (forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m a)
-> Applicative (SqidsT s m)
forall a. a -> SqidsT s m a
forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m a
forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b
forall a b. SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
forall a b c.
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
forall s (m :: * -> *). Monad m => Functor (SqidsT s m)
forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m a
forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m b
forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
forall s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
pure :: forall a. a -> SqidsT s m a
$c<*> :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
<*> :: forall a b. SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
$cliftA2 :: forall s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
liftA2 :: forall a b c.
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
$c*> :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m b
*> :: forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b
$c<* :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m a
<* :: forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m a
Applicative
    , Applicative (SqidsT s m)
Applicative (SqidsT s m) =>
(forall a b. SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b)
-> (forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b)
-> (forall a. a -> SqidsT s m a)
-> Monad (SqidsT s m)
forall a. a -> SqidsT s m a
forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b
forall a b. SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b
forall s (m :: * -> *). Monad m => Applicative (SqidsT s m)
forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m b
forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b
>>= :: forall a b. SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b
$c>> :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m b
>> :: forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m b
$creturn :: forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
return :: forall a. a -> SqidsT s m a
Monad
    , MonadReader (SqidsContext s)
    , MonadError SqidsError
    , Monad (SqidsT s m)
Monad (SqidsT s m) =>
(forall a. IO a -> SqidsT s m a) -> MonadIO (SqidsT s m)
forall a. IO a -> SqidsT s m a
forall s (m :: * -> *). MonadIO m => Monad (SqidsT s m)
forall s (m :: * -> *) a. MonadIO m => IO a -> SqidsT s m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall s (m :: * -> *) a. MonadIO m => IO a -> SqidsT s m a
liftIO :: forall a. IO a -> SqidsT s m a
MonadIO
    )

instance MonadTrans (SqidsT s) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> SqidsT s m a
lift = SqidsStack s m a -> SqidsT s m a
forall s (m :: * -> *) a. SqidsStack s m a -> SqidsT s m a
SqidsT (SqidsStack s m a -> SqidsT s m a)
-> (m a -> SqidsStack s m a) -> m a -> SqidsT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT SqidsError m a -> SqidsStack s m a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (SqidsContext s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT SqidsError m a -> SqidsStack s m a)
-> (m a -> ExceptT SqidsError m a) -> m a -> SqidsStack s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT SqidsError m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT SqidsError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (Integral s, Monad m) => MonadSqids s (SqidsT s m) where
  sqidsEncode :: [s] -> SqidsT s m Text
sqidsEncode [s]
numbers
    | [s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
numbers =
        -- If no numbers passed, return an empty string
        Text -> SqidsT s m Text
forall a. a -> SqidsT s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
Text.empty
    | (s -> Bool) -> [s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (s -> s -> Bool
forall a. Ord a => a -> a -> Bool
< s
0) [s]
numbers =
        -- Don't allow negative integers
        SqidsError -> SqidsT s m Text
forall a. SqidsError -> SqidsT s m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsNegativeNumberInInput
    | Bool
otherwise =
        [s] -> Int -> SqidsT s m Text
forall s (m :: * -> *).
(Integral s, MonadSqids s m, MonadError SqidsError m,
 MonadReader (SqidsContext s) m) =>
[s] -> Int -> m Text
encodeNumbers [s]
numbers Int
0

  sqidsDecode :: Text -> SqidsT s m [s]
sqidsDecode Text
sqid =
    (SqidsContext s -> Text -> [s]) -> SqidsT s m (Text -> [s])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Text -> [s]
forall a. Integral a => Text -> Text -> [a]
decodeWithAlphabet (Text -> Text -> [s])
-> (SqidsContext s -> Text) -> SqidsContext s -> Text -> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqidsContext s -> Text
forall s. SqidsContext s -> Text
sqidsAlphabet) SqidsT s m (Text -> [s]) -> SqidsT s m Text -> SqidsT s m [s]
forall a b. SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> SqidsT s m Text
forall a. a -> SqidsT s m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid

-- | Sqids monad
type Sqids s = SqidsT s Identity

-- | Evaluate a `SqidsT` computation with the given options.
runSqidsT :: (Integral s, Monad m) => SqidsOptions -> SqidsT s m a -> m (Either SqidsError a)
runSqidsT :: forall s (m :: * -> *) a.
(Integral s, Monad m) =>
SqidsOptions -> SqidsT s m a -> m (Either SqidsError a)
runSqidsT SqidsOptions
options SqidsT s m a
value =
  ExceptT SqidsError m a -> m (Either SqidsError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT (SqidsContext s) (ExceptT SqidsError m) a
-> SqidsContext s -> ExceptT SqidsError m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SqidsT s m a -> ReaderT (SqidsContext s) (ExceptT SqidsError m) a
forall s (m :: * -> *) a. SqidsT s m a -> SqidsStack s m a
unwrapSqidsT SqidsT s m a
withOptions) SqidsContext s
forall s. SqidsContext s
emptySqidsContext)
  where
    withOptions :: SqidsT s m a
withOptions = SqidsOptions -> SqidsT s m (SqidsContext s)
forall s (m :: * -> *).
(MonadSqids s m, MonadError SqidsError m) =>
SqidsOptions -> m (SqidsContext s)
sqidsContext SqidsOptions
options SqidsT s m (SqidsContext s)
-> (SqidsContext s -> SqidsT s m a) -> SqidsT s m a
forall a b. SqidsT s m a -> (a -> SqidsT s m b) -> SqidsT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((SqidsContext s -> SqidsContext s) -> SqidsT s m a -> SqidsT s m a
forall a.
(SqidsContext s -> SqidsContext s) -> SqidsT s m a -> SqidsT s m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
`local` SqidsT s m a
value) ((SqidsContext s -> SqidsContext s) -> SqidsT s m a)
-> (SqidsContext s -> SqidsContext s -> SqidsContext s)
-> SqidsContext s
-> SqidsT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqidsContext s -> SqidsContext s -> SqidsContext s
forall a b. a -> b -> a
const

-- | Evaluate a `SqidsT` computation with the default options. This is a short
--   form for `runSqidsT defaultSqidsOptions`.
sqidsT :: (Integral s, Monad m) => SqidsT s m a -> m (Either SqidsError a)
sqidsT :: forall s (m :: * -> *) a.
(Integral s, Monad m) =>
SqidsT s m a -> m (Either SqidsError a)
sqidsT = SqidsOptions -> SqidsT s m a -> m (Either SqidsError a)
forall s (m :: * -> *) a.
(Integral s, Monad m) =>
SqidsOptions -> SqidsT s m a -> m (Either SqidsError a)
runSqidsT SqidsOptions
defaultSqidsOptions

-- | Evaluate a `Sqids` computation with the given options.
runSqids :: (Integral s) => SqidsOptions -> Sqids s a -> Either SqidsError a
runSqids :: forall s a.
Integral s =>
SqidsOptions -> Sqids s a -> Either SqidsError a
runSqids SqidsOptions
options = Identity (Either SqidsError a) -> Either SqidsError a
forall a. Identity a -> a
runIdentity (Identity (Either SqidsError a) -> Either SqidsError a)
-> (Sqids s a -> Identity (Either SqidsError a))
-> Sqids s a
-> Either SqidsError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqidsOptions -> Sqids s a -> Identity (Either SqidsError a)
forall s (m :: * -> *) a.
(Integral s, Monad m) =>
SqidsOptions -> SqidsT s m a -> m (Either SqidsError a)
runSqidsT SqidsOptions
options -- . unwrapSqidsT

-- | Evaluate a `Sqids` computation with the default options. This is a short
--   form for `runSqids defaultSqidsOptions`.
sqids :: (Integral s) => Sqids s a -> Either SqidsError a
sqids :: forall s a. Integral s => Sqids s a -> Either SqidsError a
sqids = SqidsOptions -> Sqids s a -> Either SqidsError a
forall s a.
Integral s =>
SqidsOptions -> Sqids s a -> Either SqidsError a
runSqids SqidsOptions
defaultSqidsOptions

instance (MonadSqids s m) => MonadSqids s (StateT s m) where
  sqidsEncode :: [s] -> StateT s m Text
sqidsEncode = m Text -> StateT s m Text
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> StateT s m Text)
-> ([s] -> m Text) -> [s] -> StateT s m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> StateT s m [s]
sqidsDecode = m [s] -> StateT s m [s]
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> StateT s m [s])
-> (Text -> m [s]) -> Text -> StateT s m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m) => MonadSqids s (ExceptT e m) where
  sqidsEncode :: [s] -> ExceptT e m Text
sqidsEncode = m Text -> ExceptT e m Text
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> ExceptT e m Text)
-> ([s] -> m Text) -> [s] -> ExceptT e m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ExceptT e m [s]
sqidsDecode = m [s] -> ExceptT e m [s]
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> ExceptT e m [s])
-> (Text -> m [s]) -> Text -> ExceptT e m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m) => MonadSqids s (ReaderT r m) where
  sqidsEncode :: [s] -> ReaderT r m Text
sqidsEncode = m Text -> ReaderT r m Text
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> ReaderT r m Text)
-> ([s] -> m Text) -> [s] -> ReaderT r m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ReaderT r m [s]
sqidsDecode = m [s] -> ReaderT r m [s]
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> ReaderT r m [s])
-> (Text -> m [s]) -> Text -> ReaderT r m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m, Monoid w) => MonadSqids s (WriterT w m) where
  sqidsEncode :: [s] -> WriterT w m Text
sqidsEncode = m Text -> WriterT w m Text
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> WriterT w m Text)
-> ([s] -> m Text) -> [s] -> WriterT w m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> WriterT w m [s]
sqidsDecode = m [s] -> WriterT w m [s]
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> WriterT w m [s])
-> (Text -> m [s]) -> Text -> WriterT w m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m) => MonadSqids s (MaybeT m) where
  sqidsEncode :: [s] -> MaybeT m Text
sqidsEncode = m Text -> MaybeT m Text
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> MaybeT m Text)
-> ([s] -> m Text) -> [s] -> MaybeT m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> MaybeT m [s]
sqidsDecode = m [s] -> MaybeT m [s]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> MaybeT m [s]) -> (Text -> m [s]) -> Text -> MaybeT m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m) => MonadSqids s (ContT r m) where
  sqidsEncode :: [s] -> ContT r m Text
sqidsEncode = m Text -> ContT r m Text
forall (m :: * -> *) a. Monad m => m a -> ContT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> ContT r m Text)
-> ([s] -> m Text) -> [s] -> ContT r m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ContT r m [s]
sqidsDecode = m [s] -> ContT r m [s]
forall (m :: * -> *) a. Monad m => m a -> ContT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> ContT r m [s])
-> (Text -> m [s]) -> Text -> ContT r m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

instance (MonadSqids s m) => MonadSqids s (SelectT r m) where
  sqidsEncode :: [s] -> SelectT r m Text
sqidsEncode = m Text -> SelectT r m Text
forall (m :: * -> *) a. Monad m => m a -> SelectT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Text -> SelectT r m Text)
-> ([s] -> m Text) -> [s] -> SelectT r m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [s] -> m Text
forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> SelectT r m [s]
sqidsDecode = m [s] -> SelectT r m [s]
forall (m :: * -> *) a. Monad m => m a -> SelectT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [s] -> SelectT r m [s])
-> (Text -> m [s]) -> Text -> SelectT r m [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [s]
forall s (m :: * -> *). MonadSqids s m => Text -> m [s]
sqidsDecode

-- Clean up blocklist:
--
--   1. All words must be lowercase
--   2. No words should be less than three characters long
--   3. Remove words that contain characters that are not in the alphabet
--
filteredBlocklist :: Text -> [Text] -> [Text]
filteredBlocklist :: Text -> [Text] -> [Text]
filteredBlocklist Text
alph [Text]
ws = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isValid ((Char -> Char) -> Text -> Text
Text.map Char -> Char
toLower (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ws)
  where
    isValid :: Text -> Bool
isValid Text
w = Text -> Int
Text.length Text
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.all (Char -> Text -> Bool
`Text.elem` Text
lowercaseAlphabet) Text
w
    lowercaseAlphabet :: Text
lowercaseAlphabet = (Char -> Char) -> Text -> Text
Text.map Char -> Char
toLower Text
alph

decodeStep :: (Integral a) => (Text, Text) -> Maybe (a, (Text, Text))
decodeStep :: forall a. Integral a => (Text, Text) -> Maybe (a, (Text, Text))
decodeStep (Text
sqid, Text
alph)
  | Text -> Bool
Text.null Text
sqid = Maybe (a, (Text, Text))
forall a. Maybe a
Nothing
  | Bool
otherwise = do
      case Text -> Maybe (Char, Text)
Text.uncons Text
alph of
        Just (Char
separatorChar, Text
alphabetWithoutSeparator) ->
          let separator :: Text
separator = Char -> Text
Text.singleton Char
separatorChar
           in case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
separator Text
sqid of
              [] ->
                Maybe (a, (Text, Text))
forall a. Maybe a
Nothing
              (Text
chunk : [Text]
chunks)
                | Text -> Bool
Text.null Text
chunk ->
                    Maybe (a, (Text, Text))
forall a. Maybe a
Nothing
                | Bool
otherwise -> (a, (Text, Text)) -> Maybe (a, (Text, Text))
forall a. a -> Maybe a
Just
                    ( Text -> Text -> a
forall a. Integral a => Text -> Text -> a
toNumber Text
chunk Text
alphabetWithoutSeparator
                    , (Text -> [Text] -> Text
Text.intercalate Text
separator [Text]
chunks, Text -> Text
shuffle Text
alph)
                    )
        Maybe (Char, Text)
_ ->
          String -> Maybe (a, (Text, Text))
forall a. HasCallStack => String -> a
error String
"decode: bad input"

decodeWithAlphabet :: (Integral a) => Text -> Text -> [a]
decodeWithAlphabet :: forall a. Integral a => Text -> Text -> [a]
decodeWithAlphabet Text
alph Text
sqid
  | Text -> Bool
Text.null Text
sqid Bool -> Bool -> Bool
|| Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
Text.all (Char -> Text -> Bool
`Text.elem` Text
alph) Text
sqid) = []
  | Bool
otherwise = ((Text, Text) -> Maybe (a, (Text, Text))) -> (Text, Text) -> [a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (Text, Text) -> Maybe (a, (Text, Text))
forall a. Integral a => (Text, Text) -> Maybe (a, (Text, Text))
decodeStep (Text
slicedId, Text -> Text
Text.reverse Text
chars)
  where
    offset :: Int
offset = Char -> Text -> Int
unsafeIndex Char
prefix Text
alph
    (Char
prefix, Text
slicedId) = Text -> (Char, Text)
unsafeUncons Text
sqid
    chars :: Text
chars = Int -> Text -> Text
Text.drop Int
offset Text
alph Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
offset Text
alph

shuffle :: Text -> Text
shuffle :: Text -> Text
shuffle Text
alph =
  (Text -> (Int, Int) -> Text) -> Text -> [(Int, Int)] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Text -> (Int, Int) -> Text
mu Text
alph [(Int
i, Int
j) | Int
i <- [Int
0 .. Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2], let j :: Int
j = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    len :: Int
len = Text -> Int
Text.length Text
alph
    mu :: Text -> (Int, Int) -> Text
mu Text
chars (Int
i, Int
j) =
      let r :: Int
r = (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
ordAt Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
ordAt Int
j) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
          ordAt :: Int -> Int
ordAt = Char -> Int
ord (Char -> Int) -> (Int -> Char) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
chars HasCallStack => Text -> Int -> Char
Text -> Int -> Char
`Text.index`)
       in Int -> Int -> Text -> Text
swapChars Int
i Int
r Text
chars

toId :: (Integral a) => a -> Text -> Text
toId :: forall a. Integral a => a -> Text -> Text
toId a
num Text
alph = Text -> Text
Text.reverse ((Maybe a -> Maybe (Char, Maybe a)) -> Maybe a -> Text
forall a. (a -> Maybe (Char, a)) -> a -> Text
Text.unfoldr ((a -> (Char, Maybe a)) -> Maybe a -> Maybe (Char, Maybe a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (Char, Maybe a)
mu) (a -> Maybe a
forall a. a -> Maybe a
Just a
num))
  where
    len :: a
len = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length Text
alph)
    mu :: a -> (Char, Maybe a)
mu a
n =
      let (a
m, a
r) = a
n a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`divMod` a
len
          next :: Maybe a
next = if a
m a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just a
m
       in (HasCallStack => Text -> Int -> Char
Text -> Int -> Char
Text.index Text
alph (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
r), Maybe a
next)

toNumber :: (Integral a) => Text -> Text -> a
toNumber :: forall a. Integral a => Text -> Text -> a
toNumber Text
sqid Text
alph = (a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' a -> Char -> a
mu a
0 Text
sqid
  where
    len :: a
len = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
Text.length Text
alph)
    mu :: a -> Char -> a
mu a
v Char
c =
      case (Char -> Bool) -> Text -> Maybe Int
Text.findIndex (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Text
alph of
        Just Int
n -> a
len a -> a -> a
forall a. Num a => a -> a -> a
* a
v a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
        Maybe Int
_ -> String -> a
forall a. HasCallStack => String -> a
error String
"toNumber: bad input"

isBlockedId :: [Text] -> Text -> Bool
isBlockedId :: [Text] -> Text -> Bool
isBlockedId [Text]
bls Text
sqid =
  (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
disallowed (Int -> [Text] -> [Text]
wordsNoLongerThan (Text -> Int
Text.length Text
sqid) [Text]
bls)
  where
    lowercaseSqid :: Text
lowercaseSqid = (Char -> Char) -> Text -> Text
Text.map Char -> Char
toLower Text
sqid
    disallowed :: Text -> Bool
disallowed Text
w
      | Text -> Int
Text.length Text
sqid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 Bool -> Bool -> Bool
|| Text -> Int
Text.length Text
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 =
          -- Short words have to match exactly
          Text
w Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lowercaseSqid
      | (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
isDigit Text
w =
          -- Look for "leetspeak" words
          Text
w Text -> Text -> Bool
`Text.isPrefixOf` Text
lowercaseSqid Bool -> Bool -> Bool
|| Text
w Text -> Text -> Bool
`Text.isSuffixOf` Text
lowercaseSqid
      | Bool
otherwise =
          -- Check if word appears anywhere in the string
          Text
w Text -> Text -> Bool
`Text.isInfixOf` Text
lowercaseSqid

-- Rearrange alphabet so that second half goes in front of the first half
rearrangeAlphabet :: (Integral a) => Int -> Text -> [a] -> Text
rearrangeAlphabet :: forall a. Integral a => Int -> Text -> [a] -> Text
rearrangeAlphabet Int
increment Text
alph [a]
numbers =
  Int -> Text -> Text
Text.drop Int
offset Text
alph Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
offset Text
alph
  where
    offset :: Int
offset = (Int
increment Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> (a, Int) -> Int) -> Int -> [(a, Int)] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> (a, Int) -> Int
forall a b. (Integral a, Num b) => b -> (a, b) -> b
mu ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
numbers) ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
numbers [Int
0 ..])) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len
    len :: Int
len = Text -> Int
Text.length Text
alph

    mu :: (Integral a, Num b) => b -> (a, b) -> b
    mu :: forall a b. (Integral a, Num b) => b -> (a, b) -> b
mu b
a (a
v, b
i) =
      let currentChar :: Char
currentChar = HasCallStack => Text -> Int -> Char
Text -> Int -> Char
Text.index Text
alph (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v a -> a -> a
forall a. Integral a => a -> a -> a
`mod` Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))
       in Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
currentChar) b -> b -> b
forall a. Num a => a -> a -> a
+ b
i b -> b -> b
forall a. Num a => a -> a -> a
+ b
a

encodeNumbers ::
  ( Integral s
  , MonadSqids s m
  , MonadError SqidsError m
  , MonadReader (SqidsContext s) m
  ) => [s] -> Int -> m Text
encodeNumbers :: forall s (m :: * -> *).
(Integral s, MonadSqids s m, MonadError SqidsError m,
 MonadReader (SqidsContext s) m) =>
[s] -> Int -> m Text
encodeNumbers [s]
numbers Int
increment = do
  Text
alph <- (SqidsContext s -> Text) -> m Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext s -> Text
forall s. SqidsContext s -> Text
sqidsAlphabet
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
increment Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Text -> Int
Text.length Text
alph) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SqidsError -> m ()
forall a. SqidsError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsMaxEncodingAttempts
  let alphabet :: Text
alphabet = Int -> Text -> [s] -> Text
forall a. Integral a => Int -> Text -> [a] -> Text
rearrangeAlphabet Int
increment Text
alph [s]
numbers
  let run :: (Text, Text) -> (a, Int) -> (Text, Text)
run (Text
r, Text
chars) (a
n, Int
i)
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [s] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
numbers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 =
            (Text
sqid, Text
chars)
        | Bool
otherwise =
            (Text
sqid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
head_, Text -> Text
shuffle Text
chars)
        where
          (Char
head_, Text
tail_) = Text -> (Char, Text)
unsafeUncons Text
chars
          sqid :: Text
sqid = Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text -> Text
forall a. Integral a => a -> Text -> Text
toId a
n Text
tail_
  let (Text
sqid, Text
chars) =
        ((Text, Text) -> (s, Int) -> (Text, Text))
-> (Text, Text) -> [(s, Int)] -> (Text, Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Text, Text) -> (s, Int) -> (Text, Text)
forall {a}. Integral a => (Text, Text) -> (a, Int) -> (Text, Text)
run (Char -> Text
Text.singleton (HasCallStack => Text -> Char
Text -> Char
Text.head Text
alphabet), Text -> Text
Text.reverse Text
alphabet) ([s] -> [Int] -> [(s, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [s]
numbers [Int
0 ..])
  (Text -> Text -> m Text
forall {m :: * -> *} {s}.
MonadReader (SqidsContext s) m =>
Text -> Text -> m Text
makeMinLength Text
chars (Text -> m Text) -> (Text -> m Text) -> Text -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Text
forall {m :: * -> *}.
(MonadError SqidsError m, MonadSqids s m,
 MonadReader (SqidsContext s) m) =>
Text -> m Text
checkAgainstBlocklist) Text
sqid
  where
    makeMinLength :: Text -> Text -> m Text
makeMinLength Text
chars Text
sqid = do
      Int
minl <- (SqidsContext s -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext s -> Int
forall s. SqidsContext s -> Int
sqidsMinLength
      if Int
minl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Text -> Int
Text.length Text
sqid
        then
          let len :: Int
len = Text -> Int
Text.length Text
chars
              go :: (Text, Text) -> Text
go (Text
chars_, Text
sqid_) = do
                let diff :: Int
diff = Int
minl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
sqid_
                    shuffled :: Text
shuffled = Text -> Text
shuffle Text
chars_
                if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                  then (Text, Text) -> Text
go (Text
shuffled, Text
sqid_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
diff Int
len) Text
shuffled)
                  else Text
sqid_
           in Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Text) -> Text
go (Text
chars, Text -> Char -> Text
Text.snoc Text
sqid (HasCallStack => Text -> Char
Text -> Char
Text.head Text
chars)))
        else
          Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid

    checkAgainstBlocklist :: Text -> m Text
checkAgainstBlocklist Text
sqid = do
      [Text]
blocklist <- (SqidsContext s -> [Text]) -> m [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext s -> [Text]
forall s. SqidsContext s -> [Text]
sqidsBlocklist
      if [Text] -> Text -> Bool
isBlockedId [Text]
blocklist Text
sqid
        then [s] -> Int -> m Text
forall s (m :: * -> *).
(Integral s, MonadSqids s m, MonadError SqidsError m,
 MonadReader (SqidsContext s) m) =>
[s] -> Int -> m Text
encodeNumbers [s]
numbers (Int -> Int
forall a. Enum a => a -> a
succ Int
increment)
        else Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid