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