-- | Custom data type for timestamps (milliseconds since 1970)

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.ULID.TimeStamp (
    ULIDTimeStamp,
    mkULIDTimeStamp,
    getULIDTimeStamp
) where

import           Control.DeepSeq
import           Control.Monad
import           Data.Binary
import           Data.Binary.Roll
import           Data.Data
import           Data.Maybe
import           Data.Text as T
import           Data.Time.Clock
import           Data.Time.Clock.POSIX
import           GHC.Generics

import qualified Data.ULID.Base32 as B32


numBytes :: Int
numBytes = Int
6 -- 48 bits

-- | UNIX time in milliseconds
newtype ULIDTimeStamp = ULIDTimeStamp Integer
    deriving (ULIDTimeStamp -> ULIDTimeStamp -> Bool
(ULIDTimeStamp -> ULIDTimeStamp -> Bool)
-> (ULIDTimeStamp -> ULIDTimeStamp -> Bool) -> Eq ULIDTimeStamp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c/= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
== :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c== :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
Eq, Eq ULIDTimeStamp
Eq ULIDTimeStamp
-> (ULIDTimeStamp -> ULIDTimeStamp -> Ordering)
-> (ULIDTimeStamp -> ULIDTimeStamp -> Bool)
-> (ULIDTimeStamp -> ULIDTimeStamp -> Bool)
-> (ULIDTimeStamp -> ULIDTimeStamp -> Bool)
-> (ULIDTimeStamp -> ULIDTimeStamp -> Bool)
-> (ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp)
-> (ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp)
-> Ord ULIDTimeStamp
ULIDTimeStamp -> ULIDTimeStamp -> Bool
ULIDTimeStamp -> ULIDTimeStamp -> Ordering
ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp
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 :: ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp
$cmin :: ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp
max :: ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp
$cmax :: ULIDTimeStamp -> ULIDTimeStamp -> ULIDTimeStamp
>= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c>= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
> :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c> :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
<= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c<= :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
< :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
$c< :: ULIDTimeStamp -> ULIDTimeStamp -> Bool
compare :: ULIDTimeStamp -> ULIDTimeStamp -> Ordering
$ccompare :: ULIDTimeStamp -> ULIDTimeStamp -> Ordering
$cp1Ord :: Eq ULIDTimeStamp
Ord, Typeable, Typeable ULIDTimeStamp
DataType
Constr
Typeable ULIDTimeStamp
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ULIDTimeStamp -> c ULIDTimeStamp)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ULIDTimeStamp)
-> (ULIDTimeStamp -> Constr)
-> (ULIDTimeStamp -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ULIDTimeStamp))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ULIDTimeStamp))
-> ((forall b. Data b => b -> b) -> ULIDTimeStamp -> ULIDTimeStamp)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r)
-> (forall u. (forall d. Data d => d -> u) -> ULIDTimeStamp -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ULIDTimeStamp -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp)
-> Data ULIDTimeStamp
ULIDTimeStamp -> DataType
ULIDTimeStamp -> Constr
(forall b. Data b => b -> b) -> ULIDTimeStamp -> ULIDTimeStamp
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ULIDTimeStamp -> c ULIDTimeStamp
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ULIDTimeStamp
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ULIDTimeStamp -> u
forall u. (forall d. Data d => d -> u) -> ULIDTimeStamp -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ULIDTimeStamp
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ULIDTimeStamp -> c ULIDTimeStamp
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ULIDTimeStamp)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ULIDTimeStamp)
$cULIDTimeStamp :: Constr
$tULIDTimeStamp :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
gmapMp :: (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
gmapM :: (forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ULIDTimeStamp -> m ULIDTimeStamp
gmapQi :: Int -> (forall d. Data d => d -> u) -> ULIDTimeStamp -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ULIDTimeStamp -> u
gmapQ :: (forall d. Data d => d -> u) -> ULIDTimeStamp -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ULIDTimeStamp -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ULIDTimeStamp -> r
gmapT :: (forall b. Data b => b -> b) -> ULIDTimeStamp -> ULIDTimeStamp
$cgmapT :: (forall b. Data b => b -> b) -> ULIDTimeStamp -> ULIDTimeStamp
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ULIDTimeStamp)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ULIDTimeStamp)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c ULIDTimeStamp)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ULIDTimeStamp)
dataTypeOf :: ULIDTimeStamp -> DataType
$cdataTypeOf :: ULIDTimeStamp -> DataType
toConstr :: ULIDTimeStamp -> Constr
$ctoConstr :: ULIDTimeStamp -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ULIDTimeStamp
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ULIDTimeStamp
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ULIDTimeStamp -> c ULIDTimeStamp
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ULIDTimeStamp -> c ULIDTimeStamp
$cp1Data :: Typeable ULIDTimeStamp
Data, (forall x. ULIDTimeStamp -> Rep ULIDTimeStamp x)
-> (forall x. Rep ULIDTimeStamp x -> ULIDTimeStamp)
-> Generic ULIDTimeStamp
forall x. Rep ULIDTimeStamp x -> ULIDTimeStamp
forall x. ULIDTimeStamp -> Rep ULIDTimeStamp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ULIDTimeStamp x -> ULIDTimeStamp
$cfrom :: forall x. ULIDTimeStamp -> Rep ULIDTimeStamp x
Generic)

