web.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  (ignore-errors
    (load "roswell.github.utils.asd"))
  (ignore-errors
    (ql:quickload '(:roswell.github.utils) :silent t))
  #+quicklisp(ql:quickload '(:dexador :jonathan) :silent t))

(defpackage :ros.script.web.3788143716
  (:use :cl))
(in-package :ros.script.web.3788143716)

(defvar *version* nil)

(defun env (name)
  (let ((val (ros:getenv name)))
    (unless (zerop (length val))
      val)))

(defun version-target (&key (target :compiler))
  (values (or *version*
              (env "TRAVIS_TAG")
              (env "APPVEYOR_REPO_TAG_NAME")
              (let ((version (env "VERSION")) )
                (if (equal "99.99.99" version)
                    nil
                    version))
              (let ((branch (env "TRAVIS_BRANCH")))
                (unless (equal "master" branch)
                  branch))
              nil)
          (let ((m (or (env "ARCH")
                       (roswell.util:uname-m))))
            (cond ((and (equal m "armhf")
                        (eql target :compiler))
                   "arm")
                  ((and (not (eql target :compiler))
                        (equal m "arm"))
                   "armhf")
                  (t m)))
          (or (env "SUFFIX")
              "")
          (or (env "UNAME")
              (roswell.util:uname))))

(defun account ()
  (values
   (or (env "GH_USER") (symbol-value (uiop:safe-read-from-string "roswell.github.utils:*user*")))
   (or (env "GH_REPO") (symbol-value(uiop:safe-read-from-string "roswell.github.utils:*repo*")))))

(defun tsv-filename ()
  (or (env "TSV_FILE")
      "sbcl-bin_uri.tsv"))

(export
 (defun upload (files &key (interactive t))
   (multiple-value-bind (version target suffix uname)
       (version-target)
     (multiple-value-bind (user repo)
         (account)
       (format t "version:~A target:~A suffix:~A uname:~A user:~A repo:~A ~%" version target suffix uname
               user repo)
       (when (or (not interactive)
                 (yes-or-no-p "upload files:~%~{~S~%~}~%~%OK?" files))
         (dolist (file files)
           (loop repeat 10
                 until (ignore-errors
                         (uiop:symbol-call :roswell.github.utils :github
                                           file version user repo t))
                 do (sleep 3))))))))

(export
 (defun upload-archive (args)
   (declare (ignore args))
   (multiple-value-bind (version target suffix uname)
       (version-target :target :archive)
     (let* ((release (and version (< (length version) 20)))
            (path (format nil "sbcl-~A-~A-~A~A-binary"
                          version
                          target
                          uname
                          suffix)))
       (when release
         (ql:quickload :sb-md5)
         (loop with file-not-found = nil
               for file in (or (when (env "FILE")
                                 (list (env "FILE")))
                               `(,(format nil "~A.tar.bz2" path)
                                 ,@(when (equal uname "windows")
                                     (list (format nil "~A.msi" path)))))
               do (format t "upload file:~A " file)
                  (cond ((probe-file file)
                         (format t "~(~{~2,'0X~}~)"
                                 (map 'list #'identity (funcall (read-from-string "sb-md5:md5sum-file") file)))
                         (multiple-value-bind (user repo)
                             (account)
                           (uiop:symbol-call :roswell.github.utils :github
                                             file version user repo nil))
                         (format t "done~%"))
                        (t
                         (format t "not found~%")
                         (setf file-not-found t)))
               finally (when file-not-found
                         (uiop:quit 1))))))))

(defun releases ()
  (multiple-value-bind (user repo)
      (account)
    (jojo:parse (dex:get (format nil "https://api.github.com/repos/~A/~A/releases" user repo)))))

(defun latest-relase ()
  (multiple-value-bind (user repo)
      (account)
    (jojo:parse (dex:get (format nil "https://api.github.com/repos/~A/~A/releases/latest" user repo)))))

(defun release-uris (&optional (release (latest-relase)))
  (loop for asset in (getf release :|assets|)
        ;;when (find (getf asset :|content_type|) '("application/x-bzip2" "application/x-msi") :test 'equal)
        collect (getf asset :|browser_download_url|)))

(defun release-tag_name (&optional (release (latest-relase)))
  (getf release :|tag_name|))

(defun tsv-uri (&optional (release (latest-relase)))
  (multiple-value-bind (user repo)
      (account)
    (format nil "https://github.com/~A/~A/releases/download/~A/~A"
            user repo
            (release-tag_name release)
            (tsv-filename))))

(defun parse-tsv (string)
  (mapcar (lambda (x) (uiop:split-string x :separator '(#\tab)))
          (uiop:split-string string :separator '(#\lf))))

(defun save-tsv (file tsv)
  (with-open-file (out file :direction :output :if-exists :supersede)
    (format out "~{~{~A~^	~}~^~%~}" tsv)))

(defun modify-tsv (tsv release)
  (loop with tag-name = (release-tag_name release)
        with comp = (lambda (x) (ignore-errors (aref (nth-value 1 (ppcre:scan-to-strings "[a-z]*-[^-]*-([^/]*)$" x)) 0)))
        for uri in (remove-if-not (lambda (x) (ppcre:scan "binary" x))
                                  (release-uris release))
        for found = (find uri tsv :test #'(lambda (x y)
                                            (equal (funcall comp x)
                                                   (funcall comp (fifth y)))))
        do (if found
               (setf (fifth found) uri
                     (third found) tag-name)
               (format t "unlisted uri: ~S~%" uri)))
  tsv)

(defun tsv-get (&optional (version "files"))
  (multiple-value-bind (user repo)
      (account)
    (dex:get (format nil "https://github.com/~A/~A/releases/download/~A/~A"
                     user repo version (tsv-filename))
             :force-string t)))

(export
 (defun upload-tsv (args)
   (declare (ignore args))
   (multiple-value-bind (version)
       (version-target :target :archive)
     (let ((path (tsv-filename)))
       (progn
         (ql:quickload :sb-md5)
         (cond ((probe-file path)
                (let* ((version (or version "files"))
                       (new (format nil "~(~{~2,'0X~}~)"
                                    (map 'list #'identity (funcall (read-from-string "sb-md5:md5sum-file") path))))
                       (old (ignore-errors
                              (format nil "~(~{~2,'0X~}~)"
                                      (map 'list #'identity (funcall (read-from-string "sb-md5:md5sum-string")
                                                                     (tsv-get version)))))))
                  (format t "new:~A~%old:~A~%" new old)
                  (multiple-value-bind (user repo)
                      (account)
                    (unless (equal new old)
                      (uiop:symbol-call :roswell.github.utils :github
                                        path version user repo t)))))
               (t
                (format t "file not found:~A~%" path)
                (uiop:quit 1))))))))

(defun updated-tsv ()
  (let* ((releases (releases))
         (tsv (or (ignore-errors (parse-tsv (dex:get (tsv-uri (second releases)) :force-string t)))
                  ;; download second new release's tsv or upload current tsv.
                  (let ((*version* (release-tag_name (second releases)))
                        (result (parse-tsv (tsv-get "files"))))
                    (save-tsv (tsv-filename) result)
                    (upload-tsv nil)
                    result))))
    (mapc (lambda (x) (modify-tsv tsv x)) (reverse releases))
    (setf (rest tsv) (sort (rest tsv) (complement #'uiop/version:version<) :key #'third))
    tsv))

(export
 (defun tsv (args)
   (declare (ignore args))
   (save-tsv (tsv-filename) (updated-tsv))))

(export
 (defun get-tsv (args)
   (declare (ignore args))
   (multiple-value-bind (version)
       (version-target :target :archive)
     (with-open-file (o (tsv-filename) :direction :output :if-exists :supersede)
       (format o "~A" (tsv-get (or version "files")))))))

(export
 (defun upload-hash (args)
   (declare (ignore args))
   (multiple-value-bind (version)
       (version-target :target :archive)
     (let ((path "hash"))
       (progn
         (cond ((probe-file path)
                (multiple-value-bind (user repo)
                    (account)
                  (uiop:symbol-call :roswell.github.utils
                                    :ensure-release-exists
                                    version
                                    :owner user
                                    :repo repo)
                  (uiop:symbol-call :roswell.github.utils :github
                                    path version user repo nil)))
               (t
                (format t "file not found:~A~%" path)
                (uiop:quit 1))))))))

(export
 (defun latests (args)
   (declare (ignore args))
   (format t "~{~A~%~}" (release-uris))))

(export
 (defun version (args)
   (declare (ignore args))
   (format t "~A~%" (release-tag_name))))

(export
 (defun os (args)
   (declare (ignore args))
   (format t "~A~%" (roswell.util:uname))))

(defvar *sh* nil)
(defvar *var* nil)

(defun optp (arg)
  (when (and arg
             (loop for i across arg
                   repeat 2
                   always (eql i #\-)))
    (subseq arg 2)))

(let (cache)
  (defun table-uri-tsv (&optional file)
    (or cache
        (setf cache
              (cdr (loop for line in
                            (uiop:read-file-lines file)
                         collect (uiop:split-string line :separator '(#\tab))))))))

(defun table-sort-order ()
  (let ((osh (make-hash-table  :test 'equal))
        (cpuh (make-hash-table :test 'equal)))
    (loop with newversion
          for l in (table-uri-tsv)
          for variant = (unless (zerop (length (fourth l)))
                          (fourth l))
          for version = (mapcar #'parse-integer (uiop:split-string  (third l) :separator '(#\.)))
          for cpu = (second l)
          for os = (first l)
          unless newversion
          do (setf newversion version)
          unless variant
          do (let ((diff (cond ((equalp version newversion) 100) ;;exact the newest
                               ((and (= (first version) (first newversion));; old release in this year.
                                     (= (second version) (second newversion)))
                                30)
                               ((and (= (first version) (first newversion)) ;; not ancient.
                                     )
                                10)
                               (t 1)))) ;;ancient
               (incf (gethash os osh 0) diff)
               (incf (gethash cpu cpuh 0) diff)))
    (values
     (let (l)
       (maphash (lambda (x y) (push (list x y) l)) osh)
       (mapcar #'first (sort l #'> :key 'second)))
     (let (l)
       (maphash (lambda (x y) (push (list x y) l)) cpuh)
       (mapcar #'first (sort l #'> :key 'second))))))

(defun table-tree ()
  (multiple-value-bind (os- arch-)
      (table-sort-order)
    (loop with table = (table-uri-tsv)
          for os in os-
          collect
             (loop for arch in arch-
                   collect
                      (flet ((remove-version (x)
                               (remove-if (lambda (x) (or (digit-char-p x) (eql x #\.))) x))
                             (keep-version (x)
                               (remove-if-not (lambda (x) (or (digit-char-p x) (eql x #\.))) x)))
                        (sort
                         (remove-if-not (lambda (x)
                                          (and (equal (first x) os)
                                               (equal (second x) arch)))
                                        table)
                         (lambda (x y)
                           (cond
                             ;; sort by version the newer come first
                             ((string/= (third x)
                                        (third y))
                              (uiop:version<
                               (third y) (third x)))
                             ;; sort by variant name
                             ((string/= (remove-version (fourth x))
                                        (remove-version (fourth y)))
                              (string< (remove-version (fourth x))
                                       (remove-version (fourth y))))
                             ;; sort by variant version
                             ((string/= (keep-version (fourth x))
                                        (keep-version (fourth y)))
                              (uiop:version<
                               (keep-version (fourth y))
                               (keep-version (fourth x))))))))))))

(defun table-md (stream)
  (let ((o stream))
    (multiple-value-bind (os- arch-)
        (table-sort-order)
      (format o "~{|~A~}|~%" (cons "" arch-))
      (format o "~{|~* --- ~}|~%" (cons "" arch-))
      (loop for os in os-
            for table in (table-tree)
            do (format o "|~A" os)
               (loop for table2 in table
                     do (format o "|")
                        (loop for table3 in table2
                              for version = (uiop:split-string (third table3) :separator  '(#\.))
                              for version1 = (first version)
                              for obsolate = (equal version1 "1")
                              do (format o "~A[~A~A](~A)~A<br />"
                                         (if obsolate "~~" "")
                                         (third table3)
                                         (cond
                                           ((zerop (length (fourth table3)))
                                            (if (equal "msi" (pathname-type (fifth table3)))
                                                "(msi)"
                                                ""))
                                           (t (format nil "(~A~A)"
                                                      (fourth table3)
                                                      (if (equal "msi" (pathname-type (fifth table3)))
                                                          " msi"
                                                          ""))))
                                         (fifth table3)
                                         (if obsolate "~~" ""))))
               (format o "|~%")))))

(export
 (defun table (&rest argv)
   (declare (ignore argv))
   (table-uri-tsv (or (env "TSV_FILE") "sbcl-bin_uri.tsv"))
   (with-open-file (o "table.md"
                      :direction :output
                      :if-exists :supersede)
     (table-md o))))

(defun main (&rest argv)
  (loop
    for opt = (optp (first argv))
    while opt
    when opt
    do (setf *var* (acons opt (second argv) *var*)
             argv (cdr argv))
    do (setf argv (cdr argv))
    finally (let ((symbol (read-from-string (if argv
                                                (first argv)
                                                "default"))))
              (when (eql (nth-value 1 (find-symbol (string symbol))) :external)
                (funcall symbol (rest argv)))))
  (format t "~{~A~%~}" (reverse *sh*)))
;;; vim: set ft=lisp lisp: