Coverage report: /home/ellis/comp/core/lib/log/log.lisp

Kind	Covered	All	%
expression	245	576	42.5
branch	15	50	30.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; log.lisp --- Log Objects

2

3

;;; Code:

4

(in-package :log)

5

6

(eval-always

7

(defparameter *log-levels* (vector t :trace :debug :info :warn :error :fatal nil)))

8

9

(defun ilevel (name)

10

(position name *log-levels*))

11

(define-setf-expander ilevel (new name)

12

(setf (svref *log-levels* (ilevel name)) new))

13

14

(deftype log-level-designator () `(or (member ,@(coerce *log-levels* 'list)) integer))

15

16

(declaim (log-level-designator *log-level*))

17

(defparameter *log-level* :debug

18

"Logging is performed dynamically based on this variable. When NIL,

19

logging is disabled, which is equivalent to a level of :FATAL. When T,

20

Logging is enabled for all levels, which is equivalent to :TRACE.")

21

22

(defvar *log-message-class* 'simple-log-message

23

"The class of messages sent to the logger. May be a subclass of LOG-MESSAGE or

24

T which indicates that message data will be sent without generating a new

25

object.")

26

27

(defvar *log-show-backtrace* t)

28

(defvar *logger* nil)

29

(defvar *log-timestamp* t

30

"If non-nil, print a timestamp with log output. The value may be a

31

function in which case it is used as the function value of

32

`log-timestamp-source', or a number which will be used as the input arg to GET-REAL-TIME-SINCE.")

33

34

 (defvar *log-timestamp-format* '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2)))

35

36

(declaim (fixnum *log-indent*))

37

(defvar *log-indent* 0

38

"Level of indentation to apply to multi-line log messages.")

39

40

(defun get-real-time-since (n)

41

"Return the numbers of seconds since a relative value offset N."

42

(- (get-internal-real-time) n))

43

44

(defun init-log-timestamp ()

45

(setq *log-timestamp* (get-internal-real-time)))

46

47

;; TODO 2023-09-20: (declaim (inline log-timestamp-source)) ;; this

48

;; probably shouldn't be inlined.. bench it

49

(defun log-timestamp-source ()

50

(typecase *log-timestamp*

51

(function (funcall *log-timestamp*))

52

(number (/ (get-real-time-since *log-timestamp*) #.internal-time-units-per-second))

53

(t (/ (get-internal-real-time) #.internal-time-units-per-second))))

54

55

(defun universal-timestamp () (get-universal-time))

56

57

;; the purpose of this struct is to route log messages to the appropriate

58

;; output stream.

59

(defstruct log-router

60

(fatal *error-output*)

61

(error *error-output*)

62

(warn *debug-io*)

63

(info *terminal-io*)

64

(debug *debug-io*)

65

(trace *trace-output*))

66

67

(defmacro define-log-level (name &body pred)

68

"Define a log-level of NAME with PRED being the body of the predicate

69

function 'NAME-P'."

70

(let ((%name (string-upcase name)))

71

`(progn

72

(defun ,(intern (concatenate 'string %name "-P")) ()

73

,@(or pred `((eql *log-level* ,(sb-int:keywordicate name)))))

74

(defun ,(intern (concatenate 'string %name "!")) (&rest args)

75

(cond

76

((and *logger* (started-p *logger*))

77

(log-message ,(keywordicate name) nil args))

78

((,(symbolicate (concatenate 'string %name "-P")))

79

(fresh-line *trace-output*)

80

(format *trace-output* "#:~(~A~)~@[ ~f~]~&"

81

',name

82

(when *log-timestamp* (log-timestamp-source)))

83

(if (and (stringp (car args)) (> (length args) 1))

84

(let ((fmt (pop args)))

85

(apply 'format *trace-output* fmt args))

86

(mapc (lambda (x) (format *trace-output* "; ~A~&" x)) args))))

87

(case (length args)

88

(0 (values))

89

(1 (car args))

90

(t args)))

91

(defun ,(intern (concatenate 'string %name "-DESCRIBE")) (&rest args)

92

(,(intern (concatenate 'string %name "!")) (apply #'describe args))))))

93

94

(define-log-level trace (or (eq *log-level* :trace) (eq *log-level* t)))

95

(define-log-level debug (or (trace-p) (eq *log-level* :debug)))

96

(define-log-level info (or (debug-p) (eq *log-level* :info)))

97

(define-log-level warn (or (info-p) (eq *log-level* :warn)))

98

(define-log-level error (or (warn-p) (eq *log-level* :error)))

99

(define-log-level fatal t) ;; probably needs to be a special case

100

101

;; TODO 2023-08-31: single format control string

102

;; (defun debug! (&rest args)

103

;; (when (debug-p)

104

;; ;...

105

;; ;; RESEARCH 2023-08-31: what's better here.. loop, do, mapc+nil?

106

;; (map nil (lambda (x) (format t "~X~%" x)) args))

107

;; args)

108

109

;;; Pipes

110

(defclass log-message (message)

111

((timestamp :initarg :timestamp :accessor timestamp)

112

(level :initarg :level :accessor level)

113

(content :initarg :content :accessor content))

114

(:default-initargs

115

:timestamp (now)

116

:level :info

117

:content nil))

118

119

(defclass simple-log-message (log-message)

120

((thread :initarg :thread :accessor message-thread)

121

(tags :initarg :tags :accessor tags))

122

(:default-initargs

123

:thread *current-thread*

124

:tags nil))

125

126

(defmethod initialize-instance :before ((message log-message) &key level)

127

(unless (typep level 'log-level-designator)

128

(error "Level must be one of ~a" *log-levels*)))

129

130

(defmethod initialize-instance :before ((message simple-log-message) &key tags)

131

(unless (every #'keywordp tags)

132

(error "Tags must be keywords")))

133

134

(defvar *simple-log-message-formatter* (formatter "~a [~4,a] ~{<~a>~}: ~a"))

135

136

(defmethod format-message (stream (message simple-log-message))

137

(format stream *simple-log-message-formatter*

138

(format-timestring nil (timestamp message) :format *log-timestamp-format*)

139

(level message)

140

(tags message)

141

(format-message nil (content message))))

142

143

(declaim (inline %log-object))

144

(defun %log-object (obj)

145

(if *logger*

146

(msg *logger* obj)

147

obj))

148

149

(defun log-message (level tags content &optional (class *log-message-class*) &rest initargs)

150

(unless (listp tags)

151

(setf tags (list tags)))

152

(%log-object (apply #'make-instance class :level level :tags tags :content content initargs)))

153

154

(defun log-message* (level content &rest args)

155

(%log-object (make-instance 'log-message

156

:level level

157

:content (apply 'format nil content args))))

158

159

(defgeneric log-object (level tags datum &rest args)

160

(:method (level tags (datum string) &rest args)

161

(log-message level tags (apply #'format nil datum args)))

162

(:method (level tags (datum symbol) &rest args)

163

(log-object level tags (apply (if (subtypep datum 'condition)

164

#'make-condition

165

#'make-instance)

166

datum args)))

167

(:method (level tags (datum function) &rest args)

168

(log-message level tags (lambda () (apply datum args))))

169

(:method (level tags datum &rest args)

170

(declare (ignore args))

171

(log-message level tags datum))

172

(:method (level tags (datum condition) &rest args)

173

(declare (ignore args))

174

(log-message level tags (princ-to-string datum)

175

'condition-message :condition datum)))

176

177

(defclass rotating-file-sink (file-sink)

178

((interval :accessor interval)

179

(last-rotation :initform 0 :accessor last-rotation)

180

(path :initarg :path :initform nil :accessor path))

181

(:default-initargs

182

:interval :daily

183

:file nil))

184

185

(defun rotate-file-sink (obj &optional new-file)

186

(let ((time (setf (last-rotation obj) (get-universal-time))))

187

(cond (new-file

188

(setf (file obj) new-file))

189

(t

190

(multiple-value-bind (s m h dd mm yy) (decode-universal-time time)

191

(setf (file obj)

192

                    (make-pathname :name (format NIL "~4,'0d-~2,'0d-~2,'0d:~2,'0d:~2,'0d:~2,'0d~@[.~a~]"

193

                                                 yy mm dd h m s (pathname-name (path obj)))

194

:defaults (path obj))))))

195

(setf (last-rotation obj) time)))

196

197

(defmethod initialize-instance :after ((obj rotating-file-sink) &key interval)

198

(setf (interval obj) interval)

199

(rotate-file-sink obj))

200

201

(defmethod (setf interval) (value (obj rotating-file-sink))

202

(ecase value

203

((:hourly :daily :monthly :weekly)

204

(setf (slot-value obj 'interval) value))))

205

206

(defmethod msg :before ((obj rotating-file-sink) msg)

207

"Check the last-rotation value and rotate the file sink if needed before processing MSG."

208

(let ((pre (last-rotation obj))

209

(now (get-universal-time)))

210

(when

211

(multiple-value-bind (s m h dd mm yy dow) (decode-universal-time now)

212

(declare (ignore s m dow))

213

(multiple-value-bind (ps pm ph pdd pmm pyy pdow) (decode-universal-time pre)

214

(declare (ignore ps pm pdow))

215

(ecase (interval obj)

216

(:hourly

217

(or (/= ph h) (/= pdd dd) (/= pmm mm) (/= pyy yy)))

218

(:daily

219

(or (/= pdd dd) (/= pmm mm) (/= pyy yy)))

220

(:monthly

221

(or (/= pmm mm) (/= pyy yy)))

222

(:weekly

223

(< (* 60 60 24 7) (- (get-universal-time) (last-rotation obj)))))))

224

(rotate-file-sink obj))))

225

226

(defclass level-filter (filter)

227

((level :initform *log-level* :accessor level))

228

(:default-initargs

229

:level :info))

230

231

(defmethod initialize-instance :after ((filter level-filter) &key level)

232

(setf (level filter) level))

233

234

(defmethod (setf level) :before (level (filter level-filter))

235

"Assert LEVEL is a member of *LOG-LEVELS*."

236

(assert (find level *log-levels*) nil 'invalid-argument

237

:reason "LEVEL is not a member of *LOG-LEVELS* or an integer"

238

:item level))

239

240

(defmethod msg ((filter level-filter) (message message))

241

(let ((level (level filter)))

242

(when (<= (ilevel level)

243

(ilevel (level message)))

244

message)))

245

246

(defclass tag-filter (filter)

247

((tags :initarg :tags :initform t :accessor tags)))

248

249

(defmethod msg ((filter tag-filter) (message message))

250

(when (or (eql (tags filter) T)

251

(loop for tag in (tags filter)

252

thereis (find tag (tags message))))

253

message))

254

255

(defclass tag-tree-filter (tag-filter) ())

256

257

(defvar *tag-separator* #\.)

258

259

(defun matching-tree-tag (filter tag)

260

(let ((tag-leaves (ssplit *tag-separator* (string-upcase tag)))

261

(filter-leaves (ssplit *tag-separator* (string-upcase filter))))

262

(loop for ta in tag-leaves

263

for fill in filter-leaves

264

do (cond

265

((or (string= ta "*")

266

(string= fill "*"))

267

(return t))

268

((not (string= ta fill))

269

(return nil)))

270

finally (return (>= (length tag-leaves)

271

(length filter-leaves))))))

272

273

(defmethod msg ((filter tag-tree-filter) (message message))

274

(when (or (eql (tags filter) t)

275

(loop for tag in (tags filter)

276

thereis (find tag (tags message) :test #'matching-tree-tag)))

277

message))

278

279

;;; Log Sync

280

(defun log-sync (&optional (logger *logger*))

281

(when (and logger (log-thread logger)

282

(thread-alive-p (log-thread logger)))

283

(with-sync-message sync

284

(msg logger sync))))

285

286

;;; Logger

287

;; same as VERBOSE:CONTROLLER

288

(defclass logger (pipe)

289

((thread :initform nil :accessor log-thread)

290

(thread-continue :initform nil :accessor log-thread-continue)

291

(queue :initform (make-array '(10) :adjustable T :fill-pointer 0) :accessor queue)

292

(queue-back :initform (make-array '(10) :adjustable T :fill-pointer 0) :accessor queue-back)

293

(queue-condition :initform (make-waitqueue :name "message-condition") :reader queue-condition)

294

(queue-lock :initform (make-mutex :name "message-lock") :reader queue-lock))

295

(:documentation "A class which implements logging functionality. An instance of this class may

296

be designated as the 'global' logger by setting the value of *LOGGER*, or may

297

be implemented for a specific application."))

298

299

(defaccessor sink ((self logger)) (aref #1=(pipe self) (1- (length #1#))))

300

(defaccessor source ((self logger)) (aref (pipe self) 0))

301

302

(defmethod print-object ((self logger) stream)

303

(print-unreadable-object (self stream :type t)

304

(format stream "~@[:threaded ~* ~]~@[:running ~* ~]:size ~d"

305

(log-thread self) (log-thread-continue self) (length (queue self)))))

306

307

(defmethod start ((self logger))

308

(setf (log-thread-continue self) t)

309

(when (log-thread self)

310

(cerror "Spawn a new thread anyway"

311

"There is already a thread set on the logger."))

312

(setf (log-thread self)

313

(make-thread

314

(let ((*logger* self)

315

(*standard-output* *standard-output*)

316

(*error-output* *error-output*)

317

(*trace-output* *trace-output*)

318

(*query-io* *query-io*)

319

(*debug-io* *debug-io*))

320

(lambda () (logger-loop self)))

321

:name "log-thread")))

322

323

(defmethod started-p ((self logger)) (log-thread-continue self))

324

325

(defmethod stopped-p ((self logger)) (not (log-thread-continue self)))

326

327

(defmethod stop ((self logger) &key)

328

(setf (log-thread-continue self) nil)

329

(loop for th = (log-thread self)

330

for i from 0

331

while (and th (thread-alive-p th))

332

do (condition-notify (queue-condition self))

333

(sleep 0.1)

334

(when (< 5 i)

335

(terminate-thread th)

336

(return)))

337

self)

338

339

(defmacro with-logger-lock ((&optional (logger '*logger*)) &body body)

340

`(with-mutex ((queue-lock ,logger))

341

,@body))

342

343

(defmacro with-logger (logger &body body)

344

"Temporarily bind LOGGER to *LOGGER* for the duration of BODY."

345

`(let ((*logger* ,logger))

346

,@body))

347

348

(defmethod logger-loop ((self logger))

349

(let* ((lock (queue-lock self))

350

(condition (queue-condition self))

351

(pipe (pipe self)))

352

(grab-mutex lock)

353

(unwind-protect

354

(loop do (let ((queue (queue self)))

355

(rotatef (queue self) (queue-back self))

356

(release-mutex lock)

357

(with-simple-restart (skip "Skip processing this message batch.")

358

(loop for i from 0

359

for m across queue

360

                             do (with-simple-restart (continue "Continue processing messages, skipping ~A" m)

361

(msg pipe m))

362

(setf (aref queue i) 0)))

363

(setf (fill-pointer queue) 0))

364

(grab-mutex lock)

365

(loop while (= 0 (length (queue self)))

366

do (condition-wait* condition lock :timeout 1))

367

while (log-thread-continue self))

368

(setf (log-thread self) nil)

369

(ignore-errors (release-mutex lock)))))

370

371

(defmethod msg ((self logger) message)

372

(let ((th (log-thread self)))

373

(cond ((and th (thread-alive-p th)

374

(not (eql *current-thread* th)))

375

(with-logger-lock (self)

376

(vector-push-extend message (queue self)))

377

(condition-notify (queue-condition self)))

378

(t (msg (pipe self) message))))

379

nil)

380

381

;;; Commands

382

(defun log-pipe (&rest elements)

383

(let ((logger (if (typep (first elements) 'logger)

384

(pop elements)

385

*logger*)))

386

(with-logger-lock (logger)

387

(let ((pipe (make-pipe)))

388

(dolist (elt elements)

389

(insert-element* elt pipe))

390

(add-element logger pipe)))))

391

392

(defun default-logger (&rest args)

393

(let ((pipe (apply 'make-instance 'logger args)))

394

(defpipe (pipe)

395

(level-filter :id 'repl-level)

396

(tag-tree-filter :id 'repl-tags)

397

(stream-sink :id 'repl-stream))))

398

399

(defun remove-logger ()

400

(when *logger*

401

(stop *logger*)

402

(setf *logger* nil)))

403

404

(defun restart-logger (&optional (logger (default-logger)))

405

(remove-logger)

406

(setf *logger* logger))

407

408

;;; Macros

409

(defmacro with-conditions-logged (&body body)

410

`(block nil

411

(handler-bind

412

((error

413

(lambda (c)

414

(log-message* :error "Error signalled: ~A" cond)

415

(return)))

416

(warning

417

(lambda (c)

418

(log-message* :warn "Warning signalled: ~A" c))))

419

,@body)))