(ns frontend.routes
  (:require [clojure.string :as str]
            [frontend.async :refer [put!]]
            [frontend.config :as config]
            [secretary.core :as sec :refer-macros [defroute]])
  (:require-macros [frontend.utils :refer [inspect]]
                   [cljs.core.async.macros :as am :refer [go go-loop alt!]]))

(defn open-to-inner! [nav-ch navigation-point args]
  (put! nav-ch [navigation-point (assoc args :inner? true)]))

(defn open-to-outer! [nav-ch navigation-point args]
  (put! nav-ch [navigation-point (assoc args :inner? false)]))

(defn logout! [nav-ch]
  (put! nav-ch [:logout]))

(defn v1-build-path
  "Temporary helper method for v1-build until we figure out how to make
   secretary's render-route work for regexes"
  [org repo build-num]
  (str "/gh/" org "/" repo "/" build-num))

(defn v1-dashboard-path
  "Temporary helper method for v1-*-dashboard until we figure out how to
   make secretary's render-route work for multiple pages"
  [{:keys [org repo branch page]}]
  (let [url (cond branch (str "/gh/" org "/" repo "/tree/" branch)
                  repo (str "/gh/" org "/" repo)
                  org (str "/gh/" org)
                  :else "/")]
    (str url (when page (str "?page=" page)))))

(defn define-admin-routes! [nav-ch]
  (defroute v1-admin-switch "/admin/switch" []
    (open-to-inner! nav-ch :switch {:admin true}))
  (defroute v1-admin-recent-builds "/admin/recent-builds" []
    (open-to-inner! nav-ch :dashboard {:admin true}))
  (defroute v1-admin-deployments "/admin/deployments" []
    (open-to-inner! nav-ch :dashboard {:deployments true}))
  (defroute v1-admin-build-state "/admin/build-state" []
    (open-to-inner! nav-ch :build-state {:admin true}))

  (defroute v1-admin "/admin" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage nil}))
  (defroute v1-admin-fleet-state "/admin/fleet-state" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage :fleet-state}))
  (defroute v1-admin-system-management "/admin/management-console" []
    (.replace js/location
              ;; System management console is served at port 8800
              ;; with replicated and it's always https
              (str "https://" js/window.location.hostname ":8800/")))

  (defroute v1-admin-license "/admin/license" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage :license})))

(defn define-user-routes! [nav-ch authenticated?]
  (defroute v1-org-settings "/gh/organizations/:org/settings"
    [org _fragment]
    (open-to-inner! nav-ch :org-settings {:org org :subpage (keyword _fragment)}))
  (defn v1-org-settings-subpage [params]
    (apply str (v1-org-settings params)
         (when-let [subpage (:subpage params)]
           ["#" subpage])))
  (defroute v1-org-dashboard-alternative "/gh/organizations/:org" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-org-dashboard "/gh/:org" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-project-dashboard "/gh/:org/:repo" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-project-branch-dashboard #"/gh/([^/]+)/([^/]+)/tree/(.+)" ; workaround secretary's annoying auto-decode
    [org repo branch args]
    (open-to-inner! nav-ch :dashboard (merge args {:org org :repo repo :branch branch})))
  (defroute v1-build #"/gh/([^/]+)/([^/]+)/(\d+)"
    [org repo build-num _ {:keys [_fragment]}]
    (open-to-inner! nav-ch :build {:project-name (str org "/" repo)
                                   :build-num (js/parseInt build-num)
                                   :org org
                                   :repo repo
                                   :tab (keyword _fragment)}))
  (defroute v1-project-settings "/gh/:org/:repo/edit"
    [org repo _fragment]
    (open-to-inner! nav-ch :project-settings {:project-name (str org "/" repo)
                                              :subpage (keyword _fragment)
                                              :org org
                                              :repo repo}))
  (defn v1-project-settings-subpage [params]
    (apply str (v1-project-settings params)
           (when-let [subpage (:subpage params)]
             ["#" subpage])))
  (defroute v1-add-projects "/add-projects" []
    (open-to-inner! nav-ch :add-projects {}))
  (defroute v1-insights "/build-insights" []
    (open-to-inner! nav-ch :build-insights {}))
  (defroute v1-invite-teammates "/invite-teammates" []
    (open-to-inner! nav-ch :invite-teammates {}))
  (defroute v1-invite-teammates-org "/invite-teammates/organization/:org" [org]
    (open-to-inner! nav-ch :invite-teammates {:org org}))
  (defroute v1-account "/account" []
    (open-to-inner! nav-ch :account {:subpage nil}))
  (defroute v1-account-subpage "/account/:subpage" [subpage]
    (open-to-inner! nav-ch :account {:subpage (keyword subpage)}))
  (defroute v1-logout "/logout" []
    (logout! nav-ch))

  (defroute v1-doc "/docs" []
    (if (config/enterprise?)
      (.replace js/location "https://circleci.com/docs")
      (open-to-outer! nav-ch :documentation {})))
  (defroute v1-doc-subpage "/docs/:subpage" {:keys [subpage] :as params}
    (if (config/enterprise?)
      (.replace js/location (str "https://circleci.com/docs/" subpage))
      (open-to-outer! nav-ch :documentation (assoc params :subpage (keyword subpage)))))

  (defroute v1-about "/about" {:as params}
    (open-to-outer! nav-ch :about (assoc params
                                    :_title "About Us"
                                    :_description "Learn more about the CircleCI story and why we're building the leading Continuous Integration and Deployment platform.")))

  (defroute v1-team "/about/team" {:as params}
    (open-to-outer! nav-ch :team (assoc params
                                    :_title "About the Team"
                                    :_description "Meet the team behind CircleCI, the state-of-the-art automated testing, continuous integration, and continuous deployment tool made for developers.")))

  (defroute v1-contact "/contact" {:as params}
    (open-to-outer! nav-ch :contact (assoc params
                                      :_title "Contact Us"
                                      :_description "Get in touch with CircleCI.")))

  (defroute v1-mobile "/mobile" {:as params}
    (open-to-outer! nav-ch :mobile (assoc params
                                     :_title "Mobile Continuous Integration and Mobile App Testing"
                                     :_description "Build 5-star mobile apps with Mobile Continuous Integration by automating your build, test, and deployment workflow on iOS and Android. ")))

  (defroute v1-ios "/mobile/ios" {:as params}
    (open-to-outer! nav-ch :ios (assoc params
                                  :_title "Apple iOS App Testing"
                                  :_description "Build 5-star iOS apps by automating your development workflow with Mobile Continuous Integration and Delivery.")))

  (defroute v1-android "/mobile/android" {:as params}
    (open-to-outer! nav-ch :android (assoc params
                                      :_title "Android App Testing"
                                      :_description "Build better Android apps with Mobile Continuous Integration. Get testing today!")))

  (defroute v1-pricing "/pricing" {:as params}
    (if authenticated?
      (open-to-inner! nav-ch :account {:subpage :plans})
      (open-to-outer! nav-ch :pricing (assoc params
                                        :_analytics-page "View Pricing Outer"
                                        :_title "Pricing and Information"
                                        :_description "Save time and cost by making your engineering team more efficient. Get started for free and see how many containers and parallelism you need to scale with your team."))))

  (defroute v1-jobs "/jobs" {:as params}
    (open-to-outer! nav-ch :jobs (assoc params
                                   :_analytics-page "View jobs"
                                   :_title "Search for Jobs at CircleCI"
                                   :_description "Come work with us. Join our amazing team of highly technical engineers and business leaders to help us build great developer tools.")))

  (defroute v1-privacy "/privacy" {:as params}
    (open-to-outer! nav-ch :privacy (assoc params
                                      :_analytics-page "View Privacy"
                                      :_title "Privacy Policy"
                                      :_description "Read our privacy policy to understand how we collect and use information about you.")))

  (defroute v1-security "/security" {:as params}
    (open-to-outer! nav-ch :security (assoc params
                                       :_analytics-page "View Security"
                                       :_title "Security Policy"
                                       :_description "Read our security policy and guidelines and see how your data is safe with CircleCI.")))

  (defroute v1-security-hall-of-fame "/security/hall-of-fame" {:as params}
    (open-to-outer! nav-ch :security-hall-of-fame (assoc params
                                                    :_title "Security Hall of Fame"
                                                    :_description "Join our Security Hall of Fame by helping us make our platform more secure."
                                                    :_analytics-page "View Security Hall of Fame")))

  (defroute v1-enterprise "/enterprise" {:as params}
    (open-to-outer! nav-ch :enterprise (assoc params
                                         :_title "Enterprise Continuous Integration and Deployment"
                                         :_description "Reduce risk with Enterprise Continuous Integration from CircleCI. Integrates seamlessly with Github Enterprise and the rest of your technology stack.")))

  (defroute v1-enterprise-aws "/enterprise/aws" {:as params}
    (open-to-outer! nav-ch :aws (assoc params
                                         :_title "CircleCI Enterprise on AWS"
                                         :_description "Run CircleCI Enterprise on the same AWS infrastructure you use for everything else. Integrates seamlessly with GitHub Enterprise on AWS.")))

  (defroute v1-enterprise-azure "/enterprise/azure" {:as params}
    (open-to-outer! nav-ch :azure (assoc params
                                         :_title "CircleCI Enterprise on Azure"
                                         :_description "Install CircleCI Enterprise in your own Microsoft Azure account. Integrates with GitHub Enterprise on Azure and Active Directory authentication.")))

  (defroute v1-stories "/stories/:story" [story]
    (open-to-outer! nav-ch :stories {:story (keyword story)}))

  (defroute v1-features "/features" {:as params}
    (open-to-outer! nav-ch :features (assoc params
                                       :_title "Continuous Integration Product and Features"
                                       :_description "Build a better product and let CircleCI handle your testing. CircleCI helps your team improve productivity with faster development, reduced risk, and better code.")))

  (defroute v1-languages "/features/:language" {:as params}
    (open-to-outer! nav-ch :language-landing params))

  (defroute v1-integrations "/integrations/:integration" [integration]
    (open-to-outer! nav-ch :integrations {:integration (keyword integration)}))

  (defroute v1-changelog-individual "/changelog/:id" {:as params}
    (open-to-outer! nav-ch :changelog params))

  (defroute v1-changelog "/changelog" {:as params}
    (open-to-outer! nav-ch :changelog params))

  (defroute v1-root "/" {:as params}
    (if authenticated?
      (open-to-inner! nav-ch :dashboard params)
      (open-to-outer! nav-ch :landing (assoc params :_canonical "/"))))

  (defroute v1-home "/home" {:as params}
    (open-to-outer! nav-ch :landing (assoc params :_canonical "/")))

  (defroute v1-press "/press" {:as params}
    (open-to-outer! nav-ch :press (assoc params
                                         :_title "Press Releases and Updates"
                                         :_description "Find the latest CircleCI news and updates here.")))

  (defroute v1-signup "/signup" {:as params}
    (open-to-outer! nav-ch :signup params)))

(defn define-spec-routes! [nav-ch]
  (defroute trailing-slash #"(.+)/$" [path]
    (put! nav-ch [:navigate! {:path path :replace-token? true}]))
  (defroute v1-not-found "*" []
    (open-to-outer! nav-ch :error {:status 404})))

(defn define-routes! [state]
  (let [nav-ch (get-in @state [:comms :nav])
        authenticated? (boolean (get-in @state [:current-user]))]
    (define-user-routes! nav-ch authenticated?)
    (when (get-in @state [:current-user :admin])
      (define-admin-routes! nav-ch))
    (define-spec-routes! nav-ch)))

