{-# 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
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)
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
| SqidsMaxEncodingAttempts
| SqidsAlphabetContainsMultibyteCharacters
| SqidsAlphabetTooShort
| SqidsAlphabetRepeatedCharacters
| SqidsInvalidMinLength
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
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
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
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
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
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
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
}
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 =
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 =
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
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 =
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
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
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
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
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 =
Text
w 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 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