{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Web.Sqids.Internal
  ( sqidsVersion
  , SqidsOptions(..)
  , SqidsError(..)
  , SqidsContext(..)
  , emptySqidsContext
  , defaultSqidsOptions
  , SqidsStack
  , MonadSqids(..)
  , sqidsOptions
  , 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, runExceptT)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks, local)
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 (ord, toLower, isDigit)
import Data.List (foldl', unfoldr)
import Data.Text (Text)
import Web.Sqids.Blocklist (defaultBlocklist)
import Web.Sqids.Utils.Internal (letterCount, swapChars, wordsNoLongerThan, unsafeIndex, unsafeUncons)

import qualified Data.Text as Text

-- | 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
  -- ^ URL-safe characters
  , 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 = SqidsContext
  { SqidsContext -> Text
sqidsAlphabet  :: !Text
  , SqidsContext -> Int
sqidsMinLength :: !Int
  , SqidsContext -> [Text]
sqidsBlocklist :: ![Text]
  } deriving (Int -> SqidsContext -> ShowS
[SqidsContext] -> ShowS
SqidsContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqidsContext] -> ShowS
$cshowList :: [SqidsContext] -> ShowS
show :: SqidsContext -> String
$cshow :: SqidsContext -> String
showsPrec :: Int -> SqidsContext -> ShowS
$cshowsPrec :: Int -> SqidsContext -> ShowS
Show, SqidsContext -> SqidsContext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqidsContext -> SqidsContext -> Bool
$c/= :: SqidsContext -> SqidsContext -> Bool
== :: SqidsContext -> SqidsContext -> Bool
$c== :: SqidsContext -> SqidsContext -> Bool
Eq, Eq SqidsContext
SqidsContext -> SqidsContext -> Bool
SqidsContext -> SqidsContext -> Ordering
SqidsContext -> SqidsContext -> SqidsContext
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 :: SqidsContext -> SqidsContext -> SqidsContext
$cmin :: SqidsContext -> SqidsContext -> SqidsContext
max :: SqidsContext -> SqidsContext -> SqidsContext
$cmax :: SqidsContext -> SqidsContext -> SqidsContext
>= :: SqidsContext -> SqidsContext -> Bool
$c>= :: SqidsContext -> SqidsContext -> Bool
> :: SqidsContext -> SqidsContext -> Bool
$c> :: SqidsContext -> SqidsContext -> Bool
<= :: SqidsContext -> SqidsContext -> Bool
$c<= :: SqidsContext -> SqidsContext -> Bool
< :: SqidsContext -> SqidsContext -> Bool
$c< :: SqidsContext -> SqidsContext -> Bool
compare :: SqidsContext -> SqidsContext -> Ordering
$ccompare :: SqidsContext -> SqidsContext -> Ordering
Ord)

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

-- | Errors that can occur during encoding and decoding.
data SqidsError
  = SqidsAlphabetTooShort
  -- ^ The alphabet must be at least 5 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.
  | SqidsNegativeNumberInInput
  -- ^ One or more numbers in the list passed to `encode` are negative. Only
  --   non-negative integers can be used as input.
  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 m = ReaderT SqidsContext (ExceptT SqidsError m)

class (Monad m) => MonadSqids m where
  -- | Encode a list of integers into an ID
  encode :: [Int]    -- ^ A list of non-negative integers to encode
         -> m Text   -- ^ Returns the generated ID

  -- | Decode an ID back into a list of integers
  decode :: Text     -- ^ The encoded ID
         -> m [Int]  -- ^ Returns a list of integers

-- | Sqids constructor
sqidsOptions
  :: (MonadSqids m, MonadError SqidsError m)
  => SqidsOptions
  -> m SqidsContext
