;;
;;
;; ◆ deli2howm ◆
;;  -- deli.icio.us のデータを howm にインポートするツール
;;
;;
;; ++++++++++++++++++++++++++++
;; ●注意事項
;;      無保証です。
;;      既に同じ名前のファイルが存在した場合は追記されます
;;      （* 特定の日付のデータを２回以上取り込んだ場合も同じデータが追記されます）
;;
;; ++++++++++++++++++++++++++++
;; ●必要なもの
;;      xml-parser-modoki
;;      howm
;;
;; ++++++++++++++++++++++++++++
;; ●インストール方法
;;      deli2howm.l を ~/site-lisp/ において、
;;      以下を .xyzzy か siteinit.l に記述し、xyzzy を再起動する
;;      -------------------
;;      ;ユーザ名とパスワード。必須。
;;      (setf *deli2howm-user* "username")
;;      (setf *deli2howm-pass* "password")
;;      ;howm ファイルのファイル名形式：1日1ファイル方式にすると現存のファイルが上書きされます
;;      (setf *deli2howm-filename* "%Y/%m/%Y_%m_%d_%H%M%S.howm")
;;
;;      (autoload 'deli-to-howm-all      "deli2howm" t)
;;      (autoload 'deli-to-howm-a-day    "deli2howm" t)
;;      (autoload 'deli-to-howm-from-to  "deli2howm" t)
;;
;;      ;; 以下は設定しなくてもOK
;;      ;; ;howmディレクトリ
;;      ;; (setf *deli2howm-dir* elisp-lib::howm-directory)
;;      ;; ;howmファイルのタイトル
;;      ;; (setf *deli2howm-title* "del.icio.us for %Y-%m-%d")
;;      ;; ;howmファイルのファイル名形式
;;      ;; (setf *deli2howm-filename* elisp-lib::howm-file-name-format)
;;      ;; (setf *deli2howm-filename* elisp-lib::howm-file-name-format)
;;      ;; ;howmファイルの更新日付をブックマークの日付にする
;;      ;; (setf *deli-use-bookmarked-date* t)
;;      ---------------------
;;
;; ++++++++++++++++++++++++++++
;; ●使い方
;;      M-x deli-to-howm-all     （現在存在するすべてのブックマークを取り込みます）
;;      M-x deli-to-howm-from-to （任意の期間のブックマークを取り込みます）
;;      M-x deli-to-howm-a-day   （任意の日付のブックマークを取り込みます）
;;
;;      (* "M-x" = Esc を押してから x を押す、または Alt と x を同時に押す）
;;      from-to で実行する場合は「前の日まで」のデータで取り込むことをお勧めします。
;;      （当日はさらにデータが追加される可能性があるので）
;;
;; ++++++++++++++++++++++++++++
;; ●ライセンス
;;      このソースコードには NYSL Version 0.9982 が適用されます。
;;      条文はファイルの末尾に付与されています。

;; 2006/02/07   ver.0.9     ヒストリ変数を追加。公開
;; 2005/10/25   ver.0.7


;-------------
; Init
(provide "deli2howm")
(in-package "user")
(require "xml-parser-modoki")

;--------
; Setting

(defvar *deli2howm-user* "" "del.icio.us UserName")
(defvar *deli2howm-pass* "" "del.icio.us PassWord")

(defvar *deli2howm-title* "del.icio.us for %Y-%m-%d")
(defvar *deli2howm-dir* elisp-lib::howm-directory)
(defvar *deli2howm-filename* elisp-lib::howm-file-name-format)

(defvar *deli-use-bookmarked-date* t
  "howmファイルの更新日付をブックマークの日付にする")

;--------

(defvar *delicious-api* "http://del.icio.us/api/posts/" "del.icio.us API URI")
(defvar *deli2howm-last-run-to* nil)
(register-history-variable *deli2howm-last-run-to*)

;------------
; For Debug
(setf *deli2howm-debug-log* nil)
(setf *deli2howm-debug* nil)

;-------------
; Functions
(defun deli-format-bookmark (out href description extended tag time hash others)
  "個々のブックマークをFormatting"
  (format out "~%")
  (format out "~{[~A] ~}~%" (split-string tag " "))
  (format out "+ ~A~%" description)
  (format out "~A~%" href)
  (when extended (format out "~A~%" extended)))

(defun deli-to-howm-all ()
  "すべてのブックマークをhowmにインポート"
  (interactive)
  (let ((posts (deli-bookmark-split-by-date
                  (deli-parse-posts (get-xml-object (or (get-bookmark-xml-all)
                                                        (progn (msgbox "接続に失敗しました") nil)))))))
    (if (not posts) (message "インポートされたデータはありません")
      (let ((cnt 0)) (dolist (post posts t)
    (message (format nil "Make Howm Files ~A / ~A..." (incf cnt) (length posts)))
    (multiple-value-bind (data timestamp)
      (deli-parse-post post)
      (deli-make-howm-file data timestamp)))
        (setf *deli2howm-last-run-to* (format-date-string "%Y-%m-%d" (- (get-universal-time) (* 60 60 24))))
        (message "すべてのブックマークのインポートが完了しました。")))))

(defun deli-to-howm-a-day (date)
  "任意の日付のブックマークをhowmにインポート"
  (interactive "s日付を入力してください（YYYY-MM-DD）："
    :default0 (format-date-string "%Y-%m-%d" (- (get-universal-time) (* 60 60 24))))
  (when (string-match "20[0-9][0-9]+-[01][0-9]-[0-3][0-9]" date)
    (let (data timestamp)
      (multiple-value-setq (data timestamp)
        (deli-parse-post
           (deli-parse-posts
              (get-xml-object (or (get-bookmark-xml-a-day date)
                                  (progn (msgbox "接続に失敗しました") nil))))))
      (if (and data timestamp) (progn (deli-make-howm-file data timestamp)
                 (message (format nil "［~A］のブックマークのインポートが完了しました。" date)))
        (message "インポートされたデータはありません")
        ))))

(defun deli-to-howm-from-to (from to)
  "任意の期間のブックマークをhowmにインポート"
  (interactive "s開始の日付を入力してください（YYYY-MM-DD）：\ns終了日付を入力してください（YYYY-MM-DD）："
    :default0 (or *deli2howm-last-run-to*
                  (format-date-string "%Y-%m-%d" (- (get-universal-time) (* 60 60 24))))
    :default1 (format-date-string "%Y-%m-%d" (- (get-universal-time) (* 60 60 24))))
  (let ((st (w3cdtf-to-universal-time from))
        (ed (w3cdtf-to-universal-time to)))
    (when
        (and (integerp st) (integerp ed))
    (let ((dates
            (deli-filter-dates
               st ed
               (deli-parse-date
                  (deli-parse-dates
                     (get-xml-object (or (get-dates-xml)
                                         (progn (msgbox "接続に失敗しました") nil)))))))
          date len (cnt 0))
      (if dates (progn
        (dolist (date dates)
          (deli-to-howm-a-day date))
                  (setf *deli2howm-last-run-to* to)
                  (message (format nil "［~A〜~A］のブックマークのインポートが完了しました。" from to)))
        (message "インポートされたデータはありません")
        )))))

(defun deli-make-howm-file (data timestamp)
  "データの中身とタイムスタンプを使ってhowmのファイルを作成"
  (when (and data timestamp)
  (let ((path
           (format-date-string
              (concat (append-trail-slash (namestring *deli2howm-dir*))
                      *deli2howm-filename*) timestamp))
        st)
    (unless (file-exist-p (directory-namestring path))
      (create-directory (directory-namestring path)))
    (with-open-file (st path :direction :output :if-does-not-exist :create :if-exists :append)
      (format-date st (concat "= " *deli2howm-title*) timestamp)
      (format st "~%")
      (format-date st "[%Y-%m-%d %H:%M]" timestamp)
      (format st "~%")
      (princ data st))
    (when *deli-use-bookmarked-date* (set-file-write-time path timestamp)))))

(defun deli-bookmark-split-by-date (posts)
  "異なる日付のブックマークが混ざったデータを日付ごとのリストに編成する"
  (let ((pt1 posts) pt2 new (num 0))
    (long-operation
      (while pt1
        (message "Split Bookmarks ~A / ~A ..." num (length posts))
        (or
           (while pt2
             (when (string= (substring (get-option-by-name (caar pt2) "time") 0 10)
                            (substring (get-option-by-name (car pt1) "time") 0 10))
               (push (car pt1) (car pt2))
               (return t))
             (setf pt2 (cdr pt2)) nil)
           (progn
             (push (list (car pt1)) new)
             (setf pt2 new)
             (setf neko new)
             ))
        (setf pt1 (cdr pt1))
        (incf num)
        )) new))

(defun deli-filter-dates (from to lst)
  "日付のリストから任意の期間だけ抽出"
  (let (newlst date dt)
    (dolist (date lst newlst)
      (when (string-match "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)" date)
        (setf dt (encode-universal-time 0 0 0
                                        (parse-integer (match-string 3))
                                        (parse-integer (match-string 2))
                                        (parse-integer (match-string 1))))
        (when (and (or (not from) (>= dt from))
                   (or (not to) (<= dt to)))
          (setf newlst (cons date newlst)))))
    ))

(defun deli-parse-date (xml)
  "日付の子ノードらを解析して、Bookmarkが存在する日付をリストで返却"
  (let (pt lst)
    (while xml
      (or xml (return))
      (or (listp xml) (return))
      (setf pt (car xml))
      (setf xml (cdr xml))
      (setf lst (cons (get-option-by-name pt "date") lst))
      ) lst))

(defun deli-parse-dates (xml)
  "日付についてのデータを解析して子ノードらを返却"
  (let (pt)
    (setf pt (car xml))
    (setf xml (cdr xml))
    (when (equal (ed::xmlpm-tag-name pt) "dates")
      (ed::xmlpm-tag-contents pt)
      )))

(defun deli-parse-post (xml)
  "Bookmarkの子ノードらを解析して、TXTデータと適当なタイムスタンプを返却"
  (let (pt out datetime)
    (values
       (with-output-to-string (out)
         (while xml
           (or xml (return))
           (or (listp xml) (return))
           (setf pt (car xml))
           (setf xml (cdr xml))
           (let* ((name (ed::xmlpm-tag-name pt))
                  (href (get-option-by-name pt "href"))
                  (description (get-option-by-name pt "description"))
                  (extended (get-option-by-name pt "extended"))
                  (tag (get-option-by-name pt "tag"))
                  (time (get-option-by-name pt "time"))
                  (hash (get-option-by-name pt "hash"))
                  (others (get-option-by-name pt "others"))
                  )
             (when (equal name "post")
               (unless datetime
                 (setf datetime
                       (if (string-match "\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)T\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)Z" time)
                           (encode-universal-time (parse-integer (match-string 6))
                                                  (parse-integer (match-string 5))
                                                  (parse-integer (match-string 4))
                                                  (parse-integer (match-string 3))
                                                  (parse-integer (match-string 2))
                                                  (parse-integer (match-string 1)))
                         (get-universal-time)))
                 )
               (deli-format-bookmark out href description extended tag time hash others)
               ))
           ))
       datetime)))

(defun deli-parse-posts (xml)
  "BookmarkのXMLを解析して子を返却"
  (let (pt)
    (setf pt (car xml))
    (setf xml (cdr xml))
    (when (equal (ed::xmlpm-tag-name pt) "posts")
      (ed::xmlpm-tag-contents pt)
      )))

;; (defun get-bookmark-dom (date)
;;   (let (obj)
;;   (save-excursion
;;     (set-buffer (get-bookmark-xml-a-day date))
;;     (setf obj (xmlpm-parse))
;;     (delete-buffer (selected-buffer))
;;     obj)))

(defun get-xml-object (buffer)
  "指定されたバッファをXMLとして解析したリストを返却し、バッファを削除"
  (when buffer
    (save-excursion
      (set-buffer buffer)
      (when (prog2
                (goto-char (point-min))
                (scan-buffer "^<\\?xml[^>]+\\?>" :regexp t)
              (goto-char (point-min)))
        (prog1
            (ed::xmlpm-parse)
          (or *deli2howm-debug* (delete-buffer buffer)))))))

(defun get-bookmark-xml-all ()
  "すべてブックマークデータのXMLをバッファで返却"
  (get-xml-deli-api "all"))

(defun get-bookmark-xml-a-day (date)
  "特定の日付のブックマークデータのXMLをバッファで返却"
  (get-xml-deli-api (concat "get?dt=" date)))

(defun get-dates-xml ()
  "ブックマークが存在する日付のXMLをバッファで返却"
  (get-xml-deli-api (concat "dates?")))

(defun get-xml-deli-api (str)
  "del.icio.us API に接続してGetしたデータのバッファを返却"
  (let ((url (concat (append-trail-slash *delicious-api*) str))
        server path request header status out)
    (string-match "https?://\\([^/]+\\)\\(/.*\\)" url)
    (setf server (match-string 1))
    (setf path (or (match-string 2) ""))
    (setf request
          (with-output-to-string (out)
             (format out "GET ~A HTTP/~A~%" path "1.0")
             (format out "Host: ~A~%" server)
             (format out "Authorization: basic ~A~%"
                     (auth-encode *deli2howm-user* *deli2howm-pass*))
             (format out "User-Agent: ~A~%" "xyzzy")
             (format out "~%")))
    (if *deli2howm-debug*
        (setf *deli2howm-debug-log* (concat *deli2howm-debug-log* request)))
    (with-open-stream (stream (connect server 80))
      (format stream request)
      ;Status
      (setf status (read-line stream nil))
      (or (and (string-matchp "HTTP/[^ ]+ \\([0-9]+\\) [^ ]+" status)
               (string-equal (match-string 1) "200"))
          (return-from get-xml-deli-api nil status))
      ;Header
      (setf header
            (with-output-to-string (out)
              (while (setf in (read-line stream nil))
                (message "deli2howm :: Getting HTTP Header ......")
                (format out "~A~%" in)
                (when (string-match "Content-Type:.*" in) (read-line stream nil) (return)))))
      (save-excursion
        (let ((buf (get-buffer-create (concat " *" url "*"))))
          (set-buffer buf) (erase-buffer buf)
          ;Data
          (while (setf in (read-line stream nil))
            (message "deli2howm :: Getting HTTP Data ......")
            (insert in "\n"))
          (values buf status header))))))

(defun auth-encode (user passwd)
  "Basic認証用にユーザ名とパスワードをエンコード"
  (substitute-string (si:base64-encode (concat user ":" passwd)) "\n" ""))

(defun get-option-by-name (pt name)
  (let ((opts (ed::xmlpm-tag-opts pt)))
    (cdr (assoc name opts :test #'equal))))


(defun w3cdtf-to-universal-time (datetime)
  "W3CDTF 形式の日時を適当にユニバーサルタイムに変更"
  (when (string-matchp "\\([0-9]\\{4\\}\\)-\\([01][0-9]\\)-\\([0-3][0-9]\\)\\(T\\([0-2][0-9]\\):\\([0-5][0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\([\\+-][0-2][0-9]:[0-5][0-9]\\|Z\\)\\)?" datetime)
    (let ((year  (parse-integer (match-string 1)))
          (month (parse-integer (match-string 2)))
          (day   (parse-integer (match-string 3)))
          (hour 0)
          (min  0)
          (sec  0)
          tzone)
      (when (match-string 4)
          (hour  (parse-integer (match-string 5)))
          (min   (parse-integer (match-string 6)))
          (tzone (match-string 9))
        (when (match-string 8) (setf sec (parse-integer (match-string 8))))
        (if (string-match "\\([+-][0-9]+\\):00" tzone)
            (setf tzone (parse-integer (match-string 1)))
          (setf tzone 0)))
        (encode-universal-time sec min hour day month year tzone)
        )))

;; NYSL Version 0.9982
;;
;; A. 本ソフトウェアは Everyone'sWare です。このソフトを手にした一人一人が、
;;    ご自分の作ったものを扱うのと同じように、自由に利用することが出来ます。
;;
;;   A-1. フリーウェアです。作者からは使用料等を要求しません。
;;   A-2. 有料無料や媒体の如何を問わず、自由に転載・再配布できます。
;;   A-3. いかなる種類の 改変・他プログラムでの利用 を行っても構いません。
;;   A-4. 変更したものや部分的に使用したものは、あなたのものになります。
;;        公開する場合は、あなたの名前の下で行って下さい。
;;
;; B. このソフトを利用することによって生じた損害等について、作者は
;;    責任を負わないものとします。各自の責任においてご利用下さい。
;;
;; C. 著作者人格権はoosawaに帰属します。著作権は放棄します。
;;
;; D. 以上の３項は、ソース・実行バイナリの双方に適用されます。