Index: datashare-testing/.spublish.config ================================================================== --- datashare-testing/.spublish.config +++ datashare-testing/.spublish.config @@ -1,6 +1,8 @@ [settings] target-dir #{scheme (create-directory "/tmp/#{getenv USER}/target" #t)} allowed-users matt mrwellan +allowed-chars [0-9a-zA-Z\-\.]+ +admins matt [database] location /tmp/#{getenv USER} Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -20,18 +20,13 @@ ;; (use json) ;; (use csv) (use srfi-18) (use format) -(require-library iup) -(import (prefix iup iup:)) (require-library ini-file) (import (prefix ini-file ini:)) -(use canvas-draw) -(import canvas-draw-iup) - (use sql-de-lite srfi-1 posix regex regex-case srfi-69) ;; (import (prefix sqlite3 sqlite3:)) ;; (declare (uses configf)) ;; (declare (uses tree)) @@ -52,14 +47,12 @@ ;; (define *spublish:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define spublish:help (conc "Usage: spublish [action [params ...]] -Note: run spublish without parameters to start the gui. - ls : list contents of target area - cp : copy file to target area + cp|publish : copy file to target area rm : remove file from target area log : options: @@ -175,11 +168,11 @@ (print "ERROR: target file " targ-path " not found, nothing to remove.") (exit 1))) (spublish:db-do configdat (lambda (db) - (spublish:register-action db "rm" submitter "" comment))) + (spublish:register-action db "rm" submitter targ-file comment))) (let* ((th1 (make-thread (lambda () (delete-file targ-path) (print " ... file " targ-path " removed")) "rm thread")) @@ -202,94 +195,10 @@ (create-directory trashdir #t) (if (directory? path) (system (conc "mv " path " " trashfile)) (file-move path trash-file)))) -;;====================================================================== -;; GUI -;;====================================================================== - -;; The main menu -(define (spublish:main-menu) - (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) - (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options - (iup:menu-item "Open" action: (lambda (obj) - (iup:show (iup:file-dialog)) - (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) - (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) - -(define (spublish:publish-view configdat) - ;; (pp (hash-table->alist configdat)) - (let* ((areas (configf:get-section configdat "areas")) - (label-size "70x") - (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) - (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) - (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) - (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) - (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) - ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) - ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) - ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) - (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) - (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) - (source-tb (iup:textbox #:expand "HORIZONTAL" - #:value (or (configf:lookup configdat "settings" "basepath") - ""))) - (publish (lambda (publish-type) - (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) - (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) - (area-path (cadr area-dat)) - (area-name (car area-dat)) - (version (iup:attribute version-tb "VALUE")) - (comment (iup:attribute comment-tb "VALUE")) - (spath (iup:attribute source-tb "VALUE")) - (submitter (current-user-name)) - (quality 2)) - (spublish:publish configdat publish-type area-name version comment spath submitter quality)))) - (copy (iup:button "Copy and Publish" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (publish 'copy)))) - (link (iup:button "Link and Publish" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (publish 'link)))) - (browse-btn (iup:button "Browse" - #:size "40x" - #:action (lambda (obj) - (let* ((fd (iup:file-dialog #:dialogtype "DIR")) - (top (iup:show fd #:modal? "YES"))) - (iup:attribute-set! source-tb "VALUE" - (iup:attribute fd "VALUE")) - (iup:destroy! fd)))))) - (print "areas") - ;; (pp areas) - (fold (lambda (areadat num) - ;; (print "Adding num=" num ", areadat=" areadat) - (iup:attribute-set! areas-sel (conc num) (car areadat)) - (+ 1 num)) - 1 areas) - (iup:vbox - (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter - areas-sel) - (iup:hbox (iup:label "Version:" #:size label-size) version-tb) - ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) - ;; (iup:label "Iteration:") iteration) - (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) - (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) - (iup:hbox copy link)))) (define (spublish:lst->path pathlst) (conc "/" (string-intersperse (map conc pathlst) "/"))) (define (spublish:path->lst path) @@ -298,161 +207,10 @@ (define (spublish:pathdat-apply-heuristics configdat path) (cond ((file-exists? path) "found") (else (conc path " not installed")))) -(define (spublish:get-view configdat) - (iup:vbox - (iup:hbox - (let* ((label-size "60x") - ;; filter elements - (area-filter "%") - (version-filter "%") - (iter-filter ">= 0") - ;; reverse lookup from path to data for src and installed - (srcdat (make-hash-table)) ;; reverse lookup - (installed-dat (make-hash-table)) - ;; config values - (basepath (configf:lookup configdat "settings" "basepath")) - ;; gui elements - (submitter (iup:label "" #:expand "HORIZONTAL")) - (date-submitted (iup:label "" #:expand "HORIZONTAL")) - (comment (iup:label "" #:expand "HORIZONTAL")) - (copy-link (iup:label "" #:expand "HORIZONTAL")) - (quality (iup:label "" #:expand "HORIZONTAL")) - (installed-status (iup:label "" #:expand "HORIZONTAL")) - ;; misc - (curr-record #f) - ;; (source-data (iup:label "" #:expand "HORIZONTAL")) - (tb (iup:treebox - #:value 0 - #:name "Packages" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((path (spublish:lst->path (cdr (tree:node->path obj id)))) - (record (hash-table-ref/default srcdat path #f))) - (if record - (begin - (set! curr-record record) - (iup:attribute-set! submitter "TITLE" (spublish:pkg-get-submitter record)) - (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (spublish:pkg-get-datetime record)))) - (iup:attribute-set! comment "TITLE" (spublish:pkg-get-comment record)) - (iup:attribute-set! quality "TITLE" (spublish:pkg-get-quality record)) - (iup:attribute-set! copy-link "TITLE" (spublish:pkg-get-store_type record)) - )) - ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) - )))) - (tb2 (iup:treebox - #:value 0 - #:name "Installed" - #:expand "YES" - #:addexpanded "NO" - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((path (spublish:lst->path (cdr (tree:node->path obj id)))) - (status (hash-table-ref/default installed-dat path #f))) - (iup:attribute-set! installed-status "TITLE" (if status status "")) - )))) - (refresh (lambda (obj) - (let* ((db (spublish:open-db configdat)) - (areas (or (configf:get-section configdat "areas") '()))) - ;; - ;; first update the Sources - ;; - (for-each - (lambda (pkgitem) - (let* ((pkg-path (list (spublish:pkg-get-area pkgitem) - (spublish:pkg-get-version_name pkgitem) - (spublish:pkg-get-iteration pkgitem))) - (pkg-id (spublish:pkg-get-id pkgitem)) - (path (spublish:lst->path pkg-path))) - ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) - (if (not (hash-table-ref/default srcdat path #f)) - (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) - ;; (print "path=" path " pkgitem=" pkgitem) - (hash-table-set! srcdat path pkgitem))) - (spublish:get-pkgs db area-filter version-filter iter-filter)) - ;; - ;; then update the installed - ;; - (for-each - (lambda (area) - (let* ((path (conc "/" (cadr area))) - (fullpath (conc basepath path))) - (if (not (hash-table-ref/default installed-dat path #f)) - (tree:add-node tb2 "Installed" (spublish:path->lst path))) - (hash-table-set! installed-dat path (spublish:pathdat-apply-heuristics configdat fullpath)))) - areas) - (sqlite3:finalize! db)))) - (apply (iup:button "Apply" - #:action - (lambda (obj) - (if curr-record - (let* ((area (spublish:pkg-get-area curr-record)) - (stored-path (spublish:pkg-get-stored_path curr-record)) - (source-type (spublish:pkg-get-store_type curr-record)) - (source-path (case source-type ;; (equal? source-type "link")) - ((link)(spublish:pkg-get-source-path curr-record)) - ((copy)stored-path) - (else #f))) - (dest-stub (configf:lookup configdat "areas" area)) - (target-path (conc basepath "/" dest-stub))) - (spublish:build-dir-make-link stored-path target-path) - (print "Creating link from " stored-path " to " target-path))))))) - (iup:vbox - (iup:hbox tb tb2) - (iup:frame - #:title "Source Info" - (iup:vbox - (iup:hbox (iup:button "Refresh" #:action refresh) apply) - (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) - submitter - (iup:label "Submitted on: ") ;; #:size label-size) - date-submitted) - (iup:hbox (iup:label "Data stored: ") - copy-link - (iup:label "Quality: ") - quality) - (iup:hbox (iup:label "Comment: ") - comment))) - (iup:frame - #:title "Installed Info" - (iup:vbox - (iup:hbox (iup:label "Installed status/path: ") installed-status))) - ))))) - -(define (spublish:manage-view configdat) - (iup:vbox - (iup:hbox - (iup:button "Pushme" - #:expand "YES" - )))) - -(define (spublish:gui configdat) - (iup:show - (iup:dialog - #:title (conc "Spublish dashboard " (current-user-name) ":" (current-directory)) - #:menu (spublish:main-menu) - (let* ((tabs (iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (set! *spublish:current-tab-number* curr)) - (spublish:publish-view configdat) - (spublish:get-view configdat) - (spublish:manage-view configdat) - ))) - ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) - (iup:attribute-set! tabs "TABTITLE0" "Publish") - (iup:attribute-set! tabs "TABTITLE1" "Get") - (iup:attribute-set! tabs "TABTITLE2" "Manage") - ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - tabs))) - (iup:main-loop)) - ;;====================================================================== ;; MISC ;;====================================================================== (define (spublish:do-as-calling-user proc) @@ -607,14 +365,25 @@ (case (string->symbol (car rema)) ((help -h -help --h --help) (print spublish:help)) ((list-vars) ;; print out the ini file (map print (spublish:get-areas configdat))) + ((ls) + (let ((target-dir (configf:lookup configdat "settings" "target-dir"))) + (print "Files in " target-dir) + (system (conc "ls " target-dir)))) + ((log) + (spublish:db-do configdat (lambda (db) + (print "Listing actions") + (query (for-each-row + (lambda (row) + (apply print (intersperse row " | ")))) + (sql db "SELECT * FROM actions"))))) (else (print "ERROR: Unrecognised command. Try \"spublish help\"")))) ;; multi-word commands - ((null? rema)(spublish:gui configdat)) + ((null? rema)(print spublish:help)) ((>= (length rema) 2) (apply spublish:process-action configdat (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command. Try \"spublish help\""))))) (main)