sqidsOptions :: forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m) =>
SqidsOptions -> m SqidsContext
sqidsOptions 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 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
5) 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
alphabetLetterCount) 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 m a = SqidsT { forall (m :: * -> *) a. SqidsT m a -> SqidsStack m a
unwrapSqidsT :: SqidsStack m a }
  deriving
    ( forall a b. a -> SqidsT m b -> SqidsT m a
forall a b. (a -> b) -> SqidsT m a -> SqidsT m b
forall (m :: * -> *) a b.
Functor m =>
a -> SqidsT m b -> SqidsT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqidsT m a -> SqidsT 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 m b -> SqidsT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SqidsT m b -> SqidsT m a
fmap :: forall a b. (a -> b) -> SqidsT m a -> SqidsT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SqidsT m a -> SqidsT m b
Functor
    , forall a. a -> SqidsT m a
forall a b. SqidsT m a -> SqidsT m b -> SqidsT m a
forall a b. SqidsT m a -> SqidsT m b -> SqidsT m b
forall a b. SqidsT m (a -> b) -> SqidsT m a -> SqidsT m b
forall a b c.
(a -> b -> c) -> SqidsT m a -> SqidsT m b -> SqidsT m c
forall {m :: * -> *}. Monad m => Functor (SqidsT m)
forall (m :: * -> *) a. Monad m => a -> SqidsT m a
forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m a
forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m b
forall (m :: * -> *) a b.
Monad m =>
SqidsT m (a -> b) -> SqidsT m a -> SqidsT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> SqidsT m a -> SqidsT m b -> SqidsT 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 m a -> SqidsT m b -> SqidsT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m a
*> :: forall a b. SqidsT m a -> SqidsT m b -> SqidsT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m b
liftA2 :: forall a b c.
(a -> b -> c) -> SqidsT m a -> SqidsT m b -> SqidsT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> SqidsT m a -> SqidsT m b -> SqidsT m c
<*> :: forall a b. SqidsT m (a -> b) -> SqidsT m a -> SqidsT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
SqidsT m (a -> b) -> SqidsT m a -> SqidsT m b
pure :: forall a. a -> SqidsT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> SqidsT m a
Applicative
    , forall a. a -> SqidsT m a
forall a b. SqidsT m a -> SqidsT m b -> SqidsT m b
forall a b. SqidsT m a -> (a -> SqidsT m b) -> SqidsT m b
forall (m :: * -> *). Monad m => Applicative (SqidsT m)
forall (m :: * -> *) a. Monad m => a -> SqidsT m a
forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m b
forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> (a -> SqidsT m b) -> SqidsT 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 m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> SqidsT m a
>> :: forall a b. SqidsT m a -> SqidsT m b -> SqidsT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> SqidsT m b -> SqidsT m b
>>= :: forall a b. SqidsT m a -> (a -> SqidsT m b) -> SqidsT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SqidsT m a -> (a -> SqidsT m b) -> SqidsT m b
Monad
    , MonadReader SqidsContext
    , MonadError SqidsError
    , forall a. IO a -> SqidsT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (SqidsT m)
forall (m :: * -> *) a. MonadIO m => IO a -> SqidsT m a
liftIO :: forall a. IO a -> SqidsT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SqidsT m a
MonadIO
    )

instance MonadTrans SqidsT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> SqidsT m a
lift = forall (m :: * -> *) a. SqidsStack m a -> SqidsT 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 (Monad m) => MonadSqids (SqidsT m) where
  encode :: [Int] -> SqidsT m Text
encode [Int]
numbers
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
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
< Int
0) [Int]
numbers =
        -- Don't allow negative integers
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SqidsError
SqidsNegativeNumberInInput
    | Bool
otherwise =
        forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m,
 MonadReader SqidsContext m) =>
[Int] -> Bool -> m Text
encodeNumbers [Int]
numbers Bool
False

  decode :: Text -> SqidsT m [Int]
decode Text
sqid = Text -> Text -> [Int]
decodeWithAlphabet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext -> 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

