Merge branch 'master' of git://factorcode.org/git/factor
commit
07e7f3bcce
|
@ -1,6 +1,5 @@
|
|||
IN: temporary
|
||||
USING: bootstrap.image bootstrap.image.private
|
||||
tools.test.inference ;
|
||||
USING: bootstrap.image bootstrap.image.private tools.test ;
|
||||
|
||||
\ ' must-infer
|
||||
\ write-image must-infer
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
|
|||
namespaces namespaces tools.test sequences inference words
|
||||
arrays parser quotations continuations inference.backend effects
|
||||
namespaces.private io io.streams.string memory system threads
|
||||
tools.test.inference ;
|
||||
tools.test ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
@ -80,7 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
: indirect-test-1
|
||||
"int" { } "cdecl" alien-indirect ;
|
||||
|
||||
{ 1 1 } [ indirect-test-1 ] unit-test-effect
|
||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||
|
||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
||||
|
||||
|
@ -89,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
: indirect-test-2
|
||||
"int" { "int" "int" } "cdecl" alien-indirect data-gc ;
|
||||
|
||||
{ 3 1 } [ indirect-test-2 ] unit-test-effect
|
||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||
|
||||
[ 5 ]
|
||||
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: compiler definitions generic assocs inference math
|
||||
namespaces parser tools.test words kernel sequences arrays io
|
||||
effects tools.test.inference compiler.units inference.state ;
|
||||
effects tools.test compiler.units inference.state ;
|
||||
IN: temporary
|
||||
|
||||
DEFER: x-1
|
||||
|
@ -28,13 +28,13 @@ DEFER: c
|
|||
|
||||
[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
|
||||
|
||||
{ 0 4 } [ b ] unit-test-effect
|
||||
{ 0 4 } [ b ] must-infer-as
|
||||
|
||||
[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
|
||||
|
||||
[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
|
||||
|
||||
{ 0 6 } [ b ] unit-test-effect
|
||||
{ 0 6 } [ b ] must-infer-as
|
||||
|
||||
\ b word-xt "b-xt" set
|
||||
|
||||
|
@ -52,7 +52,7 @@ DEFER: c
|
|||
|
||||
[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
|
||||
|
||||
{ 0 4 } [ c ] unit-test-effect
|
||||
{ 0 4 } [ c ] must-infer-as
|
||||
|
||||
[ f ] [ "c-xt" get \ c word-xt = ] unit-test
|
||||
|
||||
|
|
|
@ -73,6 +73,12 @@ $nl
|
|||
{ $subsection infer-quot-value }
|
||||
"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
|
||||
|
||||
ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
|
||||
"The dataflow graph used by " { $link "compiler" } " can be obtained:"
|
||||
{ $subsection dataflow }
|
||||
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
|
||||
$nl ;
|
||||
|
||||
ARTICLE: "inference" "Stack effect inference"
|
||||
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
|
||||
$nl
|
||||
|
@ -80,14 +86,15 @@ $nl
|
|||
{ $subsection infer. }
|
||||
"Instead of printing the inferred information, it can be returned as objects on the stack:"
|
||||
{ $subsection infer }
|
||||
"The dataflow graph used by " { $link "compiler" } " can be obtained:"
|
||||
{ $subsection dataflow }
|
||||
"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
|
||||
$nl
|
||||
"The following articles describe the implementation of the stack effect inference algorithm:"
|
||||
{ $subsection "inference-simple" }
|
||||
{ $subsection "inference-combinators" }
|
||||
{ $subsection "inference-branches" }
|
||||
{ $subsection "inference-recursive" }
|
||||
{ $subsection "inference-limitations" }
|
||||
{ $subsection "dataflow-graphs" }
|
||||
{ $subsection "compiler-transforms" } ;
|
||||
|
||||
ABOUT: "inference"
|
||||
|
|
|
@ -4,23 +4,22 @@ math.parser math.private namespaces namespaces.private parser
|
|||
sequences strings vectors words quotations effects tools.test
|
||||
continuations generic.standard sorting assocs definitions
|
||||
prettyprint io inspector tuples classes.union classes.predicate
|
||||
debugger threads.private io.streams.string combinators.private
|
||||
tools.test.inference ;
|
||||
debugger threads.private io.streams.string combinators.private ;
|
||||
IN: temporary
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] unit-test-effect
|
||||
{ 1 2 } [ dup ] unit-test-effect
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
{ 1 2 } [ dup ] must-infer-as
|
||||
|
||||
{ 1 2 } [ [ dup ] call ] unit-test-effect
|
||||
{ 1 2 } [ [ dup ] call ] must-infer-as
|
||||
[ [ call ] infer ] must-fail
|
||||
|
||||
{ 2 4 } [ 2dup ] unit-test-effect
|
||||
{ 2 4 } [ 2dup ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] [ ] if ] unit-test-effect
|
||||
{ 1 0 } [ [ ] [ ] if ] must-infer-as
|
||||
[ [ if ] infer ] must-fail
|
||||
[ [ [ ] if ] infer ] must-fail
|
||||
[ [ [ 2 ] [ ] if ] infer ] must-fail
|
||||
{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
|
||||
{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
|
||||
|
||||
{ 4 3 } [
|
||||
[
|
||||
|
@ -28,17 +27,17 @@ IN: temporary
|
|||
] [
|
||||
-rot
|
||||
] if
|
||||
] unit-test-effect
|
||||
] must-infer-as
|
||||
|
||||
{ 1 1 } [ dup [ ] when ] unit-test-effect
|
||||
{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
|
||||
{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
|
||||
{ 1 1 } [ dup [ ] when ] must-infer-as
|
||||
{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
|
||||
{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ drop ] when* ] unit-test-effect
|
||||
{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
|
||||
{ 1 0 } [ [ drop ] when* ] must-infer-as
|
||||
{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
|
||||
|
||||
{ 0 1 }
|
||||
[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
|
||||
[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
|
||||
|
||||
[
|
||||
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
|
||||
|
@ -50,7 +49,7 @@ IN: temporary
|
|||
|
||||
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
|
||||
|
||||
{ 1 1 } [ termination-test-2 ] unit-test-effect
|
||||
{ 1 1 } [ termination-test-2 ] must-infer-as
|
||||
|
||||
: infinite-loop infinite-loop ;
|
||||
|
||||
|
@ -62,12 +61,12 @@ IN: temporary
|
|||
: simple-recursion-1 ( obj -- obj )
|
||||
dup [ simple-recursion-1 ] [ ] if ;
|
||||
|
||||
{ 1 1 } [ simple-recursion-1 ] unit-test-effect
|
||||
{ 1 1 } [ simple-recursion-1 ] must-infer-as
|
||||
|
||||
: simple-recursion-2 ( obj -- obj )
|
||||
dup [ ] [ simple-recursion-2 ] if ;
|
||||
|
||||
{ 1 1 } [ simple-recursion-2 ] unit-test-effect
|
||||
{ 1 1 } [ simple-recursion-2 ] must-infer-as
|
||||
|
||||
: bad-recursion-2 ( obj -- obj )
|
||||
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
||||
|
@ -77,10 +76,10 @@ IN: temporary
|
|||
: funny-recursion ( obj -- obj )
|
||||
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
||||
|
||||
{ 1 1 } [ funny-recursion ] unit-test-effect
|
||||
{ 1 1 } [ funny-recursion ] must-infer-as
|
||||
|
||||
! Simple combinators
|
||||
{ 1 2 } [ [ first ] keep second ] unit-test-effect
|
||||
{ 1 2 } [ [ first ] keep second ] must-infer-as
|
||||
|
||||
! Mutual recursion
|
||||
DEFER: foe
|
||||
|
@ -103,8 +102,8 @@ DEFER: foe
|
|||
2drop f
|
||||
] if ;
|
||||
|
||||
{ 2 1 } [ fie ] unit-test-effect
|
||||
{ 2 1 } [ foe ] unit-test-effect
|
||||
{ 2 1 } [ fie ] must-infer-as
|
||||
{ 2 1 } [ foe ] must-infer-as
|
||||
|
||||
: nested-when ( -- )
|
||||
t [
|
||||
|
@ -113,7 +112,7 @@ DEFER: foe
|
|||
] when
|
||||
] when ;
|
||||
|
||||
{ 0 0 } [ nested-when ] unit-test-effect
|
||||
{ 0 0 } [ nested-when ] must-infer-as
|
||||
|
||||
: nested-when* ( obj -- )
|
||||
[
|
||||
|
@ -122,11 +121,11 @@ DEFER: foe
|
|||
] when*
|
||||
] when* ;
|
||||
|
||||
{ 1 0 } [ nested-when* ] unit-test-effect
|
||||
{ 1 0 } [ nested-when* ] must-infer-as
|
||||
|
||||
SYMBOL: sym-test
|
||||
|
||||
{ 0 1 } [ sym-test ] unit-test-effect
|
||||
{ 0 1 } [ sym-test ] must-infer-as
|
||||
|
||||
: terminator-branch
|
||||
dup [
|
||||
|
@ -135,7 +134,7 @@ SYMBOL: sym-test
|
|||
"foo" throw
|
||||
] if ;
|
||||
|
||||
{ 1 1 } [ terminator-branch ] unit-test-effect
|
||||
{ 1 1 } [ terminator-branch ] must-infer-as
|
||||
|
||||
: recursive-terminator ( obj -- )
|
||||
dup [
|
||||
|
@ -144,7 +143,7 @@ SYMBOL: sym-test
|
|||
"Hi" throw
|
||||
] if ;
|
||||
|
||||
{ 1 0 } [ recursive-terminator ] unit-test-effect
|
||||
{ 1 0 } [ recursive-terminator ] must-infer-as
|
||||
|
||||
GENERIC: potential-hang ( obj -- obj )
|
||||
M: fixnum potential-hang dup [ potential-hang ] when ;
|
||||
|
@ -157,24 +156,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
|
|||
M: f iterate drop ;
|
||||
M: real iterate drop ;
|
||||
|
||||
{ 1 0 } [ iterate ] unit-test-effect
|
||||
{ 1 0 } [ iterate ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
|
||||
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
|
||||
{ 3 0 } [ dog ] unit-test-effect
|
||||
{ 3 0 } [ dog ] must-infer-as
|
||||
|
||||
! Regression
|
||||
DEFER: monkey
|
||||
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
|
||||
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
|
||||
{ 3 0 } [ friend ] unit-test-effect
|
||||
{ 3 0 } [ friend ] must-infer-as
|
||||
|
||||
! Regression -- same as above but we infer the second word first
|
||||
DEFER: blah2
|
||||
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
|
||||
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
|
||||
{ 3 0 } [ blah2 ] unit-test-effect
|
||||
{ 3 0 } [ blah2 ] must-infer-as
|
||||
|
||||
! Regression
|
||||
DEFER: blah4
|
||||
|
@ -182,7 +181,7 @@ DEFER: blah4
|
|||
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
|
||||
: blah4 ( a b c -- )
|
||||
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
|
||||
{ 3 0 } [ blah4 ] unit-test-effect
|
||||
{ 3 0 } [ blah4 ] must-infer-as
|
||||
|
||||
! Regression
|
||||
: bad-combinator ( obj quot -- )
|
||||
|
@ -199,7 +198,7 @@ DEFER: blah4
|
|||
dup string? [ 2array throw ] unless
|
||||
over string? [ 2array throw ] unless ;
|
||||
|
||||
{ 2 2 } [ bad-input# ] unit-test-effect
|
||||
{ 2 2 } [ bad-input# ] must-infer-as
|
||||
|
||||
! Regression
|
||||
|
||||
|
@ -218,7 +217,7 @@ DEFER: do-crap*
|
|||
! Regression
|
||||
: too-deep ( a b -- c )
|
||||
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
|
||||
{ 2 1 } [ too-deep ] unit-test-effect
|
||||
{ 2 1 } [ too-deep ] must-infer-as
|
||||
|
||||
! Error reporting is wrong
|
||||
MATH: xyz
|
||||
|
@ -258,17 +257,17 @@ DEFER: C
|
|||
[ dup B C ]
|
||||
} dispatch ;
|
||||
|
||||
{ 1 0 } [ A ] unit-test-effect
|
||||
{ 1 0 } [ B ] unit-test-effect
|
||||
{ 1 0 } [ C ] unit-test-effect
|
||||
{ 1 0 } [ A ] must-infer-as
|
||||
{ 1 0 } [ B ] must-infer-as
|
||||
{ 1 0 } [ C ] must-infer-as
|
||||
|
||||
! I found this bug by thinking hard about the previous one
|
||||
DEFER: Y
|
||||
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
|
||||
: Y ( a b -- c d ) X ;
|
||||
|
||||
{ 2 2 } [ X ] unit-test-effect
|
||||
{ 2 2 } [ Y ] unit-test-effect
|
||||
{ 2 2 } [ X ] must-infer-as
|
||||
{ 2 2 } [ Y ] must-infer-as
|
||||
|
||||
! This one comes from UI code
|
||||
DEFER: #1
|
||||
|
@ -332,9 +331,9 @@ DEFER: bar
|
|||
[ [ get-slots ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
! Test some curry stuff
|
||||
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
|
||||
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
|
||||
|
||||
{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
|
||||
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
|
||||
|
||||
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
|
||||
|
||||
|
@ -381,7 +380,7 @@ DEFER: bar
|
|||
\ assoc-like must-infer
|
||||
\ assoc-clone-like must-infer
|
||||
\ >alist must-infer
|
||||
{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
|
||||
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
|
||||
|
||||
! Test some random library words
|
||||
\ 1quotation must-infer
|
||||
|
@ -404,10 +403,10 @@ DEFER: bar
|
|||
\ define-predicate-class must-infer
|
||||
|
||||
! Test words with continuations
|
||||
{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
|
||||
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
|
||||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
|
||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
|
||||
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
|
||||
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
|
||||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
|
||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
|
||||
|
||||
\ dispose must-infer
|
||||
|
||||
|
@ -450,13 +449,13 @@ DEFER: bar
|
|||
[ [ barxxx ] infer ] must-fail
|
||||
|
||||
! A typo
|
||||
{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
|
||||
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
|
||||
|
||||
DEFER: inline-recursive-2
|
||||
: inline-recursive-1 ( -- ) inline-recursive-2 ;
|
||||
: inline-recursive-2 ( -- ) inline-recursive-1 ;
|
||||
|
||||
{ 0 0 } [ inline-recursive-1 ] unit-test-effect
|
||||
{ 0 0 } [ inline-recursive-1 ] must-infer-as
|
||||
|
||||
! Hooks
|
||||
SYMBOL: my-var
|
||||
|
@ -465,22 +464,22 @@ HOOK: my-hook my-var ( -- x )
|
|||
M: integer my-hook "an integer" ;
|
||||
M: string my-hook "a string" ;
|
||||
|
||||
{ 0 1 } [ my-hook ] unit-test-effect
|
||||
{ 0 1 } [ my-hook ] must-infer-as
|
||||
|
||||
DEFER: deferred-word
|
||||
|
||||
: calls-deferred-word [ deferred-word ] [ 3 ] if ;
|
||||
|
||||
{ 1 1 } [ calls-deferred-word ] unit-test-effect
|
||||
{ 1 1 } [ calls-deferred-word ] must-infer-as
|
||||
|
||||
USE: inference.dataflow
|
||||
|
||||
{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
|
||||
{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
|
||||
|
||||
{ 1 0 }
|
||||
[
|
||||
[ [ iterate-next ] iterate-nodes ] with-node-iterator
|
||||
] unit-test-effect
|
||||
] must-infer-as
|
||||
|
||||
: nilpotent ( quot -- )
|
||||
t [ [ call ] keep nilpotent ] [ drop ] if ; inline
|
||||
|
@ -490,11 +489,11 @@ USE: inference.dataflow
|
|||
|
||||
{ 0 1 }
|
||||
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
|
||||
unit-test-effect
|
||||
must-infer-as
|
||||
|
||||
{ 0 0 } [ [ ] semisimple ] unit-test-effect
|
||||
{ 0 0 } [ [ ] semisimple ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ drop ] each-node ] unit-test-effect
|
||||
{ 1 0 } [ [ drop ] each-node ] must-infer-as
|
||||
|
||||
DEFER: an-inline-word
|
||||
|
||||
|
@ -510,9 +509,9 @@ DEFER: an-inline-word
|
|||
: an-inline-word ( obj quot -- )
|
||||
>r normal-word r> call ; inline
|
||||
|
||||
{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
|
||||
{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
|
||||
|
||||
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
|
||||
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
|
||||
|
||||
TUPLE: custom-error ;
|
||||
|
||||
|
@ -536,4 +535,4 @@ TUPLE: custom-error ;
|
|||
|
||||
! This was a false trigger of the undecidable quotation
|
||||
! recursion bug
|
||||
{ 2 1 } [ find-last-sep ] unit-test-effect
|
||||
{ 2 1 } [ find-last-sep ] must-infer-as
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations tools.test.inference inference ;
|
||||
quotations inference ;
|
||||
|
||||
: compose-n-quot <repetition> >quotation ;
|
||||
: compose-n compose-n-quot call ;
|
||||
|
|
|
@ -25,14 +25,10 @@ $nl
|
|||
ABOUT: "number-strings"
|
||||
|
||||
HELP: digits>integer
|
||||
{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } }
|
||||
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
|
||||
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
|
||||
{ $notes "This is one of the factors of " { $link string>number } "." } ;
|
||||
|
||||
HELP: valid-digits?
|
||||
{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } }
|
||||
{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ;
|
||||
|
||||
HELP: >digit
|
||||
{ $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
|
||||
{ $description "Outputs a character representation of a digit." }
|
||||
|
@ -43,11 +39,6 @@ HELP: digit>
|
|||
{ $description "Converts a character representation of a digit to an integer." }
|
||||
{ $notes "This is one of the factors of " { $link string>number } "." } ;
|
||||
|
||||
HELP: string>integer
|
||||
{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } }
|
||||
{ $description "Creates an integer from a string representation." }
|
||||
{ $notes "The " { $link base> } " word is more general." } ;
|
||||
|
||||
HELP: base>
|
||||
{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
|
||||
{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."
|
||||
|
|
|
@ -148,10 +148,17 @@ SYMBOL: load-help?
|
|||
dup update-roots
|
||||
dup modified-sources swap modified-docs ;
|
||||
|
||||
: load-error. ( vocab error -- )
|
||||
"==== " write >r
|
||||
dup vocab-name swap f >vocab-link write-object ":" print nl
|
||||
r> print-error ;
|
||||
: vocab-heading. ( vocab -- )
|
||||
nl
|
||||
"==== " write
|
||||
dup vocab-name swap f >vocab-link write-object ":" print
|
||||
nl ;
|
||||
|
||||
: load-error. ( triple -- )
|
||||
dup first vocab-heading.
|
||||
dup second print-error
|
||||
drop ;
|
||||
! third "Traceback" swap write-object ;
|
||||
|
||||
TUPLE: require-all-error vocabs ;
|
||||
|
||||
|
@ -166,10 +173,14 @@ M: require-all-error summary
|
|||
dup length 1 = [ first require ] [
|
||||
[
|
||||
[
|
||||
[ [ require ] [ 2array , ] recover ] each
|
||||
[
|
||||
[ require ]
|
||||
[ error-continuation get 3array , ]
|
||||
recover
|
||||
] each
|
||||
] { } make
|
||||
dup empty? [ drop ] [
|
||||
dup [ nl load-error. ] assoc-each
|
||||
dup [ load-error. nl ] each
|
||||
keys require-all-error
|
||||
] if
|
||||
] with-compiler-errors
|
||||
|
|
|
@ -70,6 +70,7 @@ VAR: stamp
|
|||
"pull"
|
||||
"--no-summary"
|
||||
"git://factorcode.org/git/factor.git"
|
||||
! "http://dharmatech.onigirihouse.com/factor.git"
|
||||
"master"
|
||||
}
|
||||
run-process process-status
|
||||
|
|
|
@ -349,13 +349,23 @@ M: timestamp year. ( timestamp -- )
|
|||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] string-out ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
dup (timestamp>string)
|
||||
" " write
|
||||
timestamp-gmt-offset {
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg write-00 "00" write ] }
|
||||
{ [ dup 0 > ] [ "+" write write-00 "00" write ] }
|
||||
} cond
|
||||
] string-out ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt [
|
||||
(timestamp>string)
|
||||
" GMT" write
|
||||
] string-out ;
|
||||
>gmt timestamp>rfc822-string ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup timestamp-year number>string write CHAR: - write1
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: combinators.lib kernel math math.ranges random sequences
|
||||
tools.test tools.test.inference continuations arrays vectors ;
|
||||
tools.test continuations arrays vectors ;
|
||||
IN: temporary
|
||||
|
||||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||
|
|
|
@ -14,7 +14,7 @@ C: <node> node
|
|||
|
||||
: node-server ( port -- )
|
||||
internet-server
|
||||
"concurrency"
|
||||
"concurrency.distributed"
|
||||
[ handle-node-client ] with-server ;
|
||||
|
||||
: send-to-node ( msg pid host port -- )
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs hashtables html html.elements splitting
|
||||
http io kernel math math.parser namespaces parser sequences
|
||||
strings io.server vectors assocs.lib ;
|
||||
strings io.server vectors assocs.lib logging ;
|
||||
|
||||
IN: http.server.responders
|
||||
|
||||
|
@ -22,7 +22,7 @@ SYMBOL: responders
|
|||
<html> <body> <h1> write </h1> </body> </html> ;
|
||||
|
||||
: error-head ( error -- )
|
||||
dup log-error response
|
||||
response
|
||||
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
|
@ -30,6 +30,8 @@ SYMBOL: responders
|
|||
dup error-head
|
||||
"head" "method" get = [ drop ] [ error-body ] if ;
|
||||
|
||||
\ httpd-error ERROR add-error-logging
|
||||
|
||||
: bad-request ( -- )
|
||||
[
|
||||
! Make httpd-error print a body
|
||||
|
@ -84,17 +86,21 @@ SYMBOL: max-post-request
|
|||
: read-post-request ( header -- str hash )
|
||||
content-length [ read dup query>hash ] [ f f ] if* ;
|
||||
|
||||
: log-headers ( hash -- )
|
||||
LOG: log-headers DEBUG
|
||||
|
||||
: interesting-headers ( assoc -- string )
|
||||
[
|
||||
drop {
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append log-message
|
||||
] multi-assoc-each ;
|
||||
[
|
||||
drop {
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append % "\n" %
|
||||
] multi-assoc-each
|
||||
] "" make ;
|
||||
|
||||
: prepare-url ( url -- url )
|
||||
#! This is executed in the with-request namespace.
|
||||
|
@ -105,7 +111,7 @@ SYMBOL: max-post-request
|
|||
: prepare-header ( -- )
|
||||
read-header
|
||||
dup "header" set
|
||||
dup log-headers
|
||||
dup interesting-headers log-headers
|
||||
read-post-request "response" set "raw-response" set ;
|
||||
|
||||
! Responders are called in a new namespace with these
|
||||
|
@ -177,9 +183,6 @@ SYMBOL: max-post-request
|
|||
"/" "responder-url" set
|
||||
"default" responder call-responder ;
|
||||
|
||||
: log-responder ( path -- )
|
||||
"Calling responder " swap append log-message ;
|
||||
|
||||
: trim-/ ( url -- url )
|
||||
#! Trim a leading /, if there is one.
|
||||
"/" ?head drop ;
|
||||
|
@ -199,13 +202,15 @@ SYMBOL: max-post-request
|
|||
#! /foo/bar... - default responder used
|
||||
#! /responder/foo/bar - responder foo, argument bar
|
||||
vhost [
|
||||
dup log-responder trim-/ "responder/" ?head [
|
||||
trim-/ "responder/" ?head [
|
||||
serve-explicit-responder
|
||||
] [
|
||||
serve-default-responder
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
\ serve-responder DEBUG add-input-logging
|
||||
|
||||
: no-such-responder ( -- )
|
||||
"404 No such responder" httpd-error ;
|
||||
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel namespaces io strings splitting
|
||||
threads http http.server.responders sequences prettyprint
|
||||
io.server ;
|
||||
io.server logging ;
|
||||
|
||||
IN: http.server
|
||||
|
||||
|
@ -36,7 +36,6 @@ IN: http.server
|
|||
[ (handle-request) serve-responder ] with-scope ;
|
||||
|
||||
: parse-request ( request -- )
|
||||
dup log-message
|
||||
" " split1 dup [
|
||||
" HTTP" split1 drop url>path secure-path dup [
|
||||
swap handle-request
|
||||
|
@ -47,8 +46,9 @@ IN: http.server
|
|||
2drop bad-request
|
||||
] if ;
|
||||
|
||||
\ parse-request NOTICE add-input-logging
|
||||
|
||||
: httpd ( port -- )
|
||||
"Starting HTTP server on port " write dup . flush
|
||||
internet-server "http.server" [
|
||||
60000 stdio get set-timeout
|
||||
readln [ parse-request ] when*
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.inference io.launcher ;
|
||||
USING: tools.test io.launcher ;
|
||||
|
||||
\ <process-stream> must-infer
|
||||
|
|
|
@ -1,29 +1,6 @@
|
|||
USING: help help.syntax help.markup io ;
|
||||
IN: io.server
|
||||
|
||||
HELP: log-stream
|
||||
{ $var-description "Holds an output stream for logging messages." }
|
||||
{ $see-also log-error log-client with-logging } ;
|
||||
|
||||
HELP: log-message
|
||||
{ $values { "str" "a string" } }
|
||||
{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." }
|
||||
{ $see-also log-error log-client } ;
|
||||
|
||||
HELP: log-error
|
||||
{ $values { "str" "a string" } }
|
||||
{ $description "Logs an error message." }
|
||||
{ $see-also log-message log-client } ;
|
||||
|
||||
HELP: log-client
|
||||
{ $values { "client" "a client socket stream" } }
|
||||
{ $description "Logs an incoming client connection." }
|
||||
{ $see-also log-message log-error } ;
|
||||
|
||||
HELP: with-logging
|
||||
{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } }
|
||||
{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ;
|
||||
|
||||
HELP: with-client
|
||||
{ $values { "quot" "a quotation" } { "client" "a client socket stream" } }
|
||||
{ $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test.inference io.server ;
|
||||
USING: tools.test io.server ;
|
||||
|
||||
{ 1 0 } [ [ ] spawn-server ] unit-test-effect
|
||||
{ 1 0 } [ [ ] spawn-server ] must-infer-as
|
||||
|
|
|
@ -1,69 +1,34 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.sockets io.files continuations kernel math
|
||||
math.parser namespaces parser sequences strings
|
||||
USING: io io.sockets io.files logging continuations kernel
|
||||
math math.parser namespaces parser sequences strings
|
||||
prettyprint debugger quotations calendar qualified ;
|
||||
QUALIFIED: concurrency
|
||||
|
||||
IN: io.server
|
||||
|
||||
SYMBOL: log-stream
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-log-stream ( quot -- )
|
||||
log-stream get swap with-stream* ; inline
|
||||
|
||||
: log-message ( str -- )
|
||||
: with-client ( client quot -- )
|
||||
[
|
||||
"[" write now timestamp>string write "] " write
|
||||
print flush
|
||||
] with-log-stream ;
|
||||
over client-stream-addr accepted-connection
|
||||
with-stream*
|
||||
] curry with-disposal ; inline
|
||||
|
||||
: log-error ( str -- ) "Error: " swap append log-message ;
|
||||
|
||||
: log-client ( client -- )
|
||||
"Accepted connection from "
|
||||
swap client-stream-addr unparse append log-message ;
|
||||
|
||||
: log-file ( service -- path )
|
||||
".log" append resource-path ;
|
||||
|
||||
: with-log-file ( file quot -- )
|
||||
>r <file-appender> r>
|
||||
[ log-stream swap with-variable ] curry
|
||||
with-disposal ; inline
|
||||
|
||||
: with-log-stdio ( quot -- )
|
||||
stdio get log-stream rot with-variable ; inline
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
over [
|
||||
>r log-file
|
||||
"Writing log messages to " write dup print flush r>
|
||||
with-log-file
|
||||
] [
|
||||
nip with-log-stdio
|
||||
] if ; inline
|
||||
|
||||
: with-client ( quot client -- )
|
||||
dup log-client
|
||||
[ swap with-stream ] 2curry concurrency:spawn drop ; inline
|
||||
\ with-client NOTICE add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[ swap accept with-client ] 2keep accept-loop ; inline
|
||||
[
|
||||
>r accept r> [ with-client ] 2curry concurrency:spawn
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( server quot -- )
|
||||
[ accept-loop ] curry with-disposal ; inline
|
||||
|
||||
: spawn-server ( addrspec quot -- )
|
||||
"Waiting for connections on " pick unparse append
|
||||
log-message
|
||||
[
|
||||
>r <server> r> server-loop
|
||||
] [
|
||||
"Cannot spawn server: " print
|
||||
print-error
|
||||
2drop
|
||||
] recover ; inline
|
||||
>r <server> r> server-loop ; inline
|
||||
|
||||
\ spawn-server NOTICE add-error-logging
|
||||
|
||||
: local-server ( port -- seq )
|
||||
"localhost" swap t resolve-host ;
|
||||
|
@ -76,19 +41,21 @@ SYMBOL: log-stream
|
|||
[ spawn-server ] curry concurrency:parallel-each
|
||||
] curry with-logging ; inline
|
||||
|
||||
: log-datagram ( addrspec -- )
|
||||
"Received datagram from " swap unparse append log-message ;
|
||||
: received-datagram ( addrspec -- ) drop ;
|
||||
|
||||
\ received-datagram NOTICE add-input-logging
|
||||
|
||||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup log-datagram >r swap call r> ] keep
|
||||
[ receive dup received-datagram >r swap call r> ] keep
|
||||
pick [ send ] [ 3drop ] keep
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
"Waiting for datagrams on " over unparse append log-message
|
||||
<datagram> [ datagram-loop ] with-disposal ; inline
|
||||
|
||||
\ spawn-datagrams NOTICE add-input-logging
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
[
|
||||
[ swap spawn-datagrams ] curry concurrency:parallel-each
|
||||
|
|
|
@ -0,0 +1,69 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces words assocs logging sorting
|
||||
prettyprint io io.styles strings logging.parser ;
|
||||
IN: logging.analysis
|
||||
|
||||
SYMBOL: word-names
|
||||
SYMBOL: errors
|
||||
SYMBOL: word-histogram
|
||||
SYMBOL: message-histogram
|
||||
|
||||
: analyze-entry ( entry -- )
|
||||
dup second ERROR eq? [ dup errors get push ] when
|
||||
1 over third word-histogram get at+
|
||||
dup third word-names get member? [
|
||||
1 over 1 tail message-histogram get at+
|
||||
] when
|
||||
drop ;
|
||||
|
||||
: analyze-entries ( entries word-names -- errors word-histogram message-histogram )
|
||||
[
|
||||
word-names set
|
||||
V{ } clone errors set
|
||||
H{ } clone word-histogram set
|
||||
H{ } clone message-histogram set
|
||||
|
||||
[
|
||||
analyze-entry
|
||||
] each
|
||||
|
||||
errors get
|
||||
word-histogram get
|
||||
message-histogram get
|
||||
] with-scope ;
|
||||
|
||||
: histogram. ( assoc quot -- )
|
||||
standard-table-style [
|
||||
>r >alist sort-values <reversed> r> [
|
||||
[ >r swap r> with-cell pprint-cell ] with-row
|
||||
] curry assoc-each
|
||||
] tabular-output ;
|
||||
|
||||
: log-entry.
|
||||
[
|
||||
dup first [ write ] with-cell
|
||||
dup second [ pprint ] with-cell
|
||||
dup third [ write ] with-cell
|
||||
fourth "\n" join [ write ] with-cell
|
||||
] with-row ;
|
||||
|
||||
: errors. ( errors -- )
|
||||
standard-table-style
|
||||
[ [ log-entry. ] each ] tabular-output ;
|
||||
|
||||
: analysis. ( errors word-histogram message-histogram -- )
|
||||
"==== INTERESTING MESSAGES:" print nl
|
||||
"Total: " write dup values sum . nl
|
||||
[
|
||||
dup second write ": " write third "\n" join write
|
||||
] histogram.
|
||||
nl
|
||||
"==== WORDS:" print nl
|
||||
[ write ] histogram.
|
||||
nl
|
||||
"==== ERRORS:" print nl
|
||||
errors. ;
|
||||
|
||||
: log-analysis ( lines word-names -- )
|
||||
>r parse-log r> analyze-entries analysis. ;
|
|
@ -1 +1 @@
|
|||
Slava Pestov
|
||||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Analyze logs and produce summaries
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.analysis logging.server logging smtp io.sockets
|
||||
kernel io.files io.streams.string namespaces raptor.cron ;
|
||||
IN: logging.insomniac
|
||||
|
||||
SYMBOL: insomniac-config
|
||||
|
||||
SYMBOL: insomniac-smtp-host
|
||||
SYMBOL: insomniac-smtp-port
|
||||
SYMBOL: insomniac-sender
|
||||
SYMBOL: insomniac-recipients
|
||||
|
||||
: ?log-analysis ( service word-names -- string/f )
|
||||
>r log-path 1 log# dup exists? [
|
||||
file-lines r> [ log-analysis ] string-out
|
||||
] [
|
||||
r> 2drop f
|
||||
] if ;
|
||||
|
||||
: with-insomniac-smtp ( quot -- )
|
||||
[
|
||||
insomniac-smtp-host get [ smtp-host set ] when*
|
||||
insomniac-smtp-port get [ smtp-port set ] when*
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
: email-subject ( service -- string )
|
||||
[ "[INSOMNIAC] " % % " on " % host-name % ] "" make ;
|
||||
|
||||
: (email-log-report) ( service word-names -- )
|
||||
[
|
||||
over >r
|
||||
?log-analysis dup [
|
||||
r> email-subject
|
||||
insomniac-recipients get
|
||||
insomniac-sender get
|
||||
send-simple-message
|
||||
] [ r> 2drop ] if
|
||||
] with-insomniac-smtp ;
|
||||
|
||||
: email-log-report ( service word-names -- )
|
||||
(email-log-report) ;
|
||||
|
||||
\ email-log-report NOTICE add-error-logging
|
||||
|
||||
: schedule-insomniac ( service word-names -- )
|
||||
{ 25 } { 6 } f f f <when> -rot
|
||||
[ email-log-report ] 2curry schedule ;
|
|
@ -0,0 +1 @@
|
|||
Task which rotates logs and e-mails summaries
|
|
@ -0,0 +1,122 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: logging.server sequences namespaces concurrency
|
||||
words kernel arrays shuffle tools.annotations
|
||||
prettyprint.config prettyprint debugger io.streams.string
|
||||
splitting continuations effects arrays.lib parser strings
|
||||
combinators.lib ;
|
||||
IN: logging
|
||||
|
||||
SYMBOL: DEBUG
|
||||
SYMBOL: NOTICE
|
||||
SYMBOL: WARNING
|
||||
SYMBOL: ERROR
|
||||
SYMBOL: CRITICAL
|
||||
|
||||
: log-levels
|
||||
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
|
||||
: send-to-log-server ( array string -- )
|
||||
add* "log-server" get send ;
|
||||
|
||||
SYMBOL: log-service
|
||||
|
||||
: check-log-message
|
||||
pick string?
|
||||
pick word?
|
||||
pick word? and and
|
||||
[ "Bad parameters to log-message" throw ] unless ;
|
||||
|
||||
: log-message ( msg word level -- )
|
||||
check-log-message
|
||||
log-service get dup [
|
||||
>r >r >r string-lines r> word-name r> word-name r>
|
||||
4array "log-message" send-to-log-server
|
||||
] [
|
||||
4drop
|
||||
] if ;
|
||||
|
||||
: rotate-logs ( -- )
|
||||
{ } "rotate-logs" send-to-log-server ;
|
||||
|
||||
: close-log-files ( -- )
|
||||
{ } "close-log-files" send-to-log-server ;
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
log-service swap with-variable ; inline
|
||||
|
||||
! Aspect-oriented programming idioms
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: one-string?
|
||||
{
|
||||
[ dup array? ]
|
||||
[ dup length 1 = ]
|
||||
[ dup first string? ]
|
||||
} && nip ;
|
||||
|
||||
: inputs>message ( obj -- inputs>message )
|
||||
dup one-string? [ first ] [
|
||||
H{
|
||||
{ string-limit f }
|
||||
{ line-limit 1 }
|
||||
{ nesting-limit 3 }
|
||||
{ margin 0 }
|
||||
} clone [ unparse ] bind
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (define-logging) ( word level quot -- )
|
||||
>r >r dup r> r> 2curry annotate ;
|
||||
|
||||
: call-logging-quot ( quot word level -- quot' )
|
||||
"called" -rot [ log-message ] 3curry swap compose ;
|
||||
|
||||
: add-logging ( word level -- )
|
||||
[ call-logging-quot ] (define-logging) ;
|
||||
|
||||
: log-inputs ( n word level -- )
|
||||
log-service get [
|
||||
>r >r [ ndup ] keep narray inputs>message
|
||||
r> r> log-message
|
||||
] [
|
||||
3drop
|
||||
] if ; inline
|
||||
|
||||
: input# stack-effect effect-in length ;
|
||||
|
||||
: input-logging-quot ( quot word level -- quot' )
|
||||
over input# -rot [ log-inputs ] 3curry swap compose ;
|
||||
|
||||
: add-input-logging ( word level -- )
|
||||
[ input-logging-quot ] (define-logging) ;
|
||||
|
||||
: (log-error) ( object word level -- )
|
||||
log-service get [
|
||||
>r >r [ print-error ] string-out r> r> log-message
|
||||
] [
|
||||
2drop rethrow
|
||||
] if ;
|
||||
|
||||
: log-error ( object word -- ) ERROR (log-error) ;
|
||||
|
||||
: log-critical ( object word -- ) CRITICAL (log-error) ;
|
||||
|
||||
: error-logging-quot ( quot word -- quot' )
|
||||
dup stack-effect effect-in length
|
||||
[ >r log-error r> ndrop ] 2curry
|
||||
[ recover ] 2curry ;
|
||||
|
||||
: add-error-logging ( word level -- )
|
||||
[ over >r input-logging-quot r> error-logging-quot ]
|
||||
(define-logging) ;
|
||||
|
||||
: LOG:
|
||||
#! Syntax: name level
|
||||
CREATE
|
||||
dup reset-generic
|
||||
dup scan-word
|
||||
[ >r >r 1array inputs>message r> r> log-message ] 2curry
|
||||
define ; parsing
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser-combinators memoize kernel sequences
|
||||
logging arrays words strings vectors io io.files
|
||||
namespaces combinators combinators.lib logging.server ;
|
||||
IN: logging.parser
|
||||
|
||||
: string-of satisfy <!*> [ >string ] <@ ;
|
||||
|
||||
: 'date'
|
||||
[ CHAR: ] eq? not ] string-of
|
||||
"[" "]" surrounded-by ;
|
||||
|
||||
: 'log-level'
|
||||
log-levels [
|
||||
[ word-name token ] keep [ nip ] curry <@
|
||||
] map <or-parser> ;
|
||||
|
||||
: 'word-name'
|
||||
[ " :" member? not ] string-of ;
|
||||
|
||||
SYMBOL: malformed
|
||||
|
||||
: 'malformed-line'
|
||||
[ drop t ] string-of [ malformed swap 2array ] <@ ;
|
||||
|
||||
: 'log-message'
|
||||
[ drop t ] string-of [ 1vector ] <@ ;
|
||||
|
||||
MEMO: 'log-line' ( -- parser )
|
||||
'date' " " token <&
|
||||
'log-level' " " token <& <&>
|
||||
'word-name' ": " token <& <:&>
|
||||
'log-message' <:&>
|
||||
'malformed-line' <|> ;
|
||||
|
||||
: parse-log-line ( string -- entry )
|
||||
'log-line' parse-1 ;
|
||||
|
||||
: malformed? ( line -- ? )
|
||||
first malformed eq? ;
|
||||
|
||||
: multiline? ( line -- ? )
|
||||
first first CHAR: - = ;
|
||||
|
||||
: malformed-line
|
||||
"Warning: malformed log line:" print
|
||||
second print ;
|
||||
|
||||
: add-multiline ( line -- )
|
||||
building get empty? [
|
||||
"Warning: log begins with multiline entry" print drop
|
||||
] [
|
||||
fourth first building get peek fourth push
|
||||
] if ;
|
||||
|
||||
: parse-log ( lines -- entries )
|
||||
[
|
||||
[
|
||||
parse-log-line {
|
||||
{ [ dup malformed? ] [ malformed-line ] }
|
||||
{ [ dup multiline? ] [ add-multiline ] }
|
||||
{ [ t ] [ , ] }
|
||||
} cond
|
||||
] each
|
||||
] { } make ;
|
|
@ -0,0 +1 @@
|
|||
Log parser
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,101 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel io calendar sequences io.files
|
||||
io.sockets continuations prettyprint assocs math.parser
|
||||
words debugger math combinators concurrency arrays init
|
||||
math.ranges strings ;
|
||||
IN: logging.server
|
||||
|
||||
: log-root ( -- string )
|
||||
\ log-root get "logs" resource-path or ;
|
||||
|
||||
: log-path ( service -- path )
|
||||
log-root swap path+ ;
|
||||
|
||||
: log# ( path n -- path' )
|
||||
number>string ".log" append path+ ;
|
||||
|
||||
SYMBOL: log-files
|
||||
|
||||
: open-log-stream ( service -- stream )
|
||||
log-path
|
||||
dup make-directories
|
||||
1 log# <file-appender> ;
|
||||
|
||||
: log-stream ( service -- stream )
|
||||
log-files get [ open-log-stream ] cache ;
|
||||
|
||||
: (write-message) ( msg word-name level multi? -- )
|
||||
[
|
||||
"[" write 20 CHAR: - <string> write "] " write
|
||||
] [
|
||||
"[" write now (timestamp>rfc3339) "] " write
|
||||
] if
|
||||
write bl write ": " write print ;
|
||||
|
||||
: write-message ( msg word-name level -- )
|
||||
rot [ empty? not ] subset {
|
||||
{ [ dup empty? ] [ 3drop ] }
|
||||
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
|
||||
{ [ t ] [
|
||||
[ first -rot f (write-message) ] 3keep
|
||||
1 tail -rot [ t (write-message) ] 2curry each
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
: (log-message) ( msg -- )
|
||||
#! msg: { msg word-name level service }
|
||||
first4 log-stream [ write-message flush ] with-stream* ;
|
||||
|
||||
: try-dispose ( stream -- )
|
||||
[ dispose ] curry [ error. ] recover ;
|
||||
|
||||
: close-log-file ( service -- )
|
||||
log-files get delete-at*
|
||||
[ try-dispose ] [ drop ] if ;
|
||||
|
||||
: (close-log-files) ( -- )
|
||||
log-files get
|
||||
dup values [ try-dispose ] each
|
||||
clear-assoc ;
|
||||
|
||||
: keep-logs 10 ;
|
||||
|
||||
: ?delete-file ( path -- )
|
||||
dup exists? [ delete-file ] [ drop ] if ;
|
||||
|
||||
: delete-oldest keep-logs log# ?delete-file ;
|
||||
|
||||
: ?rename-file ( old new -- )
|
||||
over exists? [ rename-file ] [ 2drop ] if ;
|
||||
|
||||
: advance-log ( path n -- )
|
||||
[ 1- log# ] 2keep log# ?rename-file ;
|
||||
|
||||
: rotate-log ( service -- )
|
||||
dup close-log-file
|
||||
log-path
|
||||
dup delete-oldest
|
||||
keep-logs 1 [a,b] [ advance-log ] with each ;
|
||||
|
||||
: (rotate-logs) ( -- )
|
||||
(close-log-files)
|
||||
log-root directory [ drop rotate-log ] assoc-each ;
|
||||
|
||||
: log-server-loop
|
||||
[
|
||||
receive unclip {
|
||||
{ "log-message" [ (log-message) ] }
|
||||
{ "rotate-logs" [ drop (rotate-logs) ] }
|
||||
{ "close-log-files" [ drop (close-log-files) ] }
|
||||
} case
|
||||
] [ error. (close-log-files) ] recover
|
||||
log-server-loop ;
|
||||
|
||||
: log-server ( -- )
|
||||
[ log-server-loop ] spawn "log-server" set-global ;
|
||||
|
||||
[
|
||||
H{ } clone log-files set-global
|
||||
log-server
|
||||
] "logging" add-init-hook
|
|
@ -0,0 +1 @@
|
|||
Distributed concurrency log server
|
|
@ -0,0 +1 @@
|
|||
AOP Logging framework with support for log rotation and machine-readable logs
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel namespaces threads sequences calendar
|
||||
combinators.cleave combinators.lib ;
|
||||
combinators.cleave combinators.lib debugger ;
|
||||
|
||||
IN: raptor.cron
|
||||
|
||||
|
@ -43,9 +43,9 @@ C: <when> when
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: recurring-job ( when quot -- )
|
||||
[ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
|
||||
[ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
|
||||
|
||||
: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
|
||||
: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
@ -1 +1,3 @@
|
|||
Elie Chaftari
|
||||
Dirk Vleugels
|
||||
Slava Pestov
|
||||
|
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2007 Elie CHAFTARI
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! Usage: 8889 start-server
|
||||
! $ telnet 127.0.0.1 8889
|
||||
! Mock SMTP server for testing purposes.
|
||||
|
||||
! Usage: 4321 smtp-server
|
||||
! $ telnet 127.0.0.1 4321
|
||||
! Trying 127.0.0.1...
|
||||
! Connected to localhost.
|
||||
! Escape character is '^]'.
|
||||
|
@ -26,7 +28,7 @@
|
|||
! Connection closed by foreign host.
|
||||
|
||||
USING: combinators kernel prettyprint io io.server sequences
|
||||
namespaces ;
|
||||
namespaces io.sockets continuations ;
|
||||
|
||||
SYMBOL: data-mode
|
||||
|
||||
|
@ -59,10 +61,12 @@ SYMBOL: data-mode
|
|||
] }
|
||||
} cond nip [ process ] when ;
|
||||
|
||||
: start-server ( port -- )
|
||||
: smtp-server ( port -- )
|
||||
"Starting SMTP server on port " write dup . flush
|
||||
internet-server "smtp-server" [
|
||||
60000 stdio get set-timeout
|
||||
"220 hello\r\n" write flush
|
||||
process
|
||||
] with-server ;
|
||||
"127.0.0.1" swap <inet4> <server> [
|
||||
accept [
|
||||
60000 stdio get set-timeout
|
||||
"220 hello\r\n" write flush
|
||||
process
|
||||
] with-stream
|
||||
] with-disposal ;
|
|
@ -1,41 +1,111 @@
|
|||
! Tested with Apache JAMES version 2.3.1 on localhost
|
||||
! cram-md5 authentication tested against Exim 4
|
||||
! Replace "localhost" with your smtp server
|
||||
! e.g. "your.smtp.server" initialize
|
||||
USING: smtp tools.test io.streams.string threads
|
||||
smtp.server kernel sequences namespaces ;
|
||||
IN: temporary
|
||||
|
||||
USING: smtp tools.test ;
|
||||
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
|
||||
|
||||
"localhost" initialize ! replace localhost with your smtp server
|
||||
[ "hello\nworld" validate-address ] must-fail
|
||||
|
||||
! 8889 set-port ! default port = 25, change for testing purposes
|
||||
[ "slava@factorcode.org" ]
|
||||
[ "slava@factorcode.org" validate-address ] unit-test
|
||||
|
||||
! 30000 set-read-timeout ! default = 60000
|
||||
! f set-esmtp ! when esmtp (extended smtp) is not supported
|
||||
[ { "hello" "." "world" } validate-message ] must-fail
|
||||
|
||||
start
|
||||
[ "hello\r\nworld\r\n.\r\n" ] [
|
||||
{ "hello" "world" } [ send-body ] string-out
|
||||
] unit-test
|
||||
|
||||
! "md5 password here" "login" cram-md5-auth
|
||||
[
|
||||
[
|
||||
"500 syntax error" check-response
|
||||
] with-log-stdio
|
||||
] must-fail
|
||||
|
||||
"root@localhost" mailfrom ! your@mail.address
|
||||
[ ] [
|
||||
[
|
||||
"220 success" check-response
|
||||
] with-log-stdio
|
||||
] unit-test
|
||||
|
||||
"root@localhost" rcptto ! someone@example.com
|
||||
[ "220 success" ] [
|
||||
"220 success" [ receive-response ] string-in
|
||||
] unit-test
|
||||
|
||||
! { "From: Your Name <your@mail.address>"
|
||||
! "To: Destination Address <someone@example.com>"
|
||||
! "Subject: test message"
|
||||
! "Date: Thu, 17 May 2007 18:46:45 +0200"
|
||||
! "Message-Id: <unique.message.id.string@example.com>"
|
||||
! " "
|
||||
! "This is a test message."
|
||||
! } send-message
|
||||
[ "220 the end" ] [
|
||||
[
|
||||
"220-a multiline response\r\n250-another line\r\n220 the end"
|
||||
[ receive-response ] string-in
|
||||
] with-log-stdio
|
||||
] unit-test
|
||||
|
||||
{ "From: Your Name <root@localhost>"
|
||||
"To: Destination Address <root@localhost>"
|
||||
"Subject: test message"
|
||||
"Date: Thu, 17 May 2007 18:46:45 +0200"
|
||||
"Message-Id: <unique.message.id.string@example.com>"
|
||||
" "
|
||||
"This is a test message."
|
||||
} send-message
|
||||
[ ] [
|
||||
[
|
||||
"220-a multiline response\r\n250-another line\r\n220 the end"
|
||||
[ get-ok ] string-in
|
||||
] with-log-stdio
|
||||
] unit-test
|
||||
|
||||
quit
|
||||
[
|
||||
"Subject:\r\nsecurity hole" validate-header
|
||||
] must-fail
|
||||
|
||||
[
|
||||
V{
|
||||
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
|
||||
{ "From" "Doug <erg@factorcode.org>" }
|
||||
{ "Subject" "Factor rules" }
|
||||
}
|
||||
{ "slava@factorcode.org" "dharmatech@factorcode.org" }
|
||||
"erg@factorcode.org"
|
||||
] [
|
||||
"Factor rules"
|
||||
{
|
||||
"Slava <slava@factorcode.org>"
|
||||
"Ed <dharmatech@factorcode.org>"
|
||||
}
|
||||
"Doug <erg@factorcode.org>"
|
||||
simple-headers >r >r 2 head* r> r>
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
"To: Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>"
|
||||
"From: Doug <erg@factorcode.org>"
|
||||
"Subject: Factor rules"
|
||||
f
|
||||
f
|
||||
" "
|
||||
"Hi guys"
|
||||
"Bye guys"
|
||||
}
|
||||
{ "slava@factorcode.org" "dharmatech@factorcode.org" }
|
||||
"erg@factorcode.org"
|
||||
] [
|
||||
"Hi guys\nBye guys"
|
||||
"Factor rules"
|
||||
{
|
||||
"Slava <slava@factorcode.org>"
|
||||
"Ed <dharmatech@factorcode.org>"
|
||||
}
|
||||
"Doug <erg@factorcode.org>"
|
||||
prepare-simple-message
|
||||
>r >r f 3 pick set-nth f 4 pick set-nth r> r>
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ 4321 smtp-server ] in-thread ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
4321 smtp-port set
|
||||
|
||||
"Hi guys\nBye guys"
|
||||
"Factor rules"
|
||||
{
|
||||
"Slava <slava@factorcode.org>"
|
||||
"Ed <dharmatech@factorcode.org>"
|
||||
}
|
||||
"Doug <erg@factorcode.org>"
|
||||
|
||||
send-simple-message
|
||||
] with-scope
|
||||
] unit-test
|
|
@ -1,138 +1,170 @@
|
|||
! Copyright (C) 2007 Elie CHAFTARI
|
||||
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! cram-md5 auth code contributed by Dirk Vleugels <dvl@2scale.net>
|
||||
|
||||
USING: alien alien.c-types combinators crypto.common crypto.hmac base64
|
||||
kernel io io.sockets namespaces sequences splitting ;
|
||||
USING: namespaces io kernel logging io.sockets sequences
|
||||
combinators sequences.lib splitting assocs strings math.parser
|
||||
random system calendar ;
|
||||
|
||||
IN: smtp
|
||||
|
||||
! =========================================================
|
||||
! smtp.factor implementation
|
||||
! =========================================================
|
||||
SYMBOL: smtp-domain
|
||||
SYMBOL: smtp-host "localhost" smtp-host set-global
|
||||
SYMBOL: smtp-port 25 smtp-port set-global
|
||||
SYMBOL: read-timeout 60000 read-timeout set-global
|
||||
SYMBOL: esmtp t esmtp set-global
|
||||
|
||||
! Connection default values
|
||||
: default-port 25 ; inline
|
||||
: read-timeout 60000 ; inline
|
||||
: esmtp t ; inline ! t = ehlo
|
||||
: domain "localhost.localdomain" ; inline
|
||||
: log-smtp-connection ( host port -- ) 2drop ;
|
||||
|
||||
SYMBOL: sess
|
||||
SYMBOL: conn
|
||||
SYMBOL: challenge
|
||||
\ log-smtp-connection NOTICE add-input-logging
|
||||
|
||||
TUPLE: session address port timeout domain esmtp ;
|
||||
: with-smtp-connection ( quot -- )
|
||||
smtp-host get smtp-port get
|
||||
2dup log-smtp-connection
|
||||
<inet> <client> [
|
||||
smtp-domain [ host-name or ] change
|
||||
read-timeout get stdio get set-timeout
|
||||
call
|
||||
] with-stream ; inline
|
||||
|
||||
: <session> ( address -- session )
|
||||
default-port read-timeout domain esmtp
|
||||
session construct-boa ;
|
||||
: crlf "\r\n" write ;
|
||||
|
||||
! =========================================================
|
||||
! Initialization routines
|
||||
! =========================================================
|
||||
: helo ( -- )
|
||||
esmtp get "EHLO " "HELO " ? write host-name write crlf ;
|
||||
|
||||
: initialize ( address -- )
|
||||
<session> sess set ;
|
||||
: validate-address ( string -- string' )
|
||||
#! Make sure we send funky stuff to the server by accident.
|
||||
dup [ "\r\n>" member? ] contains?
|
||||
[ "Bad e-mail address: " swap append throw ] when ;
|
||||
|
||||
: set-port ( port -- )
|
||||
sess get set-session-port ;
|
||||
: mail-from ( fromaddr -- )
|
||||
"MAIL FROM:<" write validate-address write ">" write crlf ;
|
||||
|
||||
: set-read-timeout ( timeout -- )
|
||||
sess get set-session-timeout ;
|
||||
: rcpt-to ( to -- )
|
||||
"RCPT TO:<" write validate-address write ">" write crlf ;
|
||||
|
||||
: set-esmtp ( esmtp -- )
|
||||
sess get set-session-esmtp ;
|
||||
: data ( -- )
|
||||
"DATA" write crlf ;
|
||||
|
||||
: set-domain ( -- )
|
||||
host-name sess get set-session-domain ;
|
||||
: validate-message ( msg -- msg' )
|
||||
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
|
||||
|
||||
: do-start ( -- )
|
||||
sess get [ session-address ] keep session-port <inet> <client>
|
||||
dup conn set [ sess get session-timeout swap set-timeout ]
|
||||
keep stream-readln print ;
|
||||
: send-body ( body -- )
|
||||
validate-message
|
||||
[ write crlf ] each
|
||||
"." write crlf ;
|
||||
|
||||
! =========================================================
|
||||
! Command routines
|
||||
! =========================================================
|
||||
: quit ( -- )
|
||||
"QUIT" write crlf ;
|
||||
|
||||
LOG: smtp-response DEBUG
|
||||
|
||||
: check-response ( response -- )
|
||||
{
|
||||
{ [ dup "220" head? ] [ print ] }
|
||||
{ [ dup "235" swap subseq? ] [ print ] }
|
||||
{ [ dup "250" head? ] [ print ] }
|
||||
{ [ dup "221" head? ] [ print ] }
|
||||
{ [ dup "bye" head? ] [ print ] }
|
||||
{ [ dup "220" head? ] [ smtp-response ] }
|
||||
{ [ dup "235" swap subseq? ] [ smtp-response ] }
|
||||
{ [ dup "250" head? ] [ smtp-response ] }
|
||||
{ [ dup "221" head? ] [ smtp-response ] }
|
||||
{ [ dup "bye" head? ] [ smtp-response ] }
|
||||
{ [ dup "4" head? ] [ "server busy" throw ] }
|
||||
{ [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
|
||||
{ [ dup "354" head? ] [ print ] }
|
||||
{ [ dup "50" head? ] [ print "syntax error" throw ] }
|
||||
{ [ dup "53" head? ] [ print "invalid authentication data" throw ] }
|
||||
{ [ dup "55" head? ] [ print "fatal error" throw ] }
|
||||
{ [ t ] [ "unknow error" throw ] }
|
||||
{ [ dup "354" head? ] [ smtp-response ] }
|
||||
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
|
||||
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
|
||||
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
|
||||
{ [ t ] [ "unknown error" throw ] }
|
||||
} cond ;
|
||||
|
||||
SYMBOL: multiline
|
||||
|
||||
: multiline? ( response -- boolean )
|
||||
CHAR: - swap index 3 = ;
|
||||
?fourth CHAR: - = ;
|
||||
|
||||
: process-multiline ( -- response )
|
||||
conn get stream-readln dup
|
||||
multiline get " " append head? [
|
||||
print
|
||||
: process-multiline ( multiline -- response )
|
||||
>r readln r> 2dup " " append head? [
|
||||
drop dup smtp-response
|
||||
] [
|
||||
check-response process-multiline
|
||||
swap check-response process-multiline
|
||||
] if ;
|
||||
|
||||
: recv-response ( -- response )
|
||||
conn get stream-readln
|
||||
dup multiline? [
|
||||
dup 3 head multiline set process-multiline
|
||||
] [ ] if ;
|
||||
: receive-response ( -- response )
|
||||
readln
|
||||
dup multiline? [ 3 head process-multiline ] when ;
|
||||
|
||||
: get-ok ( command -- )
|
||||
>r conn get r> over stream-write stream-flush
|
||||
recv-response check-response ;
|
||||
: get-ok ( -- ) flush receive-response check-response ;
|
||||
|
||||
: helo ( -- )
|
||||
"HELO " sess get session-domain append "\r\n" append get-ok ;
|
||||
: send-raw-message ( body to from -- )
|
||||
[
|
||||
helo get-ok
|
||||
mail-from get-ok
|
||||
[ rcpt-to get-ok ] each
|
||||
data get-ok
|
||||
send-body get-ok
|
||||
quit get-ok
|
||||
] with-smtp-connection ;
|
||||
|
||||
: ehlo ( -- )
|
||||
"EHLO " sess get session-domain append "\r\n" append get-ok ;
|
||||
: validate-header ( string -- string' )
|
||||
dup [ "\r\n" member? ] contains?
|
||||
[ "Invalid header string: " swap append throw ] when ;
|
||||
|
||||
: mailfrom ( fromaddr -- )
|
||||
"MAIL FROM:<" swap append ">\r\n" append get-ok ;
|
||||
: prepare-header ( key value -- )
|
||||
swap
|
||||
validate-header %
|
||||
": " %
|
||||
validate-header % ;
|
||||
|
||||
: rcptto ( to -- )
|
||||
"RCPT TO:<" swap append ">\r\n" append get-ok ;
|
||||
: prepare-headers ( assoc -- )
|
||||
[ [ prepare-header ] "" make , ] assoc-each ;
|
||||
|
||||
: (cram-md5-auth) ( -- response )
|
||||
swap challenge get
|
||||
string>md5-hmac hex-string
|
||||
" " swap append append
|
||||
>base64 ;
|
||||
: extract-email ( recepient -- email )
|
||||
#! This could be much smarter.
|
||||
" " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
|
||||
|
||||
: cram-md5-auth ( key login -- )
|
||||
"AUTH CRAM-MD5\r\n" get-ok
|
||||
(cram-md5-auth) "\r\n" append get-ok ;
|
||||
|
||||
: data ( -- )
|
||||
"DATA\r\n" get-ok ;
|
||||
: message-id ( -- string )
|
||||
[
|
||||
"<" %
|
||||
2 big-random #
|
||||
"-" %
|
||||
millis #
|
||||
"@" %
|
||||
smtp-domain get %
|
||||
">" %
|
||||
] "" make ;
|
||||
|
||||
: start ( -- )
|
||||
set-domain ! replaces localhost.localdomain with hostname
|
||||
do-start
|
||||
sess get session-esmtp [
|
||||
ehlo
|
||||
] [
|
||||
helo
|
||||
] if ;
|
||||
: simple-headers ( subject to from -- headers to from )
|
||||
[
|
||||
>r dup ", " join "To" set [ extract-email ] map r>
|
||||
dup "From" set extract-email
|
||||
rot "Subject" set
|
||||
now timestamp>rfc822-string "Date" set
|
||||
message-id "Message-Id" set
|
||||
] { } make-assoc -rot ;
|
||||
|
||||
: send-message ( msg -- )
|
||||
data
|
||||
"\r\n" join conn get swap "\r\n" append over stream-write
|
||||
stream-flush ".\r\n" get-ok ;
|
||||
: prepare-message ( body headers -- body' )
|
||||
[
|
||||
prepare-headers
|
||||
" " ,
|
||||
dup string? [ string-lines ] when %
|
||||
] { } make ;
|
||||
|
||||
: quit ( -- )
|
||||
"QUIT\r\n" get-ok ;
|
||||
: prepare-simple-message ( body subject to from -- body' to from )
|
||||
simple-headers >r >r prepare-message r> r> ;
|
||||
|
||||
: send-message ( body headers to from -- )
|
||||
>r >r prepare-message r> r> send-raw-message ;
|
||||
|
||||
: send-simple-message ( body subject to from -- )
|
||||
prepare-simple-message send-raw-message ;
|
||||
|
||||
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
|
||||
! CRAM MD5, and the old code didn't work properly either, so here
|
||||
! it is in case anyone wants to fix it later.
|
||||
!
|
||||
! check-response used to have this clause:
|
||||
! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
|
||||
!
|
||||
! and the rest of the code was as follows:
|
||||
! : (cram-md5-auth) ( -- response )
|
||||
! swap challenge get
|
||||
! string>md5-hmac hex-string
|
||||
! " " swap append append
|
||||
! >base64 ;
|
||||
!
|
||||
! : cram-md5-auth ( key login -- )
|
||||
! "AUTH CRAM-MD5\r\n" get-ok
|
||||
! (cram-md5-auth) "\r\n" append get-ok ;
|
||||
|
|
|
@ -7,23 +7,31 @@ IN: tools.annotations
|
|||
: reset ( word -- )
|
||||
dup "unannotated-def" word-prop [
|
||||
[
|
||||
dup "unannotated-def" word-prop define
|
||||
dup dup "unannotated-def" word-prop define
|
||||
] with-compilation-unit
|
||||
f "unannotated-def" set-word-prop
|
||||
] [ drop ] if ;
|
||||
|
||||
: annotate ( word quot -- )
|
||||
over "unannotated-def" word-prop [
|
||||
"Cannot annotate a word twice" throw
|
||||
] when
|
||||
[
|
||||
over dup word-def "unannotated-def" set-word-prop
|
||||
>r dup word-def r> call define
|
||||
] with-compilation-unit ; inline
|
||||
|
||||
: word-inputs ( word -- seq )
|
||||
stack-effect [
|
||||
>r datastack r> effect-in length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
|
||||
: entering ( str -- )
|
||||
"/-- Entering: " write dup .
|
||||
stack-effect [
|
||||
>r datastack r> effect-in length tail* stack.
|
||||
] [
|
||||
.s
|
||||
] if* "\\--" print flush ;
|
||||
word-inputs stack.
|
||||
"\\--" print flush ;
|
||||
|
||||
: leaving ( str -- )
|
||||
"/-- Leaving: " write dup .
|
||||
|
|
|
@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq )
|
|||
{ [ "windows." ?head ] [ t ] }
|
||||
{ [ "cocoa" ?head ] [ t ] }
|
||||
{ [ ".test" ?tail ] [ t ] }
|
||||
{ [ "raptor" ?head ] [ t ] }
|
||||
{ [ dup "tools.deploy.app" = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
|
@ -1,15 +0,0 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: effects sequences kernel arrays quotations inference
|
||||
tools.test words ;
|
||||
IN: tools.test.inference
|
||||
|
||||
: short-effect
|
||||
dup effect-in length swap effect-out length 2array ;
|
||||
|
||||
: unit-test-effect ( effect quot -- )
|
||||
>r 1quotation r> [ infer short-effect ] curry unit-test ;
|
||||
|
||||
: must-infer ( word/quot -- )
|
||||
dup word? [ 1quotation ] when
|
||||
[ infer drop ] curry [ ] swap unit-test ;
|
|
@ -1,6 +1,36 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
USING: help.markup help.syntax kernel quotations io ;
|
||||
IN: tools.test
|
||||
|
||||
ARTICLE: "tools.test.write" "Writing unit tests"
|
||||
"Assert that a quotation outputs a specific set of values:"
|
||||
{ $subsection unit-test }
|
||||
"Assert that a quotation throws an error:"
|
||||
{ $subsection must-fail }
|
||||
{ $subsection must-fail-with }
|
||||
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
|
||||
{ $subsection must-infer }
|
||||
{ $subsection must-infer-as } ;
|
||||
|
||||
ARTICLE: "tools.test.run" "Running unit tests"
|
||||
"The following words run test harness files; any test failures are collected and printed at the end:"
|
||||
{ $subsection test }
|
||||
{ $subsection test-all } ;
|
||||
|
||||
ARTICLE: "tools.test.failure" "Handling test failures"
|
||||
"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "."
|
||||
$nl
|
||||
"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
|
||||
{ $list
|
||||
{ { $snippet "error" } " - the error thrown by the unit test" }
|
||||
{ { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
|
||||
{ { $snippet "continuation" } " - the traceback at the point of the error" }
|
||||
}
|
||||
"The following words run test harness files and output failures:"
|
||||
{ $subsection run-tests }
|
||||
{ $subsection run-all-tests }
|
||||
"The following word prints failures:"
|
||||
{ $subsection failures. } ;
|
||||
|
||||
ARTICLE: "tools.test" "Unit testing"
|
||||
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
|
||||
$nl
|
||||
|
@ -8,13 +38,10 @@ $nl
|
|||
$nl
|
||||
"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
|
||||
$nl
|
||||
"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
|
||||
{ $subsection unit-test }
|
||||
{ $subsection must-fail }
|
||||
{ $subsection must-fail-with }
|
||||
"The following words run test harness files; any test failures are collected and printed at the end:"
|
||||
{ $subsection test }
|
||||
{ $subsection test-all } ;
|
||||
"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run."
|
||||
{ $subsection "tools.test.write" }
|
||||
{ $subsection "tools.test.run" }
|
||||
{ $subsection "tools.test.failure" } ;
|
||||
|
||||
ABOUT: "tools.test"
|
||||
|
||||
|
@ -26,3 +53,37 @@ HELP: must-fail
|
|||
{ $values { "quot" "a quotation run with an empty stack" } }
|
||||
{ $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." }
|
||||
{ $notes "This word is used to test boundary conditions and fail-fast behavior." } ;
|
||||
|
||||
HELP: must-fail-with
|
||||
{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } }
|
||||
{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." }
|
||||
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
|
||||
|
||||
HELP: must-infer
|
||||
{ $values { "word/quot" "a quotation or a word" } }
|
||||
{ $description "Ensures that the quotation or word has a static stack effect without running it." }
|
||||
{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ;
|
||||
|
||||
HELP: must-infer-as
|
||||
{ $values { "effect" "a pair with shape " { $snippet "{ inputs outputs }" } } { "quot" quotation } }
|
||||
{ $description "Ensures that the quotation has the indicated stack effect without running it." }
|
||||
{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ;
|
||||
|
||||
HELP: test
|
||||
{ $values { "prefix" "a vocabulary name" } }
|
||||
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
|
||||
|
||||
HELP: run-tests
|
||||
{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
|
||||
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
|
||||
|
||||
HELP: test-all
|
||||
{ $description "Runs unit tests for all loaded vocabularies." } ;
|
||||
|
||||
HELP: run-all-tests
|
||||
{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
|
||||
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
|
||||
|
||||
HELP: failure.
|
||||
{ $values { "failures" "an association list of unit test failures" } }
|
||||
{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ;
|
||||
|
|
|
@ -3,7 +3,8 @@
|
|||
USING: namespaces arrays prettyprint sequences kernel
|
||||
vectors quotations words parser assocs combinators
|
||||
continuations debugger io io.files vocabs tools.time
|
||||
vocabs.loader source-files compiler.units inspector ;
|
||||
vocabs.loader source-files compiler.units inspector
|
||||
inference effects ;
|
||||
IN: tools.test
|
||||
|
||||
SYMBOL: failures
|
||||
|
@ -11,7 +12,8 @@ SYMBOL: failures
|
|||
: <failure> ( error what -- triple )
|
||||
error-continuation get 3array ;
|
||||
|
||||
: failure ( error what -- ) <failure> failures get push ;
|
||||
: failure ( error what -- )
|
||||
<failure> failures get push ;
|
||||
|
||||
SYMBOL: this-test
|
||||
|
||||
|
@ -28,13 +30,23 @@ SYMBOL: this-test
|
|||
{ } swap with-datastack swap >array assert=
|
||||
] 2curry (unit-test) ;
|
||||
|
||||
: short-effect ( effect -- pair )
|
||||
dup effect-in length swap effect-out length 2array ;
|
||||
|
||||
: must-infer-as ( effect quot -- )
|
||||
>r 1quotation r> [ infer short-effect ] curry unit-test ;
|
||||
|
||||
: must-infer ( word/quot -- )
|
||||
dup word? [ 1quotation ] when
|
||||
[ infer drop ] curry [ ] swap unit-test ;
|
||||
|
||||
TUPLE: expected-error ;
|
||||
|
||||
M: expected-error summary
|
||||
drop
|
||||
"The unit test expected the quotation to throw an error" ;
|
||||
|
||||
: must-fail-with ( quot test -- )
|
||||
: must-fail-with ( quot pred -- )
|
||||
>r [ expected-error construct-empty throw ] compose r>
|
||||
[ recover ] 2curry
|
||||
[ t ] swap unit-test ;
|
||||
|
@ -45,16 +57,23 @@ M: expected-error summary
|
|||
: ignore-errors ( quot -- )
|
||||
[ drop ] recover ; inline
|
||||
|
||||
: run-test ( path -- failures )
|
||||
[ "temporary" forget-vocab ] with-compilation-unit
|
||||
[
|
||||
V{ } clone [
|
||||
failures [
|
||||
[ run-file ] [ swap failure ] recover
|
||||
] with-variable
|
||||
] keep
|
||||
] keep
|
||||
[ forget-source ] with-compilation-unit ;
|
||||
: (run-test) ( vocab -- )
|
||||
dup vocab-source-loaded? [
|
||||
vocab-tests-path dup [
|
||||
dup ?resource-path exists? [
|
||||
[ "temporary" forget-vocab ] with-compilation-unit
|
||||
dup run-file
|
||||
[ dup forget-source ] with-compilation-unit
|
||||
] when
|
||||
] when
|
||||
] when drop ;
|
||||
|
||||
: run-test ( vocab -- failures )
|
||||
V{ } clone [
|
||||
failures [
|
||||
[ (run-test) ] [ swap failure ] recover
|
||||
] with-variable
|
||||
] keep ;
|
||||
|
||||
: failure. ( triple -- )
|
||||
dup second .
|
||||
|
@ -70,8 +89,7 @@ M: expected-error summary
|
|||
] [
|
||||
"==== FAILING TESTS:" print
|
||||
[
|
||||
nl
|
||||
"Failing tests in " write swap <pathname> .
|
||||
swap vocab-heading.
|
||||
[ nl failure. nl ] each
|
||||
] assoc-each
|
||||
] if
|
||||
|
@ -79,19 +97,12 @@ M: expected-error summary
|
|||
drop "==== NOTHING TO TEST" print
|
||||
] if ;
|
||||
|
||||
: run-vocab-tests ( vocabs -- failures )
|
||||
dup empty? [ f ] [
|
||||
: run-tests ( prefix -- failures )
|
||||
child-vocabs dup empty? [ f ] [
|
||||
[ dup run-test ] { } map>assoc
|
||||
[ second empty? not ] subset
|
||||
] if ;
|
||||
|
||||
: run-tests ( prefix -- failures )
|
||||
child-vocabs
|
||||
[ vocab-source-loaded? ] subset
|
||||
[ vocab-tests-path ] map
|
||||
[ dup [ ?resource-path exists? ] when ] subset
|
||||
run-vocab-tests ;
|
||||
|
||||
: test ( prefix -- )
|
||||
run-tests failures. ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test.inference ui.gadgets.books ;
|
||||
USING: tools.test ui.gadgets.books ;
|
||||
|
||||
\ <book> must-infer
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
IN: temporary
|
||||
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets tools.test namespaces sequences kernel models
|
||||
tools.test.inference ;
|
||||
ui.gadgets tools.test namespaces sequences kernel models ;
|
||||
|
||||
TUPLE: foo-gadget ;
|
||||
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
|
||||
definitions namespaces ui.gadgets
|
||||
ui.gadgets.grids prettyprint documents ui.gestures
|
||||
tools.test.inference tools.test.ui models ;
|
||||
definitions namespaces ui.gadgets ui.gadgets.grids prettyprint
|
||||
documents ui.gestures tools.test.ui models ;
|
||||
|
||||
[ "foo bar" ] [
|
||||
<editor> "editor" set
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
|
||||
namespaces models kernel tools.test.inference dlists math
|
||||
namespaces models kernel dlists math
|
||||
math.parser ui sequences hashtables assocs io arrays
|
||||
prettyprint io.streams.string ;
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: ui.gadgets ui.gadgets.scrollers
|
|||
namespaces tools.test kernel models ui.gadgets.viewports
|
||||
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
|
||||
ui.gadgets.sliders math math.vectors arrays sequences
|
||||
tools.test.inference tools.test.ui ;
|
||||
tools.test.ui ;
|
||||
|
||||
[ ] [
|
||||
<gadget> "g" set
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.ui ui.tools.browser
|
||||
tools.test.inference ;
|
||||
USING: tools.test tools.test.ui ui.tools.browser ;
|
||||
|
||||
\ <browser-gadget> must-infer
|
||||
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
USING: ui.tools.interactor tools.test.inference ;
|
||||
USING: ui.tools.interactor tools.test ;
|
||||
|
||||
\ <interactor> must-infer
|
||||
|
|
|
@ -80,14 +80,10 @@ H{ { +nullary+ t } } define-command
|
|||
\ refresh-all
|
||||
H{ { +nullary+ t } { +listener+ t } } define-command
|
||||
|
||||
\ test-changes
|
||||
H{ { +nullary+ t } { +listener+ t } } define-command
|
||||
|
||||
workspace "workflow" f {
|
||||
{ T{ key-down f { C+ } "n" } workspace-window }
|
||||
{ T{ key-down f f "ESC" } hide-popup }
|
||||
{ T{ key-down f f "F2" } refresh-all }
|
||||
{ T{ key-down f { A+ } "F2" } test-changes }
|
||||
} define-command-map
|
||||
|
||||
[
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
|
|||
ui.tools.workspace inspector kernel namespaces sequences threads
|
||||
listener tools.test ui ui.gadgets ui.gadgets.worlds
|
||||
ui.gadgets.packs vectors ui.tools tools.interpreter
|
||||
tools.interpreter.debug tools.test.inference tools.test.ui ;
|
||||
tools.interpreter.debug tools.test.ui ;
|
||||
IN: temporary
|
||||
|
||||
\ <walker> must-infer
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.inference ui.tools ;
|
||||
USING: tools.test ui.tools ;
|
||||
|
||||
\ <workspace> must-infer
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: calendar html io io.files kernel math math.parser
|
||||
http.server.responders http.server.templating namespaces parser
|
||||
sequences strings assocs hashtables debugger http.mime sorting
|
||||
html.elements ;
|
||||
html.elements logging ;
|
||||
|
||||
IN: webapps.file
|
||||
|
||||
|
@ -58,6 +58,8 @@ SYMBOL: page
|
|||
[ [ dup page set run-template-file ] with-scope ] try
|
||||
drop ;
|
||||
|
||||
\ run-page DEBUG add-input-logging
|
||||
|
||||
: include-page ( filename -- )
|
||||
"doc-root" get swap path+ run-page ;
|
||||
|
||||
|
@ -69,6 +71,8 @@ SYMBOL: page
|
|||
dup mime-type dup "application/x-factor-server-page" =
|
||||
[ drop serve-fhtml ] [ serve-static ] if ;
|
||||
|
||||
\ serve-file NOTICE add-input-logging
|
||||
|
||||
: file. ( name dirp -- )
|
||||
[ "/" append ] when
|
||||
dup <a =href a> write </a> ;
|
||||
|
@ -104,15 +108,15 @@ SYMBOL: page
|
|||
] if ;
|
||||
|
||||
: serve-object ( filename -- )
|
||||
dup directory? [ serve-directory ] [ serve-file ] if ;
|
||||
serving-path dup exists? [
|
||||
dup directory? [ serve-directory ] [ serve-file ] if
|
||||
] [
|
||||
drop "404 not found" httpd-error
|
||||
] if ;
|
||||
|
||||
: file-responder ( -- )
|
||||
"doc-root" get [
|
||||
"argument" get serving-path dup exists? [
|
||||
serve-object
|
||||
] [
|
||||
drop "404 not found" httpd-error
|
||||
] if
|
||||
"argument" get serve-object
|
||||
] [
|
||||
"404 doc-root not set" httpd-error
|
||||
] if ;
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting
|
|||
html.elements io assocs namespaces math threads vocabs html
|
||||
furnace http.server.templating calendar math.parser splitting
|
||||
continuations debugger system http.server.responders
|
||||
xml.writer prettyprint io.server ;
|
||||
xml.writer prettyprint logging ;
|
||||
IN: webapps.planet
|
||||
|
||||
: print-posting-summary ( posting -- )
|
||||
|
@ -75,27 +75,19 @@ SYMBOL: cached-postings
|
|||
|
||||
SYMBOL: last-update
|
||||
|
||||
: fetch-feed ( triple -- feed )
|
||||
second
|
||||
"Fetching " over append log-message
|
||||
dup download-feed feed-entries
|
||||
"Done fetching " swap append log-message ;
|
||||
|
||||
: <posting> ( author entry -- entry' )
|
||||
clone
|
||||
[ ": " swap entry-title 3append ] keep
|
||||
[ set-entry-title ] keep ;
|
||||
|
||||
: ?fetch-feed ( triple -- feed/f )
|
||||
[
|
||||
fetch-feed
|
||||
] [
|
||||
swap [ . error. ] with-log-stream f
|
||||
] recover ;
|
||||
: fetch-feed ( url -- feed )
|
||||
download-feed feed-entries ;
|
||||
|
||||
\ fetch-feed DEBUG add-error-logging
|
||||
|
||||
: fetch-blogroll ( blogroll -- entries )
|
||||
dup 0 <column>
|
||||
swap [ ?fetch-feed ] parallel-map
|
||||
swap [ fetch-feed ] parallel-map
|
||||
[ [ <posting> ] with map ] 2map concat ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
|
|
|
@ -1,28 +0,0 @@
|
|||
<% USING: namespaces math io ; %>
|
||||
|
||||
<h1>Annotate</h1>
|
||||
|
||||
<form method="POST" action="/responder/pastebin/annotate-paste">
|
||||
|
||||
<table>
|
||||
|
||||
<input type="hidden" name="n" value="<% "n" get number>string write %>" />
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th valign="top">Contents:</th>
|
||||
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Annotate" />
|
||||
</form>
|
|
@ -1,11 +0,0 @@
|
|||
<% USING: namespaces io ; %>
|
||||
|
||||
<h2>Annotation: <% "summary" get write %></h2>
|
||||
|
||||
<table>
|
||||
<tr><th>Annotation by:</th><td><% "author" get write %></td></tr>
|
||||
<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
|
||||
<tr><th>Created:</th><td><% "date" get write %></td></tr>
|
||||
</table>
|
||||
|
||||
<pre><% "contents" get write %></pre>
|
|
@ -1,4 +0,0 @@
|
|||
REQUIRES: libs/concurrency libs/furnace libs/irc libs/store ;
|
||||
|
||||
PROVIDE: apps/furnace-pastebin
|
||||
{ +files+ { "pastebin.factor" } } ;
|
|
@ -1,27 +0,0 @@
|
|||
<form method="POST" action="/responder/pastebin/submit-paste">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th>Summary:</th>
|
||||
<td><input type="TEXT" name="summary" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Your name:</th>
|
||||
<td><input type="TEXT" name="author" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th>Channel:</th>
|
||||
<td><input type="TEXT" name="channel" value="" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th valign="top">Contents:</th>
|
||||
<td><textarea rows="24" cols="60" name="contents"></textarea></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Submit paste" />
|
||||
</form>
|
|
@ -1,7 +0,0 @@
|
|||
<% USING: namespaces furnace sequences ; %>
|
||||
|
||||
<table width="100%">
|
||||
<% "new-paste-quot" get "New paste" render-link %>
|
||||
<tr align="left"><th> </th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr>
|
||||
<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table>
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
<% USING: namespaces io kernel math furnace ; %>
|
||||
|
||||
<tr>
|
||||
<td><% "n" get number>string write %></td>
|
||||
<td><% "summary" get write %></td>
|
||||
<td><% "author" get write %></td>
|
||||
<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
|
||||
<td><% "date" get print %></td>
|
||||
</tr>
|
|
@ -1,110 +0,0 @@
|
|||
IN: furnace:pastebin
|
||||
USING: calendar concurrency irc kernel namespaces sequences
|
||||
furnace hashtables math store ;
|
||||
|
||||
TUPLE: paste n summary author channel contents date annotations ;
|
||||
|
||||
TUPLE: annotation summary author contents ;
|
||||
|
||||
C: paste ( summary author channel contents -- paste )
|
||||
V{ } clone over set-paste-annotations
|
||||
[ set-paste-contents ] keep
|
||||
[ set-paste-channel ] keep
|
||||
[ set-paste-author ] keep
|
||||
[ set-paste-summary ] keep ;
|
||||
|
||||
TUPLE: pastebin pastes ;
|
||||
|
||||
C: pastebin ( -- pastebin )
|
||||
V{ } clone over set-pastebin-pastes ;
|
||||
|
||||
SYMBOL: store
|
||||
"pastebin.store" load-store store set-global
|
||||
<pastebin> pastebin store get store-variable
|
||||
|
||||
: add-paste ( paste pastebin -- )
|
||||
now timestamp>http-string pick set-paste-date
|
||||
dup pastebin-pastes length pick set-paste-n
|
||||
pastebin-pastes push ;
|
||||
|
||||
: get-paste ( n -- paste )
|
||||
pastebin get pastebin-pastes nth ;
|
||||
|
||||
: show-paste ( n -- )
|
||||
get-paste "show-paste" "Paste" render-page ;
|
||||
|
||||
\ show-paste { { "n" v-number } } define-action
|
||||
|
||||
: new-paste ( -- )
|
||||
f "new-paste" "New paste" render-page ;
|
||||
|
||||
\ new-paste { } define-action
|
||||
|
||||
: make-remote-process
|
||||
"trifocus.net" 4030 <node> "public-irc" <remote-process> ;
|
||||
|
||||
: alert-new-paste ( paste -- )
|
||||
>r make-remote-process r>
|
||||
f over paste-channel rot [
|
||||
dup paste-author %
|
||||
" pasted " %
|
||||
CHAR: " ,
|
||||
dup paste-summary %
|
||||
CHAR: " ,
|
||||
" at " %
|
||||
"http://wee-url.com/responder/pastebin/show-paste?n=" %
|
||||
paste-n #
|
||||
] "" make <chat-command> swap send ;
|
||||
|
||||
: alert-annotation ( annotation paste -- )
|
||||
make-remote-process -rot
|
||||
f over paste-channel 2swap [
|
||||
over annotation-author %
|
||||
" annotated paste " %
|
||||
" with \"" %
|
||||
over annotation-summary %
|
||||
"\" at " %
|
||||
"http://wee-url.com/responder/pastebin/show-paste?n=" %
|
||||
dup paste-n #
|
||||
2drop
|
||||
] "" make <chat-command> swap send ;
|
||||
|
||||
|
||||
: submit-paste ( summary author channel contents -- )
|
||||
<paste> dup pastebin get-global add-paste
|
||||
alert-new-paste store get save-store ;
|
||||
|
||||
\ submit-paste {
|
||||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "channel" "#concatenative" v-default }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
: paste-list ( -- )
|
||||
[
|
||||
[ show-paste ] "show-paste-quot" set
|
||||
[ new-paste ] "new-paste-quot" set
|
||||
|
||||
pastebin get "paste-list" "Pastebin" render-page
|
||||
] with-scope ;
|
||||
|
||||
\ paste-list { } define-action
|
||||
|
||||
\ submit-paste [ paste-list ] define-redirect
|
||||
|
||||
: annotate-paste ( paste# summary author contents -- )
|
||||
<annotation> swap get-paste
|
||||
[ paste-annotations push ] 2keep
|
||||
alert-annotation store get save-store ;
|
||||
|
||||
\ annotate-paste {
|
||||
{ "n" v-required v-number }
|
||||
{ "summary" v-required }
|
||||
{ "author" v-required }
|
||||
{ "contents" v-required }
|
||||
} define-action
|
||||
|
||||
\ annotate-paste [ "n" show-paste ] define-redirect
|
||||
|
||||
"pastebin" "paste-list" "apps/furnace-pastebin" web-app
|
|
@ -1,15 +0,0 @@
|
|||
<% USING: namespaces io furnace sequences ; %>
|
||||
|
||||
<h1>Paste: <% "summary" get write %></h1>
|
||||
|
||||
<table>
|
||||
<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
|
||||
<tr><th>Channel:</th><td><% "channel" get write %></td></tr>
|
||||
<tr><th>Created:</th><td><% "date" get write %></td></tr>
|
||||
</table>
|
||||
|
||||
<pre><% "contents" get write %></pre>
|
||||
|
||||
<% "annotations" get [ "annotation" render-template ] each %>
|
||||
|
||||
<% model get "annotate-paste" render-template %>
|
Loading…
Reference in New Issue