(defn parse-uri [uri]
  (let [[uri-path fragment] (str/split (sec/uri-without-prefix uri) "#")
        [uri-path query-string] (str/split uri-path  #"\?")
        uri-path (sec/uri-with-leading-slash uri-path)]
    [uri-path query-string fragment]))

(defn dispatch!
  "Dispatch an action for a given route if it matches the URI path."
  ;; Based on secretary.core: https://github.com/gf3/secretary/blob/579bc224f23e6c26a2299a2e5a48491fd3792faf/src/secretary/core.cljs#L314
  [uri]
  (let [[uri-path query-string fragment] (parse-uri uri)
        query-params (when query-string
                       {:query-params (sec/decode-query-params query-string)})
        {:keys [action params]} (sec/locate-route uri-path)
        action (or action identity)
        params (merge params query-params {:_fragment fragment})]
    (action params)))

(ns frontend.routes
  (:require [clojure.string :as str]
            [frontend.async :refer [put!]]
            [frontend.config :as config]
            [secretary.core :as sec :refer-macros [defroute]])
  (:require-macros [frontend.utils :refer [inspect]]
                   [cljs.core.async.macros :as am :refer [go go-loop alt!]]))

(defn open-to-inner! [nav-ch navigation-point args]
  (put! nav-ch [navigation-point (assoc args :inner? true)]))

(defn open-to-outer! [nav-ch navigation-point args]
  (put! nav-ch [navigation-point (assoc args :inner? false)]))

(defn logout! [nav-ch]
  (put! nav-ch [:logout]))

(defn v1-build-path
  "Temporary helper method for v1-build until we figure out how to make
   secretary's render-route work for regexes"
  [org repo build-num]
  (str "/gh/" org "/" repo "/" build-num))

(defn v1-dashboard-path
  "Temporary helper method for v1-*-dashboard until we figure out how to
   make secretary's render-route work for multiple pages"
  [{:keys [org repo branch page]}]
  (let [url (cond branch (str "/gh/" org "/" repo "/tree/" branch)
                  repo (str "/gh/" org "/" repo)
                  org (str "/gh/" org)
                  :else "/")]
    (str url (when page (str "?page=" page)))))

(defn define-admin-routes! [nav-ch]
  (defroute v1-admin-switch "/admin/switch" []
    (open-to-inner! nav-ch :switch {:admin true}))
  (defroute v1-admin-recent-builds "/admin/recent-builds" []
    (open-to-inner! nav-ch :dashboard {:admin true}))
  (defroute v1-admin-deployments "/admin/deployments" []
    (open-to-inner! nav-ch :dashboard {:deployments true}))
  (defroute v1-admin-build-state "/admin/build-state" []
    (open-to-inner! nav-ch :build-state {:admin true}))

  (defroute v1-admin "/admin" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage nil}))
  (defroute v1-admin-fleet-state "/admin/fleet-state" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage :fleet-state}))
  (defroute v1-admin-system-management "/admin/management-console" []
    (.replace js/location
              ;; System management console is served at port 8800
              ;; with replicated and it's always https
              (str "https://" js/window.location.hostname ":8800/")))

  (defroute v1-admin-license "/admin/license" []
    (open-to-inner! nav-ch :admin-settings {:admin true
                                            :subpage :license})))

(defn define-user-routes! [nav-ch authenticated?]
  (defroute v1-org-settings "/gh/organizations/:org/settings"
    [org _fragment]
    (open-to-inner! nav-ch :org-settings {:org org :subpage (keyword _fragment)}))
  (defn v1-org-settings-subpage [params]
    (apply str (v1-org-settings params)
         (when-let [subpage (:subpage params)]
           ["#" subpage])))
  (defroute v1-org-dashboard-alternative "/gh/organizations/:org" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-org-dashboard "/gh/:org" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-project-dashboard "/gh/:org/:repo" {:as params}
    (open-to-inner! nav-ch :dashboard params))
  (defroute v1-project-branch-dashboard #"/gh/([^/]+)/([^/]+)/tree/(.+)" ; workaround secretary's annoying auto-decode
    [org repo branch args]
    (open-to-inner! nav-ch :dashboard (merge args {:org org :repo repo :branch branch})))
  (defroute v1-build #"/gh/([^/]+)/([^/]+)/(\d+)"
    [org repo build-num _ maybe-fragment]
    ;; normal destructuring for this broke the closure compiler
    (let [_fragment (:_fragment maybe-fragment)]
      (open-to-inner! nav-ch :build {:project-name (str org "/" repo)
                                    :build-num (js/parseInt build-num)
                                    :org org
                                    :repo repo
                                    :tab (keyword _fragment)})))
  (defroute v1-project-settings "/gh/:org/:repo/edit"
    [org repo _fragment]
    (open-to-inner! nav-ch :project-settings {:project-name (str org "/" repo)
                                              :subpage (keyword _fragment)
                                              :org org
                                              :repo repo}))
  (defn v1-project-settings-subpage [params]
    (apply str (v1-project-settings params)
           (when-let [subpage (:subpage params)]
             ["#" subpage])))
  (defroute v1-add-projects "/add-projects" []
    (open-to-inner! nav-ch :add-projects {}))
  (defroute v1-insights "/build-insights" []
    (open-to-inner! nav-ch :build-insights {}))
  (defroute v1-invite-teammates "/invite-teammates" []
    (open-to-inner! nav-ch :invite-teammates {}))
  (defroute v1-invite-teammates-org "/invite-teammates/organization/:org" [org]
    (open-to-inner! nav-ch :invite-teammates {:org org}))
  (defroute v1-account "/account" []
    (open-to-inner! nav-ch :account {:subpage nil}))
  (defroute v1-account-subpage "/account/:subpage" [subpage]
    (open-to-inner! nav-ch :account {:subpage (keyword subpage)}))
  (defroute v1-logout "/logout" []
    (logout! nav-ch))

  (defroute v1-doc "/docs" []
    (if (config/enterprise?)
      (.replace js/location "https://circleci.com/docs")
      (open-to-outer! nav-ch :documentation {})))
  (defroute v1-doc-subpage "/docs/:subpage" {:keys [subpage] :as params}
    (if (config/enterprise?)
      (.replace js/location (str "https://circleci.com/docs/" subpage))
      (open-to-outer! nav-ch :documentation (assoc params :subpage (keyword subpage)))))

  (defroute v1-about "/about" {:as params}
    (open-to-outer! nav-ch :about (assoc params
                                    :_title "About Us"
                                    :_description "Learn more about the CircleCI story and why we're building the leading Continuous Integration and Deployment platform.")))

  (defroute v1-team "/about/team" {:as params}
    (open-to-outer! nav-ch :team (assoc params
                                    :_title "About the Team"
                                    :_description "Meet the team behind CircleCI, the state-of-the-art automated testing, continuous integration, and continuous deployment tool made for developers.")))

  (defroute v1-contact "/contact" {:as params}
    (open-to-outer! nav-ch :contact (assoc params
                                      :_title "Contact Us"
                                      :_description "Get in touch with CircleCI.")))

  (defroute v1-mobile "/mobile" {:as params}
    (open-to-outer! nav-ch :mobile (assoc params
                                     :_title "Mobile Continuous Integration and Mobile App Testing"
                                     :_description "Build 5-star mobile apps with Mobile Continuous Integration by automating your build, test, and deployment workflow on iOS and Android. ")))

  (defroute v1-ios "/mobile/ios" {:as params}
    (open-to-outer! nav-ch :ios (assoc params
                                  :_title "Apple iOS App Testing"
                                  :_description "Build 5-star iOS apps by automating your development workflow with Mobile Continuous Integration and Delivery.")))

  (defroute v1-android "/mobile/android" {:as params}
    (open-to-outer! nav-ch :android (assoc params
                                      :_title "Android App Testing"
                                      :_description "Build better Android apps with Mobile Continuous Integration. Get testing today!")))

  (defroute v1-pricing "/pricing" {:as params}
    (if authenticated?
      (open-to-inner! nav-ch :account {:subpage :plans})
      (open-to-outer! nav-ch :pricing (assoc params
                                        :_analytics-page "View Pricing Outer"
                                        :_title "Pricing and Information"
                                        :_description "Save time and cost by making your engineering team more efficient. Get started for free and see how many containers and parallelism you need to scale with your team."))))

  (defroute v1-jobs "/jobs" {:as params}
    (open-to-outer! nav-ch :jobs (assoc params
                                   :_analytics-page "View jobs"
                                   :_title "Search for Jobs at CircleCI"
                                   :_description "Come work with us. Join our amazing team of highly technical engineers and business leaders to help us build great developer tools.")))

  (defroute v1-privacy "/privacy" {:as params}
    (open-to-outer! nav-ch :privacy (assoc params
                                      :_analytics-page "View Privacy"
                                      :_title "Privacy Policy"
                                      :_description "Read our privacy policy to understand how we collect and use information about you.")))

  (defroute v1-security "/security" {:as params}
    (open-to-outer! nav-ch :security (assoc params
                                       :_analytics-page "View Security"
                                       :_title "Security Policy"
                                       :_description "Read our security policy and guidelines and see how your data is safe with CircleCI.")))

  (defroute v1-security-hall-of-fame "/security/hall-of-fame" {:as params}
    (open-to-outer! nav-ch :security-hall-of-fame (assoc params
                                                    :_title "Security Hall of Fame"
                                                    :_description "Join our Security Hall of Fame by helping us make our platform more secure."
                                                    :_analytics-page "View Security Hall of Fame")))

  (defroute v1-enterprise "/enterprise" {:as params}
    (open-to-outer! nav-ch :enterprise (assoc params
                                         :_title "Enterprise Continuous Integration and Deployment"
                                         :_description "Reduce risk with Enterprise Continuous Integration from CircleCI. Integrates seamlessly with Github Enterprise and the rest of your technology stack.")))

  (defroute v1-enterprise-aws "/enterprise/aws" {:as params}
    (open-to-outer! nav-ch :aws (assoc params
                                         :_title "CircleCI Enterprise on AWS"
                                         :_description "Run CircleCI Enterprise on the same AWS infrastructure you use for everything else. Integrates seamlessly with GitHub Enterprise on AWS.")))

  (defroute v1-enterprise-azure "/enterprise/azure" {:as params}
    (open-to-outer! nav-ch :azure (assoc params
                                         :_title "CircleCI Enterprise on Azure"
                                         :_description "Install CircleCI Enterprise in your own Microsoft Azure account. Integrates with GitHub Enterprise on Azure and Active Directory authentication.")))

  (defroute v1-stories "/stories/:story" [story]
    (open-to-outer! nav-ch :stories {:story (keyword story)}))

  (defroute v1-features "/features" {:as params}
    (open-to-outer! nav-ch :features (assoc params
                                       :_title "Continuous Integration Product and Features"
                                       :_description "Build a better product and let CircleCI handle your testing. CircleCI helps your team improve productivity with faster development, reduced risk, and better code.")))

  (defroute v1-languages "/features/:language" {:as params}
    (open-to-outer! nav-ch :language-landing params))

  (defroute v1-integrations "/integrations/:integration" [integration]
    (open-to-outer! nav-ch :integrations {:integration (keyword integration)}))

  (defroute v1-changelog-individual "/changelog/:id" {:as params}
    (open-to-outer! nav-ch :changelog params))

  (defroute v1-changelog "/changelog" {:as params}
    (open-to-outer! nav-ch :changelog params))

  (defroute v1-root "/" {:as params}
    (if authenticated?
      (open-to-inner! nav-ch :dashboard params)
      (open-to-outer! nav-ch :landing (assoc params :_canonical "/"))))

  (defroute v1-home "/home" {:as params}
    (open-to-outer! nav-ch :landing (assoc params :_canonical "/")))

  (defroute v1-press "/press" {:as params}
    (open-to-outer! nav-ch :press (assoc params
                                         :_title "Press Releases and Updates"
                                         :_description "Find the latest CircleCI news and updates here.")))

  (defroute v1-signup "/signup" {:as params}
    (open-to-outer! nav-ch :signup params)))