newtype Sqids a = Sqids { forall a. Sqids a -> SqidsT Identity a
unwrapSqids :: SqidsT Identity a }
  deriving
    ( forall a b. a -> Sqids b -> Sqids a
forall a b. (a -> b) -> Sqids a -> Sqids 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 -> Sqids b -> Sqids a
$c<$ :: forall a b. a -> Sqids b -> Sqids a
fmap :: forall a b. (a -> b) -> Sqids a -> Sqids b
$cfmap :: forall a b. (a -> b) -> Sqids a -> Sqids b
Functor
    , Functor Sqids
forall a. a -> Sqids a
forall a b. Sqids a -> Sqids b -> Sqids a
forall a b. Sqids a -> Sqids b -> Sqids b
forall a b. Sqids (a -> b) -> Sqids a -> Sqids b
forall a b c. (a -> b -> c) -> Sqids a -> Sqids b -> Sqids 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. Sqids a -> Sqids b -> Sqids a
$c<* :: forall a b. Sqids a -> Sqids b -> Sqids a
*> :: forall a b. Sqids a -> Sqids b -> Sqids b
$c*> :: forall a b. Sqids a -> Sqids b -> Sqids b
liftA2 :: forall a b c. (a -> b -> c) -> Sqids a -> Sqids b -> Sqids c
$cliftA2 :: forall a b c. (a -> b -> c) -> Sqids a -> Sqids b -> Sqids c
<*> :: forall a b. Sqids (a -> b) -> Sqids a -> Sqids b
$c<*> :: forall a b. Sqids (a -> b) -> Sqids a -> Sqids b
pure :: forall a. a -> Sqids a
$cpure :: forall a. a -> Sqids a
Applicative
    , Applicative Sqids
forall a. a -> Sqids a
forall a b. Sqids a -> Sqids b -> Sqids b
forall a b. Sqids a -> (a -> Sqids b) -> Sqids 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 -> Sqids a
$creturn :: forall a. a -> Sqids a
>> :: forall a b. Sqids a -> Sqids b -> Sqids b
$c>> :: forall a b. Sqids a -> Sqids b -> Sqids b
>>= :: forall a b. Sqids a -> (a -> Sqids b) -> Sqids b
$c>>= :: forall a b. Sqids a -> (a -> Sqids b) -> Sqids b
Monad
    , MonadReader SqidsContext
    , MonadError SqidsError
    , Monad Sqids
[Int] -> Sqids Text
Text -> Sqids [Int]
forall (m :: * -> *).
Monad m -> ([Int] -> m Text) -> (Text -> m [Int]) -> MonadSqids m
decode :: Text -> Sqids [Int]
$cdecode :: Text -> Sqids [Int]
encode :: [Int] -> Sqids Text
$cencode :: [Int] -> Sqids Text
MonadSqids
    )

-- | Evaluate a `SqidsT` computation with the given options.
runSqidsT :: (Monad m) => SqidsOptions -> SqidsT m a -> m (Either SqidsError a)
runSqidsT :: forall (m :: * -> *) a.
Monad m =>
SqidsOptions -> SqidsT m a -> m (Either SqidsError a)
runSqidsT SqidsOptions
options SqidsT 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 (m :: * -> *) a. SqidsT m a -> SqidsStack m a
unwrapSqidsT SqidsT m a
withOptions) SqidsContext
emptySqidsContext)
  where
    withOptions :: SqidsT m a
withOptions = forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m) =>
SqidsOptions -> m SqidsContext
sqidsOptions 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 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 :: (Monad m) => SqidsT m a -> m (Either SqidsError a)
sqidsT :: forall (m :: * -> *) a.
Monad m =>
SqidsT m a -> m (Either SqidsError a)
sqidsT = forall (m :: * -> *) a.
Monad m =>
SqidsOptions -> SqidsT m a -> m (Either SqidsError a)
runSqidsT SqidsOptions
defaultSqidsOptions

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

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

instance (MonadSqids m) => MonadSqids (StateT s m) where
  encode :: [Int] -> StateT s m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> StateT s m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m) => MonadSqids (ExceptT e m) where
  encode :: [Int] -> ExceptT e m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> ExceptT e m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m) => MonadSqids (ReaderT r m) where
  encode :: [Int] -> ReaderT r m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> ReaderT r m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m, Monoid w) => MonadSqids (WriterT w m) where
  encode :: [Int] -> WriterT w m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> WriterT w m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m) => MonadSqids (MaybeT m) where
  encode :: [Int] -> MaybeT m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> MaybeT m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m) => MonadSqids (ContT r m) where
  encode :: [Int] -> ContT r m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> ContT r m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

instance (MonadSqids m) => MonadSqids (SelectT r m) where
  encode :: [Int] -> SelectT r m Text
encode = 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 (m :: * -> *). MonadSqids m => [Int] -> m Text
encode
  decode :: Text -> SelectT r m [Int]
decode = 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 (m :: * -> *). MonadSqids m => Text -> m [Int]
decode

