{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module Foundation.UUID
    ( UUID(..)
    , newUUID
    , nil
    , fromBinary
    , uuidParser
    ) where

import Data.Maybe (fromMaybe)

import           Basement.Compat.Base
import           Foundation.Collection (Element, Sequential, foldl')
import           Foundation.Class.Storable
import           Foundation.Hashing.Hashable
import           Foundation.Bits
import           Foundation.Parser
import           Foundation.Numerical
import           Foundation.Primitive
import           Basement.Base16
import           Basement.IntegralConv
import           Basement.Types.OffsetSize
import qualified Basement.UArray as UA
import           Foundation.Random (MonadRandom, getRandomBytes)

data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
    deriving (UUID -> UUID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID -> UUID -> Bool
$c/= :: UUID -> UUID -> Bool
== :: UUID -> UUID -> Bool
$c== :: UUID -> UUID -> Bool
Eq,Eq UUID
UUID -> UUID -> Bool
UUID -> UUID -> Ordering
UUID -> UUID -> UUID
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 :: UUID -> UUID -> UUID
$cmin :: UUID -> UUID -> UUID
max :: UUID -> UUID -> UUID
$cmax :: UUID -> UUID -> UUID
>= :: UUID -> UUID -> Bool
$c>= :: UUID -> UUID -> Bool
> :: UUID -> UUID -> Bool
$c> :: UUID -> UUID -> Bool
<= :: UUID -> UUID -> Bool
$c<= :: UUID -> UUID -> Bool
< :: UUID -> UUID -> Bool
$c< :: UUID -> UUID -> Bool
compare :: UUID -> UUID -> Ordering
$ccompare :: UUID -> UUID -> Ordering
Ord,Typeable)
instance Show UUID where
    show :: UUID -> String
show = UUID -> String
toLString
instance NormalForm UUID where
    toNormalForm :: UUID -> ()
toNormalForm !UUID
_ = ()
instance Hashable UUID where
    hashMix :: forall st. Hasher st => UUID -> st -> st
hashMix (UUID Word64
a Word64
b) = forall a st. (Hashable a, Hasher st) => a -> st -> st
hashMix Word64
a forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a st. (Hashable a, Hasher st) => a -> st -> st
hashMix Word64
b
instance Storable UUID where
    peek :: Ptr UUID -> IO UUID
peek Ptr UUID
p = Word64 -> Word64 -> UUID
UUID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. ByteSwap a => BE a -> a
fromBE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StorableFixed a => Ptr a -> Offset a -> IO a
peekOff Ptr (BE Word64)
ptr Offset (BE Word64)
0)
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. ByteSwap a => BE a -> a
fromBE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StorableFixed a => Ptr a -> Offset a -> IO a
peekOff Ptr (BE Word64)
ptr Offset (BE Word64)
1)
      where ptr :: Ptr (BE Word64)
ptr = forall a b. Ptr a -> Ptr b
castPtr Ptr UUID
p :: Ptr (BE Word64)
    poke :: Ptr UUID -> UUID -> IO ()
poke Ptr UUID
p (UUID Word64
a Word64
b) = do
        forall a. StorableFixed a => Ptr a -> Offset a -> a -> IO ()
pokeOff Ptr (BE Word64)
ptr Offset (BE Word64)
0 (forall a. ByteSwap a => a -> BE a
toBE Word64
a)
        forall a. StorableFixed a => Ptr a -> Offset a -> a -> IO ()
pokeOff Ptr (BE Word64)
ptr Offset (BE Word64)
1 (forall a. ByteSwap a => a -> BE a
toBE Word64
b)
      where ptr :: Ptr (BE Word64)
ptr = forall a b. Ptr a -> Ptr b
castPtr Ptr UUID
p :: Ptr (BE Word64)
instance StorableFixed UUID where
    size :: forall (proxy :: * -> *). proxy UUID -> CountOf Word8
