{-# 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
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 = 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 []
data SqidsError
= SqidsAlphabetTooShort
| SqidsAlphabetRepeatedCharacters
| SqidsInvalidMinLength
| SqidsNegativeNumberInInput
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 :: [Int]
-> m Text
decode :: Text
-> m [Int]
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
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
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
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
}
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 =
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 =
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
)
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
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
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
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
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]
_) | Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
Text.all (Char -> Text -> Bool
`Text.elem` Text
alphabetWithoutSeparator) Text
chunk) ->
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 =
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 :: 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