Refactor content negotiation and conditional requests implementation

CHANGES.markdown

@@ -2,6 +2,11 @@
 
 # Unreleased
 
+* Refactoring of content negotiation, get rid of internal decision points
+  :accept-exists?, :accept-language-exists?, :accept-encoding-exists?,
+  :accept-charset-exists? Empty Accept-* headers are treatened as
+  absent.
+
 # New in 0.14.1
 
 * Improved highlighting of tracing view

src/liberator/conneg.clj

@@ -134,7 +134,7 @@
                x)))
 
 (defn stringify [type]
-  (reduce str (interpose "/" type)))
+  (string/join "/" type))
 
 (defn best-allowed-content-type
   "Return the first type in the Accept header that is acceptable.

src/liberator/core.clj

@@ -44,11 +44,10 @@
   (doseq [l *loggers*]
     (l category values)))
 
-(declare if-none-match-exists?)
-
 (defn map-values [f m]
   (persistent! (reduce-kv (fn [out-m k v] (assoc! out-m k (f v))) (transient {}) m)))
 
+
 (defn request-method-in [& methods]
   #(some #{(:request-method (:request %))} methods))
 
@@ -189,12 +188,6 @@
   `(defn ~name [context#]
      (run-handler '~name ~status ~message context#)))
 
-(defn header-exists? [header context]
-  (get-in context [:request :headers header]))
-
-(defn if-match-star [context]
-  (= "*" (get-in context [:request :headers "if-match"])))
-
 (defn =method [method context]
   (= (get-in context [:request :request-method]) method))
 
@@ -280,7 +273,7 @@
 (defhandler handle-precondition-failed 412 "Precondition failed.")
 
 (defdecision if-match-star-exists-for-missing?
-  if-match-star
+  (fn [context] (= "*" (get-in context [:request :headers "if-match"])))
   handle-precondition-failed
   method-put?)
 
@@ -311,155 +304,113 @@
   method-patch?)
 
 (defdecision modified-since?
-  (fn [context]
-    (let [last-modified (gen-last-modified context)]
-      [(and last-modified (.after last-modified (::if-modified-since-date context)))
-       {::last-modified last-modified}]))
+  (fn [{:keys [request] :as context}]
+    (let [modified-since (parse-http-date (get-in request [:headers "if-modified-since"]))]
+      (or (nil? modified-since)
+          (let [last-modified (gen-last-modified context)]
+            [(and last-modified (.after last-modified modified-since))
+             {::last-modified last-modified}]))))
   method-delete?
   handle-not-modified)
 
-(defdecision if-modified-since-valid-date?
-  (fn [context]
-    (if-let [date (parse-http-date (get-in context [:request :headers "if-modified-since"]))]
-      {::if-modified-since-date date}))
-  modified-since?
-  method-delete?)
-
-(defdecision if-modified-since-exists?
-  (partial header-exists? "if-modified-since")
-  if-modified-since-valid-date?
-  method-delete?)
-
 (defdecision etag-matches-for-if-none?
-  (fn [context]
-    (let [etag (gen-etag context)]
-      [(= (get-in context [:request :headers "if-none-match"]) etag)
-       {::etag etag}]))
+  (fn [{:keys [request] :as context}]
+    (if-let [if-none-match (get-in context [:request :headers "if-none-match"])]
+      (let [etag (gen-etag context)]
+        [(#{"*" etag} if-none-match)
+         {::etag etag}])))
   if-none-match?
-  if-modified-since-exists?)
-
-(defdecision if-none-match-star?
-  #(= "*" (get-in % [:request :headers "if-none-match"]))
-  if-none-match?
-  etag-matches-for-if-none?)
-
-(defdecision if-none-match-exists? (partial header-exists? "if-none-match")
-  if-none-match-star? if-modified-since-exists?)
+  modified-since?)
 
 (defdecision unmodified-since?
-  (fn [context]
-    (let [last-modified (gen-last-modified context)]
-      [(and last-modified
-            (.after last-modified
-                    (::if-unmodified-since-date context)))
-       {::last-modified last-modified}]))
+  (fn [{:keys [request] :as context}]
+    (when-let [unmodified-since (parse-http-date (get-in request [:headers "if-unmodified-since"]))]
+      (let [last-modified (gen-last-modified context)]
+        [(and last-modified (.after last-modified unmodified-since))
+         {::last-modified last-modified}])))
   handle-precondition-failed
-  if-none-match-exists?)
-
-(defdecision  if-unmodified-since-valid-date?
-  (fn [context]
-    (when-let [date (parse-http-date (get-in context [:request :headers "if-unmodified-since"]))]
-      {::if-unmodified-since-date date}))
-  unmodified-since?
-  if-none-match-exists?)
+  etag-matches-for-if-none?)
 
-(defdecision if-unmodified-since-exists? (partial header-exists? "if-unmodified-since")
-  if-unmodified-since-valid-date? if-none-match-exists?)
+(defn- match-etag-for-existing [{:keys [request resource] :as context}]
+  (let [if-match (get-in request [:headers "if-match"])]
+    (or (empty? if-match)
+        (= "*" if-match)
+        (let [etag (gen-etag context)]
+          [(= etag if-match)
+           {::etag etag}]))))
 
 (defdecision etag-matches-for-if-match?
-  (fn [context]
-    (let [etag (gen-etag context)]
-      [(= etag (get-in context [:request :headers "if-match"]))
-       {::etag etag}]))
-  if-unmodified-since-exists?
+  match-etag-for-existing
+  unmodified-since?
   handle-precondition-failed)
 
-(defdecision if-match-star?
-  if-match-star if-unmodified-since-exists? etag-matches-for-if-match?)
-
-(defdecision if-match-exists? (partial header-exists? "if-match")
-  if-match-star? if-unmodified-since-exists?)
-
-(defdecision exists? if-match-exists? if-match-star-exists-for-missing?)
+(defdecision exists? etag-matches-for-if-match? if-match-star-exists-for-missing?)
 
 (defhandler handle-unprocessable-entity 422 "Unprocessable entity.")
+
 (defdecision processable? exists? handle-unprocessable-entity)
 
 (defhandler handle-not-acceptable 406 "No acceptable resource available.")
 
-(defdecision encoding-available?
-  (fn [ctx]
-    (when-let [encoding (conneg/best-allowed-encoding
-                         (get-in ctx [:request :headers "accept-encoding"])
-                         ((get-in ctx [:resource :available-encodings]) ctx))]
-      {:representation {:encoding encoding}}))
-
-  processable? handle-not-acceptable)
-
 (defmacro try-header [header & body]
   `(try ~@body
         (catch ProtocolException e#
           (throw (ProtocolException.
                   (format "Malformed %s header" ~header) e#)))))
 
-(defdecision accept-encoding-exists? (partial header-exists? "accept-encoding")
-  encoding-available? processable?)
-
-(defdecision charset-available?
-  #(try-header "Accept-Charset"
-               (when-let [charset (conneg/best-allowed-charset
-                                   (get-in % [:request :headers "accept-charset"])
-                                   ((get-in context [:resource :available-charsets]) context))]
-                 (if (= charset "*")
-                   true
-                   {:representation {:charset charset}})))
-  accept-encoding-exists? handle-not-acceptable)
-
-(defdecision accept-charset-exists? (partial header-exists? "accept-charset")
-  charset-available? accept-encoding-exists?)
-
-
-(defdecision language-available?
-  #(try-header "Accept-Language"
-               (when-let [lang (conneg/best-allowed-language
-                                (get-in % [:request :headers "accept-language"])
-                                ((get-in context [:resource :available-languages]) context))]
-                 (if (= lang "*")
-                   true
-                   {:representation {:language lang}})))
-  accept-charset-exists? handle-not-acceptable)
-
-(defdecision accept-language-exists? (partial header-exists? "accept-language")
-  language-available? accept-charset-exists?)
-
-(defn negotiate-media-type [context]
+(defn- negotiate-encoding [{:keys [request resource] :as context}]
+  (try-header "Accept-Encoding"
+              (let [accept (get-in request [:headers "accept-encoding"])]
+                (or (empty? accept)
+                    (when-let [encoding (conneg/best-allowed-encoding
+                                         accept
+                                         ((:available-encodings resource) context))]
+                      {:representation {:encoding encoding}})))) )
+
+(defdecision encoding-available? negotiate-encoding
+  processable? handle-not-acceptable)
+
+(defn- negotiate-charset [{:keys [request resource] :as context}]
+  (try-header "Accept-Charset"
+              (let [accept (get-in request [:headers "accept-charset"])]
+                (or (empty? accept)
+                    (when-let [charset (conneg/best-allowed-charset
+                                        accept
+                                        ((:available-charsets resource) context))]
+                      {:representation {:charset charset}})))))
+
+(defdecision charset-available? negotiate-charset
+  encoding-available? handle-not-acceptable)
+
+(defn negotiate-language [{:keys [request resource] :as context}]
+  (try-header "Accept-Language"
+              (let [accept (get-in request [:headers "accept-language"])]
+                (if-let [lang (conneg/best-allowed-language
+                               (if-not (empty? accept) accept "*" )
+                               ((:available-languages resource) context))]
+                  (or (= "*" lang) {:representation {:language lang}})
+                  (empty? accept)))))
+
+(defdecision language-available? negotiate-language
+  charset-available? handle-not-acceptable)
+
+(defn negotiate-media-type [{:keys [request resource] :as context}]
   (try-header "Accept"
-              (when-let [type (conneg/best-allowed-content-type
-                               (get-in context [:request :headers "accept"])
-                               ((get-in context [:resource :available-media-types] (constantly "text/html")) context))]
-                {:representation {:media-type (conneg/stringify type)}})))
+              (let [accept (get-in request [:headers "accept"])]
+                (if-let [type (conneg/best-allowed-content-type
+                               (if-not (empty? accept) accept "*/*")
+                               ((:available-media-types resource) context))]
+                  {:representation {:media-type (conneg/stringify type)}}
+                  ;; if there's no accept headers and we cannot negotiate a
+                  ;; media type then continue
+                  (empty? accept)))))
 
 (defdecision media-type-available? negotiate-media-type
-  accept-language-exists? handle-not-acceptable)
-
-(defdecision accept-exists?
-  #(if (header-exists? "accept" %)
-     true
-     ;; "If no Accept header field is present, then it is assumed that the
-     ;; client accepts all media types" [p100]
-     ;; in this case we do content-type negotiation using */* as the accept
-     ;; specification
-     (if-let [type (liberator.conneg/best-allowed-content-type
-                    "*/*"
-                    ((get-in context [:resource :available-media-types]) context))]
-       [false {:representation {:media-type (liberator.conneg/stringify type)}}]
-       false))
-  media-type-available?
-  accept-language-exists?)
+  language-available? handle-not-acceptable)
 
 (defhandler handle-options 200 nil)
 