size      proxy UUID
_ = CountOf Word8
16
    alignment :: forall (proxy :: * -> *). proxy UUID -> CountOf Word8
alignment proxy UUID
_ = CountOf Word8
8

withComponent :: UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent :: forall a.
UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent (UUID Word64
a Word64
b) Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a
f = Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a
f Word32
x1 Word16
x2 Word16
x3 Word16
x4 Word64
x5
  where
    !x1 :: Word32
x1 = forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
a forall a. Bits a => a -> Int -> a
.>>. Int
32)
    !x2 :: Word16
x2 = forall a b. IntegralDownsize a b => a -> b
integralDownsize ((Word64
a forall a. Bits a => a -> Int -> a
.>>. Int
16) forall a. Bits a => a -> a -> a
.&. Word64
0xffff)
    !x3 :: Word16
x3 = forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
a forall a. Bits a => a -> a -> a
.&. Word64
0xffff)
    !x4 :: Word16
x4 = forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
b forall a. Bits a => a -> Int -> a
.>>. Int
48)
    !x5 :: Word64
x5 = (Word64
b forall a. Bits a => a -> a -> a
.&. Word64
0x0000ffffffffffff)
{-# INLINE withComponent #-}

toLString :: UUID -> [Char]
toLString :: UUID -> String
toLString UUID
uuid = forall a.
UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent UUID
uuid forall a b. (a -> b) -> a -> b
$ \Word32
x1 Word16
x2 Word16
x3 Word16
x4 Word64
x5 ->
    Word32 -> ShowS
hexWord_4 Word32
x1 forall a b. (a -> b) -> a -> b
$ ShowS
addDash forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x2 forall a b. (a -> b) -> a -> b
$ ShowS
addDash forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x3 forall a b. (a -> b) -> a -> b
$ ShowS
addDash forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x4 forall a b. (a -> b) -> a -> b
$ ShowS
addDash forall a b. (a -> b) -> a -> b
$ Word64 -> ShowS
hexWord64_6 Word64
x5 []
  where
    addDash :: ShowS
addDash = (:) Char
'-'
    hexWord_2 :: Word16 -> ShowS
hexWord_2 Word16
w String
l = case Word16 -> (Char, Char, Char, Char)
hexWord16 Word16
w of
                         (Char
c1,Char
c2,Char
c3,Char
c4) -> Char
c1forall a. a -> [a] -> [a]
:Char
c2forall a. a -> [a] -> [a]
:Char
c3forall a. a -> [a] -> [a]
:Char
c4forall a. a -> [a] -> [a]
:String
l
    hexWord_4 :: Word32 -> ShowS
hexWord_4 Word32
w String
l = case Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char)
hexWord32 Word32
w of
                    (Char
c1,Char
c2,Char
c3,Char
c4,Char
c5,Char
c6,Char
c7,Char
c8) -> Char
c1forall a. a -> [a] -> [a]
:Char
c2forall a. a -> [a] -> [a]
:Char
c3forall a. a -> [a] -> [a]
:Char
c4forall a. a -> [a] -> [a]
:Char
c5forall a. a -> [a] -> [a]
:Char
c6forall a. a -> [a] -> [a]
:Char
c7forall a. a -> [a] -> [a]
:Char
c8forall a. a -> [a] -> [a]
:String
l
    hexWord64_6 :: Word64 -> ShowS
hexWord64_6 Word64
w String
l = case Word64 -> Word32x2
word64ToWord32s Word64
w of
                        Word32x2 Word32
wHigh Word32
wLow -> Word16 -> ShowS
hexWord_2 (forall a b. IntegralDownsize a b => a -> b
integralDownsize Word32
wHigh) forall a b. (a -> b) -> a -> b
$ Word32 -> ShowS
hexWord_4 Word32
wLow String
l

nil :: UUID
nil :: UUID
nil = Word64 -> Word64 -> UUID
UUID Word64
0 Word64
0