-- Clean up blocklist:
--
--   1. All words must be lowercase
--   2. No words should be less than three characters
--   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 = ((Char -> Char) -> Text -> Text
Text.map Char -> Char
toLower) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isValid [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
alph) Text
w

decodeStep :: (Text, Text) -> Maybe (Int, (Text, Text))
decodeStep :: (Text, Text) -> Maybe (Int, (Text, Text))
decodeStep (Text
sqid, Text
alph)
  | Text -> Bool
Text.null Text
sqid = forall a. Maybe a
Nothing
  | Bool
otherwise =
      case Text -> Maybe (Text, Char)
Text.unsnoc Text
alph of
        Just (Text
alphabetWithoutSeparator, Char
separatorChar) ->
          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) -> forall a. a -> Maybe a
Just
                ( Text -> Text -> Int
toNumber Text
chunk Text
alphabetWithoutSeparator
                , (Text -> [Text] -> Text
Text.intercalate Text
separator [Text]
chunks, Text -> Text
shuffle Text
alph)
                )
        Maybe (Text, Char)
_ ->
          forall a. HasCallStack => String -> a
error String
"decodeId: bad input"

decodeWithAlphabet :: Text -> Text -> [Int]
decodeWithAlphabet :: Text -> Text -> [Int]
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 (Text, Text) -> Maybe (Int, (Text, Text))
decodeStep (Text, Text)
initial
  where
    offset :: Int
offset = Char -> Text -> Int
unsafeIndex Char
prefix Text
alph
    (Char
prefix, Text
next) = Text -> (Char, Text)
unsafeUncons Text
sqid
    (Char
partition, Text
chars) =
      Text -> (Char, Text)
unsafeUncons (Int -> Text -> Text
Text.drop (Int
offset forall a. Num a => a -> a -> a
+ Int
1) Text
alph forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
offset Text
alph)
    initial :: (Text, Text)
initial =
      case (Char -> Bool) -> Text -> Maybe Int
Text.findIndex (forall a. Eq a => a -> a -> Bool
== Char
partition) Text
next of
        Just Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
< Text -> Int
Text.length Text
next forall a. Num a => a -> a -> a
- Int
1 ->
          (Int -> Text -> Text
Text.drop (Int
n forall a. Num a => a -> a -> a
+ Int
1) Text
next, Text -> Text
shuffle Text
chars)
        Maybe Int
_ ->
          (Text
next, Text
chars)

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 :: Int -> Text -> Text
toId :: Int -> Text -> Text
toId Int
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 Int -> (Char, Maybe Int)
mu) (forall a. a -> Maybe a
Just Int
num))
  where
    len :: Int
len = Text -> Int
Text.length Text
alph
    mu :: Int -> (Char, Maybe Int)
mu Int
n =
      let (Int
m, Int
r) = Int
n forall a. Integral a => a -> a -> (a, a)
`divMod` Int
len
          next :: Maybe Int
next = if Int
m forall a. Eq a => a -> a -> Bool
== Int
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Int
m
       in (HasCallStack => Text -> Int -> Char
Text.index Text
alph Int
r, Maybe Int
next)

toNumber :: Text -> Text -> Int
toNumber :: Text -> Text -> Int
toNumber Text
sqid Text
alph = forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl' Int -> Char -> Int
mu Int
0 Text
sqid
  where
    len :: Int
len = Text -> Int
Text.length Text
alph
    mu :: Int -> Char -> Int
mu Int
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 -> Int
len forall a. Num a => a -> a -> a
* Int
v forall a. Num a => a -> a -> a
+ 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 :: Text -> [Int] -> Text
rearrangeAlphabet :: Text -> [Int] -> Text
rearrangeAlphabet Text
alph [Int]
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
    len :: Int
len = Text -> Int
Text.length Text
alph
    offset :: Int
offset = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> (Int, Int) -> Int
mu (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
numbers) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
numbers [Int
0..]) forall a. Integral a => a -> a -> a
`mod` Int
len
    mu :: Int -> (Int, Int) -> Int
mu Int
a (Int
v, Int
i) =
      let currentChar :: Char
currentChar = HasCallStack => Text -> Int -> Char
Text.index Text
alph (Int
v forall a. Integral a => a -> a -> a
`mod` Int
len)
       in Char -> Int
