#lang racket/base

(provide request-handler
         on-continuation-expiry
         rerender!)

(require racket/runtime-path)
(require racket/set)
(require racket/match)
(require racket/format)
(require racket/date)
(require racket/string)
(require racket/port)
(require (only-in racket/list filter-map))
(require (only-in racket/exn exn->string))
(require net/url)
(require net/uri-codec)
(require web-server/servlet)
(require json)
(require "gravatar.rkt")
(require "bootstrap.rkt")
(require "html-utils.rkt")
(require "packages.rkt")
(require "sessions.rkt")
(require "jsonp-client.rkt")
(require reloadable)
(require "daemon.rkt")
(require "config.rkt")
(require "hash-utils.rkt")
(require "static.rkt")
(require "package-source.rkt")

(define static-urlprefix
  (or (@ (config) static-urlprefix)
      ""))

(define dynamic-urlprefix
  (or (@ (config) dynamic-urlprefix)
      ""))

(define dynamic-static-urlprefix
  (or (@ (config) dynamic-static-urlprefix)
      ""))

(define disable-cache?
  (or (@ (config) disable-cache?)
      #f))

(define nav-index "Packages")
(define nav-search "Search")

(define (navbar-header)
  `(a ((href "http://www.racket-lang.org/"))
    (img ((src ,(static-resource-url "/logo-and-text.png"))
          (height "60")
          (alt "Racket Package Index")))))

(define backend-baseurl
  (or (@ (config) backend-baseurl)
      "https://pkgd.racket-lang.org"))

(define default-empty-parsed-package-source
  (git-source "git://github.com/" #f 'git 'git "github.com" #f "" "" ""))

(define COOKIE "pltsession")

(define recent-seconds
  (or (@ (config) recent-seconds)
      (* 2 24 60 60))) ;; two days

(define pkg-build-baseurl
  (or (@ (config) pkg-build-baseurl)
      "http://pkg-build.racket-lang.org/"))

(struct draft-package (old-name name description authors tags versions) #:prefab)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-values (request-handler relative-named-url)
  (dispatch-rules
   [("") main-page]
   [("search") search-page]
   [("package" (string-arg)) package-page]
   [("package" (string-arg) "edit") edit-package-page]
   [("update-my-packages") update-my-packages-page]
   [("update-package-ring" (string-arg) (integer-arg)) #:method "post" update-package-ring-page]
   [("not-found") not-found-page]
   [("create") edit-package-page]
   [("login") login-page]
   [("register-or-reset") register-or-reset-page]
   [("logout") logout-page]
   [("json" "search-completions") json-search-completions]
   [("json" "tag-search-completions") json-tag-search-completions]
   [("json" "formal-tags") json-formal-tags]
   [("pkgs-all.json") pkgs-all-json]
   ))

(define (on-continuation-expiry request)
  (with-site-config
    (bootstrap-continuation-expiry-handler request)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (send/suspend/dispatch/dynamic proc)
  (send/suspend/dispatch
   (lambda (embed-url)
     (proc (lambda args (string-append dynamic-urlprefix (apply embed-url args)))))))

(define (send/suspend/dynamic proc)
  (send/suspend
   (lambda (k-url)
     (proc (string-append dynamic-urlprefix k-url)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (named-url . args)
  (string-append dynamic-urlprefix (apply relative-named-url args)))

(define (static-resource-url suffix)
  (if (rendering-static-page?)
      (string-append static-urlprefix suffix)
      (string-append dynamic-static-urlprefix suffix)))

(define-syntax-rule (authentication-wrap #:request request body ...)
  (authentication-wrap* #f request (lambda () body ...)))

(define-syntax-rule (authentication-wrap/require-login #:request request body ...)
  (authentication-wrap* #t request (lambda () body ...)))

(define-syntax-rule (with-site-config body ...)
  (parameterize ((bootstrap-navbar-header (navbar-header))
                 (bootstrap-head-extra
                  `((link ((rel "alternate")
                           (type "application/atom+xml")
                           (title "Atom Feed")
                           (href ,(static-resource-url "/atom.xml"))))))
                 (bootstrap-navigation
                  `((,nav-index ,(main-page-url))
                    ("Documentation" "https://docs.racket-lang.org/")
                    (,nav-search ,(named-url search-page))
                    ("About"
                     (("The Racket Package System"
                       "http://docs.racket-lang.org/pkg/getting-started.html")
                      ("Package Builds" "https://pkg-build.racket-lang.org/about.html")))
                    ((div ,(glyphicon 'download-alt)
                          " Download Racket")
                     "http://download.racket-lang.org/")
                    ))
                 (bootstrap-static-urlprefix
                  (if (rendering-static-page?)
                      static-urlprefix
                      dynamic-static-urlprefix))
                 (bootstrap-dynamic-urlprefix
                  dynamic-urlprefix)
                 (bootstrap-inline-js
                  (string-append (format "PkgSiteDynamicBaseUrl = '~a';" dynamic-urlprefix)
                                 (format "PkgSiteStaticBaseUrl = '~a';" static-urlprefix)
                                 (format "IsStaticPage = ~a;" (if (rendering-static-page?)
                                                                  "true"
                                                                  "false"))))
                 (jsonp-baseurl backend-baseurl))
    body ...))

(define clear-session-cookie (make-cookie COOKIE
                                          ""
                                          #:path "/"
                                          #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))

(define-syntax-rule (with-session-cookie cookie-value body ...)
  (let ((v cookie-value))
    (parameterize ((bootstrap-cookies
                    (if v
                        (list (make-cookie COOKIE v #:path "/" #:secure? #t))
                        (list clear-session-cookie))))
      body ...)))

(define (request->session request)
  (define session-cookies
    (filter (lambda (c) (equal? (client-cookie-name c) COOKIE))
            (request-cookies request)))
  (define session-keys (map client-cookie-value session-cookies))
  ;; (log-info "Session keys from cookie: ~a" session-keys)
  (for/or ((k session-keys)) (lookup-session/touch! k)))

(define (authentication-wrap* require-login? request body)
  (define session (request->session request))
  ;; (log-info "session: ~a" session)
  (define requested-url (url->string (request-uri request)))

  (if (and require-login? (not session))
      (login-or-register-flow* (string-append dynamic-urlprefix requested-url) login-form)
      (parameterize ((bootstrap-navbar-extension
                      (cond
                       [(not session)
                        `((a ((id "register-button")
                              (class "btn btn-default navbar-btn navbar-right")
                              (href ,(login-or-register-url requested-url
                                                            (named-url register-or-reset-page))))
                             "Register")
                          (a ((id "sign-in-button")
                              (class "btn btn-success navbar-btn navbar-right")
                              (href ,(login-or-register-url requested-url
                                                            (named-url login-page))))
                             "Sign in"))]
                       [else
                        `((ul ((class "nav navbar-nav navbar-right"))
                              (li ((class "dropdown"))
                                  (a ((class "dropdown-toggle")
                                      (data-toggle "dropdown"))
                                     (img ((src ,(gravatar-image-url (session-email session)
                                                                     48))))
                                     " "
                                     ,(session-email session)
                                     " "
                                     (span ((class "caret"))))
                                  (ul ((class "dropdown-menu") (role "menu"))
                                      (li (a ((href ,(named-url update-my-packages-page)))
                                             ,(glyphicon 'refresh) " Rescan all my packages"))
                                      (li ((class "divider")))
                                      (li (a ((href ,(named-url edit-package-page)))
                                             ,(glyphicon 'plus-sign) " New package"))
                                      (li (a ((href ,(tags-page-url
                                                      (list
                                                       (format "author:~a"
                                                               (session-email session))))))
                                             ,(glyphicon 'user) " My packages"))
                                      (li ((class "divider")))
                                      (li (a ((href
                                               ,(login-or-register-url
                                                 requested-url
                                                 (named-url logout-page))))
                                             ,(glyphicon 'log-out) " Log out"))))))]))
                     (current-session session)
                     (bootstrap-cookies
                      (if session
                          (list (make-cookie COOKIE
                                             (session-key session)
                                             #:path "/"
                                             #:secure? #t))
                          (list))))
        (with-site-config (body)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
  `(input ((class "form-control")
           (type ,type)
           (name ,name)
           (id ,name)
           ,@(maybe-splice placeholder `(placeholder ,placeholder))
           (value ,initial-value))))

(define email-input (generic-input "email"))
(define password-input (generic-input "password"))
(define text-input (generic-input "text"))

(define (label for . content)
  `(label ((class "control-label") ,@(maybe-splice for `(for ,for)))
    ,@content))

(define (primary-button . content)
  `(button ((type "submit")
            (class "btn btn-primary"))
    ,@content))

(define (generic-row class)
  (define (wrap cell)
    (match cell
      [(cons 'label _) cell]
      [_ `(div ,cell)]))
  (lambda (#:id [id #f] . args)
    `(div (,@(maybe-splice id `(id ,id))
           (class ,class))
      ,@(let loop ((args args))
          (match args
            [(list* _ _   #f rest)
             (loop rest)]
            [(list* 0 0 cell rest)
             (cons cell (loop rest))]
            [(list* 0 w cell rest)
             (cons (add-classes (list (format "col-sm-~a" w)) (wrap cell))
                   (loop rest))]
            [(list* o w cell rest)
             (cons (add-classes (list (format "col-sm-offset-~a col-sm-~a" o w)) (wrap cell))
                   (loop rest))]
            ['()
             '()])))))

(define form-group (generic-row "form-group"))
(define row (generic-row "row"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (login-or-register-url k baseurl)
  (format "~a?~a"
          baseurl
          (alist->form-urlencoded (list (cons 'k (string-append dynamic-urlprefix k))))))

(define (login-or-register-flow request thunk)
  (define-form-bindings request ([k (named-url main-page)]))
  (define session (request->session request))
  (if session
      (with-site-config
        (bootstrap-redirect k))
      (login-or-register-flow* k thunk)))

(define (login-or-register-flow* k thunk)
  (with-session-cookie (thunk)
    (with-site-config
      (bootstrap-redirect k))))

(define (login-page request)
  (login-or-register-flow request login-form))

(define (register-or-reset-page request)
  (login-or-register-flow request register-form))

(define (logout-page request)
  (define session (request->session request))
  (when session (destroy-session! (session-key session)))
  (login-or-register-flow request (lambda () #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (login-form [error-message #f])
  (with-site-config
   (send/suspend/dispatch/dynamic
    (lambda (embed-url)
      (bootstrap-response "Login"
                          `(form ((class "form-horizontal")
                                  (method "post")
                                  (action ,(embed-url process-login-credentials))
                                  (role "form"))
                            ,(form-group 2 2 (label "email" "Email address")
                                         0 5 (email-input "email"))
                            ,(form-group 2 2 (label "password" "Password:")
                                         0 5 (password-input "password"))
                            ,(form-group 4 5
                                         `(a ((href ,(embed-url (lambda (req) (register-form)))))
                                           "Need to reset your password?"))
                            ,(form-group 4 5
                                         `(a ((href ,(embed-url (lambda (req) (register-form)))))
                                           "Register an account"))
                            ,@(maybe-splice
                               error-message
                               (form-group 4 5
                                           `(div ((class "alert alert-danger"))
                                             (p ,error-message))))
                            ,(form-group 4 5 (primary-button "Log in"))))))))

(define (authenticate-with-server! email password code)
  (simple-json-rpc! #:sensitive? #t
                    #:include-credentials? #f
                    "/api/authenticate"
                    (hash 'email email
                          'passwd password
                          'code code)))

(define (authentication-success->curator? success)
  (match success
    [#t #f] ;; new user -- we can only assume they are *not* curators
    [(hash-table ('curation curator?) _ ...) (if curator? #t #f)]))

(define (process-login-credentials request)
  (define-form-bindings request (email password))
  (if (or (equal? (string-trim email) "")
          (equal? (string-trim password) ""))
      (login-form "Please enter your email address and password.")
      (match (authenticate-with-server! email password "")
        [(or "wrong-code" (? eof-object?))
         (login-form "Something went awry; please try again.")]
        [(or "emailed" #f)
         (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
        [success
         (create-session! email password
                          #:curator? (authentication-success->curator? success))])))

(define (register-form #:email [email ""]
                       #:code [code ""]
                       #:error-message [error-message #f])
  (with-site-config
   (send/suspend/dispatch/dynamic
    (lambda (embed-url)
      (bootstrap-response "Register/Reset Account"
                          #:title-element ""
                          `(div ((class "registration-step-container"))
                            (div ((class "registration-step"))
                                 (div (h1 "Step 1")
                                      (p "Get a code")))
                            (span ((class "registration-step-arrow")) "→")
                            (div ((class "registration-step"))
                                 (div (h1 "Step 2")
                                      (p "Use the code"))))

                          `(div
                            (h1 "Need a code?")
                            (p "Enter your email address below, and we'll send you one.")
                            (form ((class "form-horizontal")
                                   (method "post")
                                   (action ,(embed-url notify-of-emailing))
                                   (role "form"))
                                  ,(form-group 1 3 (label "email" "Email address")
                                               0 5 (email-input "email_for_code"))
                                  ,(form-group 4 5 (primary-button "Email me a code"))))

                          `(div
                            (h1 "Got a registration or reset code?")
                            (p "Great! Enter it below, with your chosen password, to log in.")
                            (form ((class "form-horizontal")
                                   (method "post")
                                   (action ,(embed-url apply-account-code))
                                   (role "form"))
                                  ,(form-group 1 3 (label "email" "Email address")
                                               0 5 (email-input "email" email))
                                  ,(form-group 1 3 (label "code" "Code")
                                               0 5 (text-input "code" code))
                                  ,(form-group 1 3 (label "password" "Password")
                                               0 5 (password-input "password"))
                                  ,(form-group 1 3 (label "password" "Confirm password")
                                               0 5 (password-input "confirm_password"))
                                  ,@(maybe-splice
                                     error-message
                                     (form-group 4 5
                                                 `(div ((class "alert alert-danger"))
                                                   (p ,error-message))))
                                  ,(form-group 4 5 (primary-button "Continue")))))))))

(define (apply-account-code request)
  (define-form-bindings request (email code password confirm_password))
  (define (retry msg)
    (register-form #:email email
                   #:code code
                   #:error-message msg))
  (cond
   [(equal? (string-trim email) "")
    (retry "Please enter your email address.")]
   [(equal? (string-trim code) "")
    (retry "Please enter the code you received in your email.")]
   [(not (equal? password confirm_password))
    (retry "Please make sure the two password fields match.")]
   [(equal? (string-trim password) "")
    (retry "Please enter a password.")]
   [else
    (match (authenticate-with-server! email password code)
      [(? eof-object?)
       (retry "Something went awry. Please try again.")]
      ["wrong-code"
       (retry "The code you entered was incorrect. Please try again.")]
      [(or "emailed" #f)
       (retry "Something went awry; you have been emailed another code. Please check your email.")]
      [success
       ;; The email and password combo we have been given is good to go.
       ;; Set a cookie and consider ourselves logged in.
       (create-session! email password
                        #:curator? (authentication-success->curator? success))])]))

(define (notify-of-emailing request)
  (define-form-bindings request (email_for_code))
  (authenticate-with-server! email_for_code "" "") ;; TODO check result?
  (summarise-code-emailing "Account registration/reset code emailed" email_for_code))

(define (summarise-code-emailing reason email)
  (with-site-config
   (send/suspend/dispatch/dynamic
    (lambda (embed-url)
      (bootstrap-response reason
                          `(p
                            "We've emailed an account registration/reset code to "
                            (code ,email) ". Please check your email and then click "
                            "the button to continue:")
                          `(a ((class "btn btn-primary")
                               (href ,(embed-url (lambda (req) (register-form)))))
                            "Enter your code"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (use-cache?)
  ;; We use the cache if it isn't disabled, but ONLY when the user is
  ;; not logged in to an account. When they are logged in, they see
  ;; user-specific options which don't cache well.
  (not (or (current-session) disable-cache?)))

(define (main-page-url)
  (if (use-cache?)
      (format "~a/index.html" static-urlprefix)
      (named-url main-page)))

(define (view-package-url package-name)
  (define package-name-str (~a package-name))
  (if (use-cache?)
      (format "~a~a" static-urlprefix (relative-named-url package-page package-name-str))
      (named-url package-page package-name-str)))

(define (package-link package-name)
  `(a ((href ,(view-package-url package-name))) ,(~a package-name)))

(define (doc-destruct doc)
  (match doc
    [(list _ n u) (values n u)]
    [(list _ n) (values n #f)]))

(define (doc-link doc)
  (define-values (docset-name docset-url) (doc-destruct doc))
  (if docset-url
      (buildhost-link docset-url docset-name)
      `(del ,docset-name)))

(define (tags-page-url tags)
  (format "~a?~a"
          (named-url search-page)
          (alist->form-urlencoded (list (cons 'tags (string-join tags))))))

(define (author-link author-name #:gravatar? [gravatar? #f])
  `(a ((href ,(tags-page-url (list (format "author:~a" author-name)))))
    ,@(maybe-splice gravatar?
                    `(img ((src ,(gravatar-image-url author-name 48))))
                    " ")
    ,author-name))

(define (tag-link tag-name)
  `(a ((href ,(tags-page-url (list tag-name)))) ,tag-name))

(define (buildhost-link #:attributes [attributes '()] url-suffix label)
  `(a (,@attributes
       (href ,(format "~a~a" pkg-build-baseurl url-suffix))) ,label))

(define (authors-list authors #:gravatars? [gravatars? #f])
  `(ul ((class "authors")) ,@(for/list ((author authors))
                               `(li ,(author-link author #:gravatar? gravatars?)))))

(define (package-links #:pretty? [pretty? #t] package-names)
  (if (and pretty? (null? package-names))
      `(span ((class "packages none")) "None")
      `(ul ((class "list-inline packages"))
        ,@(for/list ((p package-names)) `(li ,(package-link p))))))

(define (doc-links docs)
  `(ul ((class "list-inline doclinks"))
    ,@(for/list ((doc (or docs '()))) `(li ,(doc-link doc)))))

(define (tag-links tags)
  `(ul ((class "list-inline taglinks")) ,@(for/list ((tag (or tags '()))) `(li ,(tag-link tag)))))

(define (utc->string utc)
  (if (and utc (not (zero? utc)))
      (string-append (date->string (seconds->date utc #f) #t) " (UTC)")
      "N/A"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Package hashtable getters.
;; TODO factor this stuff out into a proper data structure

;; Mandatory -- never #f
(define (package-name pkg)                  (@ pkg name))

;; Optional -- sometimes #f
(define (package-build-failure-log pkg)     (@ pkg build failure-log))
(define (package-build-success-log pkg)     (@ pkg build success-log))
(define (package-build-dep-failure-log pkg) (@ pkg build dep-failure-log))
(define (package-build-conflicts-log pkg)   (@ pkg build conflicts-log))
(define (package-ring pkg)                  (@ pkg ring))
(define (package-checksum-error pkg)        (@ pkg checksum-error))

(define (package-readme-url pkg)
  (@ (package-external-information (string->symbol (@ pkg name))) readme-url))

(define (package-default-version pkg)
  (@ (package-versions pkg) default))

(define (package-locally-modified? pkg)
  (@ pkg _LOCALLY_MODIFIED_))

;; If absent, default values substituted
(define (package-last-updated pkg)      (or (@ pkg last-updated) 0))
(define (package-last-checked pkg)      (or (@ pkg last-checked) 0))
(define (package-last-edit pkg)         (or (@ pkg last-edit) 0))
(define (package-authors pkg)           (or (@ pkg authors) '()))
(define (package-description pkg)       (or (@ pkg description) ""))
(define (package-tags pkg)              (or (@ pkg tags) '()))
(define (package-versions pkg)          (or (@ pkg versions) (hash)))
(define (package-docs pkg)              (or (@ pkg build docs) '()))
(define (package-conflicts pkg)         (or (@ pkg conflicts) '()))
(define (package-dependencies pkg)      (or (@ pkg dependencies) '()))
(define (package-modules pkg)           (or (@ pkg modules) '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (package-summary-table package-names)
  (define now (/ (current-inexact-milliseconds) 1000))
  `(table
    ((class "packages sortable"))
    (thead
     (tr
      (th 'nbsp)
      (th "Package")
      (th "Description")
      (th "Build")))
    (tbody
     ,@(maybe-splice (null? package-names)
                     `(tr (td ((colspan "4"))
                              (div ((class "alert alert-info"))
                                   "No packages found."))))
     ,@(for/list ((pkg (package-batch-detail package-names)))
         `(tr
           (td (span ((class "last-updated-negated") (style "display: none"))
                     ,(~a (- (package-last-updated pkg))))
               ,@(maybe-splice
                  (< (- now (package-last-updated pkg)) recent-seconds)
                  `(span ((class "label label-info")) "New")))
           (td (h2 ,(package-link (package-name pkg)))
               ,(authors-list (package-authors pkg)))
           (td (p ,(package-description pkg))
               ,@(maybe-splice
                  (or (pair? (package-docs pkg)) (package-readme-url pkg))
                  `(div
                    (span ((class "doctags-label")) "Docs: ")
                    ,(doc-links (package-docs pkg))
                    ,@(maybe-splice (package-readme-url pkg)
                                    " "
                                    `(a ((href ,(package-readme-url pkg)))
                                      "README"))
                    ))
               ,@(maybe-splice
                  (pair? (package-tags pkg))
                  `(div
                    (span ((class "doctags-label")) "Tags: ")
                    ,(tag-links (package-tags pkg)))))
           ,(cond
             [(package-build-failure-log pkg)
              `(td ((class "build_red"))
                ,(buildhost-link (package-build-failure-log pkg) "fails"))]
             [(and (package-build-success-log pkg)
                   (package-build-dep-failure-log pkg))
              `(td ((class "build_yellow"))
                ,(buildhost-link (package-build-success-log pkg)
                                 "succeeds")
                " with "
                ,(buildhost-link (package-build-dep-failure-log pkg)
                                 "dependency problems"))]
             [(package-build-success-log pkg)
              `(td ((class "build_green"))
                ,(buildhost-link (package-build-success-log pkg) "succeeds"))]
             [else
              `(td)]))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (main-page request)
  (parameterize ((bootstrap-active-navigation nav-index)
                 (bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
                                               (static-resource-url "/index.js"))))
    (define package-name-list (package-search "" '((main-distribution #f))))
    (authentication-wrap
     #:request request
     (if (and (not (rendering-static-page?)) (use-cache?))
         (bootstrap-redirect (main-page-url))
         (bootstrap-response "Racket Package Index"
           #:title-element ""
           #:body-class "main-page"
           `(div ((class "jumbotron"))
                 (h1 "Racket Packages")
                 (p "These are the packages in the official "
                    (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
                       "package catalog") ".")
                 (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
                       (kbd "raco pkg install " (var "package-name")))
                    " installs a package.")
                 (p "You can "
                    (a ((id "create-package-link")
                        (href ,(named-url edit-package-page)))
                       (span ((class "label label-success"))
                             ,(glyphicon 'plus-sign)
                             " add your own"))
                    " packages to the index."))
           `(div ((id "search-box"))
                 (form ((role "form")
                        (action ,(named-url search-page)))
                       ,(text-input "q" #:placeholder "Search packages")))
           `(div
             (p ((class "package-count"))
                ,(format "~a packages" (length package-name-list)))
             ,(package-summary-table package-name-list))
           `(div ((class "jumbotron"))
                 (p "Questions? Comments? Bugs? Email "
                    (a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
                    " or "
                    (a ((href "mailto:jay.mccarthy@gmail.com")) "jay.mccarthy@gmail.com")
                    ".")))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (build-status buildhost-url str label-type glyphicon-type)
  `(p ((class "build-status"))
    "Build status: "
    ,(buildhost-link buildhost-url
                     `(span ((class ,(format "label label-~a" label-type)))
                       ,(glyphicon glyphicon-type) " " ,str))))

(define (dependencies->package-names deps)
  (filter-map (lambda (dep)
                (match dep
                  [(? string? package-name) package-name]
                  [(cons (? string? package-name) _) package-name]
                  [_
                   (log-warning "dependencies->package-names: unknown dependency format: ~v" dep)
                   #f]))
              deps))

(define (clamp-ring r)
  (max 0 (min 2 r)))

(define (ring-change-link pkg proposed-new-ring link-content)
  (define new-ring (clamp-ring proposed-new-ring))
  `(form ((role "form")
          (class "ring-change-link")
          (method "post")
          (action ,(named-url update-package-ring-page (~a (package-name pkg)) new-ring)))
         (button ((class "btn btn-danger btn-xs")
                  ,@(maybe-splice
                     (= new-ring (package-ring pkg))
                     `(disabled "disabled"))
                  (type "submit")) ,link-content)))

(define (not-found-page request [package-name-str #f])
  (authentication-wrap
   #:request request
   (bootstrap-response #:code 404
                       #:message #"Page not found"
                       "Page not found"
                       `(div "The page you requested does not exist.")
                       `(ul (li (a ((href ,(main-page-url)))
                                   "Return to the package index"))))))

(define (package-page request package-name-str)
  (define package-name (string->symbol package-name-str))
  (define pkg (package-detail package-name))
  (authentication-wrap
   #:request request
   (cond
     [(not pkg)
      (bootstrap-response #:code 404
                          #:message #"No such package"
                          "Package not found"
                          (if package-name-str
                              `(div "The package " (code ,package-name-str) " does not exist.")
                              `(div "The requested package does not exist."))
                          `(ul (li (a ((href ,(main-page-url)))
                                      "Return to the package index"))))]
     [(and (not (rendering-static-page?)) (use-cache?))
      (bootstrap-redirect (view-package-url package-name))]
     [else
      (let ((default-version (package-default-version pkg)))
        (bootstrap-response (~a package-name)
          #:title-element ""
          `(div ((class "jumbotron"))
                (h1 ,(~a package-name))
                (p ,(package-description pkg))
                ,(cond
                   [(package-build-failure-log pkg)
                    (build-status (package-build-failure-log pkg)
                                  "failed" "danger" "fire")]
                   [(and (package-build-success-log pkg)
                         (package-build-dep-failure-log pkg))
                    (build-status (package-build-dep-failure-log pkg)
                                  "problems" "warning" "question-sign")]
                   [(package-build-success-log pkg)
                    (build-status (package-build-success-log pkg)
                                  "ok" "success" "ok")]
                   [else
                    ""])
                (div ((class "dropdown"))
                     ,@(let ((docs (package-docs pkg)))
                         (match docs
                           [(list)
                            `()]
                           [(list doc)
                            (define-values (n u) (doc-destruct doc))
                            (list (buildhost-link
                                   #:attributes `((class "btn btn-success btn-lg"))
                                   u
                                   `(span ,(glyphicon 'file) " Documentation")))]
                           [_
                            `((button ((class "btn btn-success btn-lg dropdown-toggle")
                                       (data-toggle "dropdown"))
                                      ,(glyphicon 'file)
                                      " Documentation "
                                      (span ((class "caret"))))
                              (ul ((class "dropdown-menu")
                                   (role "menu"))
                                  ,@(for/list ((doc docs)) `(li ,(doc-link doc)))))]))

                     " "
                     ,@(maybe-splice
                        (package-readme-url pkg)
                        `(a ((class "btn btn-info btn-lg")
                             (href ,(package-readme-url pkg)))
                            ,(glyphicon 'eye-open)
                            " README"))

                     ;; Heuristic guess as to whether we should present a "browse"
                     ;; link or a "download" link.
                     " "
                     ,(if (equal? (@ default-version source)
                                  (@ default-version source_url))
                          `(a ((class "btn btn-default btn-lg")
                               (href ,(@ default-version source_url)))
                              ,(glyphicon 'download) " Download"
                              ;; ,(if (regexp-match? "(?i:\\.zip$)" (or (@ default-version source_url) ""))
                              ;;      " Zip file"
                              ;;      " Download")
                              )
                          `(a ((class "btn btn-default btn-lg")
                               (href ,(package-source->human-tree-url (@ default-version source))))
                              ,(glyphicon 'link) " Code"))

                     ,@(maybe-splice
                        (member (current-email) (package-authors pkg))
                        " "
                        `(a ((class "btn btn-info btn-lg")
                             (href ,(named-url edit-package-page package-name-str)))
                            ,(glyphicon 'edit) " Edit this package"))
                     ))

          (if (package-locally-modified? pkg)
              `(div ((class "alert alert-warning")
                     (role "alert"))
                    ,(glyphicon 'exclamation-sign)
                    " This package has been modified since the package index was last rebuilt."
                    " The next index refresh is scheduled for "
                    ,(utc->string (/ (next-fetch-deadline) 1000)) ".")
              "")

          (if (package-checksum-error pkg)
              `(div ((class "alert alert-danger")
                     (role "alert"))
                    (span ((class "label label-danger"))
                          "Checksum error")
                    " The package checksum does not match"
                    " the package source code.")
              "")

          `(table ((class "package-details"))
                  (tr (th "Authors")
                      (td (div ((class "authors-detail"))
                               ,(authors-list #:gravatars? #t (package-authors pkg)))))
                  (tr (th "Documentation")
                      (td ,(doc-links (package-docs pkg))))
                  (tr (th "Tags")
                      (td ,(tag-links (package-tags pkg))))
                  (tr (th "Last updated")
                      (td ,(utc->string (package-last-updated pkg))))
                  (tr (th "Ring")
                      (td ,(~a (or (package-ring pkg) "N/A"))
                          ,@(maybe-splice
                             (and (package-ring pkg)
                                  (current-session)
                                  (session-curator? (current-session)))
                             " "
                             (ring-change-link pkg (- (package-ring pkg) 1) 'blacktriangledown)
                             (ring-change-link pkg (+ (package-ring pkg) 1) 'blacktriangle))))
                  (tr (th "Conflicts")
                      (td ,(package-links (package-conflicts pkg))))
                  (tr (th "Dependencies")
                      (td ,(package-links
                            (dependencies->package-names
                             (package-dependencies pkg)))))
                  (tr (th "Most recent build results")
                      (td (ul ((class "build-results"))
                              ,@(maybe-splice
                                 (package-build-success-log pkg)
                                 `(li "Compiled successfully: "
                                      ,(buildhost-link (package-build-success-log pkg)
                                                       "transcript")))
                              ,@(maybe-splice
                                 (package-build-failure-log pkg)
                                 `(li "Compiled unsuccessfully: "
                                      ,(buildhost-link (package-build-failure-log pkg)
                                                       "transcript")))
                              ,@(maybe-splice
                                 (package-build-conflicts-log pkg)
                                 `(li "Conflicts: "
                                      ,(buildhost-link (package-build-conflicts-log pkg)
                                                       "details")))
                              ,@(maybe-splice
                                 (package-build-dep-failure-log pkg)
                                 `(li "Dependency problems: "
                                      ,(buildhost-link (package-build-dep-failure-log pkg)
                                                       "details")))
                              )))
                  ,@(let* ((vs (package-versions pkg))
                           (empty-checksum "9f098dddde7f217879070816090c1e8e74d49432")
                           (vs (for/hash (((k v) (in-hash vs))
                                          #:when (not (equal? (@ v checksum)
                                                              empty-checksum)))
                                 (values k v))))
                      (maybe-splice
                       (not (hash-empty? vs))
                       `(tr (th "Versions")
                            (td (table ((class "package-versions"))
                                       (tr (th "Version")
                                           (th "Source")
                                           (th "Checksum"))
                                       ,@(for/list
                                             (((version-sym v) (in-hash vs)))
                                           `(tr
                                             (td ,(~a version-sym))
                                             (td (a ((href ,(package-source->human-tree-url
                                                             (@ v source))))
                                                    ,(@ v source)))
                                             (td ,(@ v checksum)))))))))
                  (tr (th "Last checked")
                      (td ,(utc->string (package-last-checked pkg))))
                  (tr (th "Last edited")
                      (td ,(utc->string (package-last-edit pkg))))
                  (tr (th "Modules")
                      (td (ul ((class "module-list"))
                              ,@(for/list ((mod (package-modules pkg)))
                                  (match-define (list kind path) mod)
                                  `(li ((class ,kind)) ,path)))))
                  )))])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (edit-package-page request [package-name-str ""])
  (authentication-wrap/require-login
   #:request request
   (define package-name (string->symbol package-name-str))
   (define pkg (package-detail package-name))
   (cond
    [(and pkg (not (member (current-email) (package-authors pkg))))
     ;; Not ours. Show it instead.
     (bootstrap-redirect (view-package-url package-name))]
    [(not pkg)
     ;; Doesn't exist.
     (package-form #f (draft-package ""
                                     package-name-str
                                     ""
                                     (list (current-email))
                                     '()
                                     `(("default" ,default-empty-parsed-package-source))))]
    [else
     (package-form #f
                   (draft-package package-name-str
                                  package-name-str
                                  (package-description pkg)
                                  (package-authors pkg)
                                  (package-tags pkg)
                                  (for/list (((ver info) (in-hash (package-versions pkg))))
                                    (define-values (parsed complaints)
                                      (parse-package-source (@ info source)))
                                    (list (symbol->string ver) parsed))))])))

(define (package-source-option source-type value label)
  `(option ((value ,value)
            ,@(maybe-splice (equal? source-type value) '(selected "selected")))
    ,label))

(define (put-default-first alist)
  (define default (assoc "default" alist))
  (cons default (remove default alist)))

(define (package-form error-message draft)
  (with-site-config
   (send/suspend/dispatch/dynamic
    (lambda (embed-url)

      (define (build-versions-table)
        `(table ((class "package-versions"))
          (tr (th "Version")
              (th "Source"))
          ,@(for/list ((v (put-default-first
                           (draft-package-versions draft))))
              (match-define (list version parsed-source) v)
              (define (control-name c) (format "version__~a__~a" version c))
              (define (group-name c) (format "version__~a__~a__group" version c))
              (define (textfield name label-text value [placeholder ""])
                (row #:id (group-name name)
                     0 3
                     (and label-text (label (control-name name) label-text))
                     0 (if label-text 9 12)
                     (text-input (control-name name) value #:placeholder placeholder)))
              (define-values (source-type simple-url g-transport g-host+port g-repo g-commit g-path)
                (match parsed-source
                  [#f
                   (values "simple" "" "" "" "" "" "")]
                  [(simple-url-source u _ _)
                   (values "simple" u "" "" "" "" "")]
                  [(git-source _ _ _ tr host port repo c path)
                   (values "git"
                           ""
                           (symbol->string tr)
                           (match* (tr port)
                             [(_ #f) host]
                             [(http 80) host]
                             [(https 443) host]
                             [(git 9418) host]
                             [(_ _) (format "~a:~a" host port)])
                           repo
                           (match c
                             ["master" ""]
                             [_ c])
                           path)]))
              `(tr
                (td ,version
                    ,@(maybe-splice
                       (not (equal? version "default"))
                       " "
                       `(button ((class "btn btn-danger btn-xs")
                                 (type "submit")
                                 (name "action")
                                 (value ,(control-name "delete")))
                         ,(glyphicon 'trash))))
                (td ,(row
                      0 3 `(div ((id ,(group-name "type")))
                            (select ((class "package-version-source-type")
                                     (data-packageversion ,version)
                                     (name ,(control-name "type")))
                                    ,(package-source-option source-type
                                                            "git"
                                                            "Git Repository")
                                    ,(package-source-option source-type
                                                            "simple"
                                                            "Simple URL")))
                      0 9 `(div ((id ,(group-name "fields")))
                            (div ((id ,(group-name "urlpreview"))
                                  (class "row"))
                                 (div ((class "col-sm-3"))
                                      ,(label #f "URL preview"))
                                 (div ((class "col-sm-9"))
                                      (span ((class "form-control disabled")
                                             (disabled "disabled")
                                             (id ,(control-name "urlpreview"))))))
                            ,(textfield "simple_url" #f simple-url)
                            ,(textfield "g_host_port" "Host" g-host+port)
                            ,(textfield "g_repo" "Repository" g-repo "user/repo")
                            ,(textfield "g_commit" "Branch or commit" g-commit "master")
                            ,(textfield "g_path" "Path within repository" g-path)
                            ,(row #:id (group-name "g_transport")
                                  0 3
                                  (label (control-name "g_transport") "Transport")
                                  0 9
                                  `(select ((id ,(control-name "g_transport"))
                                            (name ,(control-name "g_transport")))
                                           ,@(for/list [(t (list "git" "https" "http"))]
                                               `(option ((value ,t)
                                                         ,@(maybe-splice (equal? t g-transport)
                                                                         '(selected "selected")))
                                                        ,t)))))))))

          (tr (td ((colspan "2"))
                  (div ((class "form-inline"))
                       ,(text-input "new_version" #:placeholder "x.y.z")
                       " "
                       (button ((class "btn btn-success btn-xs")
                                (type "submit")
                                (name "action")
                                (value "add_version"))
                               ,(glyphicon 'plus-sign) " Add new version"))))
          ))

      (parameterize ((bootstrap-page-scripts (list (static-resource-url "/editpackage.js"))))
        (define old-name (draft-package-old-name draft))
        (define has-old-name? (not (equal? old-name "")))
        (bootstrap-response (if has-old-name?
                                (format "Edit package ~a" old-name)
                                "Create a new package")
                            #:body-class "package-form"
                            (if error-message
                                `(div ((class "alert alert-danger"))
                                  ,(glyphicon 'exclamation-sign) " " ,error-message)
                                "")
                            `(form ((id "edit-package-form")
                                    (method "post")
                                    (action ,(embed-url (update-draft draft)))
                                    (role "form"))
                              (div ((class "container")) ;; TODO: remove??
                                   (div ((class "row"))
                                        (div ((class "form-group col-sm-6"))
                                             ,(label "name" "Package Name")
                                             ,(text-input "name" (~a (draft-package-name draft))))
                                        (div ((class "form-group col-sm-6"))
                                             ,(label "tags" "Package Tags (space-separated)")
                                             ,(text-input "tags" (string-join
                                                                  (draft-package-tags draft)))))
                                   (div ((class "row"))
                                        (div ((class "form-group col-sm-6"))
                                             ,(label "description" "Package Description")
                                             (textarea ((class "form-control")
                                                        (name "description")
                                                        (id "description"))
                                                       ,(draft-package-description draft)))
                                        (div ((class "form-group col-sm-6"))
                                             ,(label "authors"
                                                     "Author email addresses (one per line)")
                                             (textarea ((class "form-control")
                                                        (name "authors")
                                                        (id "authors"))
                                                       ,(string-join (draft-package-authors draft)
                                                                     "\n"))))
                                   (div ((class "row"))
                                        (div ((class "form-group col-sm-12"))
                                             ,(label #f "Package Versions & Sources")
                                             ,(build-versions-table)))
                                   (div ((class "row"))
                                        (div ((class "form-group col-sm-12"))
                                             ,@(maybe-splice
                                                has-old-name?
                                                `(a ((class "btn btn-danger pull-right")
                                                     (href ,(embed-url
                                                             (confirm-package-deletion old-name))))
                                                  ,(glyphicon 'trash) " Delete package")
                                                " ")
                                             (button ((type "submit")
                                                      (class "btn btn-primary")
                                                      (name "action")
                                                      (value "save_changes"))
                                                     ,(glyphicon 'save) " Save changes")
                                             ,@(maybe-splice
                                                has-old-name?
                                                " "
                                                `(a ((class "btn btn-default")
                                                     (href ,(view-package-url old-name)))
                                                  "Cancel changes and return to package page"))))))
                            ))))))

(define ((confirm-package-deletion package-name-str) request)
  (with-site-config
   (send/suspend/dynamic
    (lambda (k-url)
      (bootstrap-response "Confirm Package Deletion"
                          `(div ((class "confirm-package-deletion"))
                            (h2 ,(format "Delete ~a?" package-name-str))
                            (p "This cannot be undone.")
                            (a ((class "btn btn-default")
                                (href ,k-url))
                               "Confirm deletion")))))
   (jsonp-rpc! "/jsonp/package/del" `((pkg . ,package-name-str)))
   (define completion-ch (make-channel))
   (delete-package! completion-ch (string->symbol package-name-str))
   (channel-get completion-ch)
   (bootstrap-redirect (main-page-url))))

(define ((update-draft draft0) request)
  (define draft (read-draft-form draft0 (request-bindings request)))
  (define-form-bindings request (action new_version))
  (match action
    ["save_changes"
     (if (save-draft! draft)
         (with-site-config
           (bootstrap-redirect (view-package-url (draft-package-name draft))))
         (package-form "Save failed."
                       ;; ^ TODO: This is the worst error message.
                       ;;         Right up there with "parse error".
                       draft))]
    ["add_version"
     (cond
      [(equal? (string-trim new_version) "")
       (package-form "Please enter a version number to add." draft)]
      [(assoc new_version (draft-package-versions draft))
       (package-form (format "Could not add version ~a, as it already exists." new_version)
                     draft)]
      [else
       (package-form #f (struct-copy draft-package draft
                          [versions (cons (list new_version default-empty-parsed-package-source)
                                          (draft-package-versions draft))]))])]
    [(regexp #px"^version__(.*)__delete$" (list _ version))
     (package-form #f (struct-copy draft-package draft
                        [versions (filter (lambda (v)
                                            (not (equal? (car v) version)))
                                          (draft-package-versions draft))]))]))

(define (read-draft-form draft bindings)
  (define (g key d)
    (cond [(assq key bindings) => cdr]
          [else d]))
  (define (read-version-source version)
    (define (vg name d)
      (g (string->symbol (format "version__~a__~a" version name)) d))
    (define type (vg 'type "simple"))
    (define simple_url (vg 'simple_url ""))
    (define g_transport (vg 'g_transport ""))
    (define g_host_port (vg 'g_host_port ""))
    (define g_repo0 (vg 'g_repo ""))
    (define g_repo (cond
                     [(regexp-match #rx"[.]git$" g_repo0) g_repo0]
                     [(equal? g_transport "git") g_repo0]
                     [else (string-append g_repo0 ".git")]))
    (define g_commit0 (vg 'g_commit ""))
    (define g_path (vg 'g_path ""))
    (define g_commit (if (equal? g_commit0 "") "master" g_commit0))
    (define-values (g_host g_port)
      (match (string-split g_host_port ":")
        [(list host) (values host #f)]
        [(list host (? string->number port)) (values host (string->number port))]
        [_ (values "" #f)]))
    (define source
      (match type
        ["simple" simple_url]
        ["git" (unparse-package-source (git-source "" #f #f
                                                   (string->symbol g_transport)
                                                   g_host
                                                   g_port
                                                   g_repo
                                                   g_commit
                                                   g_path))]))
    (define-values (parsed complaints) (parse-package-source source))
    parsed)
  (struct-copy draft-package draft
               [name (g 'name (draft-package-old-name draft))]
               [description (g 'description "")]
               [authors (string-split (g 'authors ""))]
               [tags (string-split (g 'tags ""))]
               [versions (for/list ((old (draft-package-versions draft)))
                           (match-define (list version _) old)
                           (list version
                                 (read-version-source version)))]))

(define (added-and-removed old new)
  (define old-set (list->set (or old '())))
  (define new-set (list->set new))
  (values (set->list (set-subtract new-set old-set))
          (set->list (set-subtract old-set new-set))))

(define (save-draft! draft)
  (match-define (draft-package old-name name description authors tags versions/default) draft)
  (define default-version (assoc "default" versions/default))
  (define source (unparse-package-source (cadr default-version)))
  (define versions (remove default-version versions/default))
  (define old-pkg (package-detail (string->symbol old-name)))
  ;; name, description, and default source are updateable via /jsonp/package/modify.
  ;; tags are added and removed via /jsonp/package/tag/add and .../del.
  ;; authors are added and removed via /jsonp/package/author/add and .../del.
  ;; versions other than default are added and removed via /jsonp/package/version/add and .../del.
  ;;
  ;; modify-all incorporates all the add/delete stuff into a single API call.
  (and (or (equal? old-name name)
           ;; Don't let renames stomp on existing packages
           (not (package-detail (string->symbol name))))
       (eq? #t (simple-json-rpc! "/api/package/modify-all"
                                 (hash 'pkg old-name
                                       'name name
                                       'description description
                                       'source source
                                       'tags tags
                                       'authors authors
                                       'versions versions)))
       (let* ((new-pkg (or old-pkg (hash)))
              (new-pkg (hash-set new-pkg 'name name))
              (new-pkg (hash-set new-pkg 'description description))
              (new-pkg (hash-set new-pkg 'author (string-join authors)))
              (new-pkg (hash-set new-pkg 'authors authors))
              (new-pkg (hash-set new-pkg 'tags tags))
              (new-pkg (hash-set new-pkg 'versions (friendly-versions versions/default)))
              (new-pkg (hash-set new-pkg 'source source))
              (new-pkg (hash-set new-pkg 'search-terms (compute-search-terms new-pkg)))
              (new-pkg (hash-set new-pkg '_LOCALLY_MODIFIED_ #t))
              (completion-ch (make-channel)))
         (replace-package! completion-ch old-pkg new-pkg)
         (channel-get completion-ch)
         #t)))

;; Based on (and copied from) the analogous code in meta/pkg-index/official/static.rkt
(define (compute-search-terms ht)
  (let* ([st (hasheq)]
         [st (for/fold ([st st])
                       ([t (in-list (hash-ref ht 'tags (lambda () '())))])
               (hash-set st (string->symbol t) #t))]
         [st (hash-set
              st
              (string->symbol
               (format "ring:~a" (hash-ref ht 'ring (lambda () 2)))) #t)]
         [st (for/fold ([st st])
                       ([a (in-list (string-split (hash-ref ht 'author (lambda () ""))))])
               (hash-set
                st (string->symbol (format "author:~a" a)) #t))]
         [st (if (null? (hash-ref ht 'tags (lambda () '())))
                 (hash-set st ':no-tag: #t)
                 st)]
         [st (if (hash-ref ht 'checksum-error #f)
                 (hash-set st ':error: #t)
                 st)]
         [st (if (equal? "" (hash-ref ht 'description ""))
                 (hash-set st ':no-desc: #t)
                 st)]
         [st (if (null? (hash-ref ht 'conflicts (lambda () '())))
                 st
                 (hash-set st ':conflicts: #t))])
    st))

(define (friendly-versions draft-versions)
  (for/hash ((v draft-versions))
    (match-define (list version parsed) v)
    (values (string->symbol version)
            (hash 'checksum ""
                  'source (unparse-package-source parsed)
                  ;; N.B. the source_url setting here survives only while we have saved it
                  ;; locally, before the package server catches up! The package server
                  ;; uses its own version of this code and generates its own source_url.
                  ;; However, we ignore source_url from the package server now that
                  ;; parsed-package-source-human-tree-url can do better.
                  'source_url (parsed-package-source-human-tree-url parsed)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (update-my-packages-page request)
  (authentication-wrap/require-login
   #:request request
   (jsonp-rpc! "/jsonp/update" '())
   (bootstrap-response "Refresh All My Packages"
                       `(div
                         (p "All packages where you are listed as an author are now being rescanned.")
                         (p "The results will be available after the next index refresh, which is "
                            "scheduled for " ,(utc->string (/ (next-fetch-deadline) 1000))))
                       `(ul (li (a ((href ,(main-page-url)))
                                   "Return to the package index"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (update-package-ring-page request package-name-str proposed-new-ring)
  (define new-ring (clamp-ring proposed-new-ring))
  (authentication-wrap/require-login
   #:request request
   (when (session-curator? (current-session))
     (when (jsonp-rpc! "/jsonp/package/curate" `((pkg . ,package-name-str)
                                                 (ring . ,(number->string new-ring))))
       (define old-pkg (package-detail (string->symbol package-name-str)))
       (let* ((new-pkg (hash-set old-pkg 'ring new-ring))
              (completion-ch (make-channel)))
         (replace-package! completion-ch old-pkg new-pkg)
         (channel-get completion-ch))))
   (bootstrap-redirect (view-package-url package-name-str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (search-page request)
  (parameterize ((bootstrap-active-navigation nav-search)
                 (bootstrap-page-scripts (list (static-resource-url "/searchbox.js"))))
    (authentication-wrap
     #:request request
     (define-form-bindings request ([search-text q ""]
                                    [tags-input tags ""]))
     (define tags (for/list ((t (string-split tags-input)))
                    (match t
                      [(pregexp #px"!(.*)" (list _ tag)) (list (string->symbol tag) #f)]
                      [tag (list (string->symbol tag) #t)])))
     (bootstrap-response "Search Package Index"
                         #:body-class "search-page"
                         `(form ((class "form-horizontal")
                                 (role "form"))
                           ,(form-group 0 2 (label "q" "Search terms")
                                        0 10 (text-input "q" search-text
                                                         #:placeholder
                                                         "Enter free-form text to match here"))
                           ,(form-group 0 2 (label "tags" "Tags")
                                        0 10(text-input "tags" tags-input
                                                        #:placeholder
                                                        "tag1 tag2 tag3 ..."))
                           ,(form-group 2 10 (primary-button (glyphicon 'search) " Search"))
                           (div ((class "search-results"))
                                ,@(maybe-splice
                                   (or (pair? tags) (not (equal? search-text "")))
                                   (let ((package-name-list (package-search search-text tags)))
                                     `(div
                                       (p ((class "package-count"))
                                          ,(format "~a packages found" (length package-name-list)))
                                       ,(package-summary-table package-name-list))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (cors-json-response f)
  (response/output #:mime-type #"application/json"
                   #:headers (list (header #"Access-Control-Allow-Origin" #"*"))
                   f))

(define (json-search-completions request)
  (define completions (set-union (list->set (map ~a (all-package-names))) (all-formal-tags)))
  (cors-json-response(lambda (response-port) (write-json (set->list completions) response-port))))

(define (json-tag-search-completions request)
  (cors-json-response(lambda (response-port) (write-json (set->list (all-tags)) response-port))))

(define (json-formal-tags request)
  (cors-json-response (lambda (response-port)
                        (write-json (set->list (all-formal-tags)) response-port))))

(define (pkgs-all-json request)
  (cors-json-response (lambda (response-port) (write-json (packages-jsexpr) response-port))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; TODO: fold the collection of this information into the package
;; database itself.
(define (update-external-package-information! package-name)
  (define pkg (package-detail package-name))
  (define default-version (package-default-version pkg))
  (define external-information
    (and pkg
         (if (equal? (@ default-version source)
                     (@ default-version source_url))
             ;; We don't know where to look for a readme.
             (hash)
             ;; It's probably a github-like repo. Check for a readme.
             (let ((contents
                    (with-handlers ([exn:fail:network?
                                     (lambda (e)
                                       (log-warning
                                        "Network error retrieving possible readme for ~a:\n~a"
                                        package-name
                                        (exn->string e))
                                       "")])
                      (define the-port
                        (get-pure-port (string->url (@ default-version source_url))
                                      #:redirections 10))
                      (begin0 (port->string the-port)
                        (close-input-port the-port)))))
               ;;(log-info "CONTENTS: ~a === ~a" (@ default-version source_url) contents)
               (if (regexp-match? #px"(?i:id=.readme.)" contents)
                   (let ((readme-url (string-append (@ default-version source_url) "#readme")))
                     (log-info "Package ~a has a readme at ~a" package-name readme-url)
                     (hash 'readme-url readme-url))
                   (hash))))))
  (set-package-external-information! package-name external-information))

(define (rerender! items-to-rerender)
  (thread-send (package-change-handler-thread) (list 'rerender! items-to-rerender)))

(define (internal:rerender-not-found!)
  ;; TODO: general-purpose error page instead.
  (static-render! #:mime-type "text/html"
                  relative-named-url not-found-page
                  #:ignore-response-code? #t)
  (log-info "Generating .htaccess")
  (static-put-file! "/.htaccess"
                    (string->bytes/utf-8
                     (format "ErrorDocument 404 ~a~a\n"
                             static-urlprefix
                             (relative-named-url not-found-page)))
                    "text/plain")
  (static-finish-update!))

(define (package-change-handler index-rerender-needed? pending-completions)
  (sync/timeout (and index-rerender-needed?
                     (lambda ()
                       (static-render! #:mime-type "text/html"
                                       relative-named-url main-page
                                       #:filename "/index.html")
                       (static-render! #:mime-type "application/json"
                                       relative-named-url json-search-completions)
                       (static-finish-update!)
                       (for ((completion-ch pending-completions))
                         (channel-put completion-ch (void)))
                       (package-change-handler #f '())))
                (handle-evt (thread-receive-evt)
                            (lambda (_)
                              (match (thread-receive)
                                ['upgrade ;; Happens every time site.rkt is reloaded
                                 (internal:rerender-not-found!)
                                 (package-change-handler index-rerender-needed?
                                                         pending-completions)]
                                [(list 'rerender! items-to-rerender)
                                 (log-info "rerender! ~v" items-to-rerender)
                                 (define packages-to-rerender
                                   (if items-to-rerender
                                       (filter symbol? items-to-rerender)
                                       (all-package-names)))
                                 (define total-packages-to-rerender (length packages-to-rerender))
                                 (for [(p packages-to-rerender) (i (in-naturals))]
                                   (log-info "rerendering package ~a, ~a of ~a in this batch"
                                             p
                                             (+ i 1)
                                             total-packages-to-rerender)
                                   (update-external-package-information! p)
                                   (static-render! #:mime-type "text/html"
                                                   relative-named-url
                                                   package-page
                                                   (symbol->string p)))
                                 (package-change-handler #t
                                                         pending-completions)]
                                [(list 'package-changed completion-ch package-name)
                                 (update-external-package-information! package-name)
                                 (static-render! #:mime-type "text/html"
                                                 relative-named-url
                                                 package-page
                                                 (symbol->string package-name))
                                 (package-change-handler
                                  #t
                                  (if completion-ch
                                      (cons completion-ch pending-completions)
                                      pending-completions))])))))

(when (not (package-change-handler-thread))
  (package-change-handler-thread (daemon-thread 'package-change-handler
                                                (lambda () (package-change-handler #f '())))))

(thread-send (package-change-handler-thread) 'upgrade) ;; switch to new code