newUUID :: MonadRandom randomly => randomly UUID
newUUID :: forall (randomly :: * -> *). MonadRandom randomly => randomly UUID
newUUID = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Foundation.UUID.newUUID: the impossible happned")
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UArray Word8 -> Maybe UUID
fromBinary
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
CountOf Word8 -> m (UArray Word8)
getRandomBytes CountOf Word8
16

fromBinary :: UA.UArray Word8 -> Maybe UUID
fromBinary :: UArray Word8 -> Maybe UUID
fromBinary UArray Word8
ba
    | forall ty. UArray ty -> CountOf ty
UA.length UArray Word8
ba forall a. Eq a => a -> a -> Bool
/= CountOf Word8
16 = forall a. Maybe a
Nothing
    | Bool
otherwise          = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
UUID Word64
w0 Word64
w1
  where
    w0 :: Word64
w0 = (Word64
b15 forall a. Bits a => a -> Int -> a
.<<. Int
56) forall a. Bits a => a -> a -> a
.|. (Word64
b14 forall a. Bits a => a -> Int -> a
.<<. Int
48) forall a. Bits a => a -> a -> a
.|. (Word64
b13 forall a. Bits a => a -> Int -> a
.<<. Int
40) forall a. Bits a => a -> a -> a
.|. (Word64
b12 forall a. Bits a => a -> Int -> a
.<<. Int
32) forall a. Bits a => a -> a -> a
.|.
         (Word64
b11 forall a. Bits a => a -> Int -> a
.<<. Int
24) forall a. Bits a => a -> a -> a
.|. (Word64
b10 forall a. Bits a => a -> Int -> a
.<<. Int
16) forall a. Bits a => a -> a -> a
.|. (Word64
b9 forall a. Bits a => a -> Int -> a
.<<. Int
8)   forall a. Bits a => a -> a -> a
.|. Word64
b8
    w1 :: Word64
w1 = (Word64
b7 forall a. Bits a => a -> Int -> a
.<<. Int
56) forall a. Bits a => a -> a -> a
.|. (Word64
b6 forall a. Bits a => a -> Int -> a
.<<. Int
48) forall a. Bits a => a -> a -> a
.|. (Word64
b5 forall a. Bits a => a -> Int -> a
.<<. Int
40) forall a. Bits a => a -> a -> a
.|. (Word64
b4 forall a. Bits a => a -> Int -> a
.<<. Int
32) forall a. Bits a => a -> a -> a
.|.
         (Word64
b3 forall a. Bits a => a -> Int -> a
.<<. Int
24) forall a. Bits a => a -> a -> a
.|. (Word64
b2 forall a. Bits a => a -> Int -> a
.<<. Int
16) forall a. Bits a => a -> a -> a
.|. (Word64
b1 forall a. Bits a => a -> Int -> a
.<<. Int
8)  forall a. Bits a => a -> a -> a
.|. Word64
b0

    b0 :: Word64
b0  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
0)
    b1 :: Word64
b1  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
1)
    b2 :: Word64
b2  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
2)
    b3 :: Word64
b3  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
3)
    b4 :: Word64
b4  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
4)
    b5 :: Word64
b5  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
5)
    b6 :: Word64
b6  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
6)
    b7 :: Word64
b7  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
7)
    b8 :: Word64
b8  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
8)
    b9 :: Word64
b9  = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
9)
    b10 :: Word64
b10 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
10)
    b11 :: Word64
b11 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
11)
    b12 :: Word64
b12 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
12)
    b13 :: Word64
b13 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
13)
    b14 :: Word64
b14 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
14)
    b15 :: Word64
b15 = forall a b. IntegralUpsize a b => a -> b
integralUpsize (forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
15)

uuidParser :: ( ParserSource input, Element input ~ Char
              , Sequential (Chunk input), Element input ~ Element (Chunk input)
              )
           => Parser input UUID
