{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqidsOptions] -> ShowS
$cshowList :: [SqidsOptions] -> ShowS
show :: SqidsOptions -> String
$cshow :: SqidsOptions -> String
showsPrec :: Int -> SqidsOptions -> ShowS
$cshowsPrec :: Int -> SqidsOptions -> ShowS
Show, SqidsOptions -> SqidsOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqidsOptions -> SqidsOptions -> Bool
$c/= :: SqidsOptions -> SqidsOptions -> Bool
== :: SqidsOptions -> SqidsOptions -> Bool
$c== :: SqidsOptions -> SqidsOptions -> Bool
Eq, Eq 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
min :: SqidsOptions -> SqidsOptions -> SqidsOptions
$cmin :: SqidsOptions -> SqidsOptions -> SqidsOptions
max :: SqidsOptions -> SqidsOptions -> SqidsOptions
$cmax :: SqidsOptions -> SqidsOptions -> SqidsOptions
>= :: SqidsOptions -> SqidsOptions -> Bool
$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
compare :: SqidsOptions -> SqidsOptions -> Ordering
$ccompare :: SqidsOptions -> SqidsOptions -> Ordering
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
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
showList :: [SqidsContext s] -> ShowS
$cshowList :: forall s. [SqidsContext s] -> ShowS
show :: SqidsContext s -> String
$cshow :: forall s. SqidsContext s -> String
showsPrec :: Int -> SqidsContext s -> ShowS
$cshowsPrec :: forall s. Int -> SqidsContext s -> ShowS
Show, SqidsContext s -> SqidsContext s -> Bool
forall s. SqidsContext s -> SqidsContext s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: 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
Eq, SqidsContext s -> SqidsContext s -> Bool
SqidsContext s -> SqidsContext s -> Ordering
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
min :: SqidsContext s -> SqidsContext s -> SqidsContext s
$cmin :: forall s. SqidsContext s -> SqidsContext s -> SqidsContext s
max :: SqidsContext s -> SqidsContext s -> SqidsContext s
$cmax :: forall s. SqidsContext s -> SqidsContext s -> SqidsContext s
>= :: 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
$c< :: forall s. SqidsContext s -> SqidsContext s -> Bool
compare :: SqidsContext s -> SqidsContext s -> Ordering
$ccompare :: forall s. SqidsContext s -> SqidsContext s -> Ordering
Ord)

{-# INLINE emptySqidsContext #-}
emptySqidsContext :: SqidsContext s
emptySqidsContext :: forall s. SqidsContext s
emptySqidsContext = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqidsError] -> ShowS
$cshowList :: [SqidsError] -> ShowS
show :: SqidsError -> String
$cshow :: SqidsError -> String
showsPrec :: Int -> SqidsError -> ShowS
$cshowsPrec :: Int -> SqidsError -> ShowS
Show, ReadPrec [SqidsError]
ReadPrec SqidsError
Int -> ReadS SqidsError
ReadS [SqidsError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SqidsError]
$creadListPrec :: ReadPrec [SqidsError]
readPrec :: ReadPrec SqidsError
$creadPrec :: ReadPrec SqidsError
readList :: ReadS [SqidsError]
$creadList :: ReadS [SqidsError]
readsPrec :: Int -> ReadS SqidsError
$creadsPrec :: Int -> ReadS SqidsError
Read, SqidsError -> SqidsError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqidsError -> SqidsError -> Bool
$c/= :: SqidsError -> SqidsError -> Bool
== :: SqidsError -> SqidsError -> Bool
$c== :: SqidsError -> SqidsError -> Bool
Eq, Eq 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
min :: SqidsError -> SqidsError -> SqidsError
$cmin :: SqidsError -> SqidsError -> SqidsError
max :: SqidsError -> SqidsError -> SqidsError
$cmax :: SqidsError -> SqidsError -> SqidsError
>= :: SqidsError -> SqidsError -> Bool
$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
compare :: SqidsError -> SqidsError -> Ordering
$ccompare :: SqidsError -> SqidsError -> Ordering
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
blocklist :: [Text]
minLength :: Int
alphabet :: Text
blocklist :: SqidsOptions -> [Text]
minLength :: SqidsOptions -> Int
alphabet :: SqidsOptions -> Text
..} = do

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

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

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

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

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

  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> 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
