Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

420 lines (386 sloc) 16.575 kB
(ns foreclojure.problems
(:use (foreclojure utils config
[social :only [tweet-link gist!]]
[feeds :only [create-feed]]
[users :only [golfer? get-user-id]]
[solutions :only [save-solution get-solution]])
(clojail [core :exclude [safe-read]] testers)
somnium.congomongo
(hiccup form-helpers page-helpers core)
(amalloy.utils [debug :only [?]]
[reorder :only [reorder]])
[amalloy.utils :only [defcomp]]
compojure.core)
(:require [sandbar.stateful-session :as session]
[clojure.string :as s]
(ring.util [response :as response])))
(def total-solved (agent 0))
(defn get-problem [x]
(from-mongo
(fetch-one :problems :where {:_id x})))
(defn get-problem-list
([] (get-problem-list {:approved true}))
([criteria]
(from-mongo
(fetch :problems
:only [:_id :title :tags :times-solved :user]
:where criteria
:sort {:_id 1}))))
(defn next-unsolved-problem [solved-problems]
(when-let [unsolved (->> (get-problem-list)
(remove (comp (set solved-problems) :_id))
(seq))]
(apply min-key :_id unsolved)))
(defn next-problem-link [completed-problem-id]
(when-let [{:keys [solved]} (get-user (session/session-get :user))]
(if-let [{:keys [_id title]} (next-unsolved-problem solved)]
(str "Now try <a href='/problem/" _id "'>" title "</a>!")
"You've solved them all! Come back later for more!")))
(defn get-recent-problems [n]
(map get-problem (map :_id (take-last n (get-problem-list)))))
(defn problem-feed [n]
(reduce (fn [feed v]
(conj feed [:item
[:guid (str "http://4clojure.com/problem/" (:_id v))]
[:title (:title v)]
[:description (:description v)]]))
()
(get-recent-problems n)))
(defcomp mongo-key-from-number
"Turn an integer into a key suitable for fetching from mongodb."
[id]
keyword str int)
(defn code-length [code]
(count (remove #(Character/isWhitespace %)
code)))
(defn record-golf-score! [user-id problem-id score]
(let [user-score-key (keyword (str "scores." problem-id))
problem-score-key (keyword (str "scores." score))
[problem-scores-key user-subkey] (map mongo-key-from-number
[score problem-id])]
(when-let [{:keys [_id scores] :as user}
(from-mongo
(fetch-one :users
:where {:_id user-id}))]
(let [old-score-real (get scores user-subkey)
old-score-test (or old-score-real 1e6)
old-score-key (keyword (str "scores." old-score-real))]
(when (golfer? user)
(session/session-put! :golf-chart
{:id problem-id
:score score
:best old-score-real}))
(when (< score old-score-test)
(update! :problems
{:_id problem-id,
old-score-key {:$gt 0}}
{:$inc {old-score-key -1}})
(update! :problems
{:_id problem-id}
{:$inc {problem-score-key 1}})
(update! :users
{:_id _id}
{:$set {user-score-key score}}))))))
(defn store-completed-state! [username problem-id code]
(let [{user-id :_id} (fetch-one :users
:where {:user username}
:only [:_id])]
(when (not-any? #{problem-id} (get-solved username))
(update! :users {:_id user-id} {:$addToSet {:solved problem-id}})
(update! :problems {:_id problem-id} {:$inc {:times-solved 1}})
(send total-solved inc))
(record-golf-score! user-id problem-id (code-length code))
(save-solution user-id problem-id code)))
(defn mark-completed [problem code & [user]]
(let [user (or user (session/session-get :user))
{:keys [_id approved]} problem
gist-link (html [:div.share
[:a.novisited {:href "/share/code"} "Share"]
" this solution with your friends!"])
message
(cond
(not approved) (str "You've solved the unapproved problem. Now you can approve it!")
user (do
(store-completed-state! user _id code)
(str "Congratulations, you've solved the problem!"
"<br />" (next-problem-link _id)))
:else (str "You've solved the problem! If you "
(login-link "log in") " we can track your progress."))]
(session/session-put! :code [_id code])
(flash-msg (str message " " gist-link) (str "/problem/" _id))))
(def restricted-list '[use require in-ns future agent send send-off pmap pcalls])
(defn get-tester [restricted]
(into secure-tester (concat restricted-list (map symbol restricted))))
(def sb (sandbox*))
(defn read-string-safely [s]
(binding [*read-eval* false]
(with-in-str s
(let [end (Object.)]
(doall (take-while (complement #{end})
(repeatedly #(read *in* false end))))))))
(defn run-code [id raw-code]
(let [code (.trim raw-code)
{:keys [tests restricted] :as problem} (get-problem id)
sb-tester (get-tester restricted)]
(session/flash-put! :code code)
(try
(let [user-forms (s/join " " (map pr-str (read-string-safely code)))]
(if (empty? user-forms)
(flash-msg "Empty input is not allowed" *url*)
(loop [[test & more] tests
i 0]
(session/flash-put! :failing-test i)
(if-not test
(mark-completed problem code)
(let [testcase (s/replace test "__" user-forms)]
(if (sb sb-tester (first (read-string-safely testcase)))
(recur more (inc i))
(flash-msg "You failed the unit tests." *url*)))))))
(catch Exception e
(flash-msg (.getMessage e) *url*)))))
(defn render-test-cases [tests]
[:table {:class "testcases"}
(let [fail (session/flash-get :failing-test)]
(for [[idx test] (map-indexed list tests)]
[:tr
[:td
[:img {:src (cond
(or (nil? fail) (> idx fail)) "/images/bluelight.png"
(= idx fail) "/images/redlight.png"
:else "/images/greenlight.png")}]]
[:td
[:pre {:class "brush: clojure;gutter: false;toolbar: false;light: true"}
test]]]))])
(defn render-golf-chart []
(let [{:keys [id best score] :as settings}
(session/session-get :golf-chart)
url (str "/leagues/golf/" id "?best=" best "&curr=" score)]
(session/session-delete-key! :golf-chart)
(when settings
[:img {:src url}])))
(defn render-golf-score []
(let [{:keys [id best score] :as settings}
(session/session-get :golf-chart)]
(when settings
[:div#golf-scores
[:p#golfheader (str "Code Golf Score: " score)]
[:a.graph-class {:href "#"
:onclick "return false"}
[:span#graph-link "View Chart"]]])))
(def-page code-box [id]
(let [{:keys [_id title tags description restricted tests approved user]}
(get-problem (Integer. id))]
[:div
[:span#prob-title
(when-not approved
"Unapproved: ")
title]
[:hr]
[:div#tags "Tags: "
(s/join " " tags)]
[:br]
(when-not approved
[:div#submitter "Submitted by: " user])
[:br]
[:div#prob-desc
description[:br]
(render-test-cases tests)
(when restricted
[:div#restrictions
[:u "Special Restrictions"] [:br]
(map (partial vector :li) restricted)])]
[:div
[:div.message
[:span#message-text (session/flash-get :message)]]
(render-golf-score)]
(form-to {:id "run-code"} [:post *url*]
[:br]
[:br]
[:p#instruct "Code which fills in the blank: "]
(text-area {:id "code-box"
:spellcheck "false"}
:code (or (session/flash-get :code)
(-> (session/session-get :user)
(get-user-id)
(get-solution ,,, _id))))
[:div#golfgraph
(render-golf-chart)]
(hidden-field :id id)
[:br]
[:button.large {:id "run-button" :type "submit"} "Run"]
(when-not approved
[:span [:button.large {:id "reject-button"} "Reject"]
[:button.large {:id "edit-button"} "Edit"]
[:button.large {:id "approve-button"} "Approve"]]))]))
(def-page problem-page []
[:div.message (session/flash-get :message)]
[:div#problems-error.error (session/flash-get :error)]
(link-to "/problems/rss" [:div {:class "rss"}])
[:table#problem-table.my-table
[:thead
[:tr
[:th "Title"]
[:th "Tags"]
[:th "Submitted By"]
[:th "Times Solved"]
[:th "Solved?"]]]
(let [solved (get-solved (session/session-get :user))
problems (get-problem-list)]
(map-indexed
(fn [x {:keys [title times-solved tags user], id :_id}]
[:tr (row-class x)
[:td.titlelink
[:a {:href (str "/problem/" id)}
title]]
[:td.centered
(s/join " " (map #(str "<span class='tag'>" % "</span>")
tags))]
[:td.centered user]
[:td.centered (int times-solved)]
[:td.centered
[:img {:src (if (contains? solved id)
"/images/checkmark.png"
"/images/empty-sq.png")}]]])
problems))])
(def-page unapproved-problem-page []
[:div.message (session/flash-get :message)]
[:div#problems-error.error (session/flash-get :error)]
[:table#unapproved-problems.my-table
[:thead
[:tr
[:th "Title"]
[:th "Tags"]
[:th "Submitted By"]]]
(let [problems (get-problem-list {:approved false})]
(map-indexed
(fn [x {:keys [title tags user], id :_id}]
[:tr (row-class x)
[:td.titlelink
[:a {:href (str "/problem/" id)}
title]]
[:td.centered
(s/join " " (map #(str "<span class='tag'>" % "</span>")
tags))]
[:td.centered user]])
problems))])
(defn unapproved-problems []
(let [user (session/session-get :user)]
(if (approver? user)
(unapproved-problem-page)
(flash-error "You cannot access this page" "/problems"))))
(def-page problem-submission-page []
[:div.instructions
[:p "Thanks for choosing to submit a problem. Please make sure that you own the rights to the code you are submitting and that you wouldn't mind having us use the code as a 4clojure problem. Once you've submitted your problem, it won't appear on the site until someone from the 4clojure team has had a chance to review it."]]
(form-to {:id "problem-submission"} [:post "/problems/submit"]
(hidden-field :author (session/flash-get :author))
(hidden-field :prob-id (session/flash-get :prob-id))
(label :title "Problem Title")
(text-field :title (session/flash-get :title))
(label :tags "Tags (space separated)")
(text-field :tags (session/flash-get :tags))
(label :restricted "Restricted Functions (space separated)")
(text-field :restricted (session/flash-get :restricted))
(label :description "Problem Description")
(text-area {:id "problem-description"} :description (session/flash-get :description))
[:br]
(label :code-box "Problem test cases. Use two underscores (__) for user input. Individual tests can span multiple lines, but each test should be separated by a totally blank line.")
(text-area {:id "code-box" :spellcheck "false"}
:code (session/flash-get :tests))
[:p
[:button.large {:id "run-button" :type "submit"} "Submit"]]))
(defn create-problem
"create a user submitted problem"
[title tags restricted description code id author]
(let [user (session/session-get :user)]
(if (can-submit? user)
(let [prob-id (or id
(:seq (fetch-and-modify
:seqs
{:_id "problems"}
{:$inc {:seq 1}})))]
(when (empty? author) ; newly submitted, not a moderator tweak
(send-email
{:from "team@4clojure.com"
:to ["team@4clojure.com"]
:subject (str "User submission: " title)
:body (html [:h3 (link-to (str "https://4clojure.com/problem/edit/"
id)
title)]
[:div description])}))
(update! :problems
{:_id prob-id}
{:_id prob-id
:title title
:times-solved 0
:description description
:tags (re-seq #"\S+" tags)
:restricted (re-seq #"\S+" restricted)
:tests (s/split code #"\r\n\r\n")
:user (if (empty? author) user author)
:approved false})
(flash-msg "Thank you for submitting a problem! Be sure to check back to see it posted." "/problems"))
(flash-error "You are not authorized to submit a problem." "/problems"))))
(defn edit-problem [id]
(if (approver? (session/session-get :user))
(let [{:keys [title user tags restricted description tests]} (get-problem id)]
(doseq [[k v] {:prob-id id
:author user
:title title
:tags (s/join " " tags)
:restricted (s/join " " restricted)
:description description
:tests (s/join "\r\n\r\n" tests)}]
(session/flash-put! k v))
(response/redirect "/problems/submit"))
(flash-error "You don't have access to this page" "/problems")))
(defn approve-problem [id]
"take a user submitted problem and approve it"
(if (approver? (session/session-get :user))
(do
(update! :problems
{:_id id}
{:$set {:approved true}})
(flash-msg (str "Problem " id " has been approved!")
(str "/problem/" id)))
(flash-error "You don't have access to this page" "/problems")))
(defn reject-problem [id reason]
"reject a user submitted problem by deleting it from the database"
(if (approver? (session/session-get :user))
(let [{:keys [user title description tags tests]} (get-problem id)
email (:email (get-user user))]
(destroy! :problems
{:_id id})
(send-email
{:from "team@4clojure.com"
:to [email]
:subject "Problem rejected"
:body
(str "A problem you've submitted has been rejected, but don't get discouraged! Check out the reason below, and try again.\n\n"
"Title: " title "\n"
"Tags: " tags "\n"
"Description: " description "\n"
"Tests: " tests "\n"
"Rejection Reason: " reason)})
(flash-msg (str "Problem " id " was rejected and deleted.") "/problems"))
(flash-error "You do not have permission to access this page" "/problems")))
(defroutes problems-routes
(GET "/problems" [] (problem-page))
(GET "/problem/:id" [id] (code-box id))
(GET "/problems/submit" [] (problem-submission-page))
(POST "/problems/submit" [prob-id author title tags restricted description code]
(create-problem title tags restricted description code (when (not= "" prob-id) (Integer. prob-id)) author))
(GET "/problems/unapproved" [] (unapproved-problems))
(POST "/problem/edit" [id]
(edit-problem (Integer. id)))
(POST "/problem/approve" [id]
(approve-problem (Integer. id)))
(POST "/problem/reject" [id]
(reject-problem (Integer. id) "We didn't like your problem."))
(POST "/problem/:id" [id code]
(run-code (Integer. id) code))
(GET "/problems/rss" [] (create-feed
"4Clojure: Recent Problems"
"http://4clojure.com/problems"
"Recent problems at 4Clojure.com"
"http://4clojure.com/problems/rss"
(problem-feed 20))))
Jump to Line
Something went wrong with that request. Please try again.