uuidParser :: forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
Parser input UUID
uuidParser = do
    Word64
hex1 <- forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (forall ty. Int -> CountOf ty
CountOf Int
8) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
'-'
    Word64
hex2 <- forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (forall ty. Int -> CountOf ty
CountOf Int
4) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
'-'
    Word64
hex3 <- forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (forall ty. Int -> CountOf ty
CountOf Int
4) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
'-'
    Word64
hex4 <- forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (forall ty. Int -> CountOf ty
CountOf Int
4) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
'-'
    Word64
hex5 <- forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (forall ty. Int -> CountOf ty
CountOf Int
12)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
UUID (Word64
hex1 forall a. Bits a => a -> Int -> a
.<<. Int
32 forall a. Bits a => a -> a -> a
.|. Word64
hex2 forall a. Bits a => a -> Int -> a
.<<. Int
16 forall a. Bits a => a -> a -> a
.|. Word64
hex3)
                  (Word64
hex4 forall a. Bits a => a -> Int -> a
.<<. Int
48 forall a. Bits a => a -> a -> a
.|. Word64
hex5)


parseHex :: ( ParserSource input, Element input ~ Char
            , Sequential (Chunk input), Element input ~ Element (Chunk input)
            )
         => CountOf Char -> Parser input Word64
parseHex :: forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex CountOf Char
count = do
    String
r <- forall l. IsList l => l -> [Item l]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall input.
(ParserSource input, Sequential (Chunk input),
 Element input ~ Element (Chunk input)) =>
CountOf (Element (Chunk input)) -> Parser input (Chunk input)
take CountOf Char
count
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ Char -> Bool
isValidHexa forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
r) forall a b. (a -> b) -> a -> b
$
        forall input a. ParseError input -> Parser input a
reportError forall a b. (a -> b) -> a -> b
$ forall input. Maybe String -> ParseError input
Satisfy forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"expecting hexadecimal character only: "
                                    forall a. Semigroup a => a -> a -> a
<> forall l. IsList l => [Item l] -> l
fromList (forall a. Show a => a -> String
show String
r)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word64 -> String -> Word64
listToHex Word64
0 String
r
  where
    listToHex :: Word64 -> String -> Word64
listToHex = forall collection a.
Foldable collection =>
(a -> Element collection -> a) -> a -> collection -> a
foldl' (\Word64
acc' Element String
x -> Word64
acc' forall a. Multiplicative a => a -> a -> a
* Word64
16 forall a. Additive a => a -> a -> a
+ forall {a}. Integral a => Char -> a
fromHex Element String
x)
    isValidHexa :: Char -> Bool
    isValidHexa :: Char -> Bool
isValidHexa Char
c = (Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9') Bool -> Bool -> Bool
|| (Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'f') Bool -> Bool -> Bool
|| (Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'F')
    fromHex :: Char -> a
fromHex Char
'0' = a
0
    fromHex Char
'1' = a
1
    fromHex Char
'2' = a
2
    fromHex Char
'3' = a
3
    fromHex Char
'4' = a
4
    fromHex Char
'5' = a
5
    fromHex Char
'6' = a
6
    fromHex Char
'7' = a
7
    fromHex Char
'8' = a
8
    fromHex Char
'9' = a
9
    fromHex Char
'a' = a
10
    fromHex Char
'b' = a
11
    fromHex Char
'c' = a
12
    fromHex Char
'd' = a
13
    fromHex Char
'e' = a
14
    fromHex Char
'f' = a
15
    fromHex Char
'A' = a
10
    fromHex Char
'B' = a
11
    fromHex Char
'C' = a
12
    fromHex Char
'D' = a
13
    fromHex Char
'E' = a
14
    fromHex Char
'F' = a
15
    fromHex Char
_   = forall a. HasCallStack => String -> a
error String
"Foundation.UUID.parseUUID: the impossible happened"