diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/org/gnu/clojure/gnunet/core.clj | 336 | ||||
| -rw-r--r-- | src/org/gnu/clojure/gnunet/exception.clj | 17 | ||||
| -rw-r--r-- | src/org/gnu/clojure/gnunet/filesharing.clj | 24 | ||||
| -rw-r--r-- | src/org/gnu/clojure/gnunet/parser.clj | 33 | ||||
| -rw-r--r-- | src/org/gnu/clojure/gnunet/transport.clj | 105 |
5 files changed, 231 insertions, 284 deletions
diff --git a/src/org/gnu/clojure/gnunet/core.clj b/src/org/gnu/clojure/gnunet/core.clj index f13ec9f..0c6442d 100644 --- a/src/org/gnu/clojure/gnunet/core.clj +++ b/src/org/gnu/clojure/gnunet/core.clj @@ -1,5 +1,5 @@ (ns org.gnu.clojure.gnunet.core - (:use (org.gnu.clojure.gnunet parser message peer crypto) + (:use (org.gnu.clojure.gnunet crypto exception message parser peer) clojure.contrib.monads) (:import (java.util Date Calendar))) @@ -161,146 +161,110 @@ (defn emit-messages! [peer remote-peer messages] - (send (:state-agent remote-peer) - (fn [state] - (if (:is-connected state) - (let [transport (:connected-transport state) - encoded-address (:connected-address state)] - ((:emit-messages! transport) transport remote-peer - encoded-address nil messages))) - state))) + (send-do-exception-m! (:state-agent remote-peer) + [is-connected (fetch-val :is-connected) + :when is-connected + transport (fetch-val :connected-transport) + encoded-address (fetch-val :connected-address)] + ((:emit-messages! transport) transport remote-peer encoded-address nil + messages))) (defn send-key! [peer remote-peer] - (send (:state-agent remote-peer) - (fn [state] - (if-let [public-key (deref (:public-key-atom remote-peer))] - (if (:is-connected state) - (let [state (if (= peer-status-down (:status state)) - (assoc state :status peer-status-key-sent) - state) - set-key {:sender-status (:status state) - :creation-time (:encrypt-key-created state) - :peer-id (:id remote-peer) - :encrypted-key (rsa-encrypt! - public-key - (encode-aes-key (:encrypt-key state)) - (:random peer))} - signed-material (encode-set-key-signed-material set-key) - signature (rsa-sign (:private-key peer) signed-material) - set-key (assoc set-key :signature signature) - encoded-set-key (encode-set-key set-key signed-material) - iv-seed (.nextInt (:random peer)) - ping {:iv-seed iv-seed - :challenge (:ping-challenge state) - :peer-id (:id remote-peer)} - encoded-ping (encode-core-ping ping - (:encrypt-key state) - (:id remote-peer))] - (emit-messages! peer remote-peer - [{:message-type message-type-core-set-key - :bytes encoded-set-key} - {:message-type message-type-core-ping - :bytes encoded-ping}]) - state) - state) - state)))) - -(defn verify-set-key - [peer remote-peer state message] - (when-let [public-key (deref (:public-key-atom remote-peer))] - (when-let [set-key (first (parse-set-key (:bytes message)))] - (let [status (:status state) - decrypt-key-created (:decrypt-key-created state)] - (cond - (not (= (:peer-id set-key) (seq (:id peer)))) nil - (not (rsa-verify public-key - (:signed-material set-key) (:signature set-key))) nil - (and - (or (= status peer-status-key-received) - (= status peer-status-key-confirmed)) - (< 0 (.compareTo decrypt-key-created (:creation-time set-key)))) nil - :else (when-let [decrypted-key (rsa-decrypt (:private-key peer) - (:encrypted-key set-key))] - ;; XXX: For some reason we end up with an extra 0 byte at the - ;; beginning of the decrypted-key when the MSB is 1. - (let [decrypted-key (drop (- (count decrypted-key) - aes-key-size 4) - decrypted-key)] - (when-let [decrypt-key (first - (parse-aes-key decrypted-key))] - (assoc set-key :decrypt-key decrypt-key))))))))) + (send-do-exception-m! (:state-agent remote-peer) + [:when-let [public-key (deref (:public-key-atom remote-peer))] + is-connected (fetch-val :is-connected) + :when is-connected + _ (update-val :status #(if (= % peer-status-down) peer-status-key-sent %)) + sender-status (fetch-val :status) + creation-time (fetch-val :encrypt-key-created) + encrypt-key (fetch-val :encrypt-key) + challenge (fetch-val :ping-challenge)] + (let [set-key {:sender-status sender-status + :creation-time creation-time + :peer-id (:id remote-peer) + :encrypted-key (rsa-encrypt! public-key + (encode-aes-key encrypt-key) + (:random peer))} + signed-material (encode-set-key-signed-material set-key) + signature (rsa-sign (:private-key peer) signed-material) + set-key (assoc set-key :signature signature) + encoded-set-key (encode-set-key set-key signed-material) + iv-seed (.nextInt (:random peer)) + ping {:iv-seed iv-seed + :challenge challenge + :peer-id (:id remote-peer)} + encoded-ping (encode-core-ping ping encrypt-key (:id remote-peer))] + (emit-messages! peer remote-peer + [{:message-type message-type-core-set-key :bytes encoded-set-key} + {:message-type message-type-core-ping :bytes encoded-ping}])))) (defn handle-set-key! [peer remote-peer message] - (send (:state-agent remote-peer) - (fn [state] - (if-let [set-key (verify-set-key peer remote-peer state message)] - (let [decrypt-key (:decrypt-key set-key) - state (assoc state :decrypt-key decrypt-key) - decrypt-key-created (:decrypt-key-created state) - creation-time (:creation-time set-key) - state (if (= decrypt-key-created creation-time) - state - (conj state {:last-sequence-number-received 0 - :last-packets-bitmap (int 0) - :decrypt-key-created creation-time})) - status (:status state) - sender-status (:sender-status set-key)] - (condp contains? status - #{peer-status-down} - (do (send-key! peer remote-peer) - (assoc state :status peer-status-key-received)) - #{peer-status-key-sent - peer-status-key-received} - (do (if (and (not (= sender-status peer-status-key-received)) - (not (= sender-status peer-status-key-confirmed))) - (send-key! peer remote-peer)) - (assoc state :status peer-status-key-received)) - #{peer-status-key-confirmed} - (do (if (and (not (= sender-status peer-status-key-received)) - (not (= sender-status peer-status-key-confirmed))) - (send-key! peer remote-peer)) - state) - state)) - state)))) + (send-do-exception-m! (:state-agent remote-peer) + [:when-let [public-key (deref (:public-key-atom remote-peer))] + :when-let [set-key (first (parse-set-key (:bytes message)))] + :when (= (:peer-id set-key) (:id peer)) + :when (rsa-verify public-key + (:signed-material set-key) (:signature set-key)) + status (fetch-val :status) + decrypt-key-created (fetch-val :decrypt-key-created) + :when-not (and + (or (= status peer-status-key-received) + (= status peer-status-key-confirmed)) + (.after decrypt-key-created (:creation-time set-key))) + :when-let [decrypted-key (rsa-decrypt (:private-key peer) + (:encrypted-key set-key))] + ;; XXX: For some reason we end up with an extra 0 byte at the + ;; beginning of the decrypted-key when the MSB is 1. + :let [decrypted-key (drop (- (count decrypted-key) aes-key-size 4) + decrypted-key)] + :when-let [decrypt-key (first (parse-aes-key decrypted-key))] + _ (set-val :decrypt-key decrypt-key) + :let [creation-time (:creation-time set-key)] + _ (update-state #(if (= decrypt-key-created creation-time) + % + (conj % {:last-sequence-number-received 0 + :last-packets-bitmap (int 0) + :decrypt-key-created creation-time}))) + :let [sender-status (:sender-status set-key)] + _ (update-val :status + #(if (= % peer-status-key-confirmed) % peer-status-key-received))] + (when (or (= status peer-status-down) + (and (not (= sender-status peer-status-key-received)) + (not (= sender-status peer-status-key-confirmed)))) + (send-key! peer remote-peer)))) (defn handle-core-ping! [peer remote-peer message] - (send (:state-agent remote-peer) - (fn [state] - (when-let [decrypt-key (:decrypt-key state)] - (when-let [ping (first ((parse-core-ping decrypt-key (:id peer)) - (:bytes message)))] - (when (= (:peer-id ping) (:id peer)) - (let [iv-seed (.nextInt (:random peer)) - pong {:iv-seed iv-seed - :challenge (:challenge ping) - :inbound-bw-limit (:bw-in state) - :peer-id (:id peer)} - encoded-pong (encode-core-pong pong - (:encrypt-key state) (:id remote-peer))] - (emit-messages! peer remote-peer - [{:message-type message-type-core-pong - :bytes encoded-pong}]))))) - state))) + (send-do-exception-m! (:state-agent remote-peer) + [decrypt-key (fetch-val :decrypt-key) + :when decrypt-key + :when-let [ping (first ((parse-core-ping decrypt-key (:id peer)) + (:bytes message)))] + bw-in (fetch-val :bw-in) + encrypt-key (fetch-val :encrypt-key)] + (let [iv-seed (.nextInt (:random peer)) + pong {:iv-seed iv-seed + :challenge (:challenge ping) + :inbound-bw-limit bw-in + :peer-id (:id peer)} + encoded-pong (encode-core-pong pong encrypt-key (:id remote-peer))] + (emit-messages! peer remote-peer + [{:message-type message-type-core-pong :bytes encoded-pong}])))) (defn handle-core-pong! [peer remote-peer message] - (send (:state-agent remote-peer) - (fn [state] - (if-let [decrypt-key (:decrypt-key state)] - (if-let [pong (first ((parse-core-pong decrypt-key - (:ping-challenge state) (:id peer)) - (:bytes message)))] - (if (= (:peer-id pong) (:id remote-peer)) - (condp = (:status state) - peer-status-key-received (assoc state :status - peer-status-key-confirmed) - state) - state) - state) - state)))) + (send-do-exception-m! (:state-agent remote-peer) + [decrypt-key (fetch-val :decrypt-key) + :when decrypt-key + challenge (fetch-val :ping-challenge) + :when-let [pong (first ((parse-core-pong decrypt-key + challenge (:id peer)) (:bytes message)))] + :when (= (:peer-id pong) (:id remote-peer)) + status (fetch-val :status) + :when (= status peer-status-key-received) + _ (set-val :status peer-status-key-confirmed)] nil)) (defn admit-core-message! [peer remote-peer message] @@ -308,75 +272,57 @@ (:message-type message))] (doseq [dispatcher! dispatchers] (dispatcher! peer remote-peer message)) - (do - (.write *out* "No dispatcher for message type ") - (.write *out* (.toString (:message-type message))) - (.write *out* "\n")))) + (.write *out* (str "No dispatcher for message type " + (:message-type message) "\n")))) (defn handle-core-encrypted-message! [peer remote-peer message] - (send (:state-agent remote-peer) - (fn [state] - (if-let [decrypt-key (:decrypt-key state)] - (if-let [message (first ((parse-core-encrypted-message decrypt-key - (:decrypt-key-created state) (:id peer)) - (:bytes message)))] - (let [last-seqnum-received (:last-sequence-number-received state) - seqnum (:sequence-number message)] - (cond - (.before (:timestamp message) (message-expiration)) - state - (== last-seqnum-received seqnum) - state - (> last-seqnum-received (+ 32 seqnum)) - state - (> last-seqnum-received seqnum) - (let [bit (bit-set 0 (- last-seqnum-received seqnum 1)) - bitmap (:last-packets-bitmap state)] - (if (bit-test bitmap bit) - state - (do - ;; TODO: update bandwidth tracking - (doseq [message (:messages message)] - (admit-core-message! peer remote-peer message)) - (assoc state :last-packets-bitmap (bit-or bitmap bit))))) - (< last-seqnum-received seqnum) - (let [bitmap (.intValue - (bit-shift-left - (bigint (:last-packets-bitmap state)) - (- seqnum last-seqnum-received)))] - ;; TODO: update bandwidth tracking - (doseq [message (:messages message)] - (admit-core-message! peer remote-peer message)) - (conj state {:last-packets-bitmap bitmap - :last-sequence-number-received seqnum})) - :else state)) - state) - state)))) - -(defn initialize-remote-peer-state - [peer state] - (conj state - {:status peer-status-down - :decrypt-key-created (Date. (long 0)) - :encrypt-key (generate-aes-key! (:random peer)) - :encrypt-key-created (Date.) - :ping-challenge (.nextInt (:random peer)) - ;; TODO: Make this a real number - :bw-in 20000})) + (send-do-exception-m! (:state-agent remote-peer) + [decrypt-key (fetch-val :decrypt-key) + :when decrypt-key + decrypt-key-created (fetch-val :decrypt-key-created) + :when-let [message (first + ((parse-core-encrypted-message decrypt-key + decrypt-key-created (:id peer)) (:bytes message)))] + last-seqnum (fetch-val :last-sequence-number-received) + :let [seqnum (:sequence-number message)] + :when-not (== last-seqnum seqnum) + :when-not (> last-seqnum (+ 32 seqnum)) + bitmap (fetch-val :last-packets-bitmap) + :let [bit (- last-seqnum seqnum 1)] + :when-not (and (> last-seqnum seqnum) (bit-test bitmap bit)) + _ (update-state + #(if (> last-seqnum seqnum) + (assoc % :last-packets-bitmap (bit-set bitmap bit)) + (conj % + {:last-sequence-number-received seqnum + :last-packets-bitmap (.intValue + (bit-shift-left (bigint bitmap) + (- seqnum last-seqnum)))}))) + :when-not (.before (:timestamp message) (message-expiration)) + ;; TODO: update bandwidth tracking + ] + (doseq [message (:messages message)] + (admit-core-message! peer remote-peer message)))) (defn handle-receive! [peer remote-peer message] - (send (:state-agent remote-peer) - (fn [state] - (let [state (if (contains? state :status) - state - (initialize-remote-peer-state peer state))] - (condp = (:message-type message) - message-type-core-set-key (handle-set-key! peer remote-peer message) - message-type-core-encrypted-message (handle-core-encrypted-message! - peer remote-peer message) - message-type-core-ping (handle-core-ping! peer remote-peer message) - message-type-core-pong (handle-core-pong! peer remote-peer message) - nil) - state)))) + (send-do-exception-m! (:state-agent remote-peer) + [_ (update-state + #(if (contains? % :status) + % + (conj % + {:status peer-status-down + :decrypt-key-created (Date. (long 0)) + :encrypt-key (generate-aes-key! (:random peer)) + :encrypt-key-created (Date.) + :ping-challenge (.nextInt (:random peer)) + ;; TODO: Make this a real number + :bw-in 20000})))] + (condp = (:message-type message) + message-type-core-set-key (handle-set-key! peer remote-peer message) + message-type-core-encrypted-message (handle-core-encrypted-message! + peer remote-peer message) + message-type-core-ping (handle-core-ping! peer remote-peer message) + message-type-core-pong (handle-core-pong! peer remote-peer message) + nil))) diff --git a/src/org/gnu/clojure/gnunet/exception.clj b/src/org/gnu/clojure/gnunet/exception.clj new file mode 100644 index 0000000..456bc05 --- /dev/null +++ b/src/org/gnu/clojure/gnunet/exception.clj @@ -0,0 +1,17 @@ +(ns org.gnu.clojure.gnunet.exception + (:use clojure.contrib.monads)) + +(def exception-m (maybe-t state-m :exception)) + +(with-monad exception-m + +(def nop (m-result nil)) + +(def break m-zero) +) + +(defmacro send-do-exception-m! + [target-agent steps expr] + `(send ~target-agent + (fn [state#] + (second ((domonad exception-m ~steps ~expr) state#))))) diff --git a/src/org/gnu/clojure/gnunet/filesharing.clj b/src/org/gnu/clojure/gnunet/filesharing.clj index 16c22b4..b253219 100644 --- a/src/org/gnu/clojure/gnunet/filesharing.clj +++ b/src/org/gnu/clojure/gnunet/filesharing.clj @@ -18,11 +18,11 @@ filter-mutator parse-int32 hash-bitmap parse-int32 query (items hash-size) - return-to (conditional (bit-test hash-bitmap bit-return-to) + return-to (m-when (bit-test hash-bitmap bit-return-to) (items id-size)) - sks-namespace (conditional (bit-test hash-bitmap bit-sks-namespace) + sks-namespace (m-when (bit-test hash-bitmap bit-sks-namespace) (items hash-size)) - transmit-to (conditional (bit-test hash-bitmap bit-transmit-to) + transmit-to (m-when (bit-test hash-bitmap bit-transmit-to) (items id-size)) bloomfilter (optional (parse-bloomfilter bloomfilter-k))] {:block-type block-type @@ -35,23 +35,15 @@ :transmit-to transmit-to :bloomfilter bloomfilter})) -(defn bound-priority - [priority remote-peer] - ) - (defn admit-get! [peer remote-peer message] (when-let [get-message (first (parse-get-message (:bytes message)))] - (.write *out* (.toString get-message)) - (.write *out* "\n") - ) - (when-let [return-to (if (:return-to message) - ((deref (:remote-peers-agent peer)) - (:return-to message)) - remote-peer)] - (when-let [priority (bound-priority (:priority message) remote-peer)] + (.write *out* (str get-message "\n")) + (when-let [return-to (if (:return-to get-message) + ((deref (:remote-peers-agent peer)) + (:return-to get-message)) + remote-peer)] ))) - (defn admit-put! [peer remote-peer message]) diff --git a/src/org/gnu/clojure/gnunet/parser.clj b/src/org/gnu/clojure/gnunet/parser.clj index c96b293..e931e90 100644 --- a/src/org/gnu/clojure/gnunet/parser.clj +++ b/src/org/gnu/clojure/gnunet/parser.clj @@ -3,6 +3,8 @@ (def parser-m (state-t maybe-m)) +(with-monad parser-m + (defn parser-m-until "An optimized implementation of m-until for the parser monad that replaces recursion by a loop." @@ -22,28 +24,20 @@ (defn satisfy "Produces a parser that matches an item which satisfies the given predicate." [p] - (domonad parser-m [x item - :when (p x)] + (domonad + [x item + :when (p x)] x)) (defn match-one "Match the first in a list of parsers." [& mvs] - (with-monad parser-m - (apply m-plus mvs))) + (apply m-plus mvs)) (defn optional "Makes a parser optional." [mv] - (with-monad parser-m - (m-plus mv (m-result nil)))) - -(defn conditional - "Returns the parser on a condition, otherwise a parser that returns nil." - [condition mv] - (if condition - mv - (with-monad parser-m (m-result nil)))) + (match-one mv (m-result nil))) (defn none-or-more "Makes a parser repeat none or more times." @@ -61,8 +55,9 @@ (defn one-or-more "Makes a parser repeat one or more times." [mv] - (domonad parser-m [x mv - xs (none-or-more mv)] + (domonad + [x mv + xs (none-or-more mv)] (cons x xs))) (defn n-times @@ -78,6 +73,8 @@ [0 []]) s)] [(second (first xs)) (second xs)]))) -(def - #^{:doc "Produces a parser that matches a number of items."} - items (partial n-times item)) +(defn items + "Produces a parser that matches a number of items." + [n] + (n-times item n)) +) diff --git a/src/org/gnu/clojure/gnunet/transport.clj b/src/org/gnu/clojure/gnunet/transport.clj index 6eca59a..1ad910f 100644 --- a/src/org/gnu/clojure/gnunet/transport.clj +++ b/src/org/gnu/clojure/gnunet/transport.clj @@ -1,5 +1,6 @@ (ns org.gnu.clojure.gnunet.transport - (:use (org.gnu.clojure.gnunet parser message hello peer util crypto core) + (:use (org.gnu.clojure.gnunet core crypto exception hello message parser peer + util) clojure.contrib.monads) (:import (java.util Date Calendar))) @@ -32,10 +33,11 @@ (:encoded-address ping))))) (def parse-ping - (domonad parser-m [challenge parse-uint32 - peer-id (items id-size) - transport (optional parse-utf8) - encoded-address (none-or-more item)] + (domonad parser-m + [challenge parse-uint32 + peer-id (items id-size) + transport (optional parse-utf8) + encoded-address (none-or-more item)] {:challenge challenge :peer-id peer-id :transport transport @@ -173,20 +175,22 @@ (defn verify-transport-address [peer remote-peer address] - (if (or (contains? address :latency) - (contains? address :send-time)) - address - (if-let [transport ((deref (:transports-agent peer)) - (:transport address))] - (let [challenge (.nextInt (:random peer))] - ((:emit-messages! transport) transport remote-peer - (:encoded-address address) nil - [(hello-for-peer-message peer) - (ping-message remote-peer address challenge)]) - (conj address - {:send-time (Date.) ;; TODO: Now is not the actual send time. - :challenge challenge})) - address))) + (second + ((domonad exception-m + [address (fetch-state) + :when (not (or (contains? address :latency) + (contains? address :send-time))) + :when-let [transport ((deref (:transports-agent peer)) + (:transport address))] + :let [challenge (.nextInt (:random peer))] + _ (set-state + (conj address + {:send-time (Date.) ;; TODO: Now is not the actual send time. + :challenge challenge}))] + ((:emit-messages! transport) transport remote-peer + (:encoded-address address) nil + [(hello-for-peer-message peer) + (ping-message remote-peer address challenge)])) address))) (defn verify-transport-addresses [addresses peer remote-peer] @@ -217,11 +221,11 @@ (defn send-pong-own! [peer remote-peer ping] - (if-let [transport-addresses ((deref (:transport-addresses-agent peer)) - (:transport ping))] + (when-let [transport-addresses ((deref (:transport-addresses-agent peer)) + (:transport ping))] ;; XXX: Here we're looking for an exact match, gnunet allows transport ;; plugins to do inexact matches. - (if (contains? transport-addresses (:encoded-address ping)) + (when (contains? transport-addresses (:encoded-address ping)) (let [pong {:challenge (:challenge ping) :signature-purpose signature-purpose-pong-own :expiration (pong-expiration) @@ -237,8 +241,8 @@ (doseq [transport-addresses (deref (:transport-addresses-agent remote-peer)) address (val transport-addresses)] - (if-let [transport ((deref (:transports-agent peer)) - (key transport-addresses))] + (when-let [transport ((deref (:transports-agent peer)) + (key transport-addresses))] ((:emit-messages! transport) transport remote-peer (key address) nil [{:message-type message-type-pong :bytes encoded-pong}]))))))) @@ -255,39 +259,30 @@ (:transport ping) (send-pong-own! peer remote-peer ping) :else (send-pong-using! peer remote-peer ping)))) -(defn check-pending-validation - [addresses remote-peer pong] - (if-let [public-key (deref (:public-key-atom remote-peer))] - (if-let [transport (addresses (:transport pong))] - (if-let [address (transport (:encoded-address pong))] - (cond - (not (= (:challenge address) (:challenge pong))) addresses - (= signature-purpose-pong-own (:signature-purpose pong)) - (if (rsa-verify public-key - (:signed-material pong) - (:signature pong)) - (assoc addresses (:transport pong) - (assoc transport (:encoded-address pong) - {:expiration (hello-address-expiration) - :latency (- (.getTime (Date.)) - (.getTime (:send-time address)))})) - addresses) - (= signature-purpose-pong-using (:signature-purpose pong)) - ;; TODO - fill in this case - addresses - :else addresses) - addresses) - addresses) - addresses)) - (defn handle-pong! [peer message] - (when-let [pong (first (parse-pong (:bytes message)))] - (if (not (.after (Date.) (:expiration pong))) - (when-let [remote-peer ((deref (:remote-peers-agent peer)) - (:peer-id pong))] - (send (:transport-addresses-agent remote-peer) check-pending-validation - remote-peer pong))))) + (domonad maybe-m + [pong (first (parse-pong (:bytes message))) + :when (not (.after (Date.) (:expiration pong))) + remote-peer ((deref (:remote-peers-agent peer)) (:peer-id pong)) + public-key (deref (:public-key-atom remote-peer))] + (send-do-exception-m! (:transport-addresses-agent remote-peer) + [address (with-state-field (:transport pong) + (fetch-val (:encoded-address pong))) + :when (= (:challenge address) (:challenge pong)) + _ (cond + (= signature-purpose-pong-own (:signature-purpose pong)) + (if (rsa-verify public-key (:signed-material pong) (:signature pong)) + (with-state-field (:transport pong) + (set-val (:encoded-address pong) + {:expiration (hello-address-expiration) + :latency (- (.getTime (Date.)) + (.getTime (:send-time address)))})) + break) + (= signature-purpose-pong-using (:signature-purpose pong)) + ;; TODO - fill in this case + break + :else break)] nil))) (defn emit-continuation! [peer transport remote-peer encoded-address result] |