File view: timeline.scm.html

root/render/timeline.scm

(define-module (render timeline)
  #:use-module (srfi srfi-19) ;; date
  #:use-module (web server)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (sxml simple)
  #:use-module (database postgres)
  #:use-module (database)
  #:use-module (database-fetch)
  #:use-module (privileges)
  #:use-module (settings)
  #:use-module (utils)
  #:use-module (render profile)
  #:export (make-timeline-follow
            make-timeline-posts
            make-timeline-search
            make-timeline-global
            make-timeline-local
            make-timeline-body))

(define (format-timestamp str)
  (define dot-index (string-index str #\.))
  (define pre-second-index (if dot-index
                               (- dot-index 3)
                               (string-length str)))
  (substring str 0 pre-second-index))

(define (pagination-filter pagination-before pagination-id)
  (cond ((not pagination-id)
         "")
        (pagination-before
         (string-append "AND notice.id < " (db-integer pagination-id)))
        (else
         (string-append "AND notice.id > " (db-integer pagination-id)))))

(define* (make-timeline-posts db current-user timeline-user #:key
                              (render make-timeline-body)
                              (pagination-before #t)
                              (pagination-id #f))
  (define sql
    (string-append
     "SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice left
     JOIN attachment ON attachment.id=ANY(notice.attachment)
     WHERE NOT deleted='t'
           AND reply_to IS NULL
           AND author=" (db-number (assoc-value 'id timeline-user 0))
           (pagination-filter pagination-before pagination-id) "
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;"))
  (define notices (pg-result->alist (pg-exec db sql)))
  (render db notices current-user timeline-user pagination-id))

(define* (make-timeline-posts-and-replies db current-user timeline-user #:key
                                          (render make-timeline-body))
  (define sql
    (string-append
     "SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice left
     JOIN attachment ON attachment.id=ANY(notice.attachment)
     WHERE NOT deleted='t'
           AND author=" (db-number (assoc-value 'id timeline-user 0)) "
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;"))
  (define notices (pg-result->alist (pg-exec db sql)))
  (render db notices current-user timeline-user #f))

(define (make-timeline-user-list db current-user timeline-user user-list-id)
  (define sql
    (string-append
     "WITH user_list_matches AS (
         SELECT userid FROM user_list_entry WHERE user_list=" (db-number user-list-id) "
     )
     SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice
     LEFT JOIN user_list_matches ON user_list_matches.userid=notice.author
     LEFT JOIN attachment ON attachment.id=ANY(notice.attachment)
     WHERE NOT deleted='t'
           AND notice.author=user_list_matches.userid
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;"))
  (define notices (pg-result->alist (pg-exec db sql)))
  (make-timeline-body db notices current-user timeline-user #f))

(define (make-timeline-follow db current-user timeline-user)
  (define following-id (assoc-value 'following timeline-user))
  (make-timeline-user-list db current-user timeline-user following-id))

(define (make-timeline-search db current-user query)
  (define sql
    (string-append
     "SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice left
     JOIN attachment ON attachment.id=ANY(notice.attachment)
     WHERE NOT deleted='t'
           AND to_tsvector(text) @@ to_tsquery('english'," (db-string query) ")
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;"))
  (define notices (pg-result->alist (pg-exec db sql)))
  (make-timeline-body db notices current-user #f #f))

(define (make-timeline-global db current-user)
  ;; TODO use attachment.* for array_agg and parse using the attachment table scheme
  (define sql
    "SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice left
     JOIN attachment ON attachment.id=ANY(notice.attachment)
     WHERE NOT deleted='t'
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;")
  (define notices (pg-result->alist (pg-exec db sql)))
  ;; old n simple: "SELECT * FROM notice WHERE NOT deleted='t';"
  (make-timeline-body db notices current-user #f #f))

(define (make-timeline-local db current-user)
  (define sql
    "SELECT notice.*, array_agg(attachment.url) as attachment_urls, array_agg(attachment.filename) as attachment_filenames
     FROM notice left
     JOIN attachment ON attachment.id=ANY(notice.attachment)
     JOIN profile ON profile.id=notice.author
     WHERE NOT deleted='t'
           AND author.is_local='t'
     GROUP BY notice.id
     ORDER BY notice.id DESC
     LIMIT 50;")
  (define notices (pg-result->alist (pg-exec db sql)))
  (make-timeline-body db notices current-user #f #f))

(define (make-timeline-body db notices current-user timeline-user does-paginate)
  (define handled-conversations '())
  (define highest-notice-id does-paginate)
  (define lowest-notice-id does-paginate)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (make-conversation-div notice)
    (define conversation-uri (or (assoc-ref notice 'conversation_uri) ""))
    (define notice-id (or (string->number (assoc-value 'id notice "0")) 0))
    (define repeat-id (string->number (assoc-value 'repeat_of notice "0")))
    (define repeat-notice (if repeat-id (notice-for-id db current-user repeat-id #f #t) #f))
    (when (or (not highest-notice-id) (> notice-id highest-notice-id))
      (set! highest-notice-id notice-id))
    (when (or (not lowest-notice-id) (< notice-id lowest-notice-id))
      (set! lowest-notice-id notice-id))
    ;; TODO filter this on datbase level
    (if (or (member conversation-uri handled-conversations)
            (member notice-id handled-conversations))
        '()
        (if repeat-notice
            (make-conversation-detail repeat-notice conversation-uri notice)
            (make-conversation-detail notice conversation-uri #f))))
  (define (make-conversation-detail notice conversation-uri repeater-notice)
    (define notice-id (or (string->number (assoc-value 'id notice "0")) 0))
    (define conversation-notices
      (if (string-null? conversation-uri)
          (list notice)
          (begin
            (or (pg-result->alist
                 (pg-exec db (string-append
                              "SELECT notice.*, array_agg(attachment.url) AS attachment_urls, array_agg(attachment.filename) AS attachment_filenames"
                              " FROM notice"
                              " LEFT JOIN attachment ON attachment.id=ANY(notice.attachment)"
                              " WHERE notice.conversation_uri=" (db-string conversation-uri)
                              " AND notice.repeat_of IS NULL"
                              " AND NOT notice.deleted='t'"
                              " GROUP BY notice.id"
                              " ORDER BY notice.id DESC;"
                              ;; "SELECT * FROM notice WHERE conversation="
                              ;; (db-number conversation-id)
                              ;; " OR id=" (db-number conversation-id)
                              ;; " AND NOT deleted='t';"
                              )))
                (list notice)))))
    (define sorted-converation-notices
      (sort-list conversation-notices
                 (lambda (a b)
                   (define reply-a (assoc-value 'reply_to a))
                   (define reply-b (assoc-value 'reply_to b))
                   (define id-a (assoc-value 'id a))
                   (define id-b (assoc-value 'id b))
                   (define date-a (assoc-value 'createtime a))
                   (define date-b (assoc-value 'createtime b))
                   ;; (warn "reply sort" a b)
                   (cond ((equal? id-b reply-a) #f)
                         ((equal? id-a reply-b) #t)
                         (else (string<? date-a date-b))))))
    (set! handled-conversations (cons notice-id
                                      handled-conversations))
    (when (not (string-null? conversation-uri))
      (set! handled-conversations (cons conversation-uri
                                        handled-conversations)))
    `(div (@ (class "conversation"))
          ,(map (lambda (n)
                  (make-notice-detail n (and repeater-notice
                                             (equal? (assoc-ref repeater-notice 'repeat_of)
                                                     (assoc-ref n 'id))
                                             repeater-notice)))
                sorted-converation-notices)))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (make-notice-detail notice repeater-notice)
    ;; (define attachment-ids (db-parse-array (assoc-value "attachment" notice)))
    ;; (define attachments (map (lambda (id) (attachment-for-id db id)) attachment-ids))
    (define attachments
      (filter
       (lambda (attachment)
         (not (equal? "NULL" (assoc-value 'url attachment "NULL"))))
       (map (lambda (url filename)
              `((filename . ,filename)
                (url . ,url)))
            (db-parse-array (assoc-value 'attachment_urls notice ""))
            (db-parse-array (assoc-value 'attachment_filenames notice "")))))
    (define author-id (or (string->number (assoc-value 'author notice)) 0))
    (define author (or (profile-for-id db author-id) '()))
    (define notice-id (or (assoc-value 'id notice)))

    `(div (@ (class "notice"))
          (div (@ (class "avatar"))
               ,(make-avatar author 46))
          (div (@ (class "content"))
               (div (@ (class "userline"))
                    (span (@ (class "name")) ,(assoc-value 'displayname author ""))
                    (a (@ (class "handle")
                          (href ,(assoc-value 'uri author)))
                       ,(string-append "@" (assoc-value 'handle author "UNKNOWN-USER"))))
               (div (@ (class "text"))
                    ,(if (and (assoc-value 'rendered notice)
                              (not (string-null? (assoc-value 'rendered notice))))
                         (read-sexp (assoc-value 'rendered notice))
                         (assoc-value 'text notice)))
               (div (@ (class "footer"))
                    (div (@ (class "create-time"))
                         ,(format-timestamp (assoc-value 'createtime notice)))
                    ;; TODO handle all repeaters, or at least a limit of 10
                    ,(if repeater-notice
                         `(div (@ (class "repeaters"))
                               ,(let ()
                                  (define repeater-author-id (assoc-value 'author repeater-notice))
                                  (define repeater-author (or (profile-for-id db repeater-author-id) '()))
                                  (define repeater-author-url (assoc-value 'uri repeater-author))
                                  (define repeater-author-name (or (assoc-value 'displayname repeater-author)
                                                                   (assoc-value 'handle repeater-author)))
                                  `(a (@ (href ,repeater-author-url)
                                         (title ,repeater-author-name))
                                      ,(make-avatar repeater-author 18)))
                               '())
                         '())
                    ,(make-interaction-buttons notice))
               ,(map (lambda (attachment)
                       `(div (@ (class "attachments"))
                             ,(make-attachment attachment)))
                     attachments))))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (make-interaction-buttons notice)
    (define notice-id (string->number (assoc-value 'id notice)))
    `(div (@ (class "interaction-buttons"))
          (a (@ (class "favorite")
                (href ,(string-append (get-setting 'base-path)
                                      "/notice/favorite/"
                                      (number->string notice-id)))
                (rel "nofollow"))
             "★")                       ; ♥
          (a (@ (class "repeat")
                (href ,(string-append (get-setting 'base-path)
                                      "/notice/repeat/"
                                      (number->string notice-id)))
                (rel "nofollow"))
             "↻")

          ,(if (can-delete? current-user notice)
               `(a (@ (class "delete")
                      (href ,(string-append (get-setting 'base-path)
                                            "/notice/delete/"
                                            (number->string notice-id)))
                      (rel "nofollow"))
                   "☠")
               '())
          (a (@ (class "reply")
                (href ,(string-append (get-setting 'base-path)
                                      "/notice/reply/"
                                      (number->string notice-id)))
                (rel "nofollow"))
             "↲")))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (make-attachment attachment)
    (define filename (assoc-value 'filename attachment))
    (define filepath (string-append (get-setting 'base-path)
                                    "/file/" filename))
    `(div (@ (class "attachment"))
          (a (@ (href ,filepath))
             (img (@ (src ,filepath))))))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (make-pagination-links)
    ;; TODO remove this if, always paginate
    (if does-paginate
        `(div (@ (class "pagination-timeline"))
              ,(if (and does-paginate (number->string highest-notice-id))
                   `(a (@ (class "newer")
                          (href ,(string-append ;; timeline-base-url
                                  "?after-id="
                                  (number->string highest-notice-id))))
                       "newer posts")
                   "")
              (a (@ (class "later")
                    (href ,(string-append ;; timeline-base-url
                            "?before-id="
                            (number->string lowest-notice-id))))
                 "later posts"))
        '()))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (list (if (and notices (not (null? notices)))
            (map make-conversation-div notices)
            `(div (@ (class "empty-timeline-notice"))
                  "This timeline is empty."))
        (make-pagination-links)))