{-# 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)
sqidsVersion :: String
sqidsVersion :: String
sqidsVersion = String
"0.0.1"
data SqidsOptions = SqidsOptions
{ SqidsOptions -> Text
alphabet :: !Text
, SqidsOptions -> Int
minLength :: !Int
, SqidsOptions -> [Text]
blocklist :: ![Text]
} 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)
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
| SqidsMaxEncodingAttempts
| SqidsAlphabetContainsMultibyteCharacters
| SqidsAlphabetTooShort
| SqidsAlphabetRepeatedCharacters
| SqidsInvalidMinLength
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
sqidsEncode :: [s]
-> m Text
sqidsDecode :: Text
-> m [s]
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
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
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
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
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
}
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 =
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 =
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
type Sqids s = SqidsT s Identity
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
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
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
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
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 =
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 =
Text
w Text -> Text -> Bool
`Text.isPrefixOf` Text
lowercaseSqid Bool -> Bool -> Bool
|| Text
w Text -> Text -> Bool
`Text.isSuffixOf` Text
lowercaseSqid
| Bool
otherwise =
Text
w Text -> Text -> Bool
`Text.isInfixOf` Text
lowercaseSqid
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