ADDED pkts/pktrec.scm Index: pkts/pktrec.scm ================================================================== --- /dev/null +++ pkts/pktrec.scm @@ -0,0 +1,196 @@ +(define-syntax define-record-type + (syntax-rules () + ((define-record-type type + (constructor constructor-tag ...) + predicate + (field-tag accessor . more) ...) + (begin + (define type + (make-record-type 'type '(field-tag ...))) + (define constructor + (record-constructor type '(constructor-tag ...))) + (define predicate + (record-predicate type)) + (define-record-field type field-tag accessor . more) + ...)))) + +; An auxilliary macro for define field accessors and modifiers. +; This is needed only because modifiers are optional. + +(define-syntax define-record-field + (syntax-rules () + ((define-record-field type field-tag accessor) + (define accessor (record-accessor type 'field-tag))) + ((define-record-field type field-tag accessor modifier) + (begin + (define accessor (record-accessor type 'field-tag)) + (define modifier (record-modifier type 'field-tag)))))) + +; Record types + +; We define the following procedures: +; +; (make-record-type ) -> +; (record-constructor ) -> +; (record-predicate ) -> +; (record-accessor ) -> +; (record-modifier ) -> +; where +; (

...) -> +; ( ) -> +; ( ) -> +; ( ) -> + +; Record types are implemented using vector-like records. The first +; slot of each record contains the record's type, which is itself a +; record. + +(define (record-type record) + (record-ref record 0)) + +;---------------- +; Record types are themselves records, so we first define the type for +; them. Except for problems with circularities, this could be defined as: +; (define-record-type :record-type +; (make-record-type name field-tags) +; record-type? +; (name record-type-name) +; (field-tags record-type-field-tags)) +; As it is, we need to define everything by hand. + +(define :record-type (make-record 3)) +(record-set! :record-type 0 :record-type) ; Its type is itself. +(record-set! :record-type 1 ':record-type) +(record-set! :record-type 2 '(name field-tags)) + +; Now that :record-type exists we can define a procedure for making more +; record types. + +(define (make-record-type name field-tags) + (let ((new (make-record 3))) + (record-set! new 0 :record-type) + (record-set! new 1 name) + (record-set! new 2 field-tags) + new)) + +; Accessors for record types. + +(define (record-type-name record-type) + (record-ref record-type 1)) + +(define (record-type-field-tags record-type) + (record-ref record-type 2)) + +;---------------- +; A utility for getting the offset of a field within a record. + +(define (field-index type tag) + (let loop ((i 1) (tags (record-type-field-tags type))) + (cond ((null? tags) + (error "record type has no such field" type tag)) + ((eq? tag (car tags)) + i) + (else + (loop (+ i 1) (cdr tags)))))) + +;---------------- +; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the +; procedures used by the macro expansion of DEFINE-RECORD-TYPE. + +(define (record-constructor type tags) + (let ((size (length (record-type-field-tags type))) + (arg-count (length tags)) + (indexes (map (lambda (tag) + (field-index type tag)) + tags))) + (lambda args + (if (= (length args) + arg-count) + (let ((new (make-record (+ size 1)))) + (record-set! new 0 type) + (for-each (lambda (arg i) + (record-set! new i arg)) + args + indexes) + new) + (error "wrong number of arguments to constructor" type args))))) + +(define (record-predicate type) + (lambda (thing) + (and (record? thing) + (eq? (record-type thing) + type)))) + +(define (record-accessor type tag) + (let ((index (field-index type tag))) + (lambda (thing) + (if (and (record? thing) + (eq? (record-type thing) + type)) + (record-ref thing index) + (error "accessor applied to bad value" type tag thing))))) + +(define (record-modifier type tag) + (let ((index (field-index type tag))) + (lambda (thing value) + (if (and (record? thing) + (eq? (record-type thing) + type)) + (record-set! thing index value) + (error "modifier applied to bad value" type tag thing))))) + +Records + +; This implements a record abstraction that is identical to vectors, +; except that they are not vectors (VECTOR? returns false when given a +; record and RECORD? returns false when given a vector). The following +; procedures are provided: +; (record? ) -> +; (make-record ) -> +; (record-ref ) -> +; (record-set! ) -> +; +; These can implemented in R5RS Scheme as vectors with a distinguishing +; value at index zero, providing VECTOR? is redefined to be a procedure +; that returns false if its argument contains the distinguishing record +; value. EVAL is also redefined to use the new value of VECTOR?. + +; Define the marker and redefine VECTOR? and EVAL. + +(define record-marker (list 'record-marker)) + +(define real-vector? vector?) + +(define (vector? x) + (and (real-vector? x) + (or (= 0 (vector-length x)) + (not (eq? (vector-ref x 0) + record-marker))))) + +; This won't work if ENV is the interaction environment and someone has +; redefined LAMBDA there. + +(define eval + (let ((real-eval eval)) + (lambda (exp env) + ((real-eval `(lambda (vector?) ,exp)) + vector?)))) + +; Definitions of the record procedures. + +(define (record? x) + (and (real-vector? x) + (< 0 (vector-length x)) + (eq? (vector-ref x 0) + record-marker))) + +(define (make-record size) + (let ((new (make-vector (+ size 1)))) + (vector-set! new 0 record-marker) + new)) + +(define (record-ref record index) + (vector-ref record (+ index 1))) + +(define (record-set! record index value) + (vector-set! record (+ index 1) value)) ADDED pkts/pkts.meta Index: pkts/pkts.meta ================================================================== --- /dev/null +++ pkts/pkts.meta @@ -0,0 +1,21 @@ +;; -*- scheme -*- +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category db) + +; A list of eggs pkts depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +;; (needs (autoload "3.0")) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "A sha1-chain based datastore built on packets consisting of single line cards modeled loosely on the fossil scm datastore.")) ADDED pkts/pkts.release-info Index: pkts/pkts.release-info ================================================================== --- /dev/null +++ pkts/pkts.release-info @@ -0,0 +1,3 @@ +(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") +(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") +(release "1.0") ADDED pkts/pkts.scm Index: pkts/pkts.scm ================================================================== --- /dev/null +++ pkts/pkts.scm @@ -0,0 +1,1075 @@ +;; 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 . +;; + +;; 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! 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//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 ADDED pkts/pkts.setup Index: pkts/pkts.setup ================================================================== --- /dev/null +++ pkts/pkts.setup @@ -0,0 +1,11 @@ +;; Copyright 2007-2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;;; pkts.setup +(standard-extension 'pkts "1.0") ADDED pkts/tests/run.scm Index: pkts/tests/run.scm ================================================================== --- /dev/null +++ pkts/tests/run.scm @@ -0,0 +1,139 @@ +(use test) + +;; (use (prefix pkts pkts:)) +(use pkts (prefix dbi dbi:)) +;; (use trace)(trace sdat->alist pkt->alist) + +(if (file-exists? "queue.db")(delete-file "queue.db")) + +(test-begin "pkts and pkt archives") + +;;====================================================================== +;; Basic pkt creation, parsing and conversion routines +;;====================================================================== + +(test-begin "basic packets") +(test #f '(A "This is a packet") (let-values (((t v) + (card->type/value "A This is a packet"))) + (list t v))) +(test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e" + (let-values (((uuid res) + (add-z-card '("A A")))) + res)) +(test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0) + string<=?)) +(define pkt-example #f) +(test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" + (let-values (((uuid res) + (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0))) + (set! pkt-example (cons uuid res)) + res)) +(test-end "basic packets") + +;;====================================================================== +;; Sqlite and postgresql based queue of pkts +;;====================================================================== + +(test-begin "pkt queue") +(define db #f) +(test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db"))) + (set! db dbh) + (dbi:db-dbtype dbh))) +(test #f (cdr pkt-example) + (begin + (add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0) + (lookup-by-uuid db (car pkt-example) 0))) +(test #f (cdr pkt-example) + (lookup-by-id db 1)) +(test #f 1 (length (find-pkts db '(basic) '()))) + +(test-end "pkt queue") + + +;;====================================================================== +;; Process groups of pkts +;;====================================================================== + +(test-begin "lists of packets") +(test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) + (dblst->dpkts '(1 2 3 4 5))) +(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) + ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + (get-dpkts db '(basic) 0 #f)) +(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0))) + ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + (get-not-processed-pkts db 0 'basic 1000 0)) +(test-end "lists of packets") + +(test-begin "pkts as alists") +(define pktspec '((posting . ((title . t) ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ... + (url . u) + (blurb . b))) + (comment . ((comment . c) + (score . s))) + (basic . ((b-field . b) + (a-field . a))))) +(define pktlst (find-pkts db '(basic) '())) +(define dpkt (car pktlst)) +(test #f "A" (get-value 'a-field dpkt pktspec)) + +(test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec))) + +(define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b)))) +(define test-pkt '((foo . "fooval")(bar . "barval"))) +(let*-values (((u p) (alist->pkt test-pkt basic-spec ptype: 'basic)) + ((apkt) (pkt->alist p)) + ((bpkt) (pkt->alist p pktspec: basic-spec))) + (test #f "fooval" (alist-ref 'f apkt)) + (test #f "fooval" (alist-ref 'foo bpkt)) + (test #f #f (alist-ref 'f bpkt))) + +(test-end "pkts as alists") + +(test-begin "descendents and ancestors") + +(define (get-uuid pkt)(alist-ref 'uuid pkt)) + +;; add a child to 263e +(let-values (((uuid pkt) + (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" + 'D "1486332719.0"))) + (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0)) + +(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") + (map (lambda (x)(alist-ref 'uuid x)) + (get-descendents + db 0 + "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"))) + +(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8") + (map (lambda (x)(alist-ref 'uuid x)) + (get-ancestors + db 0 + "818fe30988c9673441b8f203972a8bda6af682f8"))) + +(test-end "descendents and ancestors") + +(test-end "pkts and pkt archives") + +(test-begin "pktsdb") + +(define spec '((tests (testname n TEXT) + (testpath p TEXT) + (duration d INTEGER)))) +;; (define pktsdb (make-pktdb)) +;; (pktdb-pktsdb-spec-set! pktsdb spec) + +(define pktsdb #f) + +(test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec))) + (set! pktsdb pdb) + (pktdb-conn pdb)))) +;; (pp (pktdb-pktspec pktsdb)) +(test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1")))) + +(pktsdb-close pktsdb) + +(test-end "pktsdb")