ord Char
currentChar forall a. Num a => a -> a -> a
+ Int
i forall a. Num a => a -> a -> a
+ Int
a

encodeNumbers ::
  ( MonadSqids m
  , MonadError SqidsError m
  , MonadReader SqidsContext m
  ) => [Int] -> Bool -> m Text
encodeNumbers :: forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m,
 MonadReader SqidsContext m) =>
[Int] -> Bool -> m Text
encodeNumbers [Int]
numbers Bool
partitioned = do
  Text
alph <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext -> Text
sqidsAlphabet
  let (Text
left, Text
right) = Int -> Text -> (Text, Text)
Text.splitAt Int
2 (Text -> [Int] -> Text
rearrangeAlphabet Text
alph [Int]
numbers)
  case Text -> String
Text.unpack Text
left of
    Char
prefix : Char
partition : String
_ -> do
      let run :: (Text, Text) -> (Int, Int) -> (Text, Text)
run (Text
r, Text
chars) (Int
n, Int
i)
            | Int
i forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
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
delim, Text -> Text
shuffle Text
chars)
            where
              delim :: Char
delim = if Bool
partitioned Bool -> Bool -> Bool
&& Int
i forall a. Eq a => a -> a -> Bool
== Int
0 then Char
partition else HasCallStack => Text -> Char
Text.last Text
chars
              sqid :: Text
sqid = Text
r forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
toId Int
n (HasCallStack => Text -> Text
Text.init Text
chars)
      let (Text
sqid, Text
chars) =
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Text, Text) -> (Int, Int) -> (Text, Text)
run (Char -> Text
Text.singleton Char
prefix, Text
right) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
numbers [Int
0..])
      (forall {m :: * -> *}.
(MonadReader SqidsContext m, MonadSqids m,
 MonadError SqidsError 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 m, MonadSqids m,
 MonadError SqidsError m) =>
[Int] -> Text -> m Text
checkAgainstBlocklist [Int]
numbers) Text
sqid
    String
_ ->
      forall a. HasCallStack => String -> a
error String
"encodeNumbers: implementation error"
  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 SqidsContext -> Int
sqidsMinLength
      Text
sqid' <-
        if Int
minl forall a. Ord a => a -> a -> Bool
<= Text -> Int
Text.length Text
sqid Bool -> Bool -> Bool
|| Bool
partitioned
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid
          else forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m,
 MonadReader SqidsContext m) =>
[Int] -> Bool -> m Text
encodeNumbers (Int
0 forall a. a -> [a] -> [a]
: [Int]
numbers) Bool
True
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        if Int
minl forall a. Ord a => a -> a -> Bool
<= Text -> Int
Text.length Text
sqid'
          then Text
sqid'
          else let extra :: Int
extra = Int
minl forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
sqid
                in Char -> Text -> Text
Text.cons (HasCallStack => Text -> Char
Text.head Text
sqid') (Int -> Text -> Text
Text.take Int
extra Text
chars forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text
Text.tail Text
sqid')

    checkAgainstBlocklist :: [Int] -> Text -> m Text
checkAgainstBlocklist [Int]
nums Text
sqid = do
      [Text]
bls <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks SqidsContext -> [Text]
sqidsBlocklist
      if [Text] -> Text -> Bool
isBlockedId [Text]
bls Text
sqid then
        case [Int]
nums of
          Int
n : [Int]
ns | Bool
partitioned ->
            if Int
n forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound
              then forall a. HasCallStack => String -> a
error String
"encodeNumbers: out of range"
              else forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m,
 MonadReader SqidsContext m) =>
[Int] -> Bool -> m Text
encodeNumbers (Int
n forall a. Num a => a -> a -> a
+ Int
1 forall a. a -> [a] -> [a]
: [Int]
ns) Bool
True
          Int
n : [Int]
ns ->
            forall (m :: * -> *).
(MonadSqids m, MonadError SqidsError m,
 MonadReader SqidsContext m) =>
[Int] -> Bool -> m Text
encodeNumbers (Int
0 forall a. a -> [a] -> [a]
: Int
n forall a. a -> [a] -> [a]
: [Int]
ns) Bool
True
          [Int]
_ ->
            forall a. HasCallStack => String -> a
error String
"encodeNumbers: implementation error"
        else
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sqid