{-# 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"