<$ :: forall a b. a -> SqidsT s m b -> SqidsT s m a
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> SqidsT s m b -> SqidsT s m a
fmap :: forall a b. (a -> b) -> SqidsT s m a -> SqidsT s m b
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqidsT s m a -> SqidsT s m b
Functor
    , 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
<* :: forall a b. SqidsT s m a -> SqidsT s m b -> SqidsT s m a
$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 b
$c*> :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m a -> SqidsT s m b -> SqidsT s m b
liftA2 :: forall a b c.
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
$cliftA2 :: forall s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> SqidsT s m a -> SqidsT s m b -> SqidsT s m c
<*> :: forall a b. SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
$c<*> :: forall s (m :: * -> *) a b.
Monad m =>
SqidsT s m (a -> b) -> SqidsT s m a -> SqidsT s m b
pure :: forall a. a -> SqidsT s m a
$cpure :: forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
Applicative
    , 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
return :: forall a. a -> SqidsT s m a
$creturn :: forall s (m :: * -> *) a. Monad m => a -> SqidsT s m a
>> :: 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 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 -> (a -> SqidsT s m b) -> SqidsT s m b
Monad
    , MonadReader (SqidsContext s)
    , MonadError SqidsError
    , 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
liftIO :: forall a. IO a -> SqidsT s m a
$cliftIO :: forall s (m :: * -> *) a. MonadIO m => 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 = forall s (m :: * -> *) a. SqidsStack s m a -> SqidsT s m a
SqidsT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [s]
numbers =
        -- If no numbers passed, return an empty string
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
Text.empty
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> a -> Bool
< s
0) [s]
numbers =
        -- Don't allow negative integers
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsNegativeNumberInInput
    | Bool
otherwise =
        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 =
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. Integral a => Text -> Text -> [a]
decodeWithAlphabet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. SqidsContext s -> Text
sqidsAlphabet) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. SqidsT s m a -> SqidsStack s m a
unwrapSqidsT SqidsT s m a
withOptions) forall s. SqidsContext s
emptySqidsContext)
  where
    withOptions :: SqidsT s m a
withOptions = forall s (m :: * -> *).
(MonadSqids s m, MonadError SqidsError m) =>
SqidsOptions -> m (SqidsContext s)
sqidsContext SqidsOptions
options forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
`local` SqidsT s m a
value) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> StateT s m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ExceptT e m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ReaderT r m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> WriterT w m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> MaybeT m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> ContT r m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadSqids s m => [s] -> m Text
sqidsEncode
  sqidsDecode :: Text -> SelectT r m [s]
sqidsDecode = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isValid ((Char -> Char) -> Text -> Text
Text.map Char -> Char
toLower 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 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 = 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.splitOn Text
separator Text
sqid of
              [] ->
                forall a. Maybe a
Nothing
              (Text
chunk : [Text]
chunks)
                | Text -> Bool
Text.null Text
chunk ->
                    forall a. Maybe a
Nothing
                | Bool
otherwise -> forall a. a -> Maybe a
Just
                    ( 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)
_ ->
          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 = forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr 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 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 =
  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 forall a. Num a => a -> a -> a
- Int
2], let j :: Int
j = Int
len forall a. Num a => a -> a -> a
- Int
i 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 forall a. Num a => a -> a -> a
* Int
j forall a. Num a => a -> a -> a
+ Int -> Int
ordAt Int
i forall a. Num a => a -> a -> a
+ Int -> Int
ordAt Int
j) forall a. Integral a => a -> a -> a
`mod` Int
len
          ordAt :: Int -> Int
