;; Copyright 2006-2017, Matthew Welland.
;;
;; This file is part of Pkts
;;
;; Pkts is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Pkts is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Pkts. If not, see <http://www.gnu.org/licenses/>.
;;
;; CARDS:
;;
;; A card is a line of text, the first two characters are a letter followed by a
;; space. The letter is the card type.
;;
;; PKTS:
;;
;; A pkt is a sorted list of cards with a final card Z that contains the shar1 hash
;; of all of the preceding cards.
;;
;; APKT:
;;
;; An alist mapping card types to card data
;; '((T . "pkttype")
;; (a . "some content"))
;;
;; EPKT:
;;
;; Extended packet using friendly keys. Must use a pktspec to convert to/from epkts
;; '((ptype . "pkttype")
;; (adata . "some content))
;;
;; DPKT:
;;
;; pkts pulled from the database have this format:
;;
;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
;; (t . "v1.63/tip/dev")
;; (c . "QUICKPATT")
;; (T . "runstart")
;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;; (D . "1488995096.0"))
;; (id . 8)
;; (group-id . 0)
;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;; (parent . "")
;; (pkt-type . "runstart")
;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; pktspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;; (url . u)
;; (blurb . b)))
;; (comment . ((comment . c)
;; (score . s))))
;; Reserved cards:
;; P : pkt parent
;; R : reference pkt containing mapping of short string -> sha1sum strings
;; T : pkt type
;; D : current time from (current-time), unless provided
;; Z : shar1 hash of the packet
;; Example usage:
;;
;; Create a pkt:
;;
;; (use pkts)
;; (define-values (uuid pkt)
;; (alist->pkt
;; '((fruit . "apple") (meat . "beef")) ;; this is the data to convert
;; '((foods (fruit . f) (meat . m))) ;; this is the pkt spec
;; ptype:
;; 'foods))
;;
;; Add to pkt queue:
;;
;; (define db (open-queue-db "/tmp/pkts" "pkts.db"))
;; (add-to-queue db pkt uuid 'foods #f 0) ;; no parent and use group_id of 0
;;
;; Retrieve the packet from the db and extract a value:
;;
;; (alist-ref
;; 'meat
;; (dpkt->alist
;; (car (get-dpkts db #f 0 #f))
;; '((foods (fruit . f)
;; (meat . m)))))
;; => "beef"
;;
(module pkts
(
;; cards, util and misc
;; sort-cards
;; calc-shar1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed
construct-sdat
construct-pkt
card->type/value
add-z-card
;; queue database procs
open-queue-db
add-to-queue
create-and-queue
lookup-by-uuid
lookup-by-id
get-dpkts
get-not-processed-pkts
get-related
find-pkts
process-pkts
get-descendents
get-ancestors
get-pkts
get-last-descendent
with-queue-db
load-pkts-to-db
;; procs that operate directly on pkts, sdat, apkts, dpkts etc.
pkt->alist ;; pkt -> apkt (i.e. alist)
pkt->sdat ;; pkt -> '("a aval" "b bval" ...)
sdat->alist ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...)
dblst->dpkts ;; convert list of tuples from queue db into dpkts
dpkt->alist ;; flatten a dpkt into an alist containing all db fields and the pkt alist
dpkts->alists ;; apply dpkt->alist to a list of alists using a pkt-spec
alist->pkt ;; returns two values uuid, pkt
get-value ;; looks up a value given a key in a dpkt
flatten-all ;; merge the list of values from a query which includes a pkt into a flat alist <== really useful!
check-pkt
;; pkt alists
write-alist->pkt
read-pkt->alist
;; archive database
archive-open-db
write-archive-pkts
archive-pkts
mark-processed
;; pktsdb
pktdb-conn ;; useful
pktdb-fname
pktsdb-open
pktsdb-close
pktsdb-add-record
;; temporary
pktdb-pktspec
;; utility procs
increment-string ;; used to get indexes for strings in ref pkts
make-report ;; make a .dot file
)
(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)
;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================
(define-inline (unescape-data data)
(string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))
(define-inline (escape-data data)
(string-translate* data '(("\n" . "\\n") ("\\" . "\\\\"))))
(define-inline (make-card type data)
(conc type " " (escape-data (->string data))))
;; reverse an alist for doing pktkey -> external key conversions
;;
(define-inline (reverse-aspec aspec)
(map (lambda (dat)
(cons (cdr dat)(car dat)))
aspec))
;; add a card to the list of cards, sdat
;; if type is #f return only sdat
;; if data is #f return only sdat
;;
(define-inline (add-card sdat type data)
(if (and type data)
(cons (make-card type data) sdat)
sdat))
;;======================================================================
;; STRING AS FUNKY NUMBER
;;======================================================================
;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a
;; ref, instead the P parent card is used.
;; Question: Why does it matter to remove PTDZ?
;; To make the ref easier to use the ref strings will be the keys
;; so we cannot have overlap with any actual keys. But this is a
;; bit silly. What we need to do instead is reject keys of length
;; one where the char is in PTDZ
;;
;; This is basically base92
;;
(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~"))
;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|"))
(define (char-incr inchar)
(let* ((carry #f)
(next-char (let ((rem (member inchar string-num-chars)))
(if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list
(begin
(set! carry #t)
(car string-num-chars))
(cadr rem)))))
(values next-char carry)))
(define (increment-string str)
(if (string-null? str)
"0"
(let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd
(list->string
(let loop ((hed (car strlst))
(tal (cdr strlst))
(res '()))
(let-values (((newhed carry)(char-incr hed)))
;; (print "newhed: " newhed " carry: " carry " tal: " tal)
(let ((newres (cons newhed res)))
(if carry ;; we'll have to propagate the carry
(if (null? tal) ;; at the end, tack on "0" (which is really a "1")
(cons (car string-num-chars) newres)
(loop (car tal)(cdr tal) newres))
(append (reverse tal) newres)))))))))
;;======================================================================
;; P K T S D B I N T E R F A C E
;;
;; INTEGER, REAL, TEXT
;;======================================================================
;;
;; spec
;; ( (tablename1 . (field1name L1 TYPE)
;; (field2name L2 TYPE) ... )
;; (tablename2 ... ))
;;
;; Example: (tests (testname n TEXT)
;; (rundir r TEXT)
;; ... )
;;
;; pkt keys are taken from the first letter, if that is not unique
;; then look at the next letter and so on
;;
;; use this struct to hold the pktspec and the db handle
;;
(defstruct pktdb
(fname #f)
(pktsdb-spec #f)
(pktspec #f) ;; cache the pktspec
(field-keys #f) ;; cache the field->key mapping (field1 . k1) ...
(key-fields #f) ;; cache the key->field mapping
(conn #f)
)
;; WARNING: There is a simplification in the pktsdb spec w.r.t. pktspec.
;; The field specs are the cdr of the table list - not a full
;; list. The extra list level in pktspec is gratuitous and should
;; be removed.
;;
(define (pktsdb-spec->pktspec tables-spec)
(map (lambda (tablespec)
(list (car tablespec)
(map (lambda (field-spec)
(cons (car field-spec)(cadr field-spec)))
(cdr tablespec))))
tables-spec))
(define (pktsdb-open dbfname pktsdb-spec)
(let* ((pdb (make-pktdb))
(dbexists (file-exists? dbfname))
(db (dbi:open 'sqlite3 `((dbname . ,dbfname)))))
(pktdb-pktsdb-spec-set! pdb pktsdb-spec)
(pktdb-pktspec-set! pdb (pktsdb-spec->pktspec pktsdb-spec))
(pktdb-fname-set! pdb dbfname)
(pktdb-conn-set! pdb db)
(if (not dbexists)
(pktsdb-init pdb))
pdb))
(define (pktsdb-init pktsdb)
(let* ((db (pktdb-conn pktsdb))
(pktsdb-spec (pktdb-pktsdb-spec pktsdb)))
;; create a table for the pkts themselves
(dbi:exec db "CREATE TABLE IF NOT EXISTS pkts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, pkt TEXT);")
(for-each
(lambda (table)
(let* ((table-name (car table))
(fields (cdr table))
(stmt (conc "CREATE TABLE IF NOT EXISTS "
table-name
" (id INTEGER PRIMARY KEY,"
(string-intersperse
(map (lambda (fieldspec)
(conc (car fieldspec) " "
(caddr fieldspec)))
fields)
",")
");")))
(dbi:exec db stmt)))
pktsdb-spec)))
;; create pkt from the data and insert into pkts table
;;
;; data is assoc list of (field . value) ...
;; tablename is a symbol matching the table name
;;
(define (pktsdb-add-record pktsdb tablename data #!optional (parent #f))
(let*-values (((zkey pkt) (alist->pkt data (pktdb-pktspec pktsdb) ptype: tablename)))
;; have the data as alist so insert it into appropriate table also
(let* ((db (pktdb-conn pktsdb)))
;; TODO: Address collisions
(dbi:exec db "INSERT INTO pkts (zkey,pkt,record_id) VALUES (?,?,?);"
zkey pkt -1)
(let* (;; (pktid (pktsdb-pktkey->pktid pktsdb pktkey))
(record-id (pktsdb-insert pktsdb tablename data)))
(dbi:exec db "UPDATE pkts SET record_id=? WHERE zkey=?;"
record-id zkey)
))))
;;
(define (pktsdb-insert pktsdb tablename data)
(let* ((db (pktdb-conn pktsdb))
(stmt (conc "INSERT INTO " tablename
" (" (string-intersperse (map conc (map car data)) ",")
") VALUES ('"
;; TODO: Add lookup of data type and do not
;; wrap integers with quotes
(string-intersperse (map conc (map cdr data)) "','")
"');")))
(print "stmt: " stmt)
(dbi:exec db stmt)
;; lookup the record-id and return it
))
(define (pktsdb-close pktsdb)
(dbi:close (pktdb-conn pktsdb)))
;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1))))
;;======================================================================
;; CARDS, MISC and UTIL
;;======================================================================
;; given string (likely multi-line) "dat" return shar1 hash
;;
(define-inline (calc-shar1 instr)
(message-digest-string
(sha1-primitive)
instr))
;; given a single card return its type and value
;;
(define (card->type/value card)
(let ((ctype (substring card 0 1))
(cval (substring card 2 (string-length card))))
(values (string->symbol ctype) cval)))
;;======================================================================
;; SDAT procs
;; sdat is legacy/internal usage. Intention is to remove sdat calls from
;; the exposed calls.
;;======================================================================
;; sort list of cards
;;
(define-inline (sort-cards sdat)
(sort sdat string<=?))
;; pkt rules
;; 1. one card per line
;; 2. at least one card
;; 3. no blank lines
;; given sdat, a list of cards return uuid, packet (as sdat)
;;
(define (add-z-card sdat)
(let* ((sorted-sdat (sort-cards sdat))
(dat (string-intersperse sorted-sdat "\n"))
(uuid (calc-shar1 dat)))
(values
uuid
(conc
dat
"\nZ "
uuid))))
(define (check-pkt pkt)
(handle-exceptions
exn
#f ;; anything goes wrong - call it a crappy pkt
(let* ((sdat (string-split pkt "\n"))
(rdat (reverse sdat)) ;; reversed
(zdat (car rdat))
(Z (cadr (string-split zdat)))
(cdat (string-intersperse (reverse (cdr rdat)) "\n")))
(equal? Z (calc-shar1 cdat)))))
;;======================================================================
;; APKTs
;;======================================================================
;; convert a sdat (list of cards) to an alist
;;
(define (sdat->alist sdat)
(let loop ((hed (car sdat))
(tal (cdr sdat))
(res '()))
(let-values (( (ctype cval)(card->type/value hed) ))
;; if this card is not one of the common ones tack it on to rem
(let* ((oldval (alist-ref ctype res))
(newres (cons (cons ctype
(if oldval ;; list or string
(if (list? oldval)
(cons cval oldval)
(cons cval (list oldval)))
cval))
res)))
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres))))))
;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b") <= this is a the alist
;; (t . "v1.63/tip/dev")
;; (c . "QUICKPATT")
;; (T . "runstart")
;; (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;; (D . "1488995096.0"))
;; (id . 8)
;; (group-id . 0)
;; (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;; (parent . "")
;; (pkt-type . "runstart")
;; (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; pktspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;; (url . u)
;; (blurb . b)))
;; (comment . ((comment . c)
;; (score . s))))
;; DON'T USE?
;;
(define (get-value field dpkt . spec-in)
(if (null? spec-in)
(alist-ref field dpkt)
(let* ((spec (car spec-in))
(apkt (alist-ref 'apkt dpkt))) ;; get the pkt alist
(if (and apkt spec)
(let* ((ptype (alist-ref 'pkt-type dpkt))
(pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of pkt
(and pspec
(let* ((key (alist-ref field pspec)))
(and key (alist-ref key apkt)))))
#f))))
;; convert a dpkt to a pure alist given a pktspec
;; this flattens out the alist to include the data from
;; the queue database record
;;
(define (dpkt->alist dpkt pktspec)
(let* ((apkt (alist-ref 'apkt dpkt))
(pkt-type (or (alist-ref 'pkt-type dpkt) ;; pkt-type is from the database field pkt_type
(alist-ref 'T apkt)))
(pkt-fields (alist-ref (string->symbol pkt-type) pktspec))
(rev-fields (if pkt-fields
(reverse-aspec pkt-fields)
'())))
(append (map (lambda (entry)
(let* ((pkt-key (car entry))
(new-key (or (alist-ref pkt-key rev-fields) pkt-key)))
`(,new-key . ,(cdr entry))))
apkt)
dpkt)))
;; convert a list of dpkts into a list of alists using pkt-spec
;;
(define (dpkts->alists dpkts pkt-spec)
(map (lambda (x)
(dpkt->alist x pkt-spec))
dpkts))
;; Generic flattener, make the tuple and pkt into a single flat alist
;;
;; qry-result-spec is a list of symbols corresponding to each field
;;
(define (flatten-all inlst pktspec . qry-result-spec)
(map
(lambda (tuple)
(dpkt->alist
(apply dblst->dpkts tuple qry-result-spec)
pktspec))
inlst))
;; call like this:
;; (construct-sdat 'a "a data" 'S "S data" ...)
;; returns list of cards
;; ( "A a value" "D 12345678900" ...)
;;
(define (construct-sdat . alldat)
(let ((have-D-card #f)) ;; flag
(if (even? (length alldat))
(let loop ((type (car alldat))
(data (cadr alldat))
(tail (cddr alldat))
(res '()))
(if (eq? type 'D)(set! have-D-card #t))
(if (null? tail)
(if have-D-card ;; return the constructed pkt, add a D card if none found
(add-card res type data)
(add-card
(add-card res 'D (current-seconds))
type data))
(loop (car tail)
(cadr tail)
(cddr tail)
(add-card res type data))))
#f))) ;; #f means it failed to create the sdat
(define (construct-pkt . alldat)
(add-z-card
(apply construct-sdat alldat)))
;;======================================================================
;; CONVERTERS
;;======================================================================
(define (pkt->sdat pkt)
(map unescape-data (string-split pkt "\n")))
;; given a pure pkt return an alist
;;
(define (pkt->alist pkt #!key (pktspec #f))
(let ((sdat (cond
((string? pkt) (pkt->sdat pkt))
((list? pkt) pkt)
(else #f))))
(if pkt
(if pktspec
(dpkt->alist (list (cons 'apkt (sdat->alist sdat))) pktspec)
(sdat->alist sdat))
#f)))
;; convert an alist to an sdat
;; in: '((a . "blah")(b . "foo"))
;; out: '("a blah" "b foo")
;;
(define (alist->sdat adat)
(map (lambda (dat)
(conc (car dat) " " (cdr dat)))
adat))
;; adat is the incoming alist, aspec is the mapping
;; from incoming key to the pkt key (usually one
;; letter to keep data tight) see the pktspec at the
;; top of this file
;;
;; NOTE: alists can contain multiple instances of the same key (supported fine by pkts)
;; but you (obviously I suppose) cannot use alist-ref to access those entries.
;;
(define (alist->pkt adat aspec #!key (ptype #f))
(let* ((pkt-type (or ptype
(alist-ref 'T adat) ;; can provide in the incoming alist
#f))
(pkt-spec (if pkt-type ;; alist of external-key -> key
(or (alist-ref pkt-type aspec) '())
(if (null? aspec)
'()
(cdar aspec)))) ;; default to first one if nothing specified
(new-alist (map (lambda (dat)
(let* ((key (car dat))
(val (cdr dat))
(newkey (or (alist-ref key pkt-spec)
key)))
(cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines.
adat))
(new-with-type (if (alist-ref 'T new-alist)
new-alist
(cons `(T . ,pkt-type) new-alist)))
(with-d-card (if (alist-ref 'D new-with-type)
new-with-type
(cons `(D . ,(current-seconds))
new-with-type))))
(add-z-card
(alist->sdat with-d-card))))
;;======================================================================
;; D B Q U E U E I N T E R F A C E
;;======================================================================
;; pkts (
;; id SERIAL PRIMARY KEY,
;; uuid TEXT NOT NULL,
;; parent_uuid TEXT default '',
;; pkt_type INTEGER DEFAULT 0,
;; group_id INTEGER NOT NULL,
;; pkt TEXT NOT NULL
;; schema is list of SQL statements - can be used to extend db with more tables
;;
(define (open-queue-db dbpath dbfile #!key (schema '()))
(let* ((dbfname (conc dbpath "/" dbfile))
(dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
(db (dbi:open 'sqlite3 (list (cons 'dbname dbfname)))))
;; (set-busy-handler! (dbi:db-conn db) (busy-timeout 10000))
(if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
(for-each
(lambda (stmt)
(dbi:exec db stmt))
(cons "CREATE TABLE IF NOT EXISTS pkts
(id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL,
uuid TEXT NOT NULL,
parent_uuid TEXT TEXT DEFAULT '',
pkt_type TEXT NOT NULL,
pkt TEXT NOT NULL,
processed INTEGER DEFAULT 0)"
schema))) ;; 0=not processed, 1=processed, 2... for expansion
db))
(define (add-to-queue db pkt uuid pkt-type parent-uuid group-id)
(dbi:exec db "INSERT INTO pkts (uuid,parent_uuid,pkt_type,pkt,group_id)
VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);"
uuid
(if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid.
(if pkt-type (conc pkt-type) "")
pkt
group-id))
;; given all needed parameters create a pkt and store it in the queue
;; procs is an alist that maps pkt-type to a function that takes a list of pkt params
;; in data and returns the uuid and pkt
;;
(define (create-and-queue conn procs pkt-type parent-uuid group-id data)
(let ((proc (alist-ref pkt-type procs)))
(if proc
(let-values (( (uuid pkt) (proc data) ))
(add-to-queue conn pkt uuid pkt-type parent-uuid group-id)
uuid)
#f)))
;; given uuid get pkt, if group-id is specified use it (reduces probablity of
;; being messed up by a uuid collision)
;;
(define (lookup-by-uuid db pkt-uuid group-id)
(if group-id
(dbi:get-one db "SELECT pkt FROM pkts WHERE group_id=? AND uuid=?;" group-id pkt-uuid)
(dbi:get-one db "SELECT pkt FROM pkts WHERE uuid=?;" pkt-uuid)))
;; find a packet by its id
;;
(define (lookup-by-id db id)
(dbi:get-one db "SELECT pkt FROM pkts WHERE id=?;" id))
;; apply a proc to the open db handle for a pkt db in pdbpath
;;
(define (with-queue-db pdbpath proc #!key (schema #f))
(cond
((not (equal? (file-owner pdbpath)(current-effective-user-id)))
(print "ERROR: directory " pdbpath " is not owned by " (current-effective-user-name)))
(else
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: schema)) ;; '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(res (proc pdb)))
(dbi:close pdb)
res))))
(define (load-pkts-to-db pktsdirs pdbpath #!key (schema #f))
(with-queue-db
pdbpath
(lambda (pdb)
(for-each
(lambda (pktsdir) ;; look at all
(cond
((not (file-exists? pktsdir))
(print "ERROR: packets directory " pktsdir " does not exist."))
((not (directory? pktsdir))
(print "ERROR: packets directory path " pktsdir " is not a directory."))
((not (file-read-access? pktsdir))
(print "ERROR: packets directory path " pktsdir " is not readable."))
(else
;; (print "INFO: Loading packets found in " pktsdir)
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0))
;; (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
;; (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts)))))
pktsdirs))))
;;======================================================================
;; P R O C E S S P K T S
;;======================================================================
;; given a list of field values pulled from the queue db generate a list
;; of dpkt's
;;
(define (dblst->dpkts lst . altmap)
(let* ((maplst (if (null? altmap)
'(id group-id uuid parent pkt-type pkt processed)
altmap))
(res (map cons maplst lst))) ;; produces list of pairs, i.e an alist
(cons `(apkt . ,(pkt->alist (alist-ref 'pkt res)))
res)))
;; NB// ptypes is a list of symbols, '() or #f find all types
;;
(define (get-dpkts db ptypes group-id parent-uuid #!key (uuid #f))
(let* ((ptype-qry (if (and ptypes
(not (null? ptypes)))
(conc " IN ('" (string-intersperse (map conc ptypes) "','") "')")
(conc " LIKE '%' ")))
(rows (dbi:get-rows
db
(conc
"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
WHERE pkt_type " ptype-qry " AND group_id=?
AND processed=0 "
(if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "")
(if uuid (conc "AND uuid='" uuid "' ") "")
"ORDER BY id DESC;")
group-id)))
(map dblst->dpkts (map vector->list rows))))
;; get N pkts not yet processed for group-id
;;
(define (get-not-processed-pkts db group-id pkt-type limit offset)
(map dblst->dpkts
(map vector->list
(dbi:get-rows
db
"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
WHERE pkt_type = ? AND group_id = ? AND processed=0
LIMIT ? OFFSET ?;"
(conc pkt-type) ;; convert symbols to string
group-id
limit
offset
))))
;; given a uuid, get not processed child pkts
;;
(define (get-related db group-id uuid)
(map dblst->dpkts
(dbi:get-rows
db
"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
WHERE parent_uuid=? AND group_id=? AND processed=0;"
uuid group-id)))
;; generic pkt processor
;;
;; find all packets in group-id of type in ptypes and apply proc to pktdat
;;
(define (process-pkts conn group-id ptypes parent-uuid proc)
(let* ((pkts (get-dpkts conn ptypes group-id parent-uuid)))
(map proc pkts)))
;; criteria is an alist ((k . valpatt) ...)
;; - valpatt is a regex
;; - ptypes is a list of types (symbols expected)
;; match-type: 'any or 'all
;;
(define (find-pkts db ptypes criteria #!key (processed #f)(match-type 'any)(pkt-spec #f)) ;; processed=#f, don't use, else use
(let* ((pkts (get-dpkts db ptypes 0 #f))
(match-rules (lambda (pktdat) ;; returns a list of matching rules
(filter (lambda (c)
;; (print "c: " c)
(let* ((ctype (car c)) ;; card type
(rx (cdr c)) ;; card pattern
;; (t (alist-ref 'pkt-type pktdat))
(pkt (alist-ref 'pkt pktdat))
(apkt (pkt->alist pkt))
(cdat (alist-ref ctype apkt)))
;; (print "cdat: " cdat) ;; " apkt: " apkt)
(if cdat
(string-match rx cdat)
#f)))
criteria)))
(res (filter (lambda (pktdat)
(if (null? criteria) ;; looking for all pkts
#t
(case match-type
((any)(not (null? (match-rules pktdat))))
((all)(eq? (length (match-rules pktdat))(length criteria)))
(else
(print "ERROR: bad match type " match-type ", expecting any or all.")))))
pkts)))
(if pkt-spec
(dpkts->alists res pkt-spec)
res)))
;; get descendents of parent-uuid
;;
;; NOTE: Should be doing something like the following:
;;
;; given a uuid, get not processed child pkts
;; processed:
;; #f => get all
;; 0 => get not processed
;; 1 => get processed
;;
(define (get-ancestors db group-id uuid #!key (processed #f))
(map dblst->dpkts
(map vector->list
(dbi:get-rows
db
(conc
"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
FROM pkts
WHERE uuid IN
(WITH RECURSIVE
tree(uuid,parent_uuid)
AS
(
SELECT uuid, parent_uuid
FROM pkts
WHERE uuid = ?
UNION ALL
SELECT t.uuid, t.parent_uuid
FROM pkts t
JOIN tree ON t.uuid = tree.parent_uuid
)
SELECT uuid FROM tree)
AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
uuid group-id))))
;; Untested
;;
(define (get-descendents db group-id uuid #!key (processed #f))
(map dblst->dpkts
(map vector->list
(dbi:get-rows
db
(conc
"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed
FROM pkts
WHERE uuid IN
(WITH RECURSIVE
tree(uuid,parent_uuid)
AS
(
SELECT uuid, parent_uuid
FROM pkts
WHERE uuid = ?
UNION ALL
SELECT t.uuid, t.parent_uuid
FROM pkts t
JOIN tree ON t.parent_uuid = tree.uuid
)
SELECT uuid FROM tree)
AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
uuid group-id))))
;; look up descendents based on given info unless passed in a list via inlst
;;
(define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f))
(let ((descendents (or inlst (get-descendents db group-id uuid processed: processed))))
(if (null? descendents)
#f
(last descendents))))
;;======================================================================
;; A R C H I V E S - always to a sqlite3 db
;;======================================================================
;; open an archive db
;; path: archive-dir/<year>/month.db
;;
(define (archive-open-db archive-dir)
(let* ((curr-time (seconds->local-time (current-seconds)))
(dbpath (conc archive-dir "/" (time->string curr-time "%Y")))
(dbfile (conc dbpath "/" (time->string curr-time "%m") ".db"))
(dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f))))
(let ((db (dbi:open 'sqlite3 (list (cons 'dbname dbfile)))))
;; (set-busy-handler! db (busy-timeout 10000))
(if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness.
(dbi:exec db "CREATE TABLE IF NOT EXISTS pkts
(id INTEGER,
group_id INTEGER,
uuid TEXT,
parent_uuid TEXT,
pkt_type TEXT,
pkt TEXT,
processed INTEGER DEFAULT 0)"))
db)))
;; turn on transactions! otherwise this will be painfully slow
;;
(define (write-archive-pkts src-db db pkt-ids)
(let ((pkts (dbi:get-rows
src-db
(conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt FROM pkts WHERE id IN ("
(string-intersperse (map conc pkt-ids) ",") ")"))))
;; (dbi:with-transaction
;; db
(lambda ()
(for-each
(lambda (pkt)
(apply dbi:exec db "INSERT INTO pkts (id,group_id,uuid,parent_uuid,pkt_type,pkt)
VALUES (?,?,?,?,?,?)"
pkt))
pkts)))) ;; )
;; given a list of uuids and lists of uuids move all to
;; the sqlite3 db for the current archive period
;;
(define (archive-pkts conn pkt-ids archive-dir)
(let ((db (archive-open-db archive-dir)))
(write-archive-pkts conn db pkt-ids)
(dbi:close db))
;; (pg:with-transaction
;; conn
;; (lambda ()
(for-each
(lambda (id)
(dbi:get-one
conn
"DELETE FROM pkts WHERE id=?" id))
pkt-ids)) ;; ))
;; given a list of ids mark all as processed
;;
(define (mark-processed conn pkt-ids)
;; (pg:with-transaction
;; conn
;; (lambda ()
(for-each
(lambda (id)
(dbi:get-one
conn
"UPDATE pkts SET processed=1 WHERE id=?;" id))
pkt-ids)) ;; x))
;; a generic pkt getter, gets from the pkts db
;;
(define (get-pkts conn ptypes)
(let* ((ptypes-str (if (null? ptypes)
""
(conc " WHERE pkt_type IN ('" (string-intersperse ptypes ",") "') ")))
(qry-str (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts" ptypes-str)))
(map vector->list (dbi:get-rows conn qry-str))))
;; make a report of the pkts in the db
;; ptypes of '() gets all pkts
;; display-fields
;;
(define (make-report dest conn pktspec display-fields . ptypes)
(let* (;; (conn (dbi:db-conn (s:db)))
(all-rows (get-pkts conn ptypes))
(all-pkts (flatten-all
all-rows
pktspec
'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
(by-uuid (let ((ht (make-hash-table)))
(for-each
(lambda (pkt)
(let ((uuid (alist-ref 'uuid pkt)))
(hash-table-set! ht uuid pkt)))
all-pkts)
ht))
(by-parent (let ((ht (make-hash-table)))
(for-each
(lambda (pkt)
(let ((parent (alist-ref 'parent pkt)))
(hash-table-set! ht parent (cons pkt (hash-table-ref/default ht parent '())))))
all-pkts)
ht))
(oup (if dest (open-output-file dest) (current-output-port))))
(with-output-to-port
oup
(lambda ()
(print "digraph megatest_state_status {
// ranksep=0.05
rankdir=LR;
node [shape=\"box\"];
")
;; first all the names
(for-each
(lambda (pkt)
(let* ((uuid (alist-ref 'uuid pkt))
(shortuuid (substring uuid 0 4))
(type (alist-ref 'pkt-type pkt))
(processed (alist-ref 'processed pkt)))
(print "\"" uuid "\" [label=\"" shortuuid ", ("
type ", "
(if processed "processed" "not processed") ")")
(for-each
(lambda (key-field)
(let ((val (alist-ref key-field pkt)))
(if val
(print key-field "=" val))))
display-fields)
(print "\" ];")))
all-pkts)
;; now for parent-child relationships
(for-each
(lambda (pkt)
(let ((uuid (alist-ref 'uuid pkt))
(parent (alist-ref 'parent pkt)))
(if (not (equal? parent ""))
(print "\"" parent "\" -> \"" uuid"\";"))))
all-pkts)
(print "}")
))
(if dest
(begin
(close-output-port oup)
(system "dot -Tpdf out.dot -o out.pdf")))
))
;;======================================================================
;; Read ref pkts into a vector < laststr hash table >
;;======================================================================
;;======================================================================
;; Read/write packets to files (convience functions)
;;======================================================================
;; write alist to a pkt file
;;
(define (write-alist->pkt targdir dat #!key (pktspec '())(ptype #f))
(let-values (((uuid pkt)(alist->pkt dat pktspec ptype: ptype)))
(with-output-to-file (conc targdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
uuid)) ;; return the uuid
;; read pkt into alist
;;
(define (read-pkt->alist pkt-file #!key (pktspec #f))
(pkt->alist (with-input-from-file
pkt-file
read-string)
pktspec: pktspec))
) ;; module pkts