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
|
module Erebos.UUID (
UUID,
toString, fromString,
toText, fromText,
toASCIIBytes, fromASCIIBytes,
nextRandom,
) where
import Control.Monad
import Crypto.Random.Entropy
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BSC
import Data.Text (Text)
import Data.Text.Encoding
import Erebos.Util
newtype UUID = UUID ByteString
deriving (Eq, Ord)
instance Show UUID where
show = toString
toString :: UUID -> String
toString = BSC.unpack . toASCIIBytes
fromString :: String -> Maybe UUID
fromString = fromASCIIBytes . BSC.pack
toText :: UUID -> Text
toText = decodeUtf8 . toASCIIBytes
fromText :: Text -> Maybe UUID
fromText = fromASCIIBytes . encodeUtf8
toASCIIBytes :: UUID -> ByteString
toASCIIBytes (UUID uuid) = BS.concat
[ showHex $ BS.take 4 $ uuid
, BSC.singleton '-'
, showHex $ BS.take 2 $ BS.drop 4 uuid
, BSC.singleton '-'
, showHex $ BS.take 2 $ BS.drop 6 uuid
, BSC.singleton '-'
, showHex $ BS.take 2 $ BS.drop 8 uuid
, BSC.singleton '-'
, showHex $ BS.drop 10 uuid
]
fromASCIIBytes :: ByteString -> Maybe UUID
fromASCIIBytes bs = do
guard $ BS.length bs == 36
guard $ BSC.index bs 8 == '-'
guard $ BSC.index bs 13 == '-'
guard $ BSC.index bs 18 == '-'
guard $ BSC.index bs 23 == '-'
UUID . BS.concat <$> sequence
[ readHex $ BS.take 8 $ bs
, readHex $ BS.take 4 $ BS.drop 9 bs
, readHex $ BS.take 4 $ BS.drop 14 bs
, readHex $ BS.take 4 $ BS.drop 19 bs
, readHex $ BS.drop 24 bs
]
nextRandom :: IO UUID
nextRandom = do
[ b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf ]
<- BS.unpack <$> getEntropy 16
let version = 4
b6' = b6 .&. 0x0f .|. (version `shiftL` 4)
b8' = b8 .&. 0x3f .|. 0x80
return $ UUID $ BS.pack [ b0, b1, b2, b3, b4, b5, b6', b7, b8', b9, ba, bb, bc, bd, be, bf ]
|