Coverage report: /home/ellis/comp/core/lib/obj/uuid.lisp

Kind	Covered	All	%
expression	162	398	40.7
branch	9	28	32.1

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/uuid.lisp --- UUIDs

2

3

;;

4

5

;;; Code:

6

(in-package :obj/uuid)

7

8

(defvar *clock-seq* 0

9

"Holds the clock sequence. It is set when a version 1 uuid is

10

generated for the first time and remains unchanged during a whole

11

session.")

12

13

(defvar *node* nil

14

"Holds the IEEE 802 MAC address or a random number when such is not

15

available")

16

17

(defvar *ticks-per-count* 1024

18

"Holds the amount of ticks per count. The ticks per count determine

19

the number of possible version 1 uuids created for one time

20

interval. Common Lisp provides INTERNAL-TIME-UNITS-PER-SECOND which

21

gives the ticks per count for the current system so *ticks-per-count*

22

can be set to INTERNAL-TIME-UNITS-PER-SECOND")

23

24

(defparameter *uuid-random-state* nil

25

"Holds the random state used for generation of random numbers")

26

27

(defclass uuid ()

28

((time-low :initarg :time-low

29

:type (unsigned-byte 32)

30

:accessor time-low

31

:initform 0)

32

(time-mid :initarg :time-mid

33

:type (unsigned-byte 16)

34

:accessor time-mid

35

:initform 0)

36

(time-high-and-version :initarg :time-high

37

:type (unsigned-byte 16)

38

:accessor time-high

39

:initform 0)

40

(clock-seq-and-reserved :initarg :clock-seq-var

41

:type (unsigned-byte 8)

42

:accessor clock-seq-var

43

:initform 0)

44

(clock-seq-low :initarg :clock-seq-low

45

:type (unsigned-byte 8)

46

:accessor clock-seq-low

47

:initform 0)

48

(node :initarg :node

49

:type (unsigned-byte 48)

50

:accessor node

51

:initform 0))

52

(:documentation "Represents an uuid"))

53

54

(defun make-uuid-from-string (string)

55

   "Creates an uuid from the string represenation of an uuid. (example input string 6ba7b810-9dad-11d1-80b4-00c04fd430c8)"

56

(unless (= (length string) 36)

57

(error "~@<Could not parse ~S as UUID: string representation ~

58

has invalid length (~D). A valid UUID string representation has 36 ~

59

characters.~@:>" string (length string)))

60

(unless (and (eq (aref string 8) #\-)

61

(eq (aref string 13) #\-)

62

(eq (aref string 18) #\-)

63

(eq (aref string 23) #\-))

64

(error "~@<Could not parse ~S as UUID: positions 8, ~

65

13, 18, 21 and 23 have to contain ~C (~A) characters.~@:>"

66

string #\- (char-name #\-)))

67

(labels ((parse-block (string start end)

68

(parse-integer string :start start :end end :radix 16)))

69

(make-instance 'uuid

70

:time-low (parse-block string 0 8)

71

:time-mid (parse-block string 9 13)

72

:time-high (parse-block string 14 18)

73

:clock-seq-var (parse-block string 19 21)

74

:clock-seq-low (parse-block string 21 23)

75

:node (parse-block string 24 36))))

76

77

(defparameter +namespace-dns+ (make-uuid-from-string "6ba7b810-9dad-11d1-80b4-00c04fd430c8")

78

"The DNS Namespace. Can be used for the generation of uuids version 3 and 5")

79

(defparameter +namespace-url+ (make-uuid-from-string "6ba7b811-9dad-11d1-80b4-00c04fd430c8")

80

"The URL Namespace. Can be used for the generation of uuids version 3 and 5")

81

(defparameter +namespace-oid+ (make-uuid-from-string "6ba7b812-9dad-11d1-80b4-00c04fd430c8")

82

"The OID Namespace. Can be used for the generation of uuids version 3 and 5")

83

(defparameter +namespace-x500+ (make-uuid-from-string "6ba7b814-9dad-11d1-80b4-00c04fd430c8")

84

"The x500+ Namespace. Can be used for the generation of uuids version 3 and 5")

85

86

(defun get-node-id ()

87

"Get MAC address of first ethernet device"

88

(let ((node

89

#+linux

90

(let ((interface (first (remove "lo"

91

                                           (mapcan (lambda (x) (last (pathname-directory x)))

92

                                                   (directory "/sys/class/net/*/address"))

93

:test #'equal))))

94

(when (not (null interface))

95

(with-open-file (address (make-pathname :directory

96

                                                       `(:absolute "sys" "class" "net" ,interface)

97

                                                       :name "address"))

98

(parse-integer (remove #\: (read-line address)) :radix 16))))))

99

(unless node

100

(unless *uuid-random-state*

101

(setf *uuid-random-state* (make-random-state t)))

102

(setf node (dpb #b01 (byte 8 0) (random #xffffffffffff *uuid-random-state*))))

103

node))

104

105

(let ((uuids-this-tick 0)

106

(last-time 0))

107

(defun get-timestamp ()

108

"Get timestamp, compensate nanoseconds intervals"

109

(tagbody

110

restart

111

(let ((time-now (+ (* (get-universal-time) 10000000) 100103040000000000)))

112

                                         ;10010304000 is time between 1582-10-15 and 1900-01-01 in seconds

113

(cond ((not (= last-time time-now))

114

(setf uuids-this-tick 0

115

last-time time-now)

116

(return-from get-timestamp time-now))

117

(T

118

(cond ((< uuids-this-tick *ticks-per-count*)

119

(incf uuids-this-tick)

120

(return-from get-timestamp (+ time-now uuids-this-tick)))

121

(T

122

(sleep 0.0001)

123

(go restart)))))))))

124

125

(defun format-v3or5-uuid (hash ver)

126

   "Helper function to format a version 3 or 5 uuid. Formatting means setting the appropriate version bytes."

127

(check-type ver (or (eql 3) (eql 5)) "either 3 or 5.")

128

129

(let ((result (octet-vector-to-uuid (subseq hash 0 16))))

130

(setf (time-high result) (dpb (ecase ver

131

(3 #b0011)

132

(5 #b0101))

133

(byte 4 12)

134

(logior (ash (aref hash 6) 8)

135

(aref hash 7)))

136

(clock-seq-var result) (dpb #b10 (byte 2 6) (aref hash 8)))

137

result))

138

139

(defmethod print-object ((id uuid) stream)

140

   "Prints an uuid in the string represenation of an uuid. (example string 6ba7b810-9dad-11d1-80b4-00c04fd430c8)"

141

(format stream "~8,'0X-~4,'0X-~4,'0X-~2,'0X~2,'0X-~12,'0X"

142

(time-low id)

143

(time-mid id)

144

(time-high id)

145

(clock-seq-var id)

146

(clock-seq-low id)

147

(node id)))

148

149

(defun print-bytes (stream uuid)

150

"Prints the raw bytes in hex form. (example output 6ba7b8109dad11d180b400c04fd430c8)"

151

(format stream "~8,'0X~4,'0X~4,'0X~2,'0X~2,'0X~12,'0X"

152

(time-low uuid)

153

(time-mid uuid)

154

(time-high uuid)

155

(clock-seq-var uuid)

156

(clock-seq-low uuid)

157

(node uuid)))

158

159

(defun format-as-urn (stream uuid)

160

"Prints the uuid as a urn"

161

(format stream "urn:uuid:~(~A~)" uuid))

162

163

(defun make-null-uuid ()

164

"Generates a NULL uuid (i.e 00000000-0000-0000-0000-000000000000)"

165

(make-instance 'uuid))

166

167

(defun make-v1-uuid ()

168

"Generates a version 1 (time-based) uuid."

169

(unless *uuid-random-state*

170

(setf *uuid-random-state* (make-random-state t)))

171

(let ((timestamp (get-timestamp)))

172

(when (zerop *clock-seq*)

173

(setf *clock-seq* (random 10000 *uuid-random-state*)))

174

(unless *node*

175

(setf *node* (get-node-id)))

176

(make-instance 'uuid

177

:time-low (ldb (byte 32 0) timestamp)

178

:time-mid (ldb (byte 16 32) timestamp)

179

:time-high (dpb #b0001 (byte 4 12) (ldb (byte 12 48) timestamp))

180

:clock-seq-var (dpb #b10 (byte 2 6) (ldb (byte 6 8) *clock-seq*))

181

:clock-seq-low (ldb (byte 8 0) *clock-seq*)

182

:node *node*)))

183

184

(defun make-v3-uuid (namespace name)

185

"Generates a version 3 (named based MD5) uuid."

186

(format-v3or5-uuid

187

(digest-uuid :md5 (uuid-to-octet-vector namespace) name)

188

3))

189

190

(defun make-v4-uuid ()

191

"Generates a version 4 (random) uuid"

192

(unless *uuid-random-state*

193

(setf *uuid-random-state* (make-random-state t)))

194

(make-instance 'uuid

195

:time-low (random #xffffffff *uuid-random-state*)

196

:time-mid (random #xffff *uuid-random-state*)

197

                  :time-high (dpb #b0100 (byte 4 12) (ldb (byte 12 0) (random #xffff *uuid-random-state*)))

198

                  :clock-seq-var (dpb #b10 (byte 2 6) (ldb (byte 8 0) (random #xff *uuid-random-state*)))

199

:clock-seq-low (random #xff *uuid-random-state*)

200

:node (random #xffffffffffff *uuid-random-state*)))

201

202

(defun make-v5-uuid (namespace name)

203

"Generates a version 5 (name based SHA1) uuid."

204

(format-v3or5-uuid

205

(digest-uuid :sha1 (uuid-to-octet-vector namespace) name)

206

5))

207

208

(defun uuid= (uuid1 uuid2)

209

(or (eq uuid1 uuid2)

210

(and (= (time-low uuid1) (time-low uuid2))

211

(= (time-mid uuid1) (time-mid uuid2))

212

(= (time-high uuid1) (time-high uuid2))

213

(= (clock-seq-var uuid1) (clock-seq-var uuid2))

214

(= (clock-seq-low uuid1) (clock-seq-low uuid2))

215

(= (node uuid1)(node uuid2)))))

216

217

(defun uuid-to-octet-vector (uuid)

218

"Converts an uuid to byte-array"

219

(let ((array (make-array 16 :element-type '(unsigned-byte 8))))

220

(with-slots (time-low time-mid time-high-and-version clock-seq-and-reserved clock-seq-low node)

221

uuid

222

(loop for i from 3 downto 0

223

                       do (setf (aref array (- 3 i)) (ldb (byte 8 (* 8 i)) time-low)))

224

(loop for i from 5 downto 4

225

                       do (setf (aref array i) (ldb (byte 8 (* 8 (- 5 i))) time-mid)))

226

(loop for i from 7 downto 6

227

                       do (setf (aref array i) (ldb (byte 8 (* 8 (- 7 i))) time-high-and-version)))

228

(setf (aref array 8) (ldb (byte 8 0) clock-seq-and-reserved))

229

(setf (aref array 9) (ldb (byte 8 0) clock-seq-low))

230

(loop for i from 15 downto 10

231

do (setf (aref array i) (ldb (byte 8 (* 8 (- 15 i))) node)))

232

array)))

233

234

(defun uuid-to-string (uuid)

235

(print-object uuid nil))

236

237

(defmacro arr-to-bytes (from to array)

238

"Helper macro used in byte-array-to-uuid."

239

`(loop for i from ,from to ,to

240

with res = 0

241

do (setf (ldb (byte 8 (* 8 (- ,to i))) res) (aref ,array i))

242

finally (return res)))

243

244

(defun octet-vector-to-uuid (array)

245

"Converts a byte-array generated with uuid-to-byte-array to an uuid."

246

(check-type array

247

(array (unsigned-byte 8) (16))

248

                "Provided value is not an one-dimensional array with 16 elements of type (unsigned-byte 8)")

249

(make-instance 'uuid

250

:time-low (arr-to-bytes 0 3 array)

251

:time-mid (arr-to-bytes 4 5 array)

252

:time-high (arr-to-bytes 6 7 array)

253

:clock-seq-var (aref array 8)

254

:clock-seq-low (aref array 9)

255

:node (arr-to-bytes 10 15 array)))

256

257

(defun digest-uuid (digest uuid name)

258

   "Helper function that produces a digest from a namespace (a byte array) and a string. Used for the

259

generation of version 3 and 5 uuids."

260

(declare (ignorable digest uuid name))

261

#+ironclad

262

(let ((digester (ironclad:make-digest digest)))

263

(ironclad:update-digest digester uuid)

264

(ironclad:update-digest digester (trivial-utf-8:string-to-utf-8-bytes name))

265

(ironclad:produce-digest digester)))