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