-(defdecision is-options? #(= :options (:request-method (:request %))) handle-options accept-exists?)
+(defdecision is-options? #(= :options (:request-method (:request %))) handle-options media-type-available?)
 
 (defhandler handle-request-entity-too-large 413 "Request entity too large.")
 (defdecision valid-entity-length? is-options? handle-request-entity-too-large)
@@ -519,8 +470,6 @@
    :method-allowed?           (test-request-method :allowed-methods)
 
    :malformed?                false
-   ;;      :encoding-available?       true
-   ;;      :charset-available?        true
    :authorized?               true
    :allowed?                  true
    :valid-content-header?     true

src/liberator/dev.clj

@@ -79,12 +79,12 @@
                                (format
                                 "svg.getElementById(\"%s\").setAttribute(\"class\", svg.getElementById(\"%s\").getAttribute(\"class\") + \" %s\");" id id (if (result->bool r1) "hl-true" "hl-false"))))
                           (map vector log (rest log))))
-               
+
                "};"
                "setTimeout(function(){insertStyle()}, 500);"
                "setTimeout(function(){insertStyle()}, 1000);"
                "setTimeout(function(){insertStyle()}, 5000);"
-               
+
                ""])]
        [:body
         [:a {:href mount-url} "List of all traces"]
@@ -99,10 +99,10 @@
         [:ol (map (fn [[l [n r]]] [:li (h l) ": " (h n) " "
                                   (if (nil? r) [:em "nil"] (h (pr-str r)))]) log)]
         [:div {:style "text-align: center;"}
-         [:object {:id "trace" :data (str mount-url "trace.svg") :width "90%"
+         [:object {:id "trace" :data (str mount-url "trace.svg") :width "100%"
                    :style "border: 1px solid #666;"}]]
 
-        
+
         [:h3 "Full Request"]
         [:pre [:tt (h (with-out-str (clojure.pprint/pprint r)))]]])
       "application/json"
@@ -123,7 +123,7 @@
 
 (defresource list-handler
   :available-media-types ["text/html"]
-  :handle-ok (fn [_] 
+  :handle-ok (fn [_]
                (html5
                 [:head
                  [:title "Liberator Request Traces"]]
@@ -168,11 +168,11 @@
   :available-media-types ["text/css"]
   :handle-ok "#x-liberator-trace {
   display:block;
-  
+
   position:absolute;
   top:0;
   right:0;
-  
+
   margin-top: 1em;
   margin-right: 1em;
   padding: 0 1em;
@@ -192,7 +192,6 @@
 (defn- wrap-trace-ui [handler]
   (let [base-url (with-slash mount-url)]
     (routes
-     ;;           (fn [_] 
      (GET (str base-url "trace.svg") [] (fn [_]  trace-svg))
      (ANY (str base-url "styles.css") [] styles)
      (ANY [(str base-url ":id") :id #".+"] [id] #((log-handler id) %))
@@ -226,7 +225,7 @@
    :ui     - Include link to a resource that dumps the current request
    :header - Include full trace in response header"
   [handler & opts]
-  (-> 
+  (->
    (fn [request]
      (let [request-log (atom [])]
        (binding [*current-id* (next-id)]