;; Continuation-based web framework

;; by Jim Duey
;; last updated Dec 5, 2009

;; Copyright (c) Jim Duey, 2009. All rights reserved.  The use
;; and distribution terms for this software are covered by the Eclipse
;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; which can be found in the file epl-v10.html at the root of this
;; distribution.  By using this software in any fashion, you are
;; agreeing to be bound by the terms of this license.  You must not
;; remove this notice, or any other, from this software.


(ns web-session
  (:use clojure.contrib.monads))

; manage the history data structure so the browser back button works
(defn- check-history [context request]
  (get (:history context) (:screen-id (:params request))))

(defn- update-history [context request-screen continuation]
  (if (nil? request-screen)
    context
    (merge-with merge context
                {:history {request-screen continuation}})))

(defn- call-web-fn [f context request]
  (let [app-context (:app-context context)
        [result app-context] (f app-context request)
        new-context (assoc context :app-context app-context)]
    (if (nil? result)
      [nil new-context]
      [result (update-history new-context
                              (:screen-id (:params request))
                              (:current-handler context))])))

(with-monad cont-m
            ; compose request handlers sequentially
            (defn web-seq [& web-fns]
              (m-chain web-fns))

            ; convert a request handler function into continuation passing style
            ; also implement the history functionality
            (defn make-web-fn [f]
              (fn [[context request]]
                (let [screen-handler (check-history context request)
                      [result new-context] (when (nil? screen-handler)
                                             (call-web-fn f context request))]
                  (cond
                    screen-handler (fn [continuation]
                                     (screen-handler request))
                    (nil? result) (m-result [new-context request])
                    :else (fn [continuation]
                            [result (fn handler [new-request]
                                      (continuation [(assoc new-context :current-handler handler)
                                                     new-request]))])))))

            ; the conditional construct
            (defn web-cond [& preds-conts]
              (fn [[context request]]
                (let [pairs (partition 2 preds-conts)
                      successes (filter (fn [[pred c]]
                                          (or (= pred :else)
                                              (pred (:app-context context) request)))
                                        pairs)
                      cond-c (second (first successes))]
                  (if (nil? cond-c)
                    (m-result [context request])
                    (cond-c [context request])))))

            ; the 'loop while condition is true' construct
            (defn web-while [pred while-c]
              (fn this-fn [[context request]]
                (if (pred (:app-context context) request)
                  (m-bind (while-c [context request])
                           this-fn)
                  (m-result [context request]))))

            ; the 'loop until a condition is true' construct
            (defn web-until [pred until-c]
              (web-seq until-c
                       (web-while (complement pred)
                                  until-c))))