instance Show ULIDTimeStamp where
    show :: ULIDTimeStamp -> String
show (ULIDTimeStamp Integer
i) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> Text
forall i. Integral i => Int -> i -> Text
B32.encode Int
10 Integer
i

instance Read ULIDTimeStamp where
    readsPrec :: Int -> ReadS ULIDTimeStamp
readsPrec Int
_ = ((Integer, Text) -> (ULIDTimeStamp, String))
-> [(Integer, Text)] -> [(ULIDTimeStamp, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\(Integer
int, Text
rest) -> (Integer -> ULIDTimeStamp
ULIDTimeStamp Integer
int, Text -> String
T.unpack Text
rest))
        ([(Integer, Text)] -> [(ULIDTimeStamp, String)])
-> (String -> [(Integer, Text)]) -> ReadS ULIDTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [(Integer, Text)]
forall i. Integral i => Int -> Text -> [(i, Text)]
B32.decode Int
10
        (Text -> [(Integer, Text)])
-> (String -> Text) -> String -> [(Integer, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Binary ULIDTimeStamp where
    put :: ULIDTimeStamp -> Put
put (ULIDTimeStamp Integer
i) = (Word8 -> Put) -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> Put
forall t. Binary t => t -> Put
put (Int -> Integer -> [Word8]
unroll Int
numBytes Integer
i)
    get :: Get ULIDTimeStamp
get = Integer -> ULIDTimeStamp
ULIDTimeStamp (Integer -> ULIDTimeStamp)
-> ([Word8] -> Integer) -> [Word8] -> ULIDTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Integer
roll ([Word8] -> ULIDTimeStamp) -> Get [Word8] -> Get ULIDTimeStamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Word8 -> Get [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numBytes Get Word8
forall t. Binary t => Get t
get

instance NFData ULIDTimeStamp where
    rnf :: ULIDTimeStamp -> ()
rnf (ULIDTimeStamp Integer
i) = Integer -> ()
forall a. NFData a => a -> ()
rnf Integer
i


-- | Generate a ULID Timestamp based on a specified time
mkULIDTimeStamp
  :: POSIXTime  -- ^ Specified UNIX time with millisecond precision
                -- (e.g. 1469918176.385)
  -> ULIDTimeStamp
mkULIDTimeStamp :: POSIXTime -> ULIDTimeStamp
mkULIDTimeStamp = Integer -> ULIDTimeStamp
ULIDTimeStamp (Integer -> ULIDTimeStamp)
-> (POSIXTime -> Integer) -> POSIXTime -> ULIDTimeStamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer)
-> (POSIXTime -> POSIXTime) -> POSIXTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
*POSIXTime
1000)


-- | Generate a ULID Timestamp based on current system UNIX time
getULIDTimeStamp :: IO ULIDTimeStamp
getULIDTimeStamp :: IO ULIDTimeStamp
getULIDTimeStamp = POSIXTime -> ULIDTimeStamp
mkULIDTimeStamp (POSIXTime -> ULIDTimeStamp) -> IO POSIXTime -> IO ULIDTimeStamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getPOSIXTime