ordAt = Char -> Int
ord forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
chars HasCallStack => 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 (forall a. (a -> Maybe (Char, a)) -> a -> Text
Text.unfoldr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (Char, Maybe a)
mu) (forall a. a -> Maybe a
Just a
num))
  where
    len :: a
len = 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 forall a. Integral a => a -> a -> (a, a)
`divMod` a
len
          next :: Maybe a
next = if a
m forall a. Eq a => a -> a -> Bool
== a
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just a
m
       in (HasCallStack => Text -> Int -> Char
Text.index Text
alph (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 = forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' a -> Char -> a
mu a
0 Text
sqid
  where
    len :: a
len = 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 (forall a. Eq a => a -> a -> Bool
== Char
c) Text
alph of
        Just Int
n -> a
len forall a. Num a => a -> a -> a
* a
v forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
        Maybe Int
_ -> forall a. HasCallStack => String -> a
error String
"toNumber: bad input"

isBlockedId :: [Text] -> Text -> Bool
isBlockedId :: [Text] -> Text -> Bool
isBlockedId [Text]
bls Text
sqid =
  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 forall a. Ord a => a -> a -> Bool
<= Int
3 Bool -> Bool -> Bool
|| Text -> Int
Text.length Text
w forall a. Ord a => a -> a -> Bool
<= Int
3 =
          -- Short words have to match exactly
          Text
w 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 forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
offset Text
alph
  where
    offset :: Int
offset = (Int
increment forall a. Num a => a -> a -> a
+ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. (Integral a, Num b) => b -> (a, b) -> b
mu (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
numbers) (forall a b. [a] -> [b] -> [(a, b)]
zip [a]
numbers [Int
0 ..])) 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.index Text
alph (forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
v forall a. Integral a => a -> a -> a
`mod` forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))
       in forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
currentChar) forall a. Num a => a -> a -> a
+ b
i 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall s. SqidsContext s -> Text
sqidsAlphabet
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
increment forall a. Ord a => a -> a -> Bool
> Text -> Int
Text.length Text
alph) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsMaxEncodingAttempts
  let alphabet :: Text
alphabet = 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 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
numbers forall a. Num a => a -> a -> a
- Int
1 =
            (Text
sqid, Text
chars)
        | Bool
otherwise =
            (Text
sqid 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 forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => a -> Text -> Text
toId a
n Text
tail_
  let (Text
sqid, Text
chars) =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Integral a => (Text, Text) -> (a, Int) -> (Text, Text)
run (Char -> Text
Text.singleton (HasCallStack => Text -> Char
Text.head Text
alphabet), Text -> Text
Text.reverse Text
alphabet) (forall a b. [a] -> [b] -> [(a, b)]
zip [s]
numbers [Int
0 ..])
  (forall {m :: * -> *} {s}.
MonadReader (SqidsContext s) m =>
Text -> Text -> m Text
makeMinLength Text
chars forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {m :: * -> *}.
(MonadReader (SqidsContext s) m, MonadError SqidsError m,
 MonadSqids s m) =>
Text -> m Text
checkAgainstBlocklist) Text
sqid
  where
    makeMinLength :: Text -> Text -> m Text
makeMinLength Text
chars Text
sqid = do
      Int
minl <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall s. SqidsContext s -> Int
sqidsMinLength
      if Int
minl 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 forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
sqid_
                    shuffled :: Text
shuffled = Text -> Text
shuffle Text
chars_
                if Int
diff forall a. Ord a => a -> a -> Bool
> Int
0
                  then (Text, Text) -> Text
go (Text
shuffled, Text
sqid_ forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take (forall a. Ord a => a -> a -> a
min Int
diff Int
len) Text
shuffled)
                  else Text
sqid_
           in 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.head Text
chars)))
        else
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid

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