; macro to define a composable web request handler function
(defmacro web-fn [fn-name parms & body]
  `(def ~fn-name
     (make-web-fn (fn ~parms
                    ~@body))))

(def id-count (ref 1))

(defn new-id []
  (dosync (ref-set id-count (inc @id-count)))
  (str @id-count))

(def sessions (ref {}))

; top level request handler
(defn handle-request [request session-start]
  (let [session-id (get (:params request) :session-id (new-id))
        session (get @sessions session-id)
        [result next-handler] (if session
                                (session request)
                                (run-cont (session-start [{:app-context {:session-id session-id}} request])))]
    (dosync (ref-set sessions (assoc @sessions session-id next-handler)))
    result))


; unit test the library
  ; change the 'comment' to 'do' to enable the unit tests
(do
  ; some functions for unit testing
  ; For ease of testing, these functions expect a list as the context. This means that they
  ; are unsuitable for use with 'handle-request'
  (defn- c-inc [x r]
;    (println "inc x:" x "r:" r)
    [(inc r) (conj x :inc)])

  (defn- c-*2 [x r]
;    (println "double x:" x "r:" r)
    [(* 2 r) (conj x :double)])

  (defn- c-nothing [x r]
;    (println "nothing x:" x "r:" r)
    [nil (conj x :nothing)])

  ; apply a list of requests to a web app
  (defn all [[result continuation] requests]
    (if (not (fn? continuation))
      [[result continuation]]
      (cons result
            (when (not-empty requests)
              (all (continuation (first requests)) (rest requests))))))

  ; a web function that returns the context as a result
  (def app-context (make-web-fn (fn [context request]
                                  [context context])))

  ; unit test web-seq and make-web-fn
  (def ts (web-seq (make-web-fn c-inc)
                   (make-web-fn c-*2)
                   (make-web-fn c-nothing)
                   (make-web-fn c-inc)
                   app-context))

  (assert (= [24 100 46 [:init :inc :double :nothing :inc]]
             (all (run-cont (ts [{:app-context [:init]} 23])) [50 45 nil])))

  (def ts (web-seq (make-web-fn c-inc)
                   (web-seq (make-web-fn c-*2)
                            (make-web-fn c-nothing)
                            (make-web-fn c-inc)
                            app-context)))

  (assert (= [24 100 46 [:init :inc :double :nothing :inc]]
             (all (run-cont (ts [{:app-context [:init]} 23])) [50 45 nil])))

  ; unit testing the conditional construct
  (defn- lt100 [x r]
    (< r 100))

  (defn- gt100 [x r]
    (> r 100))

  (def tc (web-cond
            lt100 (web-seq (make-web-fn c-*2)
                           (make-web-fn c-*2))
            gt100 (web-seq (make-web-fn c-inc)
                           (make-web-fn c-inc))))

  (def ts (web-seq (make-web-fn c-inc)
                   tc
                   (make-web-fn c-nothing)
                   app-context))

  (assert (= [24 100 90 [:init :inc :double :double :nothing]]
             (all (run-cont (ts [{:app-context [:init]} 23])) [50 45 nil])))

  (assert (= [24 106 251 [:init :inc :inc :inc :nothing]]
             (all (run-cont (ts [{:app-context [:init]} 23])) [105 250 nil])))

  (assert (= [24 [:init :inc :nothing]]
             (take 2 (all (run-cont (ts [{:app-context [:init]} 23])) [100 250 nil]))))

  ; unit test the loop while true construct
  (def ts (web-seq
            (web-while lt100
                       (make-web-fn c-*2))
            app-context))

  (assert (= [46 72 [:init :double :double]]
             (take 3 (all (run-cont (ts [{:app-context [:init]} 23])) [36 100 250]))))

  ; unit test the loop until true construct
  (def ts (web-seq
            (web-until gt100
                       (make-web-fn c-*2))
            app-context))

  (assert (= [46 72 200 [:init :double :double :double]]
             (all (run-cont (ts [{:app-context [:init]} 23])) [36 100 250])))

  (web-fn page-1 [context request]
;          (println "1 choice:" (:choice (:params request)))
          [:from-1 (assoc context 1 (:screen-id (:params request)))])

  (web-fn page-2 [context request]
;          (println "2 choice:" (:choice (:params request)))
          [:from-2 (assoc context 2 (:screen-id (:params request)))])

  (web-fn page-3 [context request]
;          (println "3 choice:" (:choice (:params request)))
          [:from-3 (assoc context 3 (:screen-id (:params request)))])

  (web-fn page-4 [context request]
;          (println "4 choice:" (:choice (:params request)))
          [:from-4 (assoc context 4 (:screen-id (:params request)))])

  (web-fn page-5 [context request]
;          (println "5 choice:" (:choice (:params request)))
          [:from-5 (assoc context 5 (:screen-id (:params request)))])

  (web-fn page-a [context request]
;          (println "a choice:" (:choice (:params request)))
          [:from-a (assoc context :a (:screen-id (:params request)))])

  (web-fn page-b [context request]
;          (println "b choice:" (:choice (:params request)))
          [:from-b (assoc context :b (:screen-id (:params request)))])

  (web-fn do-nothing [context request]
;          (println "doing nothing")
          [nil (assoc context :nothing (:choice (:params request)))])

  (defn chose-a? [context request]
;    (println "choice-a?:" (:choice (:params request)))
    (= "a" (:choice (:params request))))

  (defn chose-b? [context request]
;    (println "choice-b?:" (:choice (:params request)))
    (= "b" (:choice (:params request))))

  (def test-history (web-seq page-1
                             page-2
                             do-nothing
                             (web-cond
                               chose-a? page-a
                               chose-b? page-b)
                             page-4
                             page-5
                             app-context))

  (def test-requests [{:params {:session-id 1 :screen-id 1}}
                      {:params {:session-id 1 :screen-id 2}}
                      {:params {:session-id 1 :screen-id 3 :choice "b"}}
                      {:params {:session-id 1 :screen-id 4}}
                      {:params {:session-id 1 :screen-id 5}}
                      {:params {:session-id 1 :screen-id 3 :choice "a"}}
                      {:params {:session-id 1 :screen-id 10}}
                      {:params {:session-id 1 :screen-id 11}}
                      {}
                      ])

  (assert (= [:from-1 :from-2 :from-b :from-4 :from-5 :from-a :from-4 :from-5 {5 11, 4 10, :a 3, :nothing "a", 2 2, 1 1}]
             (all (run-cont (test-history [{} (first test-requests)])) (rest test-requests))))

  (def test-history (web-while (constantly true)
                               (web-seq page-1
                                        page-2
                                        do-nothing
                                        (web-cond
                                          chose-a? page-a
                                          chose-b? page-b)
                                        page-4
                                        page-5
                                        app-context)))

  (assert (= [:from-1 :from-2 :from-b :from-4 :from-5 :from-a :from-4 :from-5 {5 11, 4 10, :a 3, :nothing "a", 2 2, 1 1}]
             (all (run-cont (test-history [{} (first test-requests)])) (rest test-requests))))

(web-fn page-1 [context request]
;        (println "page 1")
        ["name-page" 
         context])

(web-fn page-2 [context request]
;        (println "page 2")
        ["age-page" 
         context])

(web-fn page-3 [context request]
;        (println "page 3")
        ["gender-page" 
         context])

(web-fn page-4 [context request]
;        (println "page 4")
        ["summary-page" 
         context])

(def test-app (web-while (constantly true)
                        (web-seq page-1
                                 page-2
                                 page-3
                                 page-4)))

(def app-test
  [{}
   {:params {:session-id 1 :screen-id "78" :first-name "f" :last-name "o"}}
   {:params {:session-id 1 :screen-id "79" :age "30"}}
   {:params {:session-id 1 :screen-id "78" :first-name "Fred" :last-name "Ott"}}
   ])

(assert (= ["name-page" "age-page" "gender-page" "age-page"]
           (all (run-cont (test-app [{} (first app-test)])) (rest app-test))))

  )