2008-09-19 16:45:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								! Copyright (C) 2008 Slava Pestov.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							
								
									
										
										
										
											2008-06-02 16:38:44 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								USING: math kernel accessors http.server http.server.dispatchers
							 | 
						
					
						
							
								
									
										
										
										
											2008-06-17 06:21:45 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								furnace furnace.actions furnace.sessions furnace.redirection
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-23 04:35:01 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								html.components html.forms fry urls ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-29 06:58:34 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: webapps.counter
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								SYMBOL: count
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								TUPLE: counter-app < dispatcher ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-26 01:47:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								M: counter-app init-session* drop 0 count sset ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-29 06:58:34 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-26 01:47:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: <counter-action> ( quot -- action )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    <action>
							 | 
						
					
						
							
								
									
										
										
										
											2008-06-01 18:22:39 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        swap '[
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-10 23:11:40 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								            count _ schange
							 | 
						
					
						
							
								
									
										
										
										
											2008-06-01 18:22:39 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								            URL" $counter-app" <redirect>
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ] >>submit ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-30 17:12:14 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-29 06:58:34 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: <display-action> ( -- action )
							 | 
						
					
						
							
								
									
										
										
										
											2008-05-26 01:47:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    <page-action>
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ count sget "counter" set-value ] >>init
							 | 
						
					
						
							
								
									
										
										
										
											2008-06-02 16:00:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        { counter-app "counter" } >>template ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-04-29 06:58:34 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: <counter-app> ( -- responder )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    counter-app new-dispatcher
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ 1+ ] <counter-action> "inc" add-responder
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ 1- ] <counter-action> "dec" add-responder
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-29 18:15:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        <display-action> "" add-responder ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-19 16:45:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Deployment example
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-23 04:35:01 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								USING: db.sqlite furnace.alloy namespaces ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-19 16:45:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-12 09:25:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: counter-db ( -- db ) "counter.db" <sqlite-db> ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-19 16:45:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: run-counter ( -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    <counter-app>
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-23 04:35:01 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        counter-db <alloy>
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-19 16:45:27 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        main-responder set-global
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    8080 httpd ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								MAIN: run-counter
							 |