{-# LANGUAGE CPP           #-}
{-# LANGUAGE DeriveGeneric #-}

module Data.NanoID where

import           Control.Monad
import           Data.Aeson
import qualified Data.ByteString.Char8 as C
import           Data.Maybe

#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid           ((<>))
#endif

import           Data.Serialize        (Serialize)
import           Data.Text.Encoding
import           GHC.Generics
import           Numeric.Natural
import           System.Random.MWC

newtype NanoID =
  NanoID { NanoID -> ByteString
unNanoID :: C.ByteString }
  deriving (NanoID -> NanoID -> Bool
(NanoID -> NanoID -> Bool)
-> (NanoID -> NanoID -> Bool) -> Eq NanoID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NanoID -> NanoID -> Bool
== :: NanoID -> NanoID -> Bool
$c/= :: NanoID -> NanoID -> Bool
/= :: NanoID -> NanoID -> Bool
Eq, (forall x. NanoID -> Rep NanoID x)
-> (forall x. Rep NanoID x -> NanoID) -> Generic NanoID
forall x. Rep NanoID x -> NanoID
forall x. NanoID -> Rep NanoID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NanoID -> Rep NanoID x
from :: forall x. NanoID -> Rep NanoID x
$cto :: forall x. Rep NanoID x -> NanoID
to :: forall x. Rep NanoID x -> NanoID
Generic)

newtype Alphabet =
  Alphabet { Alphabet -> ByteString
unAlphabet :: C.ByteString }
  deriving (Alphabet -> Alphabet -> Bool
(Alphabet -> Alphabet -> Bool)
-> (Alphabet -> Alphabet -> Bool) -> Eq Alphabet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Alphabet -> Alphabet -> Bool
== :: Alphabet -> Alphabet -> Bool
$c/= :: Alphabet -> Alphabet -> Bool
/= :: Alphabet -> Alphabet -> Bool
Eq)

type Length = Natural

instance Show NanoID where
  show :: NanoID -> String
show = ByteString -> String
C.unpack (ByteString -> String)
-> (NanoID -> ByteString) -> NanoID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NanoID -> ByteString
unNanoID

instance Show Alphabet where
  show :: Alphabet -> String
show = ByteString -> String
C.unpack (ByteString -> String)
-> (Alphabet -> ByteString) -> Alphabet -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alphabet -> ByteString
unAlphabet

instance ToJSON NanoID where
  toJSON :: NanoID -> Value
toJSON NanoID
n = Text -> Value
String (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ NanoID -> ByteString
unNanoID NanoID
n)

instance FromJSON NanoID where
  parseJSON :: Value -> Parser NanoID
parseJSON (String Text
s) = NanoID -> Parser NanoID
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> NanoID
NanoID (ByteString -> NanoID) -> ByteString -> NanoID
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
s)
  parseJSON Value
_          = String -> Parser NanoID
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A JSON String is expected to convert to NanoID"

instance Serialize NanoID

-- | Create a new 'Alphabet' from a string of symbols of your choice
toAlphabet :: String -> Alphabet
toAlphabet :: String -> Alphabet
toAlphabet = ByteString -> Alphabet
Alphabet (ByteString -> Alphabet)
-> (String -> ByteString) -> String -> Alphabet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C.pack

-- | Standard 'NanoID' generator function
--
-- >λ: createSystemRandom >>= nanoID
-- >x2f8yFadIm-Vp14ByJ8R3
--
nanoID :: GenIO -> IO NanoID
nanoID :: GenIO -> IO NanoID
nanoID = Alphabet -> Length -> GenIO -> IO NanoID
customNanoID Alphabet
defaultAlphabet Length
21

-- | Customable 'NanoID' generator function
customNanoID
  :: Alphabet  -- ^ An 'Alphabet' of your choice
  -> Length    -- ^ A 'NanoID' length (the standard length is 21 chars)
  -> GenIO     -- ^ The pseudo-random number generator state
  -> IO NanoID
customNanoID :: Alphabet -> Length -> GenIO -> IO NanoID
customNanoID Alphabet
a Length
l GenIO
g =
  let
    ua :: ByteString
ua = Alphabet -> ByteString
unAlphabet Alphabet
a
    al :: Int
al = ByteString -> Int
C.length ByteString
ua
    l' :: Int
l' = Length -> Int
forall a. Enum a => a -> Int
fromEnum Length
l
  in
    ByteString -> NanoID
NanoID (ByteString -> NanoID)
-> (String -> ByteString) -> String -> NanoID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C.pack (String -> NanoID) -> IO String -> IO NanoID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Char -> IO String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l' ((\Int
r -> ByteString -> Int -> Char
C.index ByteString
ua (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) (Int -> Char) -> IO Int -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> GenIO -> IO Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
forall (m :: * -> *).
PrimMonad m =>
(Int, Int) -> Gen (PrimState m) -> m Int
uniformR (Int
1,Int
al) GenIO
g)

-- | The default 'Alphabet', made of URL-friendly symbols.
defaultAlphabet :: Alphabet
defaultAlphabet :: Alphabet
defaultAlphabet = String -> Alphabet
toAlphabet String
"ABCDEFGHIJKLMNOPKRSTUVWXYZ_1234567890-abcdefghijklmnopqrstuvwxyz"

-- * Some predefined 'Alphabet's, borrowed from https://github.com/CyberAP/nanoid-dictionary

numbers :: Alphabet
numbers :: Alphabet
numbers = String -> Alphabet
toAlphabet String
"1234567890"

hexadecimalLowercase :: Alphabet
hexadecimalLowercase :: Alphabet
hexadecimalLowercase = String -> Alphabet
toAlphabet String
"0123456789abcdef"

hexadecimalUppercase :: Alphabet
hexadecimalUppercase :: Alphabet
hexadecimalUppercase = String -> Alphabet
toAlphabet String
"0123456789ABCDEF"

lowercase :: Alphabet
lowercase :: Alphabet
lowercase = String -> Alphabet
toAlphabet String
"abcdefghijklmnopqrstuvwxyz"

uppercase :: Alphabet
uppercase :: Alphabet
uppercase = String -> Alphabet
toAlphabet String
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"

alphanumeric :: Alphabet
alphanumeric :: Alphabet
alphanumeric = String -> Alphabet
toAlphabet String
"ABCDEFGHIJKLMNOPKRSTUVWXYZ1234567890abcdefghijklmnopqrstuvwxyz"

nolookalikes :: Alphabet
nolookalikes :: Alphabet
nolookalikes = String -> Alphabet
toAlphabet String
"346789ABCDEFGHJKLMNPQRTUVWXYabcdefghijkmnpqrtwxyz"

nolookalikesSafe :: Alphabet
nolookalikesSafe :: Alphabet
nolookalikesSafe = String -> Alphabet
toAlphabet String
"6789ABCDEFGHJKLMNPQRTUWYabcdefghijkmnpqrtwyz"

-- * Special password

specialPassword :: Alphabet
specialPassword :: Alphabet
specialPassword = String -> Alphabet
toAlphabet String
"67{8_9A!B>CDEF)GH=JKL(MNPQ%RTU]W.Ya@bc%def&g[hij}k<m#-npq:r+twyz"