Fun new stuff in site-lisp

site-lisp/50-arc.el

@@ -0,0 +1,139 @@
+;; arc --- Summary
+;;; Commentary:
+;;; A bunch of helpers for Phabricator and arc
+;;; Code:
+
+(require 'dash)
+(require 'dash-functional)
+(require 'ido)
+(require 'image)
+(require 'json)
+(require 'projectile)
+(require 's)
+
+(defconst arc-binary "arc")
+(defconst phabricator-macro-dir "~/public_html")
+(defconst phabricator-macro-list "~tulloch/.arc_macros")
+(defconst phabricator-macro-refresh-script "~tulloch/bin/arc_macros.sh")
+
+(defcustom arc-repo-prefix-list
+  '(("fbcode" . "https://phabricator.fb.com/diffusion/FBCODE/browse/master")
+    ("www" . "https://phabricator.fb.com/diffusion/E/browse/tfb/trunk/www"))
+  "*Mapping from repository name to path in diffusion."
+  :group 'arc)
+
+(defun arc--call-conduit (method req)
+  "Call conduit METHOD with the parameters REQ."
+  (with-temp-buffer
+    (let ((tmp-file (make-temp-file "arc-conduit")))
+      (with-temp-file tmp-file (->> req json-encode insert))
+      (call-process
+       arc-binary tmp-file `(,(current-buffer) nil) nil "call-conduit" method)
+      (->> (buffer-string) json-read-from-string (assoc 'response) cdr))))
+
+;;; ----------------------------------------------------------------------------
+;;; arc macro commands.
+(defun arc--list-macros ()
+  "Load phabricator-macro-list into an ido completion window."
+  (with-temp-buffer
+    (insert-file-contents phabricator-macro-list)
+    (->> (buffer-string) (s-split "\n") (ido-completing-read "Macro: "))))
+
+(defun arc-refresh-macros ()
+  "Refresh phabricator-macro-list from Phabricator with the latest macros."
+  (interactive)
+  (call-process-shell-command
+   phabricator-macro-refresh-script nil nil nil phabricator-macro-list))
+
+(defun arc-insert-macro (name)
+  "Insert image NAME from a list of Phabricator macros."
+  (interactive  `(,(arc--list-macros)))
+  (if (display-graphic-p)
+      (let ((img (->> name arc--get-macro create-image)))
+        (when (image-animated-p img)
+          (image-animate img 0 t))
+        (insert-image img name)
+        (insert "\n\n"))
+    (insert name)))
+
+(defun arc--get-macro (macro-name)
+  "Retrieve the given MACRO-NAME image and save it to *phabricator-macro-dir*."
+  (interactive  `(,(arc--list-macros)))
+  (let* ((macro-file-name (format "%s/%s" phabricator-macro-dir macro-name))
+         (download-uri
+          (lambda (uri)
+            (when (not (file-exists-p macro-file-name))
+              (url-copy-file uri macro-file-name)
+              (shell-command (format "chmod 644 %s" macro-file-name)))
+            macro-file-name))
+         (extract-uri
+          (lambda (output)
+            (->> output (assoc (intern macro-name)) cdr (assoc 'uri) cdr))))
+    (->> (arc--call-conduit "macro.query" `(:names (,macro-name)))
+      (funcall extract-uri) (funcall download-uri) message)))
+
+
+;;; ----------------------------------------------------------------------------
+;;; arc paste commands.
+(defun arc-paste (start end)
+  "Pastes the specified region from START to END (or whole file) with arcanist.
+The resulting URL is stored in the kill
+ring and messaged in the minibuffer."
+  (interactive (if (use-region-p) `(,(region-beginning) ,(region-end))
+                 `(,(point-min) ,(point-max))))
+  (let* ((extract-uri (lambda (output) (->> output (assoc 'uri) cdr))))
+    (->> (arc--call-conduit "paste.create"
+          `(:title ,(when (buffer-file-name) (file-name-nondirectory (buffer-file-name)))
+            :content ,(buffer-substring start end)))
+      (funcall extract-uri) message kill-new)))
+
+
+;;; ----------------------------------------------------------------------------
+;;; arc inlines commands
+(defun arc-inlines ()
+  "Display the inlines for the current branch in a compilation buffer."
+  (interactive)
+  (let ((previous-dir default-directory))
+    (unwind-protect
+        (save-excursion
+          (cd (projectile-project-root))
+          (compile (format "%s inlines" arc-binary)))
+      (cd previous-dir))))
+
+;;; ----------------------------------------------------------------------------
+;;; arc browse commands
+(defun arc--repo-prefix ()
+  "So fbcode2, fbcode_contbuild dirs should still map to fbcode."
+  (->> (-first
+        (lambda (p) (s-starts-with? (car p) (projectile-project-name)))
+        arc-repo-prefix-list)
+    cdr))
+
+(defun arc-browse (start end)
+  "Paste the specified region from START to END (or current line).
+The resulting URL is stored in the kill ring and messaged in the
+minibuffer."
+  (interactive (if (use-region-p)
+                   (mapc 'line-number-at-pos
+                         `(,(region-beginning) ,(region-end)))
+                 `(,(line-number-at-pos) ,(line-number-at-pos))))
+  (when (not (arc--repo-prefix))
+    (error "Not in a known Diffusion repository"))
+  (let* ((url (format "%s/%s$%s-%s"
+                      (arc--repo-prefix)
+                      (file-relative-name
+                       (file-truename buffer-file-name)
+                       (file-truename (projectile-project-root)))
+                      start end)))
+    (->> url message kill-new)))
+
+
+;;; ----------------------------------------------------------------------------
+;;; Shortcuts
+(global-set-key (kbd "C-c C-a i") 'arc-inlines)
+(global-set-key (kbd "C-c C-a b") 'arc-browse)
+(global-set-key (kbd "C-c C-a p") 'arc-paste)
+(global-set-key (kbd "C-c C-a m") 'arc-insert-macro)
+
+(provide '50-arc)
+;;; 50-arc.el ends here

site-lisp/fb-note-publish.el

@@ -0,0 +1,207 @@
+;;; fb-note-publish.el --- Publish a markdown doc as a note  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 John Doty
+
+;; Author: John Doty <doty@fb.com>
+;; Keywords: wp, comm
+
+;;; Commentary:
+
+;; This module provides some functions for publishing a markdown document as
+;; a facebook note.  (It's derived from the disseminate project's publishing
+;; library, and it uses the same interngraph endpoint.)
+
+;;; Code:
+(require 'json)
+(require 'subr-x)
+(require 'url)
+(require 'url-vars)
+
+;; This is the unique app-id for authenticating to interngraph.
+(defconst fbn--app-id "1910641509202249")
+
+;; Go ahead and change this to '$USER.sb' if you want to test against your
+;; devserver.
+(defconst fbn--interngraph-tier "intern")
+
+(defun fbn--keychain (secret secret-group &optional secrets-tool-path)
+  "Extract the SECRET in SECRET-GROUP using the secret_tool at SECRETS-TOOL-PATH."
+  (let ((tool-path (or secrets-tool-path "/usr/local/bin/secrets_tool")))
+    (with-temp-buffer
+      (call-process tool-path nil t nil "get_from_group" secret secret-group)
+      (string-trim (buffer-string)))))
+
+(defun fbn--get-secret-token ()
+  "Extract the secret interngraph token for the disseminate library."
+  (fbn--keychain "INTERNGRAPH_TOKEN" "FBNOTE_PUBLISH"))
+
+(defun fbn--intern-graph-url (path)
+  "Construct the url to PATH on the intern graph."
+  (concat "https://interngraph." fbn--interngraph-tier ".facebook.com/" path))
+
+(defun fbn--get-unixname ()
+  "Get the unixname of the currently executing user."
+  (getenv "USER"))
+
+(defun fbn--invoke-json (path params)
+  "Invoke the intern graph PATH with PARAMS.
+
+Params should be a list of key/value cons cells describing form request data.
+We return the resulting JSON, decoded."
+  (let
+      ((url (fbn--intern-graph-url path))
+       (url-request-method "POST")
+       (url-proxy-services nil)
+       (url-request-data
+        (mapconcat (lambda (pair)
+                     (format "%s=%s"
+                             (car pair)
+                             (url-hexify-string (cdr pair))))
+                   params
+                   "&")))
+    (with-current-buffer (url-retrieve-synchronously url)
+        (goto-char (point-min))
+        (re-search-forward "^$")
+        (json-read)
+        )))
+
+(defun fbn--publish (title note-id note-html)
+  "Publish a note with specified TITLE, NOTE-ID, and NOTE-HTML.
+
+NOTE-ID may be nil to create a new note, or the ID of an existing note.  This
+function returns the ID of the created note."
+  (let ((json-response (fbn--invoke-json
+                        "research/note/"
+                        `((app      . ,fbn--app-id)
+                          (token    . ,(fbn--get-secret-token))
+                          (title    . ,title)
+                          (unixname . ,(fbn--get-unixname))
+                          (note_id  . ,note-id)
+                          (html     . ,note-html)))))
+    (cdr (assoc 'note_id json-response))))
+
+(defun fbn--convert (&optional buffer)
+  "Convert the specified BUFFER to the correct html.
+
+Here we force the use of pandoc since we don't want to have to do
+that silly thing where we split out the YAML frontmatter first,
+and of course we expect that frontmatter to exist so that we can
+stash the note ID there."
+  (let ((in-buffer (or buffer (current-buffer))))
+    (with-temp-buffer
+      (let ((out-buffer (current-buffer)))
+        (with-current-buffer in-buffer
+          (call-process-region (point-min) (point-max)
+                               "pandoc" nil out-buffer nil
+                               "-f" "markdown+yaml_metadata_block"
+                               "-t" "html"
+                               ))
+        (string-trim (buffer-string))))))
+
+(defun fbn--frontmatter-end (&optional buffer)
+  "Go to the end of the frontmatter in BUFFER."
+  (let ((in-buffer (or buffer (current-buffer))))
+    (with-current-buffer in-buffer
+      (let ((frontmatter-start))
+        (goto-char (point-min))
+        (unless (looking-at "^---$")
+          (error "This buffer does not have frontmatter"))
+        (setq frontmatter-start (match-end 0))
+        (goto-char frontmatter-start)
+        (unless (re-search-forward "^---$" (point-max) t)
+          (error "Cannot find the end of the frontmatter"))
+        (goto-char (match-beginning 0))
+        (point)))))
+
+(defun fbn--unquote (value)
+  "Unquote the specified VALUE, if it is quoted."
+  (cond
+   ;; Appears to be quoted.
+   ((string-prefix-p "\"" value)
+    (let* ((value (replace-regexp-in-string "\\\\\\\"" "\"" value))
+           (value (substring value 1 -1)))
+      value))
+   ;; Not quoted.
+   (t value)))
+
+(ert-deftest fbn-test-unquote ()
+  "Test that unquoting front matter values works properly"
+  (should (equal (fbn--unquote "Foo") "Foo"))
+  (should (equal (fbn--unquote "\"Foo\"") "Foo"))
+  (should (equal (fbn--unquote "\" \\\" \"") " \" ")))
+
+(defun fbn--frontmatter-field (field buffer)
+  "Fetch the specified FIELD from the specified BUFFER.
+
+If successful, this function returns the field value (as a
+string), and also leaves the point at the beginning of the note
+entry."
+  (with-current-buffer buffer
+    (goto-char (fbn--frontmatter-end buffer))
+    (if (re-search-backward (concat "^" field ": \\(\.\+\\)") nil t)
+        (fbn--unquote (match-string-no-properties 1)))))
+
+(defun fbn--set-frontmatter-field (field value buffer)
+  "Set the specified FIELD to VALUE in the specified BUFFER.
+
+This replaces the existing field value, if present, otherwise it
+adds it."
+  (let ((in-buffer (or buffer (current-buffer))))
+    (with-current-buffer in-buffer
+      (let ((existing-value))
+        (setq existing-value (fbn--frontmatter-field field buffer))
+        (unless (equal value existing-value)
+          (if existing-value
+              (delete-region (line-beginning-position)
+                             (progn (forward-line 1) (point))))
+          (fbn--frontmatter-end buffer)
+          (insert (concat field ": " value "\n"))
+          )))))
+
+(defun fbn--note-id (&optional buffer)
+  "Get the existing note ID out of BUFFER.
+
+If successful, this function returns the note ID (as a string), and also leaves
+the point at the beginning of the note entry."
+  (fbn--frontmatter-field "fbnote" buffer))
+
+(defun fbn--note-title (&optional buffer)
+  "Get the existing note title out of BUFFER.
+
+If successful, this function returns the note title (as a
+string), and also leaves the point at the beginning of the note
+entry."
+  (fbn--frontmatter-field "title" buffer))
+
+(defun fbn--set-note-id (id &optional buffer)
+  "Set the specified ID into the frontmatter in BUFFER.
+
+This replaces the existing ID, if present, otherwise it adds it."
+  (let ((in-buffer (or buffer (current-buffer))))
+    (with-current-buffer in-buffer
+      (let ((existing-id))
+        (setq existing-id (fbn--note-id buffer))
+        (unless (equal id existing-id)
+          (if existing-id
+              (delete-region (line-beginning-position)
+                             (progn (forward-line 1) (point))))
+          (fbn--frontmatter-end buffer)
+          (insert (concat "fbnote: " id "\n"))
+          )))))
+
+(defun fbnote-publish-markdown (&optional buffer)
+  "Publish the current markdown BUFFER as a facebook note."
+  (interactive)
+  (let ((in-buffer (or buffer (current-buffer))))
+    (save-excursion
+      (with-current-buffer in-buffer
+        (let ((note-id (fbn--note-id in-buffer))
+              (note-title (fbn--note-title in-buffer))
+              (note-html (fbn--convert in-buffer))
+              (new-id))
+          (setq new-id (fbn--publish note-title note-id note-html))
+          (fbn--set-note-id new-id)
+          (message (concat "Published note " new-id)))))))
+
+(provide 'fb-note-publish)
+;;; fb-note-publish.el ends here

site-lisp/ox-quip.el

@@ -0,0 +1,66 @@
+;;; ox-quip.el -- Publish from org-mode to Quip.
+
+;;; Commentary:
+;; Publisher from org-mode to Quip.  (Export as markdown, push as a new
+;; thread or amend to existing quip thread.)
+
+;;; Code:
+(require 'cl-extra)
+(require 'ox-md)
+(require 'quip)
+
+
+(org-export-define-derived-backend 'quip-html 'html
+  :options-alist
+  '((:section-numbers nil "num" nil)
+    (:with-toc nil "toc" nil))
+
+
+(defun org-quip--get-thread-identifier ()
+  "Get the Quip thread identifier from the doc in the current buffer, if any."
+  (org-entry-get nil "quip-id" t))
+
+(defun org-quip--put-thread-identifier (identifier)
+  "Put the Quip thread identifier in IDENTIFIER into the doc."
+  (save-excursion
+    (while (org-up-heading-safe))
+    (org-entry-put nil "quip-id" identifier)))
+
+(defun org-quip--publish-quip (content)
+  "Publish CONTENT as a new Quip document.  Return the ID of the new document."
+  (let ((response (quip-new-document content)))
+    (cdr (assoc 'id (cdr (assoc 'thread response))))))
+
+(defun org-quip-publish-to-quip ()
+  "Publish the current buffer to Quip."
+  (interactive)
+  (let
+      ((quip-id (org-quip--get-thread-identifier))
+       (content (org-export-as 'md)))
+    (if quip-id
+        (org-quip-update-quip quip-id content)
+      (let ((new-quip-id (org-quip--publish-quip content)))
+        (org-quip--put-thread-identifier new-quip-id)))))
+
+;;
+
+;; Org-to-quip filter:
+;;
+;; So, Quip HTML is a very specific, strict subset of HTML. Quip has only a
+;; few different block types, and it can't do certain things (like
+;; multi-paragraph list items.)
+;;
+;; Structure:
+;;  - A list of top-level items:
+;;
+;;    Headlines: <h1> <h2> <h3>
+;;    Block quotes: <blockquote>
+;;    Code block: <pre>
+;;
+;;    <h3>
+;;
+;;
+
+
+(provide 'ox-quip)
+;;; ox-quip.el ends here

site-lisp/quip.el

@@ -0,0 +1,228 @@
+;;; quip.el --- Quip API client for emacs -*- lexical-binding: t; -*-
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'url)
+
+
+;; Customization groups
+(defgroup quip-api nil
+  "Customization options for using the Quip API"
+  :prefix "quip-"
+  :group 'external
+  :tag "Quip")
+
+(defcustom quip-api-key ""
+  "Your API key for Quip.
+
+Get it from https://fb.quip.com/api/personal-token."
+  :type 'string
+  :group 'quip-api)
+
+(defun quip-invoke-json (path method params)
+  "Make a request to the Quip API, and return the parsed JSON from the response.
+
+A Quip API call involves issuing an HTTP request to path PATH,
+with method METHOD, and parameters PARAMS.  This routine knows the
+base URL and adds the necessary headers."
+  (if (not quip-api-key)
+      (error "%s"
+             "The custom variable quip-api-key is undefined. Use custom-set-variable to set it before using quip."))
+  (let
+      ((url (concat "https://platform.quip.com/1/" path))
+       (url-request-method method)
+       (url-request-extra-headers `(("Authorization" . ,(concat "Bearer " quip-api-key))
+                                    ("Content-Type" . "application/x-www-form-urlencoded")))
+       (url-request-data
+        (mapconcat (lambda (pair) (format "%s=%s" (car pair) (url-hexify-string (cdr pair))))
+                   params
+                   "&")))
+    (with-current-buffer (url-retrieve-synchronously url)
+      (goto-char (point-min))
+      (re-search-forward "^$")
+      (json-read))))
+
+(defun quip-new-document (content &optional format)
+  "Create a new Quip document with the provided CONTENT.
+
+This function returns the parsed JSON response.  The optional
+FORMAT argument is one of 'html' or 'markdown', and indicates
+that the content should be interpreted as such."
+  (quip-invoke-json "threads/new-document"
+                    "POST"
+                    `((format  . ,(or format "markdown"))
+                      (content . ,content))))
+
+(defun quip-get-thread (id)
+  "Get the Quip thread with the specified ID.  Return the parsed JSON response."
+  (quip-invoke-json (concat "threads/" id) "GET" nil))
+
+(defconst quip-location-append 0)
+(defconst quip-location-prepend 1)
+(defconst quip-location-after-section 2)
+(defconst quip-location-before-section 3)
+(defconst quip-location-replace-section 4)
+(defconst quip-location-delete-section 5)
+
+(defun quip-thread-append (thread content &optional format)
+                                        ; checkdoc-order: nil
+  "Append CONTENT to the specified THREAD.
+
+The optional FORMAT argument is one of 'html' or 'markdown', and
+indicates how the content is to be interpreted."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((format     .  ,(or format "markdown"))
+                      (content    . ,content)
+                      (location   . ,quip-location-append)
+                      (thread_id  . ,thread))))
+
+(defun quip-thread-prepend (thread content &optional format)
+                                        ; checkdoc-order: nil
+  "Prepend CONTENT to the specified THREAD.
+
+The optional FORMAT argument is one of 'html' or 'markdown', and
+indicates how the content is to be interpreted."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((format     .  ,(or format "markdown"))
+                      (content    . ,content)
+                      (location   . ,quip-location-prepend)
+                      (thread_id  . ,thread))))
+
+(defun quip-thread-append-after (thread section content &optional format)
+                                        ; checkdoc-order: nil
+  "Append CONTENT to specified SECTION in the specified THREAD.
+
+The content is appended after the specified section.
+
+The optional FORMAT argument is one of 'html' or 'markdown', and
+indicates how the content is to be interpreted."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((format     .  ,(or format "markdown"))
+                      (content    . ,content)
+                      (location   . ,quip-location-after-section)
+                      (section_id . ,section)
+                      (thread_id  . ,thread))))
+
+(defun quip-thread-prepend-before (thread section content &optional format)
+                                        ; checkdoc-order: nil
+  "Prepend CONTENT to the specified SECTION of THREAD.
+
+The content is added before the specified section.
+
+The optional FORMAT argument is one of 'html' or 'markdown', and
+indicates how the content is to be interpreted."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((format     .  ,(or format "markdown"))
+                      (content    . ,content)
+                      (location   . ,quip-location-before-section)
+                      (section_id . ,section)
+                      (thread_id  . ,thread))))
+
+(defun quip-thread-replace-section (thread section content &optional format)
+                                        ; checkdoc-order: nil
+  "Replace the specified SECTION of THREAD with the specified CONTENT.
+
+The optional FORMAT argument is one of 'html' or 'markdown', and
+indicates how the content is to be interpreted."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((format     .  ,(or format "markdown"))
+                      (content    . ,content)
+                      (location   . ,quip-location-replace-section)
+                      (section_id . ,section)
+                      (thread_id  . ,thread))))
+
+(defun quip-thread-delete-section (thread section)
+                                        ; checkdoc-order: nil
+  "Delete the specified SECTION of THREAD."
+  (quip-invoke-json "threads/edit-document"
+                    "POST"
+                    `((location   . ,quip-location-delete-section)
+                      (section_id . ,section)
+                      (thread_id  . ,thread))))
+
+
+;;; Content parsing functions
+
+(defun quip-get-item-type (item)
+  "Classify the specified HTML ITEM."
+  (let ((elem-type (car item)))
+    (cond
+     ((eq elem-type 'p)          'paragraph)
+     ((eq elem-type 'h1)         'h1)
+     ((eq elem-type 'h2)         'h2)
+     ((eq elem-type 'h3)         'h3)
+     ((eq elem-type 'blockquote) 'block-quote)
+     ((eq elem-type 'q)          'pull-quote)
+     ((eq elem-type 'pre)        'code-block)
+     ((eq elem-type 'li)         'list-item)
+     ((eq elem-type 'span)       'span)
+     ((eq elem-type 'div)
+      (letrec ((inner           (cl-caddr item))
+               (inner-elem-type (car inner)))
+        (cond
+         ((eq inner-elem-type 'ul) 'ul)
+         ((eq inner-elem-type 'ol) 'ol)
+         (t                        'unrecognized-inner))))
+     (t                          'unrecognized))))
+
+(defun quip-get-item-id (item type)
+  "Extract the ID from the provided ITEM given its TYPE."
+  (let ((attribs (cadr item)))
+    (cond
+     ((or (eq type 'ul)  ;; Nested IDs.
+          (eq type 'ol))
+      (letrec ((inner (cl-caddr item))
+               (inner-attribs (cadr inner)))
+        (assoc-default 'id inner-attribs)))
+     (t (assoc-default 'id attribs)))))
+
+(defun quip-get-item-content (item type)
+  "Extract the content from the provided ITEM given its TYPE."
+  (cond
+   ((or (eq type 'ul)  ;; Nested Content
+        (eq type 'ol))
+    (letrec ((inner (cl-caddr item))
+             (inner-elems (cddr inner)))
+      (mapcar #'quip-get-item-from-element inner-elems)))
+   (t (cl-caddr item))))
+
+(cl-defstruct quip-item type id content)
+
+(defun quip-get-item-from-element (element)
+  "Construct a (type, id, content) list from the given ELEMENT."
+  (letrec
+      ((item-type (quip-get-item-type element))
+       (item-id (quip-get-item-id element item-type))
+       (item-content (quip-get-item-content element item-type)))
+    (make-quip-item
+     :type item-type
+     :id item-id
+     :content item-content)))
+
+
+(defun quip-parse-html-content (html)
+  "Parse the provided HTML into a list of (type, item, content) lists."
+  (with-temp-buffer
+    (insert html)
+    (letrec
+        ((parsed-html (libxml-parse-html-region (point-min) (point-max)))
+         (raw-items (cddr (cl-caddr parsed-html)))
+         (html-items (cl-remove-if #'stringp raw-items)))
+
+      (mapcar #'quip-get-item-from-element html-items)
+    )))
+
+;; (prin1
+;;  (quip-parse-html-content
+;;   (assoc-default 'html (quip-get-thread "idflAWG6R6Uu"))))
+
+(provide 'quip)
+;;; quip.el ends here