1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4module Foundation.UUID 5 ( UUID(..) 6 , newUUID 7 , nil 8 , fromBinary 9 , uuidParser 10 ) where 11 12import Data.Maybe (fromMaybe) 13 14import Basement.Compat.Base 15import Foundation.Collection (Element, Sequential, foldl') 16import Foundation.Class.Storable 17import Foundation.Hashing.Hashable 18import Foundation.Bits 19import Foundation.Parser 20import Foundation.Numerical 21import Foundation.Primitive 22import Basement.Base16 23import Basement.IntegralConv 24import Basement.Types.OffsetSize 25import qualified Basement.UArray as UA 26import Foundation.Random (MonadRandom, getRandomBytes) 27 28data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 29 deriving (Eq,Ord,Typeable) 30instance Show UUID where 31 show = toLString 32instance NormalForm UUID where 33 toNormalForm !_ = () 34instance Hashable UUID where 35 hashMix (UUID a b) = hashMix a . hashMix b 36instance Storable UUID where 37 peek p = UUID <$> (fromBE <$> peekOff ptr 0) 38 <*> (fromBE <$> peekOff ptr 1) 39 where ptr = castPtr p :: Ptr (BE Word64) 40 poke p (UUID a b) = do 41 pokeOff ptr 0 (toBE a) 42 pokeOff ptr 1 (toBE b) 43 where ptr = castPtr p :: Ptr (BE Word64) 44instance StorableFixed UUID where 45 size _ = 16 46 alignment _ = 8 47 48withComponent :: UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a 49withComponent (UUID a b) f = f x1 x2 x3 x4 x5 50 where 51 !x1 = integralDownsize (a .>>. 32) 52 !x2 = integralDownsize ((a .>>. 16) .&. 0xffff) 53 !x3 = integralDownsize (a .&. 0xffff) 54 !x4 = integralDownsize (b .>>. 48) 55 !x5 = (b .&. 0x0000ffffffffffff) 56{-# INLINE withComponent #-} 57 58toLString :: UUID -> [Char] 59toLString uuid = withComponent uuid $ \x1 x2 x3 x4 x5 -> 60 hexWord_4 x1 $ addDash $ hexWord_2 x2 $ addDash $ hexWord_2 x3 $ addDash $ hexWord_2 x4 $ addDash $ hexWord64_6 x5 [] 61 where 62 addDash = (:) '-' 63 hexWord_2 w l = case hexWord16 w of 64 (c1,c2,c3,c4) -> c1:c2:c3:c4:l 65 hexWord_4 w l = case hexWord32 w of 66 (c1,c2,c3,c4,c5,c6,c7,c8) -> c1:c2:c3:c4:c5:c6:c7:c8:l 67 hexWord64_6 w l = case word64ToWord32s w of 68 Word32x2 wHigh wLow -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l 69 70nil :: UUID 71nil = UUID 0 0 72 73newUUID :: MonadRandom randomly => randomly UUID 74newUUID = fromMaybe (error "Foundation.UUID.newUUID: the impossible happned") 75 . fromBinary 76 <$> getRandomBytes 16 77 78fromBinary :: UA.UArray Word8 -> Maybe UUID 79fromBinary ba 80 | UA.length ba /= 16 = Nothing 81 | otherwise = Just $ UUID w0 w1 82 where 83 w0 = (b15 .<<. 56) .|. (b14 .<<. 48) .|. (b13 .<<. 40) .|. (b12 .<<. 32) .|. 84 (b11 .<<. 24) .|. (b10 .<<. 16) .|. (b9 .<<. 8) .|. b8 85 w1 = (b7 .<<. 56) .|. (b6 .<<. 48) .|. (b5 .<<. 40) .|. (b4 .<<. 32) .|. 86 (b3 .<<. 24) .|. (b2 .<<. 16) .|. (b1 .<<. 8) .|. b0 87 88 b0 = integralUpsize (UA.unsafeIndex ba 0) 89 b1 = integralUpsize (UA.unsafeIndex ba 1) 90 b2 = integralUpsize (UA.unsafeIndex ba 2) 91 b3 = integralUpsize (UA.unsafeIndex ba 3) 92 b4 = integralUpsize (UA.unsafeIndex ba 4) 93 b5 = integralUpsize (UA.unsafeIndex ba 5) 94 b6 = integralUpsize (UA.unsafeIndex ba 6) 95 b7 = integralUpsize (UA.unsafeIndex ba 7) 96 b8 = integralUpsize (UA.unsafeIndex ba 8) 97 b9 = integralUpsize (UA.unsafeIndex ba 9) 98 b10 = integralUpsize (UA.unsafeIndex ba 10) 99 b11 = integralUpsize (UA.unsafeIndex ba 11) 100 b12 = integralUpsize (UA.unsafeIndex ba 12) 101 b13 = integralUpsize (UA.unsafeIndex ba 13) 102 b14 = integralUpsize (UA.unsafeIndex ba 14) 103 b15 = integralUpsize (UA.unsafeIndex ba 15) 104 105uuidParser :: ( ParserSource input, Element input ~ Char 106 , Sequential (Chunk input), Element input ~ Element (Chunk input) 107 ) 108 => Parser input UUID 109uuidParser = do 110 hex1 <- parseHex (CountOf 8) <* element '-' 111 hex2 <- parseHex (CountOf 4) <* element '-' 112 hex3 <- parseHex (CountOf 4) <* element '-' 113 hex4 <- parseHex (CountOf 4) <* element '-' 114 hex5 <- parseHex (CountOf 12) 115 return $ UUID (hex1 .<<. 32 .|. hex2 .<<. 16 .|. hex3) 116 (hex4 .<<. 48 .|. hex5) 117 118 119parseHex :: ( ParserSource input, Element input ~ Char 120 , Sequential (Chunk input), Element input ~ Element (Chunk input) 121 ) 122 => CountOf Char -> Parser input Word64 123parseHex count = do 124 r <- toList <$> take count 125 unless (and $ isValidHexa <$> r) $ 126 reportError $ Satisfy $ Just $ "expecting hexadecimal character only: " 127 <> fromList (show r) 128 return $ listToHex 0 r 129 where 130 listToHex = foldl' (\acc' x -> acc' * 16 + fromHex x) 131 isValidHexa :: Char -> Bool 132 isValidHexa c = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f') || ('A' <= c && c <= 'F') 133 fromHex '0' = 0 134 fromHex '1' = 1 135 fromHex '2' = 2 136 fromHex '3' = 3 137 fromHex '4' = 4 138 fromHex '5' = 5 139 fromHex '6' = 6 140 fromHex '7' = 7 141 fromHex '8' = 8 142 fromHex '9' = 9 143 fromHex 'a' = 10 144 fromHex 'b' = 11 145 fromHex 'c' = 12 146 fromHex 'd' = 13 147 fromHex 'e' = 14 148 fromHex 'f' = 15 149 fromHex 'A' = 10 150 fromHex 'B' = 11 151 fromHex 'C' = 12 152 fromHex 'D' = 13 153 fromHex 'E' = 14 154 fromHex 'F' = 15 155 fromHex _ = error "Foundation.UUID.parseUUID: the impossible happened" 156