Generate repo index files on deploy

src/clojars/email.clj

@@ -46,12 +46,14 @@
      (reset! email-latch (CountDownLatch. n))))
 
   (defn wait-for-mock-emails
-    "Blocks for up to 100ms waiting for `n` emails to be sent via the mock,
-  where `n` was passed to `expect-mock-emails` (defaulting to 1 if not called).
-  Returns true if `n` reached within that time. Reset with `expect-mock-emails`
-  between tests using the same system."
-    []
-    (.await @email-latch 100 TimeUnit/MILLISECONDS))
+    "Blocks for up to `wait-ms` (default: 100ms) waiting for `n` emails to be sent
+  via the mock, where `n` was passed to `expect-mock-emails` (defaulting to 1 if
+  not called). Returns true if `n` reached within that time. Reset with
+  `expect-mock-emails` between tests using the same system."
+    ([]
+     (wait-for-mock-emails 100))
+    ([wait-ms]
+     (.await @email-latch wait-ms TimeUnit/MILLISECONDS)))
 
   (defn mock-mailer []
     (expect-mock-emails)

src/clojars/repo_indexing.clj

@@ -0,0 +1,138 @@
+(ns clojars.repo-indexing
+  (:require
+   [clojars.event :as event]
+   [clojars.retry :as retry]
+   [clojars.s3 :as s3]
+   [clojars.web.common :as common]
+   [clojars.web.safe-hiccup :as safe-hiccup]
+   [clojure.java.io :as io]
+   [clojure.string :as str]
+   [hiccup.element :as el])
+  (:import
+   (java.io
+    ByteArrayInputStream)))
+
+(set! *warn-on-reflection* true)
+
+(defn- last-segment
+  [path]
+  (peek (str/split path #"/")))
+
+(defn- entry-line-dispatch
+  [entry]
+  (if (:Prefix entry)
+    :prefix
+    :file))
+
+(defmulti entry-line
+  #'entry-line-dispatch)
+
+(def ^:private name-col-width 50)
+(def ^:private date-col-width 16)
+(def ^:private size-col-width 10)
+
+(defn- blanks
+  [max-len content-str]
+  (apply str (repeat (- max-len (count content-str)) " ")))
+
+(def ^:private dash "-")
+
+(defmethod entry-line :prefix
+  [{:keys [Prefix]}]
+  (let [suffix (format "%s/" (last-segment Prefix))]
+    (list
+     (el/link-to {:title suffix} suffix suffix)
+     (blanks name-col-width suffix)
+     (blanks date-col-width dash)
+     dash
+     (blanks size-col-width dash)
+     dash
+     "\n")))
+
+(defmethod entry-line :file
+  [{:keys [Key LastModified Size]}]
+  (let [file-name (last-segment Key)
+        size (str Size)]
+    (list
+     (el/link-to {:title file-name} file-name file-name)
+     (blanks name-col-width file-name)
+     (common/format-date-with-time LastModified)
+     (blanks size-col-width size)
+     size
+     "\n")))
+
+(defn generate-index
+  ^String
+  [path entries]
+  (safe-hiccup/html5
+   {:lang "en"}
+   [:head
+    [:meta {:charset "utf-8"}]
+    [:meta {:name "viewport" :content "width=device-width,initial-scale=1"}]
+    [:title (format "Clojars Repository: %s" path)]]
+   [:body
+    [:header
+     [:h1 (or path "/")]]
+    [:hr]
+    [:main
+     [:pre#contents
+      (when (some? path)
+        (list
+         (el/link-to "../" "../")
+         "\n"))
+      (mapcat entry-line entries)]]
+    [:hr]]))
+
+(defn- sort-entries
+  [entries]
+  (sort
+   (fn [e1 e2]
+     (cond
+       (and (:Prefix e1) (:Prefix e2)) (compare (:Prefix e1) (:Prefix e2))
+       (:Prefix e1)                    -1
+       (:Prefix e2)                    1
+       :else                           (compare (:Key e1) (:Key e2))))
+   entries))
+
+(def ^:private index-file-name "index.html")
+
+(defn get-path-entries
+  [repo-bucket path]
+  (->> (s3/list-entries repo-bucket path)
+       ;; filter out index files
+       (remove (fn [{:keys [Key]}]
+                 (and Key
+                      (str/ends-with? Key index-file-name))))
+       (sort-entries)))
+
+(defn normalize-path
+  [path]
+  (let [path (cond
+               (str/blank? path)           nil
+               (= "/" path)                nil
+               (str/starts-with? path "/") (subs path 1)
+               :else                       path)]
+    (if (and (some? path)
+             (not (str/ends-with? path "/")))
+      (str path "/")
+      path)))
+
+(defn handler
+  [{:keys [error-reporter repo-bucket]} type {:as _data :keys [path]}]
+  (when (= :repo-path-needs-index type)
+    (let [path (normalize-path path)]
+      (retry/retry {:error-reporter error-reporter}
+                   (when-some [entries (get-path-entries repo-bucket path)]
+                     (let [key (if path
+                                 (format "%s%s" path index-file-name)
+                                 index-file-name)
+                           index (generate-index path entries)]
+                       (s3/put-object repo-bucket
+                                      key
+                                      (io/input-stream (ByteArrayInputStream. (.getBytes index)))
+                                      {:ContentType (s3/content-type key)})))))))
+
+(defn repo-indexing-component
+  "Handles async repo-indexing for a path. Needs the error-reporter & repo-bucket components."
+  []
+  (event/handler-component #'handler))

src/clojars/retry.clj

@@ -0,0 +1,27 @@
+(ns clojars.retry
+  (:require
+   [clojars.errors :as errors]))
+
+(defn retry*
+  [{:keys [n sleep jitter error-reporter]
+    :or {sleep 1000
+         jitter 20
+         n 3}}
+   f]
+  (loop [i n]
+    (if (> i 0)
+      (let [result (try
+                     (f)
+                     (catch Exception t
+                       t))]
+        (if (instance? Exception result)
+          (do (errors/report-error error-reporter result)
+              (Thread/sleep (+ sleep (rand-int jitter)))
+              (recur (dec i)))
+          result))
+      (throw (ex-info (format "Retry limit %s has been reached" n)
+                      {:n n :sleep sleep :jitter jitter})))))
+
+(defmacro retry
+  [opts & body]
+  `(retry* ~opts (fn [] ~@body)))

src/clojars/routes/repo.clj

@@ -329,8 +329,23 @@
     (when (= :single-use-status/yes (:single_use token))
       (db/consume-deploy-token db (:id token)))))
 
+(defn- gen-repo-paths
+  [{:as _version-data :keys [group-path name version]}]
+  (let [parts (conj (str/split group-path #"/")
+                    name version)]
+    (reduce
+     (fn [acc part]
+       (conj acc
+             (if (str/blank? (peek acc))
+               part
+               (format "%s/%s" (peek acc) part))))
+     [""]
+     parts)))
+
 (defn- emit-deploy-events
   [db event-emitter {:as version-data :keys [group]}]
+  (doseq [path (gen-repo-paths version-data)]
+    (event/emit event-emitter :repo-path-needs-index {:path path}))
   (doseq [user (db/group-active-users db group)]
     (event/emit event-emitter :version-deployed (assoc version-data :user user))))
 

src/clojars/s3.clj

@@ -214,6 +214,7 @@
        :clj            :txt
        :eclipse-plugin :zip
        :gz             "application/gzip"
+       :html           "text/html"
        :jar            "application/x-java-archive"
        :md5            :txt
        :pom            :xml

src/clojars/storage.clj

@@ -1,8 +1,8 @@
 (ns clojars.storage
   (:require
    [clojars.cdn :as cdn]
-   [clojars.errors :as errors]
    [clojars.file-utils :as fu]
+   [clojars.retry :as retry]
    [clojars.s3 :as s3]
    [clojure.java.io :as io])
   (:import
@@ -97,34 +97,16 @@
       (when (not= "ok" status)
         (throw (ex-info (format "Fastly purge failed for %s" path) resp))))))
 
-(defn- retry
-  [f {:keys [n sleep jitter error-reporter]
-      :or {sleep 1000
-           jitter 20
-           n 3}}]
-  (loop [i n]
-    (if (> i 0)
-      (let [result (try
-                     (f)
-                     (catch Exception t
-                       t))]
-        (if (instance? Exception result)
-          (do (errors/report-error error-reporter result)
-              (Thread/sleep (+ sleep (rand-int jitter)))
-              (recur (dec i)))
-          result))
-      (throw (ex-info (format "Retry limit %s has been reached" n) {:n n :sleep sleep :jitter jitter})))))
-
 (defrecord CDNStorage [error-reporter cdn-token cdn-url]
   Storage
   (-write-artifact [_ path _ _]
     ;; Purge any file in the deploy in case it has been requested in
     ;; the last 24 hours, since fastly will cache the 404.  Run in a
     ;; future so we don't have to wait for the request to finish to
     ;; complete the deploy.
-    (future (retry
-             #(purge cdn-token cdn-url path)
-             {:error-reporter error-reporter})))
+    (future (retry/retry
+             {:error-reporter error-reporter}
+             (purge cdn-token cdn-url path))))
   (remove-path [_ path]
     (purge cdn-token cdn-url path))
   (path-exists? [_ _])

src/clojars/system.clj

@@ -12,6 +12,7 @@
    [clojars.oauth.github :as github]
    [clojars.oauth.gitlab :as gitlab]
    [clojars.remote-service :as remote-service]
+   [clojars.repo-indexing :as repo-indexing]
    [clojars.ring-servlet-patch :as patch]
    [clojars.s3 :as s3]
    [clojars.search :as search]
@@ -91,6 +92,7 @@
           :mailer         (simple-mailer (:mail config))
           :notifications  (notifications/notification-component)
           :repo-bucket    (s3/s3-client (get-in config [:s3 :repo-bucket]))
+          :repo-indexer   (repo-indexing/repo-indexing-component)
           :repo-lister    (repo-listing/repo-lister (:cache-path config))
           :storage        (storage-component (:repo config) (:cdn-token config) (:cdn-url config))))
         (component/system-using
@@ -100,6 +102,7 @@
           :event-emitter  [:error-reporter]
           :http           [:app]
           :notifications  [:db :mailer]
+          :repo-indexer   [:error-reporter :repo-bucket]
           :repo-lister    [:repo-bucket]
           :event-receiver [:error-reporter]
           :storage        [:error-reporter :repo-bucket]}))))