(defn define-spec-routes! [nav-ch]
  (defroute trailing-slash #"(.+)/$" [path]
    (put! nav-ch [:navigate! {:path path :replace-token? true}]))
  (defroute v1-not-found "*" []
    (open-to-outer! nav-ch :error {:status 404})))

(defn define-routes! [state]
  (let [nav-ch (get-in @state [:comms :nav])
        authenticated? (boolean (get-in @state [:current-user]))]
    (define-user-routes! nav-ch authenticated?)
    (when (get-in @state [:current-user :admin])
      (define-admin-routes! nav-ch))
    (define-spec-routes! nav-ch)))

(defn parse-uri [uri]
  (let [[uri-path fragment] (str/split (sec/uri-without-prefix uri) "#")
        [uri-path query-string] (str/split uri-path  #"\?")
        uri-path (sec/uri-with-leading-slash uri-path)]
    [uri-path query-string fragment]))

(defn dispatch!
  "Dispatch an action for a given route if it matches the URI path."
  ;; Based on secretary.core: https://github.com/gf3/secretary/blob/579bc224f23e6c26a2299a2e5a48491fd3792faf/src/secretary/core.cljs#L314
  [uri]
  (let [[uri-path query-string fragment] (parse-uri uri)
        query-params (when query-string
                       {:query-params (sec/decode-query-params query-string)})
        {:keys [action params]} (sec/locate-route uri-path)
        action (or action identity)
        params (merge params query-params {:_fragment fragment})]
    (action params)))

Work around bizarre compilation failure

Work around bizarre compilation failure

Somehow it produced javascript that had a space in the middle of what
should've been one token


(ns antlion-clojure.slack
  (:require [gniazdo.core :as ws]
            [clojure.core.async :refer [go-loop <! put!]]
            [clj-slack.usergroups.users :as usergroups-users]
            [clj-slack.chat :as chat]
            [clj-slack.channels :as channels]
            [clj-slack.groups :as groups]
            [slack-rtm.core :as rtm]
            [com.stuartsierra.component :as component]))

(def api-url "https://slack.com/api")

;; REST API
(defrecord Payload
  [type subtype user text channel group optionals])

(defrecord Channel
  [id name])

(defn parse-channel
  [s]
  (some-> (re-matches #"\<(.*)\>" s)
          second
          (clojure.string/split #"\|")
          (update 0 #(->> % (drop 1) (apply str)))
          (#(apply ->Channel %))))

(defn parse-user
  [s]
  (some->> (re-matches #"\<(@.*)\>" s)
           second
           (drop 1)
           (apply str)))

(defn parse-usergroups
  [s]
  (some->> s
           (re-matches #"\<\!subteam\^(.*)\|.*\>")
           second))

(defn message-for-me?
  [{:keys [slack res] :as opt}]
  (when (:text res)
    (re-matches (re-pattern (str "\\<\\@"
                                 (-> slack :rtm-connection :start :self :id)
                                 "\\> .*"))
                (:text res))))

(defn message-from-me?
  [{:keys [slack res] :as opt}]
  (= (-> slack :rtm-connection :start :self :id)
     (:id res)))

(defn post
  [{:keys [connection]} {:keys [channel text optionals]}]
  (chat/post-message connection channel text (merge {:as_user "true"} optionals)))

(defn reply
  [{:keys [connection]} {:keys [channel text user optionals]}]
  (chat/post-message connection channel (str "<@" user "> " text) (merge {:as_user "true"} optionals)))

(defn channel-invite
  [{:keys [connection invite-token]} {:keys [channel user]}]
  (-> connection
      (assoc :token invite-token)
      (channels/invite channel user)))

(defn group-invite
  [{:keys [connection invite-token]} {:keys [channel user]}]
  (-> connection
      (assoc :token invite-token)
      (groups/invite channel user)))

(defn usergroups-users
  [{:keys [connection invite-token]} usergroups-id]
  (-> connection
      (assoc :token invite-token)
      (usergroups-users/list usergroups-id)
      :users))

(defn- dispatch-message!
  [slack {:keys [subtype user] :as payload}]
  (cond
    (= :channel_invite subtype)
    (channel-invite slack payload)
    (= :group_invite subtype)
    (group-invite slack payload)
    (nil? subtype)
    (if user
      (reply slack payload)
      (post slack payload))
    :else nil))

(defn- dispatch-payload!
  [slack {:keys [type] :as payload}]
  (case type
    :message (dispatch-message! slack payload)
    nil))

(defn reaction!
  [slack payload]
  (cond
    (vector? payload) (doseq [p payload] (dispatch-payload! slack p))
    (map? payload) (dispatch-payload! slack payload)
    :else nil))

(defn send-payload
  [slack payload]
  (let [dispatcher (-> slack :rtm-connection :dispatcher)]
    (cond
      (vector? payload)
      (doseq [p payload] (rtm/send-event dispatcher p))
      (map? payload)
      (rtm/send-event dispatcher payload))))

(defn sub-to-event!
  [slack type f]
  (let [events-publication (-> slack :rtm-connection :events-publication)]
    (rtm/sub-to-event events-publication type f)))

(defrecord SlackComponent
  [rtm-connection connection invite-token]
  component/Lifecycle
  (start [this]
    (println ";; Starting SlackComponent")
    (let [rtm-connection (rtm/connect connection)]
      (-> this
          (assoc :rtm-connection rtm-connection))))
  (stop [{:keys [rtm-connection] :as this}]
      (println ";; Stopping SlackComponent")
      (when-not (:dispatcher rtm-connection)
        (rtm/send-event (:dispatcher rtm-connection) :close))
      (-> this
          (dissoc :rtm-connection))))

(defn slack-component
  [antlion-clojure-token antlion-clojure-invite-token]
  (map->SlackComponent {:connection {:token antlion-clojure-token :api-url api-url}
                        :invite-token antlion-clojure-invite-token}))

(ns antlion-clojure.slack
  (:require [gniazdo.core :as ws]
            [clojure.core.async :refer [go-loop <! put!]]
            [clj-slack.usergroups.users :as usergroups-users]
            [clj-slack.chat :as chat]
            [clj-slack.channels :as channels]
            [clj-slack.groups :as groups]
            [slack-rtm.core :as rtm]
            [com.stuartsierra.component :as component]))

(def api-url "https://slack.com/api")

;; REST API
(defrecord Payload
  [type subtype user text channel group optionals])

(defrecord Channel
  [id name])

(defn parse-channel
  [s]
  (some-> (re-matches #"\<(.*)\>" s)
          second
          (clojure.string/split #"\|")
          (update 0 #(->> % (drop 1) (apply str)))
          (#(apply ->Channel %))))

(defn parse-user
  [s]
  (some->> (re-matches #"\<(@.*)\>" s)
           second
           (drop 1)
           (apply str)))

(defn parse-usergroups
  [s]
  (some->> s
           (re-matches #"\<\!subteam\^(.*)\|.*\>")
           second))

(defn message-for-me?
  [{:keys [slack res] :as opt}]
  (when (:text res)
    (re-matches (re-pattern (str "\\<\\@"
                                 (-> slack :rtm-connection :start :self :id)
                                 "\\> .*"))
                (:text res))))

(defn message-from-me?
  [{:keys [slack res] :as opt}]
  (= (-> slack :rtm-connection :start :self :id)
     (:user res)))

(defn post
  [{:keys [connection]} {:keys [channel text optionals]}]
  (chat/post-message connection channel text (merge {:as_user "true"} optionals)))

(defn reply
  [{:keys [connection]} {:keys [channel text user optionals]}]
  (chat/post-message connection channel (str "<@" user "> " text) (merge {:as_user "true"} optionals)))

(defn channel-invite
  [{:keys [connection invite-token]} {:keys [channel user]}]
  (-> connection
      (assoc :token invite-token)
      (channels/invite channel user)))

(defn group-invite
  [{:keys [connection invite-token]} {:keys [channel user]}]
  (-> connection
      (assoc :token invite-token)
      (groups/invite channel user)))

(defn usergroups-users
  [{:keys [connection invite-token]} usergroups-id]
  (-> connection
      (assoc :token invite-token)
      (usergroups-users/list usergroups-id)
      :users))

(defn- dispatch-message!
  [slack {:keys [subtype user] :as payload}]
  (cond
    (= :channel_invite subtype)
    (channel-invite slack payload)
    (= :group_invite subtype)
    (group-invite slack payload)
    (nil? subtype)
    (if user
      (reply slack payload)
      (post slack payload))
    :else nil))

(defn- dispatch-payload!
  [slack {:keys [type] :as payload}]
  (case type
    :message (dispatch-message! slack payload)
    nil))

(defn reaction!
  [slack payload]
  (cond
    (vector? payload) (doseq [p payload] (dispatch-payload! slack p))
    (map? payload) (dispatch-payload! slack payload)
    :else nil))

(defn send-payload
  [slack payload]
  (let [dispatcher (-> slack :rtm-connection :dispatcher)]
    (cond
      (vector? payload)
      (doseq [p payload] (rtm/send-event dispatcher p))
      (map? payload)
      (rtm/send-event dispatcher payload))))

(defn sub-to-event!
  [slack type f]
  (let [events-publication (-> slack :rtm-connection :events-publication)]
    (rtm/sub-to-event events-publication type f)))

(defrecord SlackComponent
  [rtm-connection connection invite-token]
  component/Lifecycle
  (start [this]
    (println ";; Starting SlackComponent")
    (let [rtm-connection (rtm/connect connection)]
      (-> this
          (assoc :rtm-connection rtm-connection))))
  (stop [{:keys [rtm-connection] :as this}]
      (println ";; Stopping SlackComponent")
      (when-not (:dispatcher rtm-connection)
        (rtm/send-event (:dispatcher rtm-connection) :close))
      (-> this
          (dissoc :rtm-connection))))

(defn slack-component
  [antlion-clojure-token antlion-clojure-invite-token]
  (map->SlackComponent {:connection {:token antlion-clojure-token :api-url api-url}
                        :invite-token antlion-clojure-invite-token}))

Fix message-from-me?

Fix message-from-me?


(ns caesium.crypto.secretbox-benchmark
  (:require [caesium.randombytes :refer [randombytes]]
            [caesium.crypto.secretbox :as s]
            [caesium.bytes-conv :as bc]
            [clojure.test :refer [deftest]]
            [criterium.core :refer [bench]]
            [caesium.bench-utils :refer [fmt-bytes]]
            [caesium.binding :refer [sodium]])
  (:import [java.nio ByteBuffer]))

(defn secretbox-easy-to-direct-byte-bufs-with-macros!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->direct-byte-buf-macro out)
        ^ByteBuffer msg (bc/->direct-byte-buf-macro msg)
        ^ByteBuffer nonce (bc/->direct-byte-buf-macro nonce)
        ^ByteBuffer key (bc/->direct-byte-buf-macro key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-direct-byte-bufs!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->direct-byte-buf out)
        ^ByteBuffer msg (bc/->direct-byte-buf msg)
        ^ByteBuffer nonce (bc/->direct-byte-buf nonce)
        ^ByteBuffer key (bc/->direct-byte-buf key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-indirect-byte-bufs-with-macros!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->indirect-byte-buf-macro out)
        ^ByteBuffer msg (bc/->indirect-byte-buf-macro msg)
        ^ByteBuffer nonce (bc/->indirect-byte-buf-macro nonce)
        ^ByteBuffer key (bc/->indirect-byte-buf-macro key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-indirect-byte-bufs!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->indirect-byte-buf out)
        ^ByteBuffer msg (bc/->indirect-byte-buf msg)
        ^ByteBuffer nonce (bc/->indirect-byte-buf nonce)
        ^ByteBuffer key (bc/->indirect-byte-buf key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-byte-bufs-nocast!
  [^ByteBuffer out ^ByteBuffer msg ^ByteBuffer nonce ^ByteBuffer key]
  (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
  out)

(defn secretbox-easy-refl!
  [out msg nonce key]
  (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
  out)

(def sizes (map (partial bit-shift-left 1) [6 8 10 12 20 24]))

(defmacro bench-secretnonce
  [fs converter]
  (let [rand-buf `(comp ~converter ~randombytes)]
    `(doseq [[size# msg#] (map (juxt identity ~rand-buf) sizes)
             f# ~fs]
       (let [key# (~rand-buf s/keybytes)
             nonce# (~rand-buf s/noncebytes)
             out# (~rand-buf (+ s/macbytes size#))]
         (println f# (fmt-bytes size#) (mapv type [out# msg# nonce# key#]))
         (bench (f out# msg# nonce# key#))))))

(deftest ^:benchmark to-buf!-benchmarks
  (println "secretbox to-buf! with direct bufs, pre-allocation")
  (bench-secretnonce [secretbox-easy-to-direct-byte-bufs-with-macros!
                      secretbox-easy-to-direct-byte-bufs!
                      secretbox-easy-to-byte-bufs-nocast!
                      secretbox-easy-refl!]
                     bc/->direct-byte-buf)

  (println "secretbox to-buf! with indirect bufs, pre-allocation")
  (bench-secretnonce [secretbox-easy-to-indirect-byte-bufs-with-macros!
                      secretbox-easy-to-indirect-byte-bufs!
                      secretbox-easy-to-byte-bufs-nocast!
                      secretbox-easy-refl!]
                     bc/->indirect-byte-buf)

  (println "secretbox to-buf! with byte arrays, pre-allocation")
  (bench-secretnonce [s/secretbox-easy-to-buf!] identity))

(ns caesium.crypto.secretbox-benchmark
  (:require [caesium.randombytes :refer [randombytes]]
            [caesium.crypto.secretbox :as s]
            [caesium.bytes-conv :as bc]
            [clojure.test :refer [deftest]]
            [criterium.core :refer [bench]]
            [caesium.bench-utils :refer [fmt-bytes]]
            [caesium.binding :refer [sodium]])
  (:import [java.nio ByteBuffer]))

(defn secretbox-easy-to-direct-byte-bufs-with-macros!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->direct-byte-buf-macro out)
        ^ByteBuffer msg (bc/->direct-byte-buf-macro msg)
        ^ByteBuffer nonce (bc/->direct-byte-buf-macro nonce)
        ^ByteBuffer key (bc/->direct-byte-buf-macro key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-direct-byte-bufs!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->direct-byte-buf out)
        ^ByteBuffer msg (bc/->direct-byte-buf msg)
        ^ByteBuffer nonce (bc/->direct-byte-buf nonce)
        ^ByteBuffer key (bc/->direct-byte-buf key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-indirect-byte-bufs-with-macros!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->indirect-byte-buf-macro out)
        ^ByteBuffer msg (bc/->indirect-byte-buf-macro msg)
        ^ByteBuffer nonce (bc/->indirect-byte-buf-macro nonce)
        ^ByteBuffer key (bc/->indirect-byte-buf-macro key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-indirect-byte-bufs!
  [out msg nonce key]
  (let [^ByteBuffer out (bc/->indirect-byte-buf out)
        ^ByteBuffer msg (bc/->indirect-byte-buf msg)
        ^ByteBuffer nonce (bc/->indirect-byte-buf nonce)
        ^ByteBuffer key (bc/->indirect-byte-buf key)]
    (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
    out))

(defn secretbox-easy-to-byte-bufs-nocast!
  [^ByteBuffer out ^ByteBuffer msg ^ByteBuffer nonce ^ByteBuffer key]
  (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
  out)

(defn secretbox-easy-refl!
  [out msg nonce key]
  (.crypto_secretbox_easy sodium out msg (.remaining msg) nonce key)
  out)

(def sizes (map (partial bit-shift-left 1) [6 8 10 12 20 24]))

(defmacro bench-secretnonce
  [fs converter]
  (let [rand-buf `(comp ~converter ~randombytes)]
    `(doseq [[size# msg#] (map (juxt identity ~rand-buf) sizes)
             f# ~fs]
       (let [key# (~rand-buf s/keybytes)
             nonce# (~rand-buf s/noncebytes)
             out# (~rand-buf (+ s/macbytes size#))]
         (println f# (fmt-bytes size#) (mapv type [out# msg# nonce# key#]))
         (bench (f# out# msg# nonce# key#))))))

(deftest ^:benchmark to-buf!-benchmarks
  (println "secretbox to-buf! with direct bufs, pre-allocation")
  (bench-secretnonce [secretbox-easy-to-direct-byte-bufs-with-macros!
                      secretbox-easy-to-direct-byte-bufs!
                      secretbox-easy-to-byte-bufs-nocast!
                      secretbox-easy-refl!]
                     bc/->direct-byte-buf)

  (println "secretbox to-buf! with indirect bufs, pre-allocation")
  (bench-secretnonce [secretbox-easy-to-indirect-byte-bufs-with-macros!
                      secretbox-easy-to-indirect-byte-bufs!
                      secretbox-easy-to-byte-bufs-nocast!
                      secretbox-easy-refl!]
                     bc/->indirect-byte-buf)

  (println "secretbox to-buf! with byte arrays, pre-allocation")
  (bench-secretnonce [s/secretbox-easy-to-buf!] identity))

Fix benchmark macro

Fix benchmark macro


(ns clj.medusa.changesets
  (:require [clj-http.lite.client :as client]
            [pl.danieljanus.tagsoup :as tagsoup]))

;; This library finds changesets given build dates (dates of the form YYYY-MM-DD)
;; or build IDs (exact build timestamps of the form YYYYMMDDhhmmss).
;;
;; Example: obtaining a link to the changesets for build date 2015-05-03:
;;
;;     (println (find-build-changeset (find-date-buildid "2015-05-03" "mozilla-central") "mozilla-central"))
;;
;; Example: obtaining a link to changesets for buildid 20150503030209
;;
;;     (println (find-build-changeset "20150503030209" "mozilla-central"))

(declare elements-by-tag-name)

(defn- split-buildid
  "Splits a buildid `buildid` into a dictionary with the date/time components as entries."
  [buildid]
  {:y (Integer/parseInt (subs buildid 0 4)) :m (Integer/parseInt (subs buildid 4 6)) :d (Integer/parseInt (subs buildid 6 8))
   :hour (Integer/parseInt (subs buildid 8 10)) :min (Integer/parseInt (subs buildid 10 12)) :sec (Integer/parseInt (subs buildid 12 14))})

(defn- list-elements-by-tag-name
  "Obtains a list of all tags with tag name `tag-name` in `children`, a list of DOM elements in the form outputted by Tagsoup."
  [children tag-name]
  (cond (empty? children) '()
        (vector? (first children)) (concat (elements-by-tag-name (first children) tag-name)
                                           (list-elements-by-tag-name (rest children) tag-name))
        :else '()))

(defn- elements-by-tag-name
  "Obtains a list of all tags with tag name `tag-name` in `tag`, a DOM in the form outputted by Tagsoup."
  [tag tag-name]
  {:pre [(vector? tag) (keyword? tag-name)]}
  (if (= (first tag) :a)
    (cons tag (list-elements-by-tag-name (rest (rest tag)) tag-name))
    (list-elements-by-tag-name (rest (rest tag)) tag-name)))

(defn- find-build-dir-revision
  "Finds the hg revision associated with the build dir URL `build-dir-url`."
  [build-dir-url]
  (let [response (tagsoup/parse build-dir-url)
        links (elements-by-tag-name response :a)
        text-file-links (filter #(re-find #"^firefox.*win32\.txt$" (get % 2)) links)]
    (assert (= (count text-file-links) 1) "Could not find revision ID text file")
    (let [revision-file-url (str build-dir-url (:href (second (first text-file-links))))
          revision-file (:body (client/get revision-file-url))
          revision (re-find #"https:\/\/hg\.mozilla.*([0-9a-f]{12})$" revision-file)]
      (second revision))))

(defn- find-build-revision
  "Finds the hg revision of associated with the buildid `buildid` on channel `channel`."
  [buildid channel]
  (let [p (split-buildid buildid)
        build-dir-url (format "http://ftp.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/%02d-%02d-%02d-%02d-%02d-%02d-%s/"
                    (:y p) (:m p) (:y p) (:m p) (:d p) (:hour p) (:min p) (:sec p) channel)]
    (find-build-dir-revision build-dir-url)))

(defn- find-preceding-build-revision
  "Find the first build made before buildid `buildid` on channel `channel`, and get its associated revision."
  [buildid channel]
  (let [p (split-buildid buildid)

        ;; Obtain a list of links to build directories in the desired channel
        build-dirs-url (format "https://ftp.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/" (:y p) (:m p))
        target (format "%02d-%02d-%02d-%02d-%02d-%02d-%s/" (:y p) (:m p) (:d p) (:hour p) (:min p) (:sec p) channel)
        response (tagsoup/parse build-dirs-url)
        links (elements-by-tag-name response :a)
        build-dirs-suffix (format "-%s/" channel)
        build-dirs-links (filter #(.endsWith (get % 2) build-dirs-suffix) links)

        ;; Find the index of the link before the link having the specified buildid
        target-link-index (dec (first (keep-indexed #(when (= (clojure.string/trim (get %2 2)) target) %1) build-dirs-links)))]
    (if (= target-link-index -1) ; check if we have the directory of previous build in the same month's folder
        (let [year (if (= (:m p) 0) (dec (:y p)) (:y p)) ; the build is the first one in that month, use the last build of the previous month's folder
              month (if (= (:m p) 0) 12 (dec (:m p)))

              ;; Obtain the last link to build directories in the desired channel in the previous month's folder, which is the build dir of the last build in the previous month
              prev-build-dirs-url (format "https://ftp.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/" year month)
              response (tagsoup/parse prev-build-dirs-url)
              links (elements-by-tag-name response :a)
              target-link (last (filter #(.endsWith (get % 2) build-dirs-suffix) links))
              build-dir-url (str prev-build-dirs-url (:href (second target-link)))]
          (find-build-dir-revision build-dir-url))
        (let [target-link (nth build-dirs-links target-link-index) ; get the build directory and the revision from the link
              build-dir-url (str build-dirs-url (:href (second target-link)))]
          (find-build-dir-revision build-dir-url)))))

(defn find-build-changeset
  "Finds the changesets corresponding to the build with buildid `buildid`, which is a URL for a page with a list of all new changesets that went into that build."
  [buildid channel]
  (let [from-revision (find-preceding-build-revision buildid channel)
        to-revision (find-build-revision buildid channel)]
    (format "https://hg.mozilla.org/%s/pushloghtml?fromchange=%s&tochange=%s"
            channel from-revision to-revision)))

(defn find-date-buildid
  "Determines the buildid (a date-time of the form YYYYMMDDhhmmss) corresponding to a given build date `date` (a date of the form YYYY-MM-DD) on the channel string `channel`, generally mozilla-central."
  [date channel]
  (let [[_ year month day] (re-find #"^(\d{4})-(\d{2})-(\d{2})$" date)
        build-dirs-suffix (format "-%s/" channel)
        build-dirs-url (format "https://ftp.mozilla.org/pub/mozilla.org/firefox/nightly/%s/%s/" year month)
        response (tagsoup/parse build-dirs-url)
        links (elements-by-tag-name response :a)
        build-dirs-links (filter #(.endsWith (get % 2) build-dirs-suffix) links)
        target-link (first (filter #(.startsWith (get % 2) date) build-dirs-links))
        [_ hour minute second] (re-find #"^\d{4}-\d{2}-\d{2}-(\d{2})-(\d{2})-(\d{2})" (get target-link 2))]
    (str year month day hour minute second)))

(ns clj.medusa.changesets
  (:require [clj-http.lite.client :as client]
            [pl.danieljanus.tagsoup :as tagsoup]))

;; This library finds changesets given build dates (dates of the form YYYY-MM-DD)
;; or build IDs (exact build timestamps of the form YYYYMMDDhhmmss).
;;
;; Example: obtaining a link to the changesets for build date 2015-05-03:
;;
;;     (println (find-build-changeset (find-date-buildid "2015-05-03" "mozilla-central") "mozilla-central"))
;;
;; Example: obtaining a link to changesets for buildid 20150503030209
;;
;;     (println (find-build-changeset "20150503030209" "mozilla-central"))

(declare elements-by-tag-name)

(defn- split-buildid
  "Splits a buildid `buildid` into a dictionary with the date/time components as entries."
  [buildid]
  {:y (Integer/parseInt (subs buildid 0 4)) :m (Integer/parseInt (subs buildid 4 6)) :d (Integer/parseInt (subs buildid 6 8))
   :hour (Integer/parseInt (subs buildid 8 10)) :min (Integer/parseInt (subs buildid 10 12)) :sec (Integer/parseInt (subs buildid 12 14))})

(defn- list-elements-by-tag-name
  "Obtains a list of all tags with tag name `tag-name` in `children`, a list of DOM elements in the form outputted by Tagsoup."
  [children tag-name]
  (cond (empty? children) '()
        (vector? (first children)) (concat (elements-by-tag-name (first children) tag-name)
                                           (list-elements-by-tag-name (rest children) tag-name))
        :else '()))

(defn- elements-by-tag-name
  "Obtains a list of all tags with tag name `tag-name` in `tag`, a DOM in the form outputted by Tagsoup."
  [tag tag-name]
  {:pre [(vector? tag) (keyword? tag-name)]}
  (if (= (first tag) :a)
    (cons tag (list-elements-by-tag-name (rest (rest tag)) tag-name))
    (list-elements-by-tag-name (rest (rest tag)) tag-name)))

(defn- find-build-dir-revision
  "Finds the hg revision associated with the build dir URL `build-dir-url`."
  [build-dir-url]
  (let [response (tagsoup/parse build-dir-url)
        links (elements-by-tag-name response :a)
        text-file-links (filter #(re-find #"^firefox.*win32\.txt$" (get % 2)) links)]
    (assert (= (count text-file-links) 1) "Could not find revision ID text file")
    (let [revision-file-url (str build-dir-url (:href (second (first text-file-links))))
          revision-file (:body (client/get revision-file-url))
          revision (re-find #"https:\/\/hg\.mozilla.*([0-9a-f]{12})$" revision-file)]
      (second revision))))

(defn- find-build-revision
  "Finds the hg revision of associated with the buildid `buildid` on channel `channel`."
  [buildid channel]
  (let [p (split-buildid buildid)
        build-dir-url (format "https://archive.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/%02d-%02d-%02d-%02d-%02d-%02d-%s/"
                    (:y p) (:m p) (:y p) (:m p) (:d p) (:hour p) (:min p) (:sec p) channel)]
    (find-build-dir-revision build-dir-url)))

(defn- find-preceding-build-revision
  "Find the first build made before buildid `buildid` on channel `channel`, and get its associated revision."
  [buildid channel]
  (let [p (split-buildid buildid)

        ;; Obtain a list of links to build directories in the desired channel
        build-dirs-url (format "https://archive.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/" (:y p) (:m p))
        target (format "%02d-%02d-%02d-%02d-%02d-%02d-%s/" (:y p) (:m p) (:d p) (:hour p) (:min p) (:sec p) channel)
        response (tagsoup/parse build-dirs-url)
        links (elements-by-tag-name response :a)
        build-dirs-suffix (format "-%s/" channel)
        build-dirs-links (filter #(.endsWith (get % 2) build-dirs-suffix) links)

        ;; Find the index of the link before the link having the specified buildid
        target-link-index (dec (first (keep-indexed #(when (= (clojure.string/trim (get %2 2)) target) %1) build-dirs-links)))]
    (if (= target-link-index -1) ; check if we have the directory of previous build in the same month's folder
        (let [year (if (= (:m p) 0) (dec (:y p)) (:y p)) ; the build is the first one in that month, use the last build of the previous month's folder
              month (if (= (:m p) 0) 12 (dec (:m p)))

              ;; Obtain the last link to build directories in the desired channel in the previous month's folder, which is the build dir of the last build in the previous month
              prev-build-dirs-url (format "https://archive.mozilla.org/pub/mozilla.org/firefox/nightly/%02d/%02d/" year month)
              response (tagsoup/parse prev-build-dirs-url)
              links (elements-by-tag-name response :a)
              target-link (last (filter #(.endsWith (get % 2) build-dirs-suffix) links))
              build-dir-url (str prev-build-dirs-url (:href (second target-link)))]
          (find-build-dir-revision build-dir-url))
        (let [target-link (nth build-dirs-links target-link-index) ; get the build directory and the revision from the link
              build-dir-url (str build-dirs-url (:href (second target-link)))]
          (find-build-dir-revision build-dir-url)))))

(defn find-build-changeset
  "Finds the changesets corresponding to the build with buildid `buildid`, which is a URL for a page with a list of all new changesets that went into that build."
  [buildid channel]
  (let [from-revision (find-preceding-build-revision buildid channel)
        to-revision (find-build-revision buildid channel)]
    (format "https://hg.mozilla.org/%s/pushloghtml?fromchange=%s&tochange=%s"
            channel from-revision to-revision)))

(defn find-date-buildid
  "Determines the buildid (a date-time of the form YYYYMMDDhhmmss) corresponding to a given build date `date` (a date of the form YYYY-MM-DD) on the channel string `channel`, generally mozilla-central."
  [date channel]
  (let [[_ year month day] (re-find #"^(\d{4})-(\d{2})-(\d{2})$" date)
        build-dirs-suffix (format "-%s/" channel)
        build-dirs-url (format "https://archive.mozilla.org/pub/mozilla.org/firefox/nightly/%s/%s/" year month)
        response (tagsoup/parse build-dirs-url)
        links (elements-by-tag-name response :a)
        build-dirs-links (filter #(.endsWith (get % 2) build-dirs-suffix) links)
        target-link (first (filter #(.startsWith (get % 2) date) build-dirs-links))
        [_ hour minute second] (re-find #"^\d{4}-\d{2}-\d{2}-(\d{2})-(\d{2})-(\d{2})" (get target-link 2))]
    (str year month day hour minute second)))

Use the new archive.mozilla.org URL, as ftp.mozilla.org is being phased out.


(ns quil.helpers.seqs
  (:require [quil.core :refer [noise]]))

(defn range-incl
  "Returns a lazy seq of nums from start (inclusive) to end
  (inclusive), by step, where start defaults to 0, end to infinity and
  step to 1 or -1 depending on whether end is greater than or less
  than start respectively."
  ([] (range-incl 0 Double/POSITIVE_INFINITY))
  ([end] (range-incl 0 end))
  ([start end] (if (< start end)
                 (range-incl start end 1)
                 (range-incl start end -1)))
  ([start end step]
   (lazy-seq
    (let [b (chunk-buffer 32)
          comp (if (pos? step) <= >=)]
      (loop [i start]
        (if (and (< (count b) 32)
                 (comp i end))
          (do
            (chunk-append b i)
            (recur (+ i step)))
          (chunk-cons (chunk b)
                      (when (comp i end)
                        (range-incl i end step)))))))))

(defn indexed-range-incl
  "Returns a sequence of [idx val] pairs over the specified inclusive
  range"
  ([] (indexed-range-incl 0 Double/POSITIVE_INFINITY))
  ([end] (indexed-range-incl 0 end))
  ([start end]
     (if (< start end)
       (indexed-range-incl start end 1)
       (indexed-range-incl start end -1)))
  ([start end step]
     (map list (range) (range-incl start end step))))

(defn indexed-range
  "Returns a sequence of [idx val] pairs over the specified range"
  ([] (indexed-range 0 Double/POSITIVE_INFINITY))
  ([end] (indexed-range 0 end))
  ([start end]
     (if (< start end)
       (indexed-range start end 1)
       (indexed-range start end -1)))
  ([start end step]
     (map list (range) (range start end step))))

(defn steps
  "Returns a lazy sequence of numbers starting at
  start (default 0) with successive additions of step. step may be a
  sequence of steps to apply."
  ([] (steps 1))
  ([step] (steps 0 step))
  ([start step]
     (let [[step next-step] (if (sequential? step)
                              [(first step) (next step)]
                              [step step])]
       (lazy-seq (cons start (if next-step
                               (steps (+ step start) next-step)
                               [(+ step start)]))))))

(defn cycle-between
  "Cycle between min and max with inc-step and dec-step starting at
  start in direction :up"
  ([min max] (cycle-between min min max 1 1))
  ([min max inc-step] (cycle-between min min max inc-step inc-step))
  ([min max inc-step dec-step] (cycle-between min min max inc-step dec-step))
  ([start min max inc-step dec-step] (cycle-between start min max inc-step dec-step :up))
  ([start min max inc-step dec-step direction]
     (let [inc-step (if (neg? inc-step) (* -1 inc-step) inc-step)
           dec-step (if (neg? dec-step) (* -1 dec-step) dec-step)
           next (if (= :up direction)
                  (+ start inc-step)
                  (- start dec-step))
           [next dir] (if (= :up direction)
                        (if (> next max) [(- start dec-step) :down] [next :up])
                        (if (< next min) [(+ start inc-step) :up] [next :down]))]
       (lazy-seq (cons start (cycle-between next min max inc-step dec-step dir))))))

(defn tap
  "Debug tool for lazy sequences. Apply to a lazy-seq to print out
  current value when each element of the sequence is evaluated."
  ([s] (tap "-->" s))
  ([msg s]
     (map #(do (println (str msg " " %)) %) s)))

(defn- swap-returning-prev!
  "Similar to swap! except returns vector containing the previous and new values

  (def a (atom 0))
  (swap-returning-prev! a inc) ;=> [0 1]"
  [atom f & args]
  (loop []
    (let [old-val  @atom
          new-val  (apply f (cons old-val args))
          success? (compare-and-set! atom old-val new-val)]
      (if success?
        [old-val new-val]
        (recur)))))

(defn seq->stream
  "Converts a sequence to a stream - a stateful function which returns
  each subequent element each time it is called

  (def s (seq->stream [1 2 3]))
  (s) ;=> 1
  (s) ;=> 2
  (s) ;=> 3
  (s) ;=> nil"
  [s]
  (let [state (atom (seq s))]
    (fn []
      (let [[old new] (swap-returning-prev! state rest)]
        (first old)))))

(defn tally
  "Cumulative tally. Takes a sequence of numbers and returns a new
  sequence which is a cumulative tally of the successive additions of
  each element in the original seq.

  (take 5 (tally (range))) ;=> [0 1 3 6 10]"
  ([s] (tally s 0))
  ([s amount]
     (lazy-seq
      (let [nxt-amount (+ (first s) amount)
            nxt-s (next s)]
        (cons nxt-amount (if nxt-s
                           (tally nxt-s nxt-amount)
                           []))))))

(defn perlin-noise-seq
  "Generate a lazy infinite sequence of perlin noise values starting from
  the specified seed with incr added to the seed for each successive value."
  [seed incr]
  (lazy-seq (cons (noise seed) (perlin-noise-seq (+ seed incr) incr))))

(ns quil.helpers.seqs
  (:require [quil.core :refer [noise]]))

(defn range-incl
  "Returns a lazy seq of nums from start (inclusive) to end
  (inclusive), by step, where start defaults to 0, end to infinity and
  step to 1 or -1 depending on whether end is greater than or less
  than start respectively."
  ([] (range-incl 0 Double/POSITIVE_INFINITY))
  ([end] (range-incl 0 end))
  ([start end] (if (< start end)
                 (range-incl start end 1)
                 (range-incl start end -1)))
  ([start end step]
   (lazy-seq
    (let [b (chunk-buffer 32)
          comp (if (pos? step) <= >=)]
      (loop [i start]
        (if (and (< (count b) 32)
                 (comp i end))
          (do
            (chunk-append b i)
            (recur (+ i step)))
          (chunk-cons (chunk b)
                      (when (comp i end)
                        (range-incl i end step)))))))))

(defn indexed-range-incl
  "Returns a sequence of [idx val] pairs over the specified inclusive
  range"
  ([] (indexed-range-incl 0 Double/POSITIVE_INFINITY))
  ([end] (indexed-range-incl 0 end))
  ([start end]
     (if (< start end)
       (indexed-range-incl start end 1)
       (indexed-range-incl start end -1)))
  ([start end step]
     (map list (range) (range-incl start end step))))

(defn indexed-range
  "Returns a sequence of [idx val] pairs over the specified range"
  ([] (indexed-range 0 Double/POSITIVE_INFINITY))
  ([end] (indexed-range 0 end))
  ([start end]
     (if (< start end)
       (indexed-range start end 1)
       (indexed-range start end -1)))
  ([start end step]
     (map list (range) (range start end step))))

(defn steps
  "Returns a lazy sequence of numbers starting at
  start (default 0) with successive additions of step. step may be a
  sequence of steps to apply."
  ([] (steps 1))
  ([step] (steps 0 step))
  ([start step]
     (let [[step next-step] (if (sequential? step)
                              [(first step) (next step)]
                              [step step])]
       (lazy-seq (cons start (if next-step
                               (steps (+ step start) next-step)
                               [(+ step start)]))))))

(defn cycle-between
  "Cycle between min and max with inc-step and dec-step starting at
  start in direction :up"
  ([min max] (cycle-between min min max 1 1))
  ([min max inc-step] (cycle-between min min max inc-step inc-step))
  ([min max inc-step dec-step] (cycle-between min min max inc-step dec-step))
  ([start min max inc-step dec-step] (cycle-between start min max inc-step dec-step :up))
  ([start min max inc-step dec-step direction]
     (let [inc-step (if (neg? inc-step) (* -1 inc-step) inc-step)
           dec-step (if (neg? dec-step) (* -1 dec-step) dec-step)
           next (if (= :up direction)
                  (+ start inc-step)
                  (- start dec-step))
           [next dir] (if (= :up direction)
                        (if (> next max) [(- start dec-step) :down] [next :up])
                        (if (< next min) [(+ start inc-step) :up] [next :down]))]
       (lazy-seq (cons start (cycle-between next min max inc-step dec-step dir))))))

(defn tap
  "Debug tool for lazy sequences. Apply to a lazy-seq to print out
  current value when each element of the sequence is evaluated."
  ([s] (tap "-->" s))
  ([msg s]
     (map #(do (println (str msg " " %)) %) s)))

(defn- swap-returning-prev!
  "Similar to swap! except returns vector containing the previous and new values

  (def a (atom 0))
  (swap-returning-prev! a inc) ;=> [0 1]"
  [atom f & args]
  (loop []
    (let [old-val  @atom
          new-val  (apply f (cons old-val args))
          success? (compare-and-set! atom old-val new-val)]
      (if success?
        [old-val new-val]
        (recur)))))

(defn seq->stream
  "Converts a sequence to a stream - a stateful function which returns
  each subequent element each time it is called

  (def s (seq->stream [1 2 3]))
  (s) ;=> 1
  (s) ;=> 2
  (s) ;=> 3
  (s) ;=> nil"
  [s]
  (let [state (atom (seq s))]
    (fn []
      (let [[old new] (swap-returning-prev! state rest)]
        (first old)))))

(defn tally
  "Cumulative tally. Returns a lazy sequence of the successive sums
  of coll, starting with init plus the first element.

  (take 5 (tally (range)))   ;=> (0 1 3 6 10)
  (take 5 (tally 3 (range))) ;=> (3 4 6 9 13)
  (tally [])                 ;=> ()
  (tally 100 [])             ;=> ()"
  ([coll] (tally 0 coll))
  ([init coll]
     (rest (reductions + init coll))))

(defn perlin-noise-seq
  "Generate a lazy infinite sequence of perlin noise values starting from
  the specified seed with incr added to the seed for each successive value."
  [seed incr]
  (lazy-seq (cons (noise seed) (perlin-noise-seq (+ seed incr) incr))))

Refactor tally to use reductions

Refactor tally to use reductions


;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>

(ns uxbox.cli.collimp
  "Collection importer command line helper."
  (:require [clojure.spec :as s]
            [clojure.pprint :refer [pprint]]
            [clojure.java.io :as io]
            [mount.core :as mount]
            [cuerdas.core :as str]
            [suricatta.core :as sc]
            [storages.core :as st]
            [storages.util :as fs]
            [uxbox.config]
            [uxbox.db :as db]
            [uxbox.migrations]
            [uxbox.media :as media]
            [uxbox.cli.sql :as sql]
            [uxbox.util.spec :as us]
            [uxbox.util.cli :as cli]
            [uxbox.util.uuid :as uuid]
            [uxbox.util.data :as data])
  (:import [java.io Reader PushbackReader]
           [javax.imageio ImageIO]))

;; --- Constants & Specs

(def ^:const +imates-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6e")

(s/def ::name string?)
(s/def ::type keyword?)
(s/def ::path string?)
(s/def ::regex us/regex?)

(s/def ::import-entry
  (s/keys :req-un [::name ::type ::path ::regex]))

;; --- CLI Helpers

(defn printerr
  [& args]
  (binding [*out* *err*]
    (apply println args)))

(defn pushback-reader
  [reader]
  (PushbackReader. ^Reader reader))

;; --- Colors Collections Importer

(def storage media/images-storage)

(defn- create-image-collection
  "Create or replace image collection by its name."
  [conn {:keys [name] :as entry}]
  (let [id (uuid/namespaced +imates-uuid-ns+ name)
        sqlv (sql/create-image-collection {:id id :name name})]
    (sc/execute conn sqlv)
    id))

(defn- retrieve-image-size
  [path]
  (let [path (fs/path path)
        file (.toFile path)
        buff (ImageIO/read file)]
    [(.getWidth buff)
     (.getHeight buff)]))

(defn- retrieve-image
  [conn id]
  {:pre [(uuid? id)]}
  (let [sqlv (sql/get-image {:id id})]
    (some->> (sc/fetch-one conn sqlv)
             (data/normalize-attrs))))

(defn- delete-image
  [conn {:keys [id path] :as image}]
  {:pre [(uuid? id)
         (fs/path? path)]}
  (let [sqlv (sql/delete-image {:id id})]
    @(st/delete storage path)
    (sc/execute conn sqlv)))

(defn- create-image
  [conn collid imageid localpath]
  {:pre [(fs/path? localpath)
         (uuid? collid)
         (uuid? imageid)]}
  (let [filename (fs/base-name localpath)
        [width height] (retrieve-image-size localpath)
        extension (second (fs/split-ext filename))
        path @(st/save storage filename localpath)
        params {:name filename
                :path (str path)
                :mimetype (case extension
                            ".jpg" "image/jpeg"
                            ".png" "image/png")
                :width width
                :height height
                :collection collid
                :id imageid}
        sqlv (sql/create-image params)]
    (sc/execute conn sqlv)))

(defn- import-image
  [conn id fpath]
  {:pre [(uuid? id) (fs/path? fpath)]}
  #_(let [imageid (uuid/namespaced +imates-uuid-ns+ (str id fpath))]
    (if-let [image (retrieve-image conn imageid)]
      (do
        (delete-image conn image)
        (create-image conn id imageid fpath))
      (create-image conn id imageid fpath))))

(defn- process-images-entry
  [conn {:keys [path regex] :as entry}]
  {:pre [(s/valid? ::import-entry entry)]}
  (let [id (uuid/random) #_(create-image-collection conn entry)]
    (doseq [fpath (fs/list-files path)]
      (when (re-matches regex (str fpath))
        (import-image conn id fpath)))))

;; --- Entry Point

(defn- check-path!
  [path]
  (when-not path
    (cli/print-err! "No path is provided.")
    (cli/exit! -1))
  (when-not (fs/exists? path)
    (cli/print-err! "Path does not exists.")
    (cli/exit! -1))
  (when (fs/directory? path)
    (cli/print-err! "The provided path is a directory.")
    (cli/exit! -1))
  (fs/path path))

(defn- read-import-file
  [path]
  (let [path (check-path! path)
        parent (fs/parent path)
        reader (pushback-reader (io/reader path))]
    [parent (read reader)]))

(defn- start-system
  []
  (-> (mount/only #{#'uxbox.config/config
                    #'uxbox.db/datasource
                    #'uxbox.migrations/migrations})
      (mount/start)))

(defn- stop-system
  []
  (mount/stop))

(defn- run-importer
  [directory data]
  (println "Running importer on:")
  (pprint data))

(defn -main
  [& [path]]
  (let [[directory data] (read-import-file path)]
    (start-system)
    (try
      (run-importer directory data)
      (finally
        (stop-system)))))

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) 2016 Andrey Antukh <niwi@niwi.nz>

(ns uxbox.cli.collimp
  "Collection importer command line helper."
  (:require [clojure.spec :as s]
            [clojure.pprint :refer [pprint]]
            [clojure.java.io :as io]
            [mount.core :as mount]
            [cuerdas.core :as str]
            [suricatta.core :as sc]
            [storages.core :as st]
            [storages.util :as fs]
            [uxbox.config]
            [uxbox.db :as db]
            [uxbox.migrations]
            [uxbox.media :as media]
            [uxbox.cli.sql :as sql]
            [uxbox.util.spec :as us]
            [uxbox.util.cli :as cli]
            [uxbox.util.uuid :as uuid]
            [uxbox.util.data :as data])
  (:import [java.io Reader PushbackReader]
           [javax.imageio ImageIO]))

;; --- Constants & Specs

(def ^:const +imates-uuid-ns+ #uuid "3642a582-565f-4070-beba-af797ab27a6e")

(s/def ::name string?)
(s/def ::path string?)
(s/def ::regex us/regex?)

(s/def ::import-entry
  (s/keys :req-un [::name ::path ::regex]))

;; --- CLI Helpers

(defn printerr
  [& args]
  (binding [*out* *err*]
    (apply println args)))

(defn pushback-reader
  [reader]
  (PushbackReader. ^Reader reader))

;; --- Colors Collections Importer

(def storage media/images-storage)

(defn- create-image-collection
  "Create or replace image collection by its name."
  [conn {:keys [name] :as entry}]
  (let [id (uuid/namespaced +imates-uuid-ns+ name)
        sqlv (sql/create-image-collection {:id id :name name})]
    (sc/execute conn sqlv)
    id))

(defn- retrieve-image-size
  [path]
  (let [path (fs/path path)
        file (.toFile path)
        buff (ImageIO/read file)]
    [(.getWidth buff)
     (.getHeight buff)]))

(defn- retrieve-image
  [conn id]
  {:pre [(uuid? id)]}
  (let [sqlv (sql/get-image {:id id})]
    (some->> (sc/fetch-one conn sqlv)
             (data/normalize-attrs))))

(defn- delete-image
  [conn {:keys [id path] :as image}]
  {:pre [(uuid? id)
         (fs/path? path)]}
  (let [sqlv (sql/delete-image {:id id})]
    @(st/delete storage path)
    (sc/execute conn sqlv)))

(defn- create-image
  [conn collid imageid localpath]
  {:pre [(fs/path? localpath)
         (uuid? collid)
         (uuid? imageid)]}
  (let [filename (fs/base-name localpath)
        [width height] (retrieve-image-size localpath)
        extension (second (fs/split-ext filename))
        path @(st/save storage filename localpath)
        params {:name filename
                :path (str path)
                :mimetype (case extension
                            ".jpg" "image/jpeg"
                            ".png" "image/png")
                :width width
                :height height
                :collection collid
                :id imageid}
        sqlv (sql/create-image params)]
    (sc/execute conn sqlv)))

(defn- import-image
  [conn id fpath]
  {:pre [(uuid? id) (fs/path? fpath)]}
  #_(let [imageid (uuid/namespaced +imates-uuid-ns+ (str id fpath))]
    (if-let [image (retrieve-image conn imageid)]
      (do
        (delete-image conn image)
        (create-image conn id imageid fpath))
      (create-image conn id imageid fpath))))

(defn- process-images-entry
  [conn {:keys [path regex] :as entry}]
  {:pre [(s/valid? ::import-entry entry)]}
  (let [id (uuid/random) #_(create-image-collection conn entry)]
    (doseq [fpath (fs/list-files path)]
      (when (re-matches regex (str fpath))
        (import-image conn id fpath)))))

;; --- Entry Point

(defn- check-path!
  [path]
  (when-not path
    (cli/print-err! "No path is provided.")
    (cli/exit! -1))
  (when-not (fs/exists? path)
    (cli/print-err! "Path does not exists.")
    (cli/exit! -1))
  (when (fs/directory? path)
    (cli/print-err! "The provided path is a directory.")
    (cli/exit! -1))
  (fs/path path))

(defn- read-import-file
  [path]
  (let [path (check-path! path)
        parent (fs/parent path)
        reader (pushback-reader (io/reader path))]
    [parent (read reader)]))

(defn- start-system
  []
  (-> (mount/only #{#'uxbox.config/config
                    #'uxbox.db/datasource
                    #'uxbox.migrations/migrations})
      (mount/start)))

(defn- stop-system
  []
  (mount/stop))

(defn- run-importer
  [directory data]
  (println "Running importer on:")
  (pprint data))

(defn -main
  [& [path]]
  (let [[directory data] (read-import-file path)]
    (start-system)
    (try
      (run-importer directory data)
      (finally
        (stop-system)))))

Remove unused type attr from import entry spec.


(ns graphql-clj.validator
  (:require [graphql-clj.validator.rules.default-values-of-correct-type]
            [graphql-clj.validator.rules.arguments-of-correct-type]
            [graphql-clj.validator.rules.fields-on-correct-type]
            [graphql-clj.validator.rules.known-argument-names]
            [graphql-clj.validator.rules.known-type-names]
            [graphql-clj.validator.rules.known-fragment-names]
            [graphql-clj.validator.rules.variables-are-input-types]
            [graphql-clj.validator.rules.no-undefined-variables]
            [graphql-clj.validator.rules.no-fragment-cycles]
            [graphql-clj.validator.rules.fragments-on-composite-types]
            [graphql-clj.validator.rules.unique-variable-names]
            [graphql-clj.validator.rules.unique-operation-names]
            [graphql-clj.validator.rules.unique-input-field-names]
            [graphql-clj.validator.rules.unique-fragment-names]
            [graphql-clj.validator.rules.unique-argument-names]
            [graphql-clj.validator.rules.provided-non-null-arguments]
            [graphql-clj.validator.rules.no-unused-variables]
            [graphql-clj.validator.rules.no-unused-fragments]
            [graphql-clj.validator.rules.known-directives]
            [graphql-clj.validator.rules.lone-anonymous-operation]
            [graphql-clj.validator.rules.variables-in-allowed-position]
            [graphql-clj.validator.rules.scalar-leafs]
            [graphql-clj.validator.transformations.unbox]
            [graphql-clj.validator.transformations.cleanup-paths]
            [graphql-clj.validator.transformations.schema :as ts]
            [graphql-clj.visitor :as visitor]
            [graphql-clj.spec :as spec]
            [instaparse.core :as insta]
            [graphql-clj.introspection :as intro]
            [graphql-clj.error :as ge]))

(def first-pass-rules [spec/fix-lists spec/add-spec spec/define-specs])

(def second-pass-rules-schema
  (flatten [graphql-clj.validator.rules.unique-input-field-names/schema-rules
            graphql-clj.validator.rules.unique-argument-names/schema-rules
            graphql-clj.validator.transformations.unbox/rules
            graphql-clj.validator.transformations.cleanup-paths/rules]))

(def second-pass-rules-statement
  (flatten [graphql-clj.validator.rules.lone-anonymous-operation/rules
            graphql-clj.validator.rules.known-type-names/rules
            graphql-clj.validator.rules.known-argument-names/rules
            graphql-clj.validator.rules.known-fragment-names/rules
            graphql-clj.validator.rules.no-undefined-variables/rules
            graphql-clj.validator.rules.unique-input-field-names/statement-rules
            graphql-clj.validator.rules.arguments-of-correct-type/rules
            graphql-clj.validator.rules.default-values-of-correct-type/rules
            graphql-clj.validator.rules.variables-are-input-types/rules
            graphql-clj.validator.rules.fields-on-correct-type/rules
            graphql-clj.validator.rules.no-fragment-cycles/rules
            graphql-clj.validator.rules.fragments-on-composite-types/rules
            graphql-clj.validator.rules.unique-variable-names/rules
            graphql-clj.validator.rules.unique-operation-names/rules
            graphql-clj.validator.rules.unique-fragment-names/rules
            graphql-clj.validator.rules.unique-argument-names/statement-rules
            graphql-clj.validator.rules.provided-non-null-arguments/rules
            graphql-clj.validator.rules.no-unused-variables/rules
            graphql-clj.validator.rules.no-unused-fragments/rules
            graphql-clj.validator.rules.known-directives/rules
            graphql-clj.validator.rules.variables-in-allowed-position/rules
            graphql-clj.validator.rules.scalar-leafs/rules
            graphql-clj.validator.transformations.unbox/rules
            graphql-clj.validator.transformations.cleanup-paths/rules]))

(defn- validate [visit-fn]
  (try
    (visit-fn)
    (catch Exception e
      {:state {:errors [(or (ex-data e) {:error (.getMessage e)})]}})))

(defn- guard-parsed [doc-type doc]
  (when (insta/failure? doc)
    (let [msg (format "Syntax error in %s document" doc-type)]
      (ge/throw-error msg {:loc {:line (:line doc) :column (:column doc)}}))))

(defn- inject-introspection-schema
  "Given a schema definition, add internal introspection type system definitions,
   unless we are processing the introspection schema itself."
  [schema]
  (if (= schema intro/introspection-schema)
    schema
    (update schema :type-system-definitions concat (:type-system-definitions intro/introspection-schema))))

(defn- validate-schema*
  "Inject the introspection schema to form a complete schema definition.
   Then, do a 2 pass validation:
   - 1) Add specs and validate that all types resolve.
   - 2) Apply validation rules and final transformations."
  [schema rules1 rules2]
  (guard-parsed "schema" schema)
  (let [combined-schema (inject-introspection-schema schema)
        s (visitor/initial-state combined-schema)
        {:keys [document state]} (visitor/visit-document combined-schema s rules1)
        second-pass (visitor/visit-document document state rules2)]
    (assoc-in second-pass [:state :schema] (ts/mapify-schema (:document second-pass)))))

(defn validate-statement*
  "Do a 2 pass validation of a statement"
  [document' state rules1 rules2]
  (guard-parsed "schema" state)
  (guard-parsed "statement" document')
  (let [s (assoc state :statement-hash (hash document'))
        {:keys [document state]} (visitor/visit-document document' s rules1)]
    (visitor/visit-document document state rules2)))

;; Public API

(defn validate-schema
  ([schema]
   (validate-schema schema second-pass-rules-schema))
  ([schema rules2]
   (:state (validate #(validate-schema* schema first-pass-rules rules2))))) ;; Unwrap state - it now encompasses the original schema

(defn validate-statement
  ([document state]
   (validate-statement document state second-pass-rules-statement))
  ([document state rules2]
   (if (:errors state) ;; Don't try to validate a statement if the schema is invalid
     state
     (validate #(validate-statement* document state first-pass-rules rules2)))))

(ns graphql-clj.validator
  (:require [graphql-clj.validator.rules.default-values-of-correct-type]
            [graphql-clj.validator.rules.arguments-of-correct-type]
            [graphql-clj.validator.rules.fields-on-correct-type]
            [graphql-clj.validator.rules.known-argument-names]
            [graphql-clj.validator.rules.known-type-names]
            [graphql-clj.validator.rules.known-fragment-names]
            [graphql-clj.validator.rules.variables-are-input-types]
            [graphql-clj.validator.rules.no-undefined-variables]
            [graphql-clj.validator.rules.no-fragment-cycles]
            [graphql-clj.validator.rules.fragments-on-composite-types]
            [graphql-clj.validator.rules.unique-variable-names]
            [graphql-clj.validator.rules.unique-operation-names]
            [graphql-clj.validator.rules.unique-input-field-names]
            [graphql-clj.validator.rules.unique-fragment-names]
            [graphql-clj.validator.rules.unique-argument-names]
            [graphql-clj.validator.rules.provided-non-null-arguments]
            [graphql-clj.validator.rules.no-unused-variables]
            [graphql-clj.validator.rules.no-unused-fragments]
            [graphql-clj.validator.rules.known-directives]
            [graphql-clj.validator.rules.lone-anonymous-operation]
            [graphql-clj.validator.rules.variables-in-allowed-position]
            [graphql-clj.validator.rules.scalar-leafs]
            [graphql-clj.validator.transformations.unbox]
            [graphql-clj.validator.transformations.cleanup-paths]
            [graphql-clj.validator.transformations.schema :as ts]
            [graphql-clj.visitor :as visitor]
            [graphql-clj.spec :as spec]
            [instaparse.core :as insta]
            [graphql-clj.introspection :as intro]
            [graphql-clj.error :as ge]))

(def first-pass-rules [spec/fix-lists spec/add-spec spec/define-specs])

(def second-pass-rules-schema
  (flatten [graphql-clj.validator.rules.unique-input-field-names/schema-rules
            graphql-clj.validator.rules.unique-argument-names/schema-rules
            graphql-clj.validator.transformations.unbox/rules
            graphql-clj.validator.transformations.cleanup-paths/rules]))

(def second-pass-rules-statement
  (flatten [graphql-clj.validator.rules.lone-anonymous-operation/rules
            graphql-clj.validator.rules.known-type-names/rules
            graphql-clj.validator.rules.known-argument-names/rules
            graphql-clj.validator.rules.known-fragment-names/rules
            graphql-clj.validator.rules.no-undefined-variables/rules
            graphql-clj.validator.rules.unique-input-field-names/statement-rules
            graphql-clj.validator.rules.arguments-of-correct-type/rules
            graphql-clj.validator.rules.default-values-of-correct-type/rules
            graphql-clj.validator.rules.variables-are-input-types/rules
            graphql-clj.validator.rules.fields-on-correct-type/rules
            graphql-clj.validator.rules.no-fragment-cycles/rules
            graphql-clj.validator.rules.fragments-on-composite-types/rules
            graphql-clj.validator.rules.unique-variable-names/rules
            graphql-clj.validator.rules.unique-operation-names/rules
            graphql-clj.validator.rules.unique-fragment-names/rules
            graphql-clj.validator.rules.unique-argument-names/statement-rules
            graphql-clj.validator.rules.provided-non-null-arguments/rules
            graphql-clj.validator.rules.no-unused-variables/rules
            graphql-clj.validator.rules.no-unused-fragments/rules
            graphql-clj.validator.rules.known-directives/rules
            graphql-clj.validator.rules.variables-in-allowed-position/rules
            graphql-clj.validator.rules.scalar-leafs/rules
            graphql-clj.validator.transformations.unbox/rules
            graphql-clj.validator.transformations.cleanup-paths/rules]))

(defn- validate [visit-fn]
  (try
    (visit-fn)
    (catch Exception e
      {:state {:errors [(or (ex-data e) {:error (.getMessage e)})]}})))

(defn- guard-parsed [doc-type doc]
  (when (insta/failure? doc)
    (let [msg (format "Syntax error in %s document" doc-type)]
      (ge/throw-error msg {:loc {:line (:line doc) :column (:column doc)}}))))

(defn- inject-introspection-schema
  "Given a schema definition, add internal introspection type system definitions,
   unless we are processing the introspection schema itself."
  [schema]
  (if (= schema intro/introspection-schema)
    schema
    (update schema :type-system-definitions concat (:type-system-definitions intro/introspection-schema))))

(defn- validate-schema**
  "Inject the introspection schema to form a complete schema definition.
   Then, do a 2 pass validation (without error handling):
   - 1) Add specs and validate that all types resolve.
   - 2) Apply validation rules and final transformations."
  [schema rules1 rules2]
  (guard-parsed "schema" schema)
  (let [combined-schema (inject-introspection-schema schema)
        s (visitor/initial-state combined-schema)
        {:keys [document state]} (visitor/visit-document combined-schema s rules1)
        second-pass (visitor/visit-document document state rules2)]
    (assoc-in second-pass [:state :schema] (ts/mapify-schema (:document second-pass)))))

(defn validate-statement**
  "Do a 2 pass validation of a statement (without error handling)"
  [document' state rules1 rules2]
  (guard-parsed "schema" state)
  (guard-parsed "statement" document')
  (let [s (assoc state :statement-hash (hash document'))
        {:keys [document state]} (visitor/visit-document document' s rules1)]
    (visitor/visit-document document state rules2)))

;; Public API

(defn validate-schema*
  "Validate a schema with error handling, but without memoization"
  ([schema]
   (validate-schema* schema second-pass-rules-schema))
  ([schema rules2]
   (:state (validate #(validate-schema** schema first-pass-rules rules2))))) ;; Unwrap state - it now encompasses the original schema

(def validate-schema (memoize validate-schema*))

(defn validate-statement*
  "Validate a statement with error handling, but without memoization"
  ([document state]
   (validate-statement* document state second-pass-rules-statement))
  ([document state rules2]
   (if (:errors state) ;; Don't try to validate a statement if the schema is invalid
     state
     (validate #(validate-statement** document state first-pass-rules rules2)))))

(def validate-statement (memoize validate-statement*))

Add memoization for schema and statement validation


{:plugins [[cider/cider-nrepl "0.15.0"]
           [refactor-nrepl "2.3.1"]]
 :dependencies [[cider/cider-nrepl "0.15.0"]
                [acyclic/squiggly-clojure "0.1.6"]]
 :env {:squiggly
       ;; Quote options to avoid warnings
       ;; introduced with `lein-environ 1.1.0` plugin
       "{:checkers [:eastwood]
         :eastwood-exclude-linters [:unlimited-use :no-ns-form-found]}"}}

{:plugins [[cider/cider-nrepl "0.15.1-SNAPSHOT"]
           [refactor-nrepl "2.4.0-SNAPSHOT"]]
 :dependencies [[acyclic/squiggly-clojure "0.1.8"]]
 :env {:squiggly
       ;; Quote options to avoid warnings
       ;; introduced with `lein-environ 1.1.0` plugin
       "{:checkers [:eastwood]
         :eastwood-exclude-linters [:unlimited-use :no-ns-form-found]}"}}

Use latest cider.

Use latest cider.

No need to specify cider-nrepl in both `:plugins` *and* `:dependencies`.
(Should only be in `:plugins`)


(ns ring.middleware.lint
  "Lint Ring requests and responses."
  (:use [clojure.contrib.except :only (throwf)])
  (:require [clojure.set :as set])
  (:import (java.io File InputStream)))

(defn- lint
  "Asserts that spec applied to val returns logical truth, otherwise raises
  an exception with a message produced by applying format to the message-pattern
  argument and a printing of an invalid val."
  [val spec message]
  (try
    (if-not (spec val)
      (throwf "Ring lint error: specified %s, but %s was not" message (pr-str val)))
    (catch Exception e
      (if-not (re-find #"^Ring lint error: " (.getMessage e))
        (throwf
          "Ring lint error: exception occured when checking that %s on %s: %s"
          message (pr-str val) (.getMessage e))
        (throw e)))))

(defn- check-req
  "Validates the request, throwing an exception on violations of the spec"
  [req]
  (lint req map?
    "Ring request must a Clojure map")

  (lint (:server-port req) integer?
    ":server-port must be an Integer")
  (lint (:server-name req) string?
    ":server-name must be a String")
  (lint (:remote-addr req) string?
    ":remote-addr must be a String")
  (lint (:uri req) #(and (string? %) (.startsWith ^String % "/"))
    ":uri must be a String starting with \"/\"")
  (lint (:query-string req) #(or (nil? %) (string? %))
    ":query-string must be nil or a non-blank String")
  (lint (:scheme req) #{:http :https}
    ":scheme must be one of :http or :https")
  (lint (:request-method req) #{:get :head :options :put :post :delete}
    ":request-method must be one of :get, :head, :options, :put, :post, or :delete")
  (lint (:content-type req) #(or (nil? %) (string? %))
    ":content-type must be nil or a String")
  (lint (:content-length req) #(or (nil? %) (integer? %))
    ":content-length must be nil or an Integer")
  (lint (:character-encoding req) #(or (nil? %) (string? %))
    ":character-encoding must be nil or a String")

  (let [headers (:headers req)]
    (lint headers map?
      ":headers must be a Clojure map")
    (doseq [[hname hval] headers]
      (lint hname string?
         "header names must be Strings")
      (lint hname #(= % (.toLowerCase ^String %))
        "header names must be in lower case")
      (lint hval string?
        "header values must be strings")))

  (lint (:body req) #(or (nil? %) (instance? InputStream %))
    ":body must be nil or an InputStream"))

(defn- check-resp
  "Validates the response, throwing an exception on violations of the spec"
  [resp]
  (lint resp map?
    "Ring response must be a Clojure map")

  (lint (:status resp) #(and (integer? %) (>= % 100))
    ":status must be an Intger greater than or equal to 100")

  (let [headers (:headers resp)]
    (lint headers map?
      ":headers must be a Clojure map")
    (doseq [[hname hval] headers]
      (lint hname string?
        "header names must Strings")
      (lint hval #(or (string? %) (every? string? %))
        "header values must be Strings or colls of Strings")))

  (lint (:body resp) #(or (nil? %) (string? %) (instance? File %)
                          (instance? InputStream %))
    ":body must a String, File, or InputStream"))

(defn wrap-lint
  "Wrap an app to validate incoming requests and outgoing responses
  according to the Ring spec."
  [app]
  (fn [req]
    (check-req req)
    (let [resp (app req)]
      (check-resp resp)
      resp)))

(ns ring.middleware.lint
  "Lint Ring requests and responses."
  (:require [clojure.set :as set])
  (:import (java.io File InputStream)))

(defn- lint
  "Asserts that spec applied to val returns logical truth, otherwise raises
  an exception with a message produced by applying format to the message-pattern
  argument and a printing of an invalid val."
  [val spec message]
  (try
    (if-not (spec val)
      (throw (Exception. (format "Ring lint error: specified %s, but %s was not" message (pr-str val)))))
    (catch Exception e
      (if-not (re-find #"^Ring lint error: " (.getMessage e))
        (throw (Exception. (format
          "Ring lint error: exception occured when checking that %s on %s: %s"
          message (pr-str val) (.getMessage e))))
        (throw e)))))

(defn- check-req
  "Validates the request, throwing an exception on violations of the spec"
  [req]
  (lint req map?
    "Ring request must a Clojure map")

  (lint (:server-port req) integer?
    ":server-port must be an Integer")
  (lint (:server-name req) string?
    ":server-name must be a String")
  (lint (:remote-addr req) string?
    ":remote-addr must be a String")
  (lint (:uri req) #(and (string? %) (.startsWith ^String % "/"))
    ":uri must be a String starting with \"/\"")
  (lint (:query-string req) #(or (nil? %) (string? %))
    ":query-string must be nil or a non-blank String")
  (lint (:scheme req) #{:http :https}
    ":scheme must be one of :http or :https")
  (lint (:request-method req) #{:get :head :options :put :post :delete}
    ":request-method must be one of :get, :head, :options, :put, :post, or :delete")
  (lint (:content-type req) #(or (nil? %) (string? %))
    ":content-type must be nil or a String")
  (lint (:content-length req) #(or (nil? %) (integer? %))
    ":content-length must be nil or an Integer")
  (lint (:character-encoding req) #(or (nil? %) (string? %))
    ":character-encoding must be nil or a String")

  (let [headers (:headers req)]
    (lint headers map?
      ":headers must be a Clojure map")
    (doseq [[hname hval] headers]
      (lint hname string?
         "header names must be Strings")
      (lint hname #(= % (.toLowerCase ^String %))
        "header names must be in lower case")
      (lint hval string?
        "header values must be strings")))

  (lint (:body req) #(or (nil? %) (instance? InputStream %))
    ":body must be nil or an InputStream"))

(defn- check-resp
  "Validates the response, throwing an exception on violations of the spec"
  [resp]
  (lint resp map?
    "Ring response must be a Clojure map")

  (lint (:status resp) #(and (integer? %) (>= % 100))
    ":status must be an Intger greater than or equal to 100")

  (let [headers (:headers resp)]
    (lint headers map?
      ":headers must be a Clojure map")
    (doseq [[hname hval] headers]
      (lint hname string?
        "header names must Strings")
      (lint hval #(or (string? %) (every? string? %))
        "header values must be Strings or colls of Strings")))

  (lint (:body resp) #(or (nil? %) (string? %) (instance? File %)
                          (instance? InputStream %))
    ":body must a String, File, or InputStream"))

(defn wrap-lint
  "Wrap an app to validate incoming requests and outgoing responses
  according to the Ring spec."
  [app]
  (fn [req]
    (check-req req)
    (let [resp (app req)]
      (check-resp resp)
      resp)))

Remove contrib dependencies from r.m.lint.