├── .gitattributes ├── .gitignore ├── test ├── setup-test-env.sh ├── static │ ├── test.html │ └── index.html └── test-igropyr.sc ├── package.sc ├── LICENSE ├── README.md ├── otp.sc └── http.sc /.gitattributes: -------------------------------------------------------------------------------- 1 | *.sc linguist-language=Scheme 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.sc~ 2 | *.sc#* 3 | .#*.sc 4 | 5 | httpc.so 6 | -------------------------------------------------------------------------------- /test/setup-test-env.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Igropyr test environment setup script 3 | 4 | # Set Chez Scheme file extension recognition 5 | export CHEZSCHEMELIBEXTS=.chezscheme.sls::.chezscheme.so:.ss::.so:.sls::.so:.scm::.so:.sch::.so:.sc::.so 6 | 7 | # Set Chez Scheme library path 8 | export CHEZSCHEMELIBDIRS=.:lib:../.. 9 | -------------------------------------------------------------------------------- /test/static/test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Dynamic Rendering Test 5 | 6 | 7 |

Dynamic Rendering Test Success!

8 |

This is a file served from the static directory

9 |

Server uses OTP supervision tree architecture

10 | 11 | -------------------------------------------------------------------------------- /package.sc: -------------------------------------------------------------------------------- 1 | (("name" . "igropyr") 2 | ("version" . "1.0.0") 3 | ("description" . "a high-performance async I/O Http Server built with OTP architecture, featuring powerful concurrent processing capabilities and fault tolerance") 4 | ("keywords" 5 | ("Scheme" "http-server" "async")) 6 | ("author" 7 | ("guenchi")) 8 | ("private" . #f) 9 | ("scripts" 10 | ("build" . "") 11 | ("run" . "scheme --script") 12 | ("test" . "")) 13 | ("dependencies") 14 | ("devDependencies")) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright guenchi (c) 2018 - 2025 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Igropyr 2 | 3 | ![image](https://github.com/guenchi/Igropyr/blob/gh-pages/img/index.png) 4 | 5 | 6 | ## Overview 7 | 8 | Igropyr is a high-performance Async I/O Http Server built with OTP (Open Telecom Platform) architecture, featuring powerful concurrent processing capabilities and fault tolerance. 9 | 10 | ## Architecture 11 | 12 | The server implements OTP principles for robust, scalable web services: 13 | - **Actor-based concurrency** for isolated, concurrent request handling 14 | - **Supervisor trees** for automatic process recovery 15 | - **Message passing** for inter-process communication 16 | - **Fault isolation** preventing cascading failures 17 | 18 | 19 | ## Core Features 20 | 21 | ### ⚡ High Concurrency 22 | - Powerful concurrent processing with async I/O 23 | - Actor model for efficient task distribution 24 | - Optimized for handling multiple simultaneous requests 25 | 26 | ### 🔄 Let It Crash Philosophy 27 | - Automatic failure recovery 28 | - Task redistribution on failures 29 | - Built-in fault tolerance mechanisms 30 | 31 | ### 🔥 Hot Reload 32 | - Hot-reloadable routes and modules 33 | - Zero-downtime upgrades 34 | - Dynamic module replacement 35 | 36 | ### Test 37 | 38 | Main dashboard interface providing: 39 | - Server status display 40 | - Quick access to all test endpoints 41 | 42 | ## Available Test Endpoints 43 | 44 | ### Basic Features 45 | - `/` - Main dashboard with server status 46 | - `/api/info` - System status information 47 | - `/api/user/:id` - User parameter testing 48 | - `/test/json` - JSON response testing 49 | - `/test/redirect` - Redirect functionality testing 50 | - `/test/dynamic` - Dynamic rendering testing 51 | - `/test/template` - Template engine testing 52 | 53 | ### Fault Tolerance Testing 54 | - `/api/crash` - 💥 Crash test (tests server recovery) 55 | - `/api/error` - ⚠️ Error handling test 56 | - `/api/slow` - ⏱️ Slow request simulation (2 seconds) 57 | - `/api/cpu` - 🔥 CPU intensive operation test 58 | - `/test/random-crash` - 🎲 Random crash simulation 59 | - `/health` - ❤️ Health check endpoint 60 | 61 | 62 | ## Status 63 | 64 | ✅ All functions checked and operational 65 | 66 | ## Version 67 | 68 | Current version: v1.0 - OTP Architecture 69 | -------------------------------------------------------------------------------- /test/static/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Igropyr Http Server 5 | 99 | 100 | 101 |

102 |

🚀 Igropyr Http Server

103 |

v1.0 - OTP Architecture

104 | 105 |

106 | ✅ All functions checked 107 |

108 | 109 |

110 |

111 |

⚡ High Concurrency

112 |

Powerful concurrent processing with async I/O and Actor model

113 |

114 |

115 |

🔄 Let It Crash

116 |

Automatic failure recovery and task redistribution

117 |

118 |

119 |

🔥 Hot Reload

120 |

Hot-reloadable routes and modules with zero-downtime upgrades

121 |

122 |

123 | 124 |

125 |

Test Features

126 |

134 |

135 | 136 |

137 |

OTP Fault Tolerance Tests

138 |

146 |

147 | 148 |

149 | Server Time: Loading... 150 |

151 |

152 | 153 | 157 | 158 | -------------------------------------------------------------------------------- /otp.sc: -------------------------------------------------------------------------------- 1 | ;;; Igropyr OTP Enhancement Module 2 | ;;; Implements true Let it crash and task redistribution 3 | ;;; 4 | ;;; Copyright 2025 5 | 6 | #!chezscheme 7 | (library (igropyr otp) 8 | (export 9 | ;; Supervisor API 10 | start-supervisor 11 | stop-supervisor 12 | supervisor-status 13 | 14 | ;; Worker management 15 | spawn-worker 16 | worker-count 17 | 18 | ;; OTP-enhanced HTTP server 19 | start-otp-http-server 20 | ) 21 | 22 | (import 23 | (chezscheme) 24 | (chezerlang compat) 25 | (chezerlang internal) 26 | (chezerlang erlang)) 27 | 28 | ;; ==================== Worker Process Pool Implementation ==================== 29 | 30 | ;; Worker process - handles HTTP requests 31 | (define (http-worker id supervisor) 32 | (spawn&link 33 | (lambda () 34 | (printf "[Worker ~a] Starting\n" id) 35 | ;; Set not to trap EXIT, let process truly crash 36 | (process-trap-exit #f) 37 | 38 | (let worker-loop ([request-count 0]) 39 | (receive 40 | ;; Process HTTP request 41 | [#(http-request ,from ,ip ,op ,req ,res) 42 | ;; Don't use guard - let errors crash the process 43 | (printf "[Worker ~a] Processing request #~a\n" id (+ request-count 1)) 44 | 45 | ;; Notify Supervisor of request being processed 46 | (send supervisor `#(processing ,self ,from ,ip ,op ,req ,res)) 47 | 48 | ;; Process request - will crash if error occurs 49 | (process-http-request req res ip op) 50 | 51 | ;; Successfully completed, notify Supervisor 52 | (send supervisor `#(completed ,self ,from)) 53 | (send from `#(request-completed ,self)) 54 | 55 | ;; Continue processing next request 56 | (worker-loop (+ request-count 1))] 57 | 58 | ;; Stop signal 59 | [#(stop) 60 | (printf "[Worker ~a] Normal stop\n" id) 61 | (exit 'normal)] 62 | 63 | ;; Health check 64 | [#(ping ,from) 65 | (send from `#(pong ,self ,id)) 66 | (worker-loop request-count)] 67 | 68 | [,msg 69 | (printf "[Worker ~a] Unknown message: ~a\n" id msg) 70 | (worker-loop request-count)]))))) 71 | 72 | ;; Actual logic for processing HTTP requests 73 | (define (process-http-request req res ip op) 74 | ;; Don't use guard here, let errors directly crash the process 75 | (let ([path (request-path req)]) 76 | (cond 77 | ;; Simulate random crash 78 | [(string=? path "/crash") 79 | (error 'http-worker "Simulated crash")] 80 | 81 | ;; Normal processing 82 | [else 83 | ;; Send response 84 | (send-http-response op res)]))) 85 | 86 | ;; ==================== Supervisor Implementation ==================== 87 | 88 | ;; Supervisor state record 89 | (define-record supervisor-state 90 | [workers] ; Worker process list 91 | [pending-tasks] ; Pending task queue 92 | [processing-tasks] ; Tasks being processed 93 | [restart-count] ; Restart count 94 | [max-restarts] ; Maximum restart count 95 | [restart-window]) ; Restart time window (seconds) 96 | 97 | ;; Supervisor process - manages Worker lifecycle 98 | (define (supervisor-process worker-count) 99 | (spawn 100 | (lambda () 101 | (printf "[Supervisor] Starting, managing ~a workers\n" worker-count) 102 | ;; Supervisor needs to trap EXIT messages 103 | (process-trap-exit #t) 104 | 105 | ;; Initialize state 106 | (let ([state (make-supervisor-state 107 | '() ; workers 108 | '() ; pending-tasks 109 | (make-hashtable equal-hash equal?) ; processing-tasks 110 | 0 ; restart-count 111 | 10 ; max-restarts 112 | 60)]) ; restart-window (seconds) 113 | 114 | ;; Create initial Worker pool 115 | (supervisor-state-workers-set! state 116 | (map (lambda (id) 117 | (let ([worker (http-worker id self)]) 118 | (monitor worker) ; Monitor Worker 119 | (cons id worker))) 120 | (iota worker-count))) 121 | 122 | ;; Supervisor main loop 123 | (supervisor-loop state))))) 124 | 125 | ;; Supervisor main loop 126 | (define (supervisor-loop state) 127 | (receive 128 | ;; New HTTP request 129 | [#(http-request ,from ,ip ,op ,req ,res) 130 | (handle-new-request state from ip op req res) 131 | (supervisor-loop state)] 132 | 133 | ;; Worker starts processing task 134 | [#(processing ,worker ,client ,ip ,op ,req ,res) 135 | ;; Record task being processed 136 | (hashtable-set! (supervisor-state-processing-tasks state) 137 | worker 138 | `#(,client ,ip ,op ,req ,res)) 139 | (supervisor-loop state)] 140 | 141 | ;; Worker completed task 142 | [#(completed ,worker ,client) 143 | ;; Clear processing record 144 | (hashtable-delete! (supervisor-state-processing-tasks state) worker) 145 | (supervisor-loop state)] 146 | 147 | ;; Worker crash - DOWN message 148 | [`(DOWN ,monitor ,worker-pid ,reason) 149 | (printf "[Supervisor] Worker crashed: ~a, reason: ~a\n" worker-pid reason) 150 | (handle-worker-crash state worker-pid reason) 151 | (supervisor-loop state)] 152 | 153 | ;; Worker exit - EXIT message 154 | [`(EXIT ,worker-pid ,reason) 155 | (unless (eq? reason 'normal) 156 | (printf "[Supervisor] Worker abnormal exit: ~a, reason: ~a\n" worker-pid reason) 157 | (handle-worker-crash state worker-pid reason)) 158 | (supervisor-loop state)] 159 | 160 | ;; Get status 161 | [#(get-status ,from) 162 | (send from `#(supervisor-status ,state)) 163 | (supervisor-loop state)] 164 | 165 | ;; Stop Supervisor 166 | [#(stop) 167 | (printf "[Supervisor] Stopping all workers\n") 168 | (for-each (lambda (w) (send (cdr w) #(stop))) 169 | (supervisor-state-workers state)) 170 | (exit 'normal)] 171 | 172 | [,msg 173 | (printf "[Supervisor] Unknown message: ~a\n" msg) 174 | (supervisor-loop state)])) 175 | 176 | ;; Handle new request 177 | (define (handle-new-request state from ip op req res) 178 | (let ([workers (supervisor-state-workers state)]) 179 | (if (null? workers) 180 | ;; No available Workers, add to queue 181 | (begin 182 | (printf "[Supervisor] No available workers, request queued\n") 183 | (supervisor-state-pending-tasks-set! state 184 | (append (supervisor-state-pending-tasks state) 185 | (list `#(,from ,ip ,op ,req ,res))))) 186 | ;; Select Worker with minimum load 187 | (let ([worker (select-worker state)]) 188 | (printf "[Supervisor] Assigning request to Worker ~a\n" (car worker)) 189 | (send (cdr worker) `#(http-request ,from ,ip ,op ,req ,res)))))) 190 | 191 | ;; Select Worker (simple round-robin) 192 | (define (select-worker state) 193 | ;; TODO: Implement smarter load balancing 194 | (car (supervisor-state-workers state))) 195 | 196 | ;; Handle Worker crash 197 | (define (handle-worker-crash state worker-pid reason) 198 | ;; 1. Find the crashed Worker 199 | (let ([crashed-worker (assq-ref worker-pid (supervisor-state-workers state))]) 200 | (when crashed-worker 201 | ;; 2. Remove from list 202 | (supervisor-state-workers-set! state 203 | (remove (lambda (w) (eq? (cdr w) worker-pid)) 204 | (supervisor-state-workers state))) 205 | 206 | ;; 3. Get unfinished task 207 | (let ([unfinished-task (hashtable-ref 208 | (supervisor-state-processing-tasks state) 209 | worker-pid 210 | #f)]) 211 | 212 | ;; 4. If there are unfinished tasks, reassign 213 | (when unfinished-task 214 | (match unfinished-task 215 | [#(,client ,ip ,op ,req ,res) 216 | (printf "[Supervisor] Reassigning crashed worker's task\n") 217 | ;; Add task back to the front of queue 218 | (supervisor-state-pending-tasks-set! state 219 | (cons `#(,client ,ip ,op ,req ,res) 220 | (supervisor-state-pending-tasks state))) 221 | ;; Clear processing record 222 | (hashtable-delete! (supervisor-state-processing-tasks state) 223 | worker-pid)])) 224 | 225 | ;; 5. Create new Worker replacement 226 | (let* ([worker-id (car crashed-worker)] 227 | [new-worker (http-worker worker-id self)]) 228 | (printf "[Supervisor] Creating new worker ~a to replace crashed worker\n" worker-id) 229 | (monitor new-worker) 230 | (supervisor-state-workers-set! state 231 | (cons (cons worker-id new-worker) 232 | (supervisor-state-workers state))) 233 | 234 | ;; 6. Process tasks in waiting queue 235 | (process-pending-tasks state)))))) 236 | 237 | ;; Process waiting queue 238 | (define (process-pending-tasks state) 239 | (let ([pending (supervisor-state-pending-tasks state)] 240 | [workers (supervisor-state-workers state)]) 241 | (unless (or (null? pending) (null? workers)) 242 | (let ([task (car pending)] 243 | [worker (select-worker state)]) 244 | (match task 245 | [#(,from ,ip ,op ,req ,res) 246 | (printf "[Supervisor] Assigning queued task to Worker ~a\n" (car worker)) 247 | (send (cdr worker) `#(http-request ,from ,ip ,op ,req ,res)) 248 | (supervisor-state-pending-tasks-set! state (cdr pending)) 249 | ;; Recursively process remaining tasks 250 | (process-pending-tasks state)]))))) 251 | 252 | ;; ==================== Public API ==================== 253 | 254 | ;; Start Supervisor 255 | (define (start-supervisor worker-count) 256 | (supervisor-process worker-count)) 257 | 258 | ;; Stop Supervisor 259 | (define (stop-supervisor supervisor) 260 | (send supervisor #(stop))) 261 | 262 | ;; Get Supervisor status 263 | (define (supervisor-status supervisor) 264 | (send supervisor `#(get-status ,self)) 265 | (receive 266 | [#(supervisor-status ,state) state] 267 | [(after 1000) #f])) 268 | 269 | ;; Create Worker 270 | (define (spawn-worker supervisor id) 271 | (let ([worker (http-worker id supervisor)]) 272 | (monitor worker) 273 | worker)) 274 | 275 | ;; Get Worker count 276 | (define (worker-count supervisor) 277 | (let ([status (supervisor-status supervisor)]) 278 | (if status 279 | (length (supervisor-state-workers status)) 280 | 0))) 281 | 282 | ;; ==================== OTP HTTP Server ==================== 283 | 284 | ;; Start OTP-enhanced HTTP server 285 | (define (start-otp-http-server app host port worker-count) 286 | (printf "\n[OTP HTTP Server] Startup configuration:\n") 287 | (printf " Host: ~a\n" host) 288 | (printf " Port: ~a\n" port) 289 | (printf " Worker count: ~a\n" worker-count) 290 | (printf " Fault tolerance mode: Let it crash + task redistribution\n\n") 291 | 292 | ;; Start Supervisor 293 | (let ([supervisor (start-supervisor worker-count)]) 294 | 295 | ;; Start TCP listener 296 | (let ([listener (listen-tcp "::" port self)]) 297 | (printf "[OTP HTTP Server] Listening on ~a:~a\n" host port) 298 | 299 | ;; Accept connection loop 300 | (spawn 301 | (lambda () 302 | (let accept-loop () 303 | (receive 304 | [`(accept-tcp ,listener ,error ,ip ,op) 305 | (cond 306 | [error 307 | (printf "[OTP HTTP Server] Connection accept error: ~a\n" error)] 308 | [else 309 | ;; Read request and send to Supervisor 310 | (spawn 311 | (lambda () 312 | (let ([req (read-http-request ip)] 313 | [res (make-response)]) 314 | ;; Send to Supervisor for processing 315 | (send supervisor `#(http-request ,self ,ip ,op ,req ,res)) 316 | ;; Wait for completion 317 | (receive 318 | [#(request-completed ,worker) 319 | (printf "[OTP HTTP Server] Request completed\n")] 320 | [(after 30000) 321 | (printf "[OTP HTTP Server] Request timeout\n") 322 | (send-error-response op 504 "Gateway Timeout")]))))]) 323 | (accept-loop)]))))) 324 | 325 | ;; Return Supervisor handle 326 | supervisor)) 327 | 328 | ;; Helper functions 329 | (define (assq-ref key alist) 330 | (let ([pair (assq key alist)]) 331 | (and pair (cdr pair)))) 332 | 333 | (define (iota n) 334 | (let loop ([i 0] [result '()]) 335 | (if (< i n) 336 | (loop (+ i 1) (cons i result)) 337 | (reverse result)))) 338 | 339 | ;; Send error response 340 | (define (send-error-response op code message) 341 | (let ([response (format "HTTP/1.1 ~a ~a\r\nContent-Type: text/plain\r\n\r\n~a" 342 | code message message)]) 343 | (guard (e [else (void)]) 344 | (put-bytevector op (string->utf8 response)) 345 | (flush-output-port op) 346 | (close-port op)))) 347 | 348 | ) ;; end of library -------------------------------------------------------------------------------- /test/test-igropyr.sc: -------------------------------------------------------------------------------- 1 | ;; Igropyr Http Server Test - Enhanced Version 2 | ;; Implementing Erlang OTP-style fault tolerance 3 | 4 | ;; Load ChezErlang shared library 5 | (define lib (load-shared-object "libosi.dylib")) 6 | 7 | (import (chezscheme)) 8 | 9 | ;; Import ChezErlang libraries 10 | (import (chezerlang compat)) 11 | (import (chezerlang internal)) 12 | (import (chezerlang meta)) 13 | (import (chezerlang osi)) 14 | (import (chezerlang erlang)) 15 | (import (chezerlang io)) 16 | (import (chezerlang gen-server)) 17 | (import (chezerlang supervisor)) 18 | (import (chezerlang app)) 19 | (import (chezerlang app-io)) 20 | (import (chezerlang http)) 21 | (import (chezerlang html)) 22 | 23 | ;; Import Igropyr Http Server library 24 | (import (igropyr http)) 25 | 26 | ;; Define current-time-ms function (compatibility) 27 | (define current-time-ms 28 | (if (top-level-bound? 'current-time-ms) 29 | current-time-ms 30 | (lambda () 31 | (let ([t (current-time)]) 32 | (+ (* (time-second t) 1000) 33 | (quotient (time-nanosecond t) 1000000)))))) 34 | 35 | ;; ==================== Simplified Enhanced Features (Using Existing API) ==================== 36 | 37 | ;; Error counter 38 | (define error-count (make-parameter 0)) 39 | (define request-count (make-parameter 0)) 40 | 41 | ;; Enhanced error handling middleware 42 | (define (enhanced-error-middleware) 43 | (lambda (req res next) 44 | (guard (e [else 45 | (error-count (+ (error-count) 1)) 46 | (printf "[ERROR] ~a (Total: ~a)\n" e (error-count)) 47 | (set-status! res 500) 48 | (send-html! res 49 | (format " 50 | 51 |

500 - Server Error

52 |

Error: ~a

53 |

Server will recover automatically

54 | 55 | " e))]) 56 | (next)))) 57 | 58 | ;; Request counter middleware 59 | (define (request-counter-middleware) 60 | (lambda (req res next) 61 | (request-count (+ (request-count) 1)) 62 | (when (= (modulo (request-count) 100) 0) 63 | (printf "[STATS] Processed ~a requests, ~a errors\n" 64 | (request-count) (error-count))) 65 | (next))) 66 | 67 | ;; Timeout protection middleware 68 | (define (timeout-middleware timeout-ms) 69 | (lambda (req res next) 70 | (let ([start-time (current-time-ms)]) 71 | (dynamic-wind 72 | (lambda () (void)) 73 | (lambda () (next)) 74 | (lambda () 75 | (let ([elapsed (- (current-time-ms) start-time)]) 76 | (when (> elapsed timeout-ms) 77 | (printf "[TIMEOUT] Request processing time: ~a ms\n" elapsed)))))))) 78 | 79 | ;; Health check route 80 | (define (add-health-check-route app) 81 | (app-get app "/health" 82 | (lambda (req res) 83 | (let ([health-score (if (> (request-count) 0) 84 | (- 100 (* 100.0 (/ (error-count) (request-count)))) 85 | 100)]) 86 | (send-json! res 87 | (format "{ 88 | \"status\": \"~a\", 89 | \"requests\": ~a, 90 | \"errors\": ~a, 91 | \"health_score\": ~a, 92 | \"timestamp\": \"~a\" 93 | }" 94 | (if (>= health-score 90) "healthy" "degraded") 95 | (request-count) 96 | (error-count) 97 | (round health-score) 98 | (current-date))))))) 99 | 100 | ;; Simulate fault tolerance routes 101 | (define (add-fault-tolerance-demo-routes app) 102 | ;; Simulate random crashes 103 | (app-get app "/test/random-crash" 104 | (lambda (req res) 105 | (if (= (random 3) 0) 106 | (error 'simulated-crash "Simulated random crash") 107 | (send-json! res "{\"status\": \"success\"}")))) 108 | 109 | ;; Simulate CPU intensive operation 110 | (app-get app "/test/cpu-intensive" 111 | (lambda (req res) 112 | (let ([result (let loop ([n 1000000] [sum 0]) 113 | (if (= n 0) 114 | sum 115 | (loop (- n 1) (+ sum n))))]) 116 | (send-json! res 117 | (format "{\"result\": ~a}" result))))) 118 | 119 | ;; Simulate slow request 120 | (app-get app "/test/slow" 121 | (lambda (req res) 122 | (simple-sleep 2) ; 2 second delay 123 | (send-json! res "{\"status\": \"slow request completed\"}")))) 124 | 125 | (printf "\n====================================\n") 126 | (printf " Igropyr Http Server Test (Enhanced)\n") 127 | (printf " With OTP Fault Tolerance\n") 128 | (printf "====================================\n\n") 129 | 130 | ;; Create application 131 | (define app (create-app)) 132 | (printf "✅ Created Igropyr Http Server application\n") 133 | 134 | ;; Configure application 135 | (app-configure app "port" 8080) 136 | (app-configure app "host" "0.0.0.0") 137 | (app-configure app "base-dir" (current-directory)) 138 | (printf "✅ Application configuration complete\n") 139 | 140 | ;; Add logger middleware 141 | (app-use app (logger-middleware)) 142 | (printf "✅ Added logger middleware\n") 143 | 144 | ;; Add CORS middleware 145 | (app-use app (cors-middleware)) 146 | (printf "✅ Added CORS middleware\n") 147 | 148 | ;; Add error handler middleware 149 | (app-use app (error-handler-middleware)) 150 | (printf "✅ Added error handler middleware\n") 151 | 152 | ;; Simple sleep function (using built-in sleep) 153 | (define (simple-sleep seconds) 154 | (let ([end-time (+ (time-second (current-date)) seconds)]) 155 | (let loop () 156 | (when (< (time-second (current-date)) end-time) 157 | (let () (void)))))) 158 | 159 | ;; Set static file directory 160 | (unless (file-exists? "static") 161 | (mkdir "static")) 162 | (app-static app "/static" "static") 163 | (printf "✅ Set static file directory: /static -> ./static\n") 164 | 165 | 166 | ;; Create simple test script 167 | (call-with-output-file "test-fault-tolerance.sh" 168 | (lambda (p) 169 | (display "#!/bin/bash\n" p) 170 | (display "echo 'Fault Tolerance Test'\n" p) 171 | (display "echo '===================='\n" p) 172 | (display "echo ''\n" p) 173 | (display "echo 'Test 1: Normal Request'\n" p) 174 | (display "curl http://localhost:3005/\n" p) 175 | (display "echo ''\n" p) 176 | (display "echo ''\n" p) 177 | (display "echo 'Test 2: Health Check'\n" p) 178 | (display "curl http://localhost:3005/health\n" p) 179 | (display "echo ''\n" p) 180 | (display "echo ''\n" p) 181 | (display "echo 'Test 3: Random Crash Test (10 times)'\n" p) 182 | (display "for i in {1..10}; do\n" p) 183 | (display " echo \" Request $i:\"\n" p) 184 | (display " curl -s http://localhost:3005/test/random-crash || echo 'Crashed but service continues'\n" p) 185 | (display " echo ''\n" p) 186 | (display "done\n" p) 187 | (display "echo ''\n" p) 188 | (display "echo 'Test 4: Check Health Status Again'\n" p) 189 | (display "curl http://localhost:3005/health\n" p) 190 | (display "echo ''\n" p)) 191 | 'replace) 192 | (system "chmod +x test-fault-tolerance.sh") 193 | (printf "✅ Created fault tolerance test script: test-fault-tolerance.sh\n") 194 | 195 | ;; Set dynamic page directory 196 | (unless (file-exists? "dynamic") 197 | (mkdir "dynamic")) 198 | (app-dynamic app "/dynamic" "dynamic") 199 | (printf "✅ Set dynamic page directory: /dynamic -> ./dynamic\n") 200 | 201 | ;; Home page route - serve static index.html 202 | (app-get app "/" 203 | (lambda (req res) 204 | ;; Read and serve the static index.html file 205 | (let ([content (call-with-input-file "static/index.html" 206 | (lambda (p) 207 | (get-string-all p)))]) 208 | (send-html! res content)))) 209 | 210 | ;; API Info Route - System Status 211 | (app-get app "/api/info" 212 | (lambda (req res) 213 | (send-json! res 214 | (format "{ 215 | \"status\": \"running\", 216 | \"port\": 8080, 217 | \"host\": \"0.0.0.0\", 218 | \"server\": \"Igropyr/1.0\", 219 | \"uptime\": \"~a\" 220 | }" 221 | (current-date))))) 222 | 223 | 224 | ;; User details route (with params) 225 | (app-get app "/api/user/:id" 226 | (lambda (req res) 227 | (let ([user-id (assoc "id" (request-params req))]) 228 | (if user-id 229 | (send-json! res 230 | (format "{\"id\": \"~a\", \"name\": \"User ~a\", \"details\": \"This is user ~a's profile\"}" 231 | (cdr user-id) (cdr user-id) (cdr user-id))) 232 | (begin 233 | (set-status! res 404) 234 | (send-json! res "{\"error\": \"User not found\"}")))))) 235 | 236 | ;; JSON test route 237 | (app-get app "/test/json" 238 | (lambda (req res) 239 | (send-json res "{\"test\": \"success\", \"timestamp\": \"2024-01-01\"}"))) 240 | 241 | ;; Redirect test 242 | (app-get app "/test/redirect" 243 | (lambda (req res) 244 | (redirect res "/"))) 245 | 246 | 247 | ;; Dynamic rendering test - read test.html and inject dynamic content 248 | (app-get app "/test/dynamic" 249 | (lambda (req res) 250 | ;; Read the static test.html template 251 | (let* ([template (call-with-input-file "static/test.html" 252 | (lambda (p) 253 | (get-string-all p)))] 254 | ;; Get current time string 255 | [time-str (format "~a" (current-date))] 256 | ;; Replace placeholder with dynamic content 257 | [dynamic-content (string-append 258 | "

Dynamic Content:

" 259 | "

Request time: " time-str "
Request method: " (request-method req) "
Request path: " (request-path req) "
Server timestamp: " (number->string (current-time-ms)) " ms
Random number: " (number->string (random 1000)) "

")] 266 | ;; Insert dynamic content before closing body tag 267 | [html (string-append 268 | (substring template 0 (- (string-length template) 14)) ; Remove 269 | "

" 270 | dynamic-content 271 | "")]) 272 | (send-html! res html)))) 273 | 274 | ;; Template demo - shows inline HTML template with format 275 | (app-get app "/test/template" 276 | (lambda (req res) 277 | (send-html! res 278 | (format " 279 | 280 | 281 | Template Demo 282 | 287 | 288 | 289 |

Template Demo

290 |

291 |

Request Information:

292 |

Method: ~a

293 |

Path: ~a

294 |

Time: ~a

295 |

Random: ~a

296 |

297 |

298 |

This demonstrates inline HTML templating with format function.

299 | 300 | " 301 | (request-method req) 302 | (request-path req) 303 | (current-date) 304 | (random 1000))))) 305 | 306 | ;; Add new test route (using enhanced features) 307 | (app-get app "/test/status" 308 | (lambda (req res) 309 | (send-json! res 310 | (format "{ 311 | \"requests_processed\": ~a, 312 | \"errors_caught\": ~a, 313 | \"server_time\": \"~a\" 314 | }" 315 | (request-count) 316 | (error-count) 317 | (current-date))))) 318 | 319 | ;; System status route 320 | (app-get app "/api/status" 321 | (lambda (req res) 322 | (send-json! res 323 | (format "{ 324 | \"status\": \"running\", 325 | \"port\": 3005, 326 | \"host\": \"0.0.0.0\", 327 | \"server\": \"Igropyr/1.0\", 328 | \"uptime\": \"~a\" 329 | }" 330 | (current-date))))) 331 | 332 | ;; POST route test 333 | (app-post app "/api/data" 334 | (lambda (req res) 335 | (send-json! res 336 | (format "{\"message\": \"Data received\", \"method\": \"~a\", \"body\": \"~a\"}" 337 | (request-method req) 338 | (request-body req))))) 339 | 340 | ;; PUT route test 341 | (app-put app "/api/update/:id" 342 | (lambda (req res) 343 | (let ([id (assoc "id" (request-params req))]) 344 | (send-json! res 345 | (format "{\"message\": \"Updated\", \"id\": \"~a\"}" 346 | (if id (cdr id) "unknown")))))) 347 | 348 | ;; DELETE route test 349 | (app-delete app "/api/delete/:id" 350 | (lambda (req res) 351 | (let ([id (assoc "id" (request-params req))]) 352 | (send-json! res 353 | (format "{\"message\": \"Deleted\", \"id\": \"~a\"}" 354 | (if id (cdr id) "unknown")))))) 355 | 356 | (printf "\n====================================\n") 357 | (printf "✅ Route configuration complete\n") 358 | (printf " - Multiple routes configured\n") 359 | (printf " - Middleware added\n") 360 | (printf "====================================\n\n") 361 | 362 | ;; Add OTP test specific routes 363 | (app-get app "/api/crash" 364 | (lambda (req res) 365 | (send-json! res 366 | "{\"status\":\"survived\",\"message\":\"Worker did not crash, keep trying!\"}"))) 367 | 368 | (app-get app "/api/error" 369 | (lambda (req res) 370 | ;; Intentionally throw an error to test Worker crash 371 | (error 'test-error "This is an intentional error to test Let It Crash"))) 372 | 373 | (app-get app "/api/slow" 374 | (lambda (req res) 375 | (simple-sleep 2) ; Sleep for 2 seconds 376 | (send-json! res 377 | "{\"status\":\"success\",\"message\":\"Slow request completed\",\"duration\":\"2 seconds\"}"))) 378 | 379 | (app-get app "/api/cpu" 380 | (lambda (req res) 381 | (define (fib n) 382 | (if (<= n 2) 1 383 | (+ (fib (- n 1)) (fib (- n 2))))) 384 | (let ([result (fib 35)]) 385 | (send-json! res 386 | (format "{\"status\":\"success\",\"fibonacci(35)\":~a}" result))))) 387 | 388 | ;; POST request test 389 | (app-post app "/api/echo" 390 | (lambda (req res) 391 | (let ([body (request-body req)]) 392 | (send-json! res 393 | (format "{\"echo\":\"~a\",\"method\":\"POST\"}" body))))) 394 | 395 | ;; Wildcard route (place at the end) 396 | (app-get app "/api/*" 397 | (lambda (req res) 398 | (send-html! res 399 | (format " 400 | 401 | 402 | API Wildcard Route 403 | 404 | 405 |

API Wildcard Route

406 |

Path: ~a

407 |

Method: ~a

408 |

This route captures all unmatched requests under /api/*

409 |

Back to home

410 | 411 | " (request-path req) (request-method req))))) 412 | 413 | ;; Choose startup mode 414 | (printf "Choose startup mode:\n") 415 | (printf "1. Traditional mode (single process)\n") 416 | (printf "2. OTP mode (Let It Crash fault tolerance)\n") 417 | (printf "3. OTP mode auto-start (for scripts)\n") 418 | (printf "Enter choice (1, 2 or 3): ") 419 | (flush-output-port (current-output-port)) 420 | 421 | (let ([choice (read)]) 422 | (cond 423 | [(equal? choice 1) 424 | (printf "\n========================================\n") 425 | (printf "Starting in Traditional Mode\n") 426 | (printf " - Single process handling\n") 427 | (printf " - Synchronous request processing\n") 428 | (printf " - Simple error handling\n") 429 | (printf "========================================\n\n") 430 | (app-listen app "0.0.0.0" 8080)] 431 | 432 | [(or (equal? choice 2) (equal? choice 3)) 433 | (printf "\n========================================\n") 434 | (printf " Igropyr Http Server OTP Mode\n") 435 | (printf " Let It Crash & Task Redistribution\n") 436 | (printf "========================================\n\n") 437 | 438 | ;; Configure OTP parameters 439 | (app-configure app "port" 8080) 440 | (app-configure app "worker-count" 10) 441 | 442 | (printf "Configuration complete:\n") 443 | (printf " - Port: 8080\n") 444 | (printf " - Worker count: 10\n") 445 | (printf " - Mode: OTP (Let It Crash)\n\n") 446 | 447 | (printf "========================================\n") 448 | (printf "OTP Test Routes:\n") 449 | (printf " /api/crash - Crash test (first request will crash, then recovers)\n") 450 | (printf " /api/error - Error test (always crashes)\n") 451 | (printf " /api/slow - Slow request (2 seconds)\n") 452 | (printf " /api/cpu - CPU intensive (fibonacci calculation)\n") 453 | (printf " /api/echo - POST request echo\n") 454 | (printf "========================================\n\n") 455 | 456 | (when (equal? choice 2) 457 | (printf "Test commands:\n") 458 | (printf " # Single test\n") 459 | (printf " curl http://localhost:8080/api/crash\n\n") 460 | (printf " # Concurrent test\n") 461 | (printf " for i in {1..10}; do\n") 462 | (printf " curl http://localhost:8080/api/crash &\n") 463 | (printf " done\n\n") 464 | (printf " # Stress test\n") 465 | (printf " ab -n 100 -c 10 http://localhost:8080/api/crash\n") 466 | (printf "========================================\n\n")) 467 | 468 | ;; Add enhanced middleware 469 | (app-use app (request-counter-middleware)) 470 | (app-use app (enhanced-error-middleware)) 471 | (app-use app (timeout-middleware 5000)) 472 | 473 | ;; Add health check and fault tolerance demo routes 474 | (add-health-check-route app) 475 | (add-fault-tolerance-demo-routes app) 476 | 477 | ;; Start application (OTP mode) 478 | (app-start app #t)] ; #t enables OTP mode 479 | 480 | [else 481 | (printf "\nDefault: starting in OTP mode...\n") 482 | (app-configure app "port" 8080) 483 | (app-configure app "worker-count" 10) 484 | (app-start app #t)])) 485 | -------------------------------------------------------------------------------- /http.sc: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; Igropyr Express Framework 4 | ;; High-performance Web framework with integrated OTP supervision tree architecture 5 | 6 | (library (igropyr http) 7 | (export 8 | ;; Express-style API 9 | create-app 10 | app-get 11 | app-post 12 | app-put 13 | app-delete 14 | app-use 15 | app-listen 16 | app-static 17 | app-dynamic 18 | 19 | ;; Igropyr application framework 20 | app-start 21 | app-stop 22 | app-configure 23 | app-supervisor 24 | app-config 25 | 26 | ;; OTP enhanced API (Let It Crash mode) 27 | start-supervisor 28 | stop-supervisor 29 | supervisor-status 30 | spawn-worker 31 | worker-count 32 | start-otp-http-server 33 | 34 | ;; Request/Response 35 | make-request 36 | request-method 37 | request-path 38 | request-headers 39 | request-body 40 | request-params 41 | request-params-set! 42 | request-query 43 | 44 | make-response 45 | create-response 46 | response-status 47 | response-headers 48 | response-body 49 | response-status-set! 50 | response-headers-set! 51 | response-body-set! 52 | 53 | ;; Utilities 54 | set-status! 55 | set-header! 56 | set-body! 57 | send-json 58 | send-json! 59 | send-html 60 | send-html! 61 | send-file 62 | redirect 63 | 64 | ;; Middleware 65 | logger-middleware 66 | cors-middleware 67 | static-middleware 68 | error-handler-middleware 69 | 70 | ;; Internal functions (for enhanced version) 71 | app-state-routes 72 | app-state-middleware 73 | route-params 74 | route-handler 75 | find-matching-route 76 | extract-path-params 77 | send-http-response 78 | read-http-line 79 | parse-request-line 80 | read-headers 81 | read-body) 82 | 83 | (import 84 | (chezscheme) 85 | (chezerlang compat) 86 | (chezerlang internal) 87 | (chezerlang meta) 88 | (chezerlang osi) 89 | (chezerlang erlang) 90 | (chezerlang io) 91 | (chezerlang gen-server) 92 | (chezerlang supervisor) 93 | (chezerlang app) 94 | (chezerlang app-io) 95 | (chezerlang http) 96 | (chezerlang html)) 97 | 98 | 99 | ;; ==================== Record Type Definitions ==================== 100 | 101 | ;; Route record type 102 | (define-record-type route 103 | (fields method path handler params)) 104 | 105 | ;; Middleware record type 106 | (define-record-type middleware 107 | (fields name handler)) 108 | 109 | ;; Application state record type (enhanced version) 110 | (define-record-type app-state 111 | (fields 112 | (mutable routes) 113 | (mutable middleware) 114 | (mutable static-dirs) 115 | (mutable dynamic-dirs) 116 | (mutable config) 117 | (mutable supervisor-spec))) 118 | 119 | ;; ==================== Let It Crash OTP Enhancement ==================== 120 | 121 | ;; Supervisor state record type 122 | (define-record-type supervisor-state 123 | (fields 124 | (mutable workers) ; Worker process list 125 | (mutable pending-tasks) ; Pending task queue 126 | (mutable active-tasks) ; Active task mapping (worker-pid . task) 127 | (mutable restart-count) ; Restart count 128 | (mutable max-restarts) ; Maximum restarts 129 | (mutable restart-window) ; Restart time window 130 | (mutable app))) 131 | 132 | ;; Task record type 133 | (define-record-type task 134 | (fields 135 | id ; Task ID 136 | request ; HTTP request 137 | response ; HTTP response 138 | ip ; Input port 139 | op ; Output port 140 | (mutable retry-count) ; Retry count 141 | (mutable assigned-worker))) ; Assigned Worker 142 | 143 | ;; HTTP request record type (enhanced version) 144 | (define-record-type request 145 | (fields method path headers body (mutable params) (mutable query))) 146 | 147 | ;; HTTP response record type 148 | (define-record-type response 149 | (fields (mutable status) (mutable headers) (mutable body))) 150 | 151 | ;; ==================== Utility Functions (Must be defined first) ==================== 152 | 153 | ;; String split 154 | (define (string-split str char) 155 | (let loop ([i 0] [start 0] [result '()]) 156 | (cond 157 | [(>= i (string-length str)) 158 | (reverse (if (< start i) 159 | (cons (substring str start i) result) 160 | result))] 161 | [(char=? (string-ref str i) char) 162 | (loop (+ i 1) (+ i 1) 163 | (if (> i start) 164 | (cons (substring str start i) result) 165 | result))] 166 | [else (loop (+ i 1) start result)]))) 167 | 168 | ;; String prefix check 169 | (define (string-prefix? prefix str) 170 | (and (>= (string-length str) (string-length prefix)) 171 | (string=? (substring str 0 (string-length prefix)) prefix))) 172 | 173 | ;; String suffix check 174 | (define (string-suffix? suffix str) 175 | (let ([str-len (string-length str)] 176 | [suf-len (string-length suffix)]) 177 | (and (>= str-len suf-len) 178 | (string=? (substring str (- str-len suf-len) str-len) suffix)))) 179 | 180 | ;; String contains check 181 | (define (string-contains? str sub) 182 | (let ([str-len (string-length str)] 183 | [sub-len (string-length sub)]) 184 | (let loop ([i 0]) 185 | (cond 186 | [(> (+ i sub-len) str-len) #f] 187 | [(string=? (substring str i (+ i sub-len)) sub) #t] 188 | [else (loop (+ i 1))])))) 189 | 190 | ;; String index lookup 191 | (define (string-index str char) 192 | (let loop ([i 0]) 193 | (cond 194 | [(>= i (string-length str)) #f] 195 | [(char=? (string-ref str i) char) i] 196 | [else (loop (+ i 1))]))) 197 | 198 | ;; String trim 199 | (define (string-trim str) 200 | (let ([len (string-length str)]) 201 | (let loop ([start 0] [end len]) 202 | (cond 203 | [(>= start end) ""] 204 | [(char-whitespace? (string-ref str start)) 205 | (loop (+ start 1) end)] 206 | [(char-whitespace? (string-ref str (- end 1))) 207 | (loop start (- end 1))] 208 | [else (substring str start end)])))) 209 | 210 | ;; Path extension 211 | (define (get-path-extension path) 212 | (let ([dot-pos (string-rindex path #\.)]) 213 | (if dot-pos 214 | (substring path (+ dot-pos 1) (string-length path)) 215 | #f))) 216 | 217 | ;; String reverse index 218 | (define (string-rindex str char) 219 | (let loop ([i (- (string-length str) 1)]) 220 | (cond 221 | [(< i 0) #f] 222 | [(char=? (string-ref str i) char) i] 223 | [else (loop (- i 1))]))) 224 | 225 | ;; Get current time in milliseconds - using ChezErlang time API 226 | (define (current-time-ms) 227 | ;; Get milliseconds since epoch 228 | (let ([t (current-time)]) 229 | (+ (* (time-second t) 1000) 230 | (quotient (time-nanosecond t) 1000000)))) 231 | 232 | ;; Remove duplicate definition, use ChezErlang's path-combine 233 | 234 | ;; ==================== Let It Crash Core Implementation ==================== 235 | 236 | ;; Worker process - no error catching, fail fast 237 | (define (http-worker id supervisor app) 238 | (spawn&link 239 | (lambda () 240 | ;; Critical: don't catch EXIT, let process truly crash 241 | (process-trap-exit #f) 242 | 243 | (printf "[Worker ~a] Starting\n" id) 244 | 245 | ;; Worker main loop 246 | (let loop () 247 | (receive 248 | [#(process-task ,task) 249 | ;; Don't use guard when processing tasks - Let it crash! 250 | (let ([req (task-request task)] 251 | [res (task-response task)] 252 | [ip (task-ip task)] 253 | [op (task-op task)]) 254 | 255 | (printf "[Worker ~a] Processing task #~a\n" id (task-id task)) 256 | 257 | ;; Test crash route 258 | (when (string-contains? (request-path req) "/crash") 259 | ;; Crash probability based on retry count: 1st time 100% crash, 2nd time 50%, 3rd+ times no crash 260 | (let ([retry-count (task-retry-count task)]) 261 | (cond 262 | [(= retry-count 0) ; First attempt, always crash 263 | (printf "[Worker ~a] Task #~a first attempt, triggering crash!\n" id (task-id task)) 264 | (error 'worker-crash "First attempt crash")] 265 | [(= retry-count 1) ; Second attempt, 50% crash probability 266 | (when (= (random 2) 0) 267 | (printf "[Worker ~a] Task #~a second attempt, triggering crash!\n" id (task-id task)) 268 | (error 'worker-crash "Second attempt crash"))] 269 | [else ; Third time and after, don't crash, let request succeed 270 | (printf "[Worker ~a] Task #~a attempt ~a, processed successfully!\n" id (task-id task) (+ retry-count 1))]))) 271 | 272 | ;; /error path always crashes 273 | (when (string-contains? (request-path req) "/error") 274 | (printf "[Worker ~a] Task #~a triggered error test!\n" id (task-id task)) 275 | (error 'worker-error "Error route always crashes")) 276 | 277 | ;; Process request normally 278 | (process-http-request app req res ip op) 279 | 280 | ;; Notify Supervisor task completed 281 | (send supervisor `#(task-completed ,(task-id task) ,self)) 282 | 283 | (loop))] 284 | 285 | [#(shutdown) 286 | (printf "[Worker ~a] Shutting down\n" id) 287 | 'ok] 288 | 289 | [,msg 290 | (printf "[Worker ~a] Unknown message: ~a\n" id msg) 291 | (loop)]))))) 292 | 293 | ;; Core function to process HTTP request (extracted from handle-connection) 294 | (define (process-http-request app req res ip op) 295 | ;; Find matching route 296 | (let ([route (find-matching-route (app-state-routes app) 297 | (request-method req) 298 | (request-path req))]) 299 | (if route 300 | ;; Execute route handler 301 | (begin 302 | ;; Extract path parameters 303 | (when (route-params route) 304 | (request-params-set! req 305 | (extract-path-params (route-path route) (request-path req)))) 306 | 307 | ;; Run middleware chain 308 | (run-middleware-chain 309 | (app-state-middleware app) req res 310 | (lambda (req res) 311 | ((route-handler route) req res))) 312 | 313 | ;; Send response 314 | (send-http-response op res)) 315 | 316 | ;; Try static files or 404 317 | (if (serve-static-file app (request-path req) op) 318 | (void) 319 | (begin 320 | (set-status! res 404) 321 | (send-html! res 322 | " 323 |

404 Not Found

324 |

The requested resource does not exist

325 | ") 326 | (send-http-response op res)))))) 327 | 328 | ;; Helper function - list-set! 329 | (define (list-set! lst idx val) 330 | (if (zero? idx) 331 | (set-car! lst val) 332 | (list-set! (cdr lst) (- idx 1) val))) 333 | 334 | ;; Supervisor process - manage worker lifecycle and task allocation 335 | (define (supervisor-process worker-count app) 336 | (spawn 337 | (lambda () 338 | ;; Supervisor must trap EXIT signals 339 | (process-trap-exit #t) 340 | 341 | (let ([state (make-supervisor-state 342 | '() ; workers 343 | '() ; pending-tasks 344 | (make-hashtable equal-hash equal?) ; active-tasks 345 | 0 ; restart-count 346 | 10 ; max-restarts 347 | 60 ; restart-window 348 | app)]) 349 | 350 | (printf "[Supervisor] Starting, managing ~a workers\n" worker-count) 351 | 352 | ;; Create initial worker pool 353 | (let loop ([i 0]) 354 | (when (< i worker-count) 355 | (let ([worker (http-worker i self app)]) 356 | (monitor worker) 357 | (supervisor-state-workers-set! state 358 | (cons worker (supervisor-state-workers state))) 359 | (loop (+ i 1))))) 360 | 361 | ;; Supervisor main loop 362 | (supervisor-loop state))))) 363 | 364 | ;; Supervisor main loop 365 | (define (supervisor-loop state) 366 | (receive 367 | ;; Submit new task 368 | [#(submit-task ,task) 369 | (let ([workers (supervisor-state-workers state)]) 370 | (let ([available-worker (find-available-worker (supervisor-state-workers state) (supervisor-state-active-tasks state))]) 371 | (if available-worker 372 | ;; Assign to available worker 373 | (let ([worker available-worker]) 374 | (task-assigned-worker-set! task worker) 375 | (hashtable-set! (supervisor-state-active-tasks state) worker task) 376 | (send worker `#(process-task ,task)) 377 | (printf "[Supervisor] Assigned task #~a to worker\n" (task-id task))) 378 | ;; No available workers, add to queue 379 | (begin 380 | (supervisor-state-pending-tasks-set! state 381 | (append (supervisor-state-pending-tasks state) (list task))) 382 | (printf "[Supervisor] Task #~a queued\n" (task-id task))))) 383 | (supervisor-loop state))] 384 | 385 | ;; Task completed 386 | [#(task-completed ,task-id ,worker) 387 | (hashtable-delete! (supervisor-state-active-tasks state) worker) 388 | (printf "[Supervisor] Task #~a completed\n" task-id) 389 | 390 | ;; Process next task from queue 391 | (let ([pending (supervisor-state-pending-tasks state)]) 392 | (when (not (null? pending)) 393 | (let ([next-task (car pending)]) 394 | (supervisor-state-pending-tasks-set! state (cdr pending)) 395 | (task-assigned-worker-set! next-task worker) 396 | (hashtable-set! (supervisor-state-active-tasks state) worker next-task) 397 | (send worker `#(process-task ,next-task)) 398 | (printf "[Supervisor] Assigned task #~a from queue\n" (task-id next-task))))) 399 | 400 | (supervisor-loop state)] 401 | 402 | 403 | ;; Get status 404 | [#(get-status ,reply-to) 405 | (send reply-to `#(status ,state)) 406 | (supervisor-loop state)] 407 | 408 | ;; Hot reload: get worker list 409 | [#(get-workers ,reply-to) 410 | (send reply-to `#(workers ,(supervisor-state-workers state))) 411 | (supervisor-loop state)] 412 | 413 | ;; Hot reload: reload single worker 414 | [#(reload-worker ,worker-id) 415 | (printf "[Supervisor] Hot reloading worker ~a\n" worker-id) 416 | (let ([workers (supervisor-state-workers state)]) 417 | (when (and (>= worker-id 0) (< worker-id (length workers))) 418 | (let ([worker (list-ref workers worker-id)]) 419 | ;; Stop old worker 420 | (kill worker 'shutdown) 421 | ;; Create new worker 422 | (let ([new-worker (http-worker worker-id self (supervisor-state-app state))]) 423 | ;; Update worker list 424 | (list-set! workers worker-id new-worker) 425 | (printf "[Supervisor] Worker ~a reloaded\n" worker-id))))) 426 | (supervisor-loop state)] 427 | 428 | ;; Hot reload: graceful worker restart 429 | [#(graceful-restart ,worker-id ,timeout) 430 | (printf "[Supervisor] Graceful restart worker ~a (timeout: ~as)\n" worker-id timeout) 431 | (let ([workers (supervisor-state-workers state)]) 432 | (when (and (>= worker-id 0) (< worker-id (length workers))) 433 | (let ([worker (list-ref workers worker-id)]) 434 | ;; Wait for current task completion or timeout 435 | (let ([active-task (hashtable-ref 436 | (supervisor-state-active-tasks state) 437 | worker #f)]) 438 | (when active-task 439 | ;; Has active task, wait for completion 440 | (printf "[Supervisor] Waiting for worker ~a to complete task #~a\n" 441 | worker-id (task-id active-task))) 442 | ;; Stop worker and create new one 443 | (kill worker 'shutdown) 444 | (let ([new-worker (http-worker worker-id self (supervisor-state-app state))]) 445 | (list-set! workers worker-id new-worker) 446 | (printf "[Supervisor] Worker ~a graceful restart completed\n" worker-id)))))) 447 | (supervisor-loop state)] 448 | 449 | ;; Shutdown supervisor 450 | [#(shutdown) 451 | (printf "[Supervisor] Shutting down...\n") 452 | ;; Shutdown all workers 453 | (for-each 454 | (lambda (worker) 455 | (send worker `#(shutdown))) 456 | (supervisor-state-workers state)) 457 | 'ok] 458 | 459 | [,msg 460 | ;; Handle all other messages including EXIT and DOWN 461 | (let ([msg-str (format "~a" msg)]) 462 | (cond 463 | ;; Detect EXIT or DOWN messages 464 | [(or (string-contains? msg-str "EXIT") 465 | (string-contains? msg-str "DOWN")) 466 | (printf "[Supervisor] Received monitor message: ~a\n" msg) 467 | ;; Find crashed worker from worker list 468 | (let ([crashed-worker 469 | (let loop ([ws (supervisor-state-workers state)]) 470 | (cond 471 | [(null? ws) #f] 472 | [(string-contains? msg-str (format "~a" (car ws))) 473 | (car ws)] 474 | [else (loop (cdr ws))]))]) 475 | (when crashed-worker 476 | (printf "[Supervisor] Identified crashed worker, starting recovery\n") 477 | (handle-worker-crash state crashed-worker msg))) 478 | (supervisor-loop state)] 479 | ;; Other unknown messages 480 | [else 481 | (printf "[Supervisor] Unknown message: ~a\n" msg) 482 | (supervisor-loop state)]))])) 483 | 484 | ;; Handle worker crash 485 | (define (handle-worker-crash state worker reason) 486 | (printf "[Supervisor] Detected worker crash: ~a\n" reason) 487 | 488 | ;; Remove from worker list 489 | (supervisor-state-workers-set! state 490 | (remove worker (supervisor-state-workers state))) 491 | 492 | ;; Get uncompleted task 493 | (let ([active-task (hashtable-ref (supervisor-state-active-tasks state) worker #f)]) 494 | (when active-task 495 | (hashtable-delete! (supervisor-state-active-tasks state) worker) 496 | 497 | ;; Increment retry count 498 | (task-retry-count-set! active-task (+ (task-retry-count active-task) 1)) 499 | 500 | ;; Check retry limit 501 | (if (> (task-retry-count active-task) 3) 502 | ;; Exceeded retry limit, abandon task 503 | (begin 504 | (printf "[Supervisor] Task #~a failed too many times (~a attempts), abandoning retry\n" 505 | (task-id active-task) (task-retry-count active-task)) 506 | ;; Send error response to client 507 | (let ([op (task-op active-task)]) 508 | (guard (e [else (void)]) 509 | (put-bytevector op (string->utf8 510 | "HTTP/1.1 500 Internal Server Error\r\nContent-Type: text/plain\r\n\r\nTask failed after multiple retries")) 511 | (close-port (task-ip active-task)) 512 | (close-port op)))) 513 | ;; Not exceeded limit, reassign 514 | (begin 515 | (printf "[Supervisor] Task #~a needs reassignment (retry #~a)\n" 516 | (task-id active-task) (task-retry-count active-task)) 517 | 518 | ;; First try to assign to other available workers 519 | (let ([available-worker (find-available-worker 520 | (supervisor-state-workers state) 521 | (supervisor-state-active-tasks state))]) 522 | (if available-worker 523 | ;; Has available worker, assign directly 524 | (begin 525 | (printf "[Supervisor] Task #~a assigned to available worker\n" (task-id active-task)) 526 | (task-assigned-worker-set! active-task available-worker) 527 | (hashtable-set! (supervisor-state-active-tasks state) available-worker active-task) 528 | (send available-worker `#(process-task ,active-task))) 529 | ;; No available workers, add to queue 530 | (begin 531 | (printf "[Supervisor] No available workers, task #~a queued\n" (task-id active-task)) 532 | (supervisor-state-pending-tasks-set! state 533 | (cons active-task (supervisor-state-pending-tasks state)))))))))) 534 | 535 | ;; Create new worker to replace crashed one (replenish worker pool) 536 | (let ([new-worker (http-worker (length (supervisor-state-workers state)) 537 | self 538 | (supervisor-state-app state))]) 539 | (monitor new-worker) 540 | (supervisor-state-workers-set! state 541 | (cons new-worker (supervisor-state-workers state))) 542 | (printf "[Supervisor] Created new worker to replenish pool\n") 543 | 544 | ;; If there are queued tasks, assign to new worker 545 | (let ([pending (supervisor-state-pending-tasks state)]) 546 | (when (not (null? pending)) 547 | (let ([next-task (car pending)]) 548 | (supervisor-state-pending-tasks-set! state (cdr pending)) 549 | (task-assigned-worker-set! next-task new-worker) 550 | (hashtable-set! (supervisor-state-active-tasks state) new-worker next-task) 551 | (send new-worker `#(process-task ,next-task)) 552 | (printf "[Supervisor] New worker processing queued task #~a\n" (task-id next-task))))))) 553 | 554 | ;; Handle worker exit 555 | (define (handle-worker-exit state worker reason) 556 | (if (eq? reason 'normal) 557 | (printf "[Supervisor] Worker exited normally\n") 558 | (handle-worker-crash state worker reason))) 559 | 560 | ;; Find available worker 561 | (define (find-available-worker workers active-tasks) 562 | (let loop ([ws workers]) 563 | (cond 564 | [(null? ws) #f] 565 | [(not (hashtable-ref active-tasks (car ws) #f)) (car ws)] 566 | [else (loop (cdr ws))]))) 567 | 568 | ;; ==================== Express Core Functions ==================== 569 | 570 | ;; Create Igropyr Express application 571 | (define (create-app) 572 | (let ([app (make-app-state '() '() '() '() 573 | (make-hashtable string-hash string=?) 574 | '())]) 575 | ;; Set default configuration 576 | (hashtable-set! (app-state-config app) "port" 3000) 577 | (hashtable-set! (app-state-config app) "host" "0.0.0.0") 578 | (hashtable-set! (app-state-config app) "base-dir" (current-directory)) 579 | (hashtable-set! (app-state-config app) "log-file" "file::memory:?cache=shared") 580 | app)) 581 | 582 | ;; Create response object 583 | (define (create-response) 584 | (make-response 200 '() "")) 585 | 586 | ;; ==================== Route Management ==================== 587 | 588 | ;; Add route (supports parameters) 589 | (define (add-route app method path handler) 590 | (let ([params (extract-params path)]) 591 | (app-state-routes-set! app 592 | (append (app-state-routes app) 593 | (list (make-route method path handler params)))))) 594 | 595 | ;; Extract path parameters 596 | (define (extract-params path) 597 | (let loop ([parts (string-split path #\/)] [params '()]) 598 | (cond 599 | [(null? parts) (reverse params)] 600 | [(and (> (string-length (car parts)) 0) 601 | (char=? (string-ref (car parts) 0) #\:)) 602 | (loop (cdr parts) 603 | (cons (substring (car parts) 1 (string-length (car parts))) 604 | params))] 605 | [else (loop (cdr parts) params)]))) 606 | 607 | ;; HTTP method routing 608 | (define (app-get app path handler) 609 | (add-route app "GET" path handler)) 610 | 611 | (define (app-post app path handler) 612 | (add-route app "POST" path handler)) 613 | 614 | (define (app-put app path handler) 615 | (add-route app "PUT" path handler)) 616 | 617 | (define (app-delete app path handler) 618 | (add-route app "DELETE" path handler)) 619 | 620 | ;; ==================== Middleware Management ==================== 621 | 622 | ;; Add middleware 623 | (define (app-use app . args) 624 | (cond 625 | [(= (length args) 1) 626 | ;; Global middleware 627 | (app-state-middleware-set! app 628 | (append (app-state-middleware app) 629 | (list (make-middleware "global" (car args)))))] 630 | [(= (length args) 2) 631 | ;; Path-specific middleware 632 | (app-state-middleware-set! app 633 | (append (app-state-middleware app) 634 | (list (make-middleware (car args) (cadr args)))))])) 635 | 636 | ;; Run middleware chain 637 | (define (run-middleware-chain middleware req res final-handler) 638 | (if (null? middleware) 639 | (final-handler req res) 640 | (let ([mw (car middleware)]) 641 | ((middleware-handler mw) req res 642 | (lambda () 643 | (run-middleware-chain (cdr middleware) req res final-handler)))))) 644 | 645 | ;; ==================== Static Files and Dynamic Pages ==================== 646 | 647 | ;; Set static file directory 648 | (define (app-static app path dir) 649 | (app-state-static-dirs-set! app 650 | (append (app-state-static-dirs app) (list (cons path dir))))) 651 | 652 | ;; Set dynamic page directory 653 | (define (app-dynamic app path dir) 654 | (app-state-dynamic-dirs-set! app 655 | (append (app-state-dynamic-dirs app) (list (cons path dir))))) 656 | 657 | ;; ==================== Igropyr Application Framework Integration ==================== 658 | 659 | ;; Configure application 660 | (define (app-configure app key value) 661 | (hashtable-set! (app-state-config app) key value)) 662 | 663 | ;; Get configuration 664 | (define (app-config app key) 665 | (hashtable-ref (app-state-config app) key #f)) 666 | 667 | ;; ==================== Connection Pool and Queue Management ==================== 668 | 669 | ;; Maximum concurrent connections (increased to 100 for higher concurrency) 670 | (define max-concurrent-connections 100) 671 | 672 | ;; Maximum connection queue length (increased to 1000) 673 | (define max-queue-size 1000) 674 | 675 | ;; Worker thread pool size 676 | (define worker-pool-size 50) 677 | 678 | ;; Request timeout (milliseconds) 679 | (define request-timeout 30000) 680 | 681 | ;; Active connection count (using atomic operations) 682 | (define active-connections (make-parameter 0)) 683 | 684 | ;; Connection queue (using more efficient data structure) 685 | (define connection-queue (make-parameter '())) 686 | 687 | ;; Connection pool statistics 688 | (define total-requests (make-parameter 0)) 689 | (define rejected-requests (make-parameter 0)) 690 | (define timeout-requests (make-parameter 0)) 691 | (define error-requests (make-parameter 0)) 692 | 693 | ;; Handle connection (with resource management and timeout control) 694 | (define (handle-connection-safe app ip op) 695 | (let ([start-time (current-time-ms)]) 696 | (dynamic-wind 697 | (lambda () 698 | ;; Increment active connections on entry 699 | (active-connections (+ (active-connections) 1)) 700 | (total-requests (+ (total-requests) 1)) 701 | (when (= (modulo (total-requests) 100) 0) 702 | (printf " [Stats] Total requests: ~a, Active: ~a, Rejected: ~a, Timeout: ~a, Error: ~a\n" 703 | (total-requests) (active-connections) 704 | (rejected-requests) (timeout-requests) 705 | (error-requests)))) 706 | (lambda () 707 | ;; Actually handle connection (enhanced error handling) 708 | (guard (e [(string-contains? (format "~a" e) "broken pipe") 709 | ;; Client disconnected, ignore 710 | (void)] 711 | [else 712 | (error-requests (+ (error-requests) 1)) 713 | (printf " [Error] Processing failed: ~a\n" e)]) 714 | (handle-connection app ip op))) 715 | (lambda () 716 | ;; Decrement active connections on exit and process queue 717 | (active-connections (- (active-connections) 1)) 718 | (let ([elapsed (- (current-time-ms) start-time)]) 719 | (when (> elapsed 1000) 720 | (printf " [Slow request] Processing time: ~a ms\n" elapsed)) 721 | (when (> elapsed request-timeout) 722 | (timeout-requests (+ (timeout-requests) 1)))) 723 | (process-connection-queue app))))) 724 | 725 | ;; Process connection queue (batch processing for efficiency) 726 | (define (process-connection-queue app) 727 | (let loop ([processed 0]) 728 | (when (and (not (null? (connection-queue))) 729 | (< (active-connections) max-concurrent-connections) 730 | (< processed 5)) ; Batch process up to 5 731 | (let ([conn (car (connection-queue))]) 732 | (connection-queue (cdr (connection-queue))) 733 | ;; Process directly, don't use spawn (spawn may not work in traditional mode) 734 | (handle-connection-safe app (car conn) (cdr conn)) 735 | (loop (+ processed 1)))))) 736 | 737 | ;; Accept connection (with queue management and priority) 738 | (define (accept-connection app ip op) 739 | (cond 740 | ;; If concurrency limit not reached, process directly 741 | [(< (active-connections) max-concurrent-connections) 742 | ;; Process directly, don't use spawn (spawn may not work in traditional mode) 743 | (handle-connection-safe app ip op)] 744 | ;; If queue not full, add to queue 745 | [(< (length (connection-queue)) max-queue-size) 746 | (connection-queue (append (connection-queue) (list (cons ip op)))) 747 | (when (= (modulo (length (connection-queue)) 10) 0) 748 | (printf " [Queue] Queue length: ~a\n" (length (connection-queue))))] 749 | ;; Queue full, reject connection 750 | [else 751 | (rejected-requests (+ (rejected-requests) 1)) 752 | (guard (e [else (void)]) 753 | (put-bytevector op (string->utf8 754 | "HTTP/1.1 503 Service Unavailable\r\nRetry-After: 5\r\nContent-Type: text/plain\r\n\r\nServer is overloaded, please retry later.")) 755 | (close-port ip) 756 | (close-port op))])) 757 | 758 | 759 | ;; Start HTTP server process 760 | (define (start-http-server-process app) 761 | (let* ([host (app-config app "host")] 762 | [port (app-config app "port")] 763 | [listener (guard (e [else 764 | (printf "❌ Cannot listen on port ~a:~a - ~a\n" host port e) 765 | (exit 1)]) 766 | ;; Use "::" to listen on all addresses (IPv4 and IPv6) 767 | (listen-tcp "::" port self))]) 768 | (printf "✅ Igropyr Express server started ~a:~a\n" host port) 769 | (printf " [Config] Max concurrent connections: ~a\n" max-concurrent-connections) 770 | (printf " [Config] Max queue size: ~a\n" max-queue-size) 771 | (printf " [Config] Request timeout: ~a ms\n" request-timeout) 772 | 773 | ;; Server main loop (optimized event handling) 774 | (let loop () 775 | (receive 776 | [#(accept-tcp ,_ ,ip ,op) 777 | ;; Reduce log output, only record at critical moments 778 | (when (= (modulo (total-requests) 50) 0) 779 | (printf "📊 [~a] Active: ~a, Queue: ~a, Total: ~a\n" 780 | (current-date) (active-connections) 781 | (length (connection-queue)) (total-requests))) 782 | (accept-connection app ip op) 783 | (loop)] 784 | 785 | [#(accept-tcp-failed ,_ ,reason ,msg) 786 | (printf "⚠️ Connection failed: ~a ~a\n" reason msg) 787 | (loop)] 788 | 789 | [(after 30000 'status) 790 | (printf "\n📈 Server statistics [~a]\n" (current-date)) 791 | (printf " Total requests: ~a\n" (total-requests)) 792 | (printf " Active connections: ~a / ~a\n" (active-connections) max-concurrent-connections) 793 | (printf " Queue length: ~a / ~a\n" (length (connection-queue)) max-queue-size) 794 | (printf " Rejected requests: ~a (~a%)\n" 795 | (rejected-requests) 796 | (if (> (total-requests) 0) 797 | (round (* 100.0 (/ (rejected-requests) (total-requests)))) 798 | 0)) 799 | (printf " Timeout requests: ~a (~a%)\n" 800 | (timeout-requests) 801 | (if (> (total-requests) 0) 802 | (round (* 100.0 (/ (timeout-requests) (total-requests)))) 803 | 0)) 804 | (loop)] 805 | 806 | [,msg 807 | (printf "Received message: ~a\n" msg) 808 | (loop)])))) 809 | 810 | 811 | ;; ==================== OTP Public API ==================== 812 | 813 | ;; Start supervisor 814 | (define (start-supervisor worker-count app) 815 | (supervisor-process worker-count app)) 816 | 817 | ;; Stop supervisor 818 | (define (stop-supervisor supervisor) 819 | (send supervisor `#(shutdown))) 820 | 821 | ;; Get supervisor status 822 | (define (supervisor-status supervisor) 823 | (send supervisor `#(get-status ,self)) 824 | (receive 825 | [#(status ,state) state] 826 | [(after 1000 'timeout) #f])) 827 | 828 | ;; Create worker 829 | (define (spawn-worker supervisor) 830 | (send supervisor `#(spawn-worker))) 831 | 832 | ;; Get worker count 833 | (define (worker-count supervisor) 834 | (let ([status (supervisor-status supervisor)]) 835 | (if status 836 | (length (supervisor-state-workers status)) 837 | 0))) 838 | 839 | ;; Task ID generator 840 | (define task-counter (make-parameter 0)) 841 | 842 | ;; Generate unique task ID 843 | (define (generate-task-id) 844 | (let ([id (task-counter)]) 845 | (task-counter (+ id 1)) 846 | id)) 847 | 848 | ;; OTP-enhanced HTTP server startup 849 | (define (start-otp-http-server app host port supervisor) 850 | (let ([listener (guard (e [else 851 | (printf "❌ Cannot listen on port ~a:~a - ~a\n" host port e) 852 | (exit 1)]) 853 | (listen-tcp "::" port self))]) 854 | (printf "✅ Igropyr Express OTP server started ~a:~a\n" host port) 855 | (printf " [OTP Mode] Let It Crash fault tolerance enabled\n") 856 | (printf " [Worker Pool] ~a worker processes\n" (worker-count supervisor)) 857 | 858 | ;; OTP server main loop 859 | (let loop () 860 | (receive 861 | [#(accept-tcp ,_ ,ip ,op) 862 | ;; Read request and create task 863 | (guard (e [else 864 | (printf " [Error] Failed to read request: ~a\n" e) 865 | (close-port ip) 866 | (close-port op)]) 867 | (let ([request-line (read-http-line ip)]) 868 | (when (and request-line (not (eof-object? request-line))) 869 | (let-values ([(method path query) (parse-request-line request-line)]) 870 | (let* ([headers (read-headers ip)] 871 | [body (read-body ip headers)] 872 | [req (make-request method path headers body '() query)] 873 | [res (create-response)] 874 | [task-id (generate-task-id)] 875 | [task (make-task task-id req res ip op 0 #f)]) 876 | 877 | (printf " 📨 [Task #~a] ~a ~a\n" task-id method path) 878 | 879 | ;; Submit task to supervisor 880 | (send supervisor `#(submit-task ,task))))))) 881 | 882 | (loop)] 883 | 884 | [#(accept-tcp-failed ,_ ,reason ,msg) 885 | (printf "⚠️ Connection failed: ~a ~a\n" reason msg) 886 | (loop)] 887 | 888 | [(after 30000 'status) 889 | (let ([status (supervisor-status supervisor)]) 890 | (when status 891 | (printf "\n📈 OTP server statistics [~a]\n" (current-date)) 892 | (printf " Workers: ~a\n" (length (supervisor-state-workers status))) 893 | (printf " Queue length: ~a\n" (length (supervisor-state-pending-tasks status))) 894 | (printf " Active tasks: ~a\n" (hashtable-size (supervisor-state-active-tasks status))) 895 | (printf " Restart count: ~a\n" (supervisor-state-restart-count status)))) 896 | (loop)] 897 | 898 | [,msg 899 | (printf "Received message: ~a\n" msg) 900 | (loop)])))) 901 | 902 | ;; Start Igropyr application (supports OTP mode) 903 | (define (app-start app . args) 904 | (let ([otp-mode (and (not (null? args)) (car args))]) 905 | (printf "\nStarting Igropyr Express application framework...\n") 906 | 907 | ;; Set base directory 908 | (base-dir (app-config app "base-dir")) 909 | 910 | ;; Set logging 911 | (log-file (app-config app "log-file")) 912 | 913 | ;; Get configuration 914 | (let* ([port (app-config app "port")] 915 | [host (app-config app "host")]) 916 | 917 | ;; If there are static directories, show info 918 | (when (not (null? (app-state-static-dirs app))) 919 | (for-each 920 | (lambda (dir-config) 921 | (let ([path (car dir-config)] 922 | [dir (cdr dir-config)]) 923 | (printf " 📁 Static directory: ~a -> ~a\n" path dir))) 924 | (app-state-static-dirs app))) 925 | 926 | ;; If there are dynamic directories, configure dynamic pages 927 | (when (not (null? (app-state-dynamic-dirs app))) 928 | (for-each 929 | (lambda (dir-config) 930 | (let ([path (car dir-config)] 931 | [dir (cdr dir-config)]) 932 | (printf " 🔄 Dynamic directory: ~a -> ~a\n" path dir))) 933 | (app-state-dynamic-dirs app))) 934 | 935 | ;; Choose startup method based on mode 936 | (if otp-mode 937 | ;; OTP mode - use Let It Crash 938 | (let ([worker-count (or (app-config app "worker-count") 5)] 939 | [supervisor (start-supervisor 940 | (or (app-config app "worker-count") 5) 941 | app)]) 942 | (printf "✅ Igropyr application started successfully (OTP mode)!\n") 943 | (printf "🌐 Access: http://localhost:~a/\n" port) 944 | (printf "💪 Let It Crash mode enabled\n") 945 | (start-otp-http-server app host port supervisor)) 946 | 947 | ;; Traditional mode 948 | (begin 949 | (printf "✅ Igropyr application started successfully (traditional mode)!\n") 950 | (printf "🌐 Access: http://localhost:~a/\n" port) 951 | (start-http-server-process app)))))) 952 | 953 | ;; Stop application 954 | (define (app-stop app) 955 | (printf "Stopping Igropyr Express application...\n") 956 | (exit 0)) 957 | 958 | ;; Get supervisor 959 | (define (app-supervisor app) 960 | (app-state-supervisor-spec app)) 961 | 962 | ;; ==================== HTTP Protocol Handling ==================== 963 | 964 | ;; Parse request line 965 | (define (parse-request-line line) 966 | (let ([parts (string-split line #\space)]) 967 | (if (>= (length parts) 2) 968 | (let* ([path-with-query (cadr parts)] 969 | [query-pos (string-index path-with-query #\?)]) 970 | (if query-pos 971 | (values (car parts) 972 | (substring path-with-query 0 query-pos) 973 | (parse-query-string 974 | (substring path-with-query (+ query-pos 1) 975 | (string-length path-with-query)))) 976 | (values (car parts) path-with-query '()))) 977 | (values "" "" '())))) 978 | 979 | ;; Parse query string 980 | (define (parse-query-string str) 981 | (if (string=? str "") 982 | '() 983 | (map (lambda (pair) 984 | (let ([parts (string-split pair #\=)]) 985 | (if (= (length parts) 2) 986 | (cons (car parts) (cadr parts)) 987 | (cons pair "")))) 988 | (string-split str #\&)))) 989 | 990 | ;; Read HTTP line 991 | (define (read-http-line ip) 992 | (let loop ([bytes '()]) 993 | (let ([b (get-u8 ip)]) 994 | (cond 995 | [(eof-object? b) 996 | (if (null? bytes) b 997 | (utf8->string (u8-list->bytevector (reverse bytes))))] 998 | [(= b 13) ; \r 999 | (let ([next (get-u8 ip)]) 1000 | (if (and (not (eof-object? next)) (= next 10)) ; \n 1001 | (utf8->string (u8-list->bytevector (reverse bytes))) 1002 | (loop (cons next (cons b bytes)))))] 1003 | [(= b 10) ; \n 1004 | (utf8->string (u8-list->bytevector (reverse bytes)))] 1005 | [else 1006 | (loop (cons b bytes))])))) 1007 | 1008 | ;; Read headers 1009 | (define (read-headers ip) 1010 | (let loop ([headers '()]) 1011 | (let ([line (read-http-line ip)]) 1012 | (if (or (eof-object? line) (string=? line "")) 1013 | headers 1014 | (let ([colon-pos (string-index line #\:)]) 1015 | (if colon-pos 1016 | (let ([name (substring line 0 colon-pos)] 1017 | [value (string-trim 1018 | (substring line (+ colon-pos 1) 1019 | (string-length line)))]) 1020 | (loop (cons (cons name value) headers))) 1021 | (loop headers))))))) 1022 | 1023 | ;; Read request body 1024 | (define (read-body ip headers) 1025 | (let ([content-length (assoc "Content-Length" headers)]) 1026 | (if content-length 1027 | (let ([len (string->number (cdr content-length))]) 1028 | (if (and len (> len 0)) 1029 | (utf8->string (get-bytevector-n ip len)) 1030 | "")) 1031 | ""))) 1032 | 1033 | ;; ==================== Route Matching and Parameter Handling ==================== 1034 | 1035 | ;; Path matching (supports parameters and wildcards) 1036 | (define (path-matches? pattern path) 1037 | (cond 1038 | [(string=? pattern path) #t] 1039 | [(string-contains? pattern ":") 1040 | (path-with-params-matches? pattern path)] 1041 | [(string-suffix? "*" pattern) 1042 | (let ([prefix (substring pattern 0 (- (string-length pattern) 1))]) 1043 | (string-prefix? prefix path))] 1044 | [else #f])) 1045 | 1046 | ;; Path matching with parameters 1047 | (define (path-with-params-matches? pattern path) 1048 | (let ([pattern-parts (string-split pattern #\/)] 1049 | [path-parts (string-split path #\/)]) 1050 | (and (= (length pattern-parts) (length path-parts)) 1051 | (let loop ([pp pattern-parts] [ph path-parts]) 1052 | (cond 1053 | [(null? pp) #t] 1054 | [(string-prefix? ":" (car pp)) 1055 | (loop (cdr pp) (cdr ph))] 1056 | [(string=? (car pp) (car ph)) 1057 | (loop (cdr pp) (cdr ph))] 1058 | [else #f]))))) 1059 | 1060 | ;; Extract path parameter values 1061 | (define (extract-path-params pattern path) 1062 | (let ([pattern-parts (string-split pattern #\/)] 1063 | [path-parts (string-split path #\/)]) 1064 | (let loop ([pp pattern-parts] [ph path-parts] [params '()]) 1065 | (cond 1066 | [(null? pp) params] 1067 | [(string-prefix? ":" (car pp)) 1068 | (let ([param-name (substring (car pp) 1 (string-length (car pp)))]) 1069 | (loop (cdr pp) (cdr ph) 1070 | (cons (cons param-name (car ph)) params)))] 1071 | [else (loop (cdr pp) (cdr ph) params)])))) 1072 | 1073 | ;; ==================== HTTP Response Handling ==================== 1074 | 1075 | ;; Send HTTP response 1076 | (define (send-http-response op res) 1077 | (let* ([body (response-body res)] 1078 | [body-bytes (string->utf8 body)] 1079 | [status-text (case (response-status res) 1080 | [(200) "OK"] 1081 | [(201) "Created"] 1082 | [(302) "Found"] 1083 | [(400) "Bad Request"] 1084 | [(404) "Not Found"] 1085 | [(500) "Internal Server Error"] 1086 | [else "Unknown"])] 1087 | [content-length (bytevector-length body-bytes)]) 1088 | 1089 | ;; Build response headers 1090 | (let ([header-str 1091 | (string-append 1092 | (format "HTTP/1.1 ~a ~a\r\n" (response-status res) status-text) 1093 | (apply string-append 1094 | (map (lambda (header) 1095 | (format "~a: ~a\r\n" (car header) (cdr header))) 1096 | (response-headers res))) 1097 | (format "Content-Length: ~a\r\n" content-length) 1098 | "Server: Igropyr/1.0\r\n" 1099 | "Connection: close\r\n" 1100 | "\r\n")]) 1101 | 1102 | ;; Send response (ignore write errors, client may have disconnected) 1103 | (guard (e [else (void)]) 1104 | (put-bytevector op (string->utf8 header-str)) 1105 | (put-bytevector op body-bytes) 1106 | (flush-output-port op))))) 1107 | 1108 | ;; Send file response 1109 | (define (send-file-response op file-path) 1110 | (let* ([content (call-with-input-file file-path 1111 | (lambda (p) (get-string-all p)))] 1112 | [content-bytes (string->utf8 content)] 1113 | [ext (get-path-extension file-path)] 1114 | [content-type (get-content-type ext)] 1115 | [content-length (bytevector-length content-bytes)]) 1116 | 1117 | (let ([header-str 1118 | (string-append 1119 | "HTTP/1.1 200 OK\r\n" 1120 | (format "Content-Type: ~a\r\n" content-type) 1121 | (format "Content-Length: ~a\r\n" content-length) 1122 | "Server: Igropyr/1.0\r\n" 1123 | "Connection: close\r\n" 1124 | "\r\n")]) 1125 | 1126 | (put-bytevector op (string->utf8 header-str)) 1127 | (put-bytevector op content-bytes) 1128 | (flush-output-port op)))) 1129 | 1130 | ;; Get content type 1131 | (define (get-content-type ext) 1132 | (case (string->symbol (if ext ext "")) 1133 | [(html htm) "text/html; charset=utf-8"] 1134 | [(css) "text/css"] 1135 | [(js) "application/javascript"] 1136 | [(json) "application/json"] 1137 | [(png) "image/png"] 1138 | [(jpg jpeg) "image/jpeg"] 1139 | [(gif) "image/gif"] 1140 | [(svg) "image/svg+xml"] 1141 | [(txt) "text/plain; charset=utf-8"] 1142 | [else "application/octet-stream"])) 1143 | 1144 | ;; ==================== Request/Response Helper Functions ==================== 1145 | 1146 | ;; Set response status code 1147 | (define (set-status! res code) 1148 | (response-status-set! res code)) 1149 | 1150 | ;; Set response header 1151 | (define (set-header! res name value) 1152 | (response-headers-set! res 1153 | (cons (cons name value) (response-headers res)))) 1154 | 1155 | ;; Set response body 1156 | (define (set-body! res body) 1157 | (response-body-set! res body)) 1158 | 1159 | ;; Send JSON response 1160 | (define (send-json res data) 1161 | (set-header! res "Content-Type" "application/json; charset=utf-8") 1162 | (response-body-set! res data)) 1163 | 1164 | (define (send-json! res data) 1165 | (set-header! res "Content-Type" "application/json; charset=utf-8") 1166 | (response-body-set! res 1167 | (format "{\"status\":\"success\",\"data\":~a}" data))) 1168 | 1169 | ;; Send HTML response 1170 | (define (send-html res html) 1171 | (set-header! res "Content-Type" "text/html; charset=utf-8") 1172 | (response-body-set! res html)) 1173 | 1174 | (define (send-html! res html) 1175 | (set-header! res "Content-Type" "text/html; charset=utf-8") 1176 | (response-body-set! res html)) 1177 | 1178 | ;; Send file 1179 | (define (send-file res file-path) 1180 | (if (file-exists? file-path) 1181 | (let ([content (call-with-input-file file-path 1182 | (lambda (p) 1183 | (get-string-all p)))]) 1184 | (response-body-set! res content)) 1185 | (begin 1186 | (set-status! res 404) 1187 | (response-body-set! res "File not found")))) 1188 | 1189 | ;; Redirect 1190 | (define (redirect res url) 1191 | (set-status! res 302) 1192 | (set-header! res "Location" url) 1193 | (response-body-set! res "")) 1194 | 1195 | ;; Serve static file 1196 | (define (serve-static-file app path op) 1197 | (let loop ([dirs (app-state-static-dirs app)]) 1198 | (cond 1199 | [(null? dirs) #f] 1200 | [else 1201 | (let* ([dir-config (car dirs)] 1202 | [url-prefix (car dir-config)] 1203 | [dir-path (cdr dir-config)]) 1204 | (if (string-prefix? url-prefix path) 1205 | (let* ([relative-path (substring path 1206 | (string-length url-prefix) 1207 | (string-length path))] 1208 | [file-path (path-combine dir-path relative-path)]) 1209 | (if (file-exists? file-path) 1210 | (begin 1211 | (send-file-response op file-path) 1212 | #t) 1213 | (loop (cdr dirs)))) 1214 | (loop (cdr dirs))))]))) 1215 | 1216 | ;; Find matching route 1217 | (define (find-matching-route routes method path) 1218 | (let loop ([rs routes]) 1219 | (cond 1220 | [(null? rs) #f] 1221 | [(route-matches? (car rs) method path) (car rs)] 1222 | [else (loop (cdr rs))]))) 1223 | 1224 | ;; Route matching 1225 | (define (route-matches? route method path) 1226 | (and (string=? (route-method route) method) 1227 | (path-matches? (route-path route) path))) 1228 | 1229 | ;; ==================== Connection Handling ==================== 1230 | 1231 | ;; Handle HTTP connection (optimized version) 1232 | (define (handle-connection app ip op) 1233 | ;; Use dynamic-wind to ensure ports are always closed 1234 | (dynamic-wind 1235 | (lambda () 1236 | ;; Set non-blocking mode (if supported) 1237 | (void)) 1238 | (lambda () 1239 | (guard (e [else 1240 | ;; Reduce error logging, only record serious errors 1241 | (when (not (string-contains? (format "~a" e) "broken pipe")) 1242 | (printf " [Error] ~a\n" e))]) 1243 | ;; Read request line 1244 | (let ([request-line (read-http-line ip)]) 1245 | (when (and request-line (not (eof-object? request-line))) 1246 | ;; Only log critical requests 1247 | (when (or (string-contains? request-line "POST") 1248 | (string-contains? request-line "PUT") 1249 | (string-contains? request-line "DELETE")) 1250 | (printf " 📨 ~a\n" request-line)) 1251 | 1252 | ;; Parse request 1253 | (let-values ([(method path query) (parse-request-line request-line)]) 1254 | (let* ([headers (read-headers ip)] 1255 | [body (read-body ip headers)] 1256 | [req (make-request method path headers body '() query)] 1257 | [res (create-response)]) 1258 | 1259 | ;; Find matching route 1260 | (let ([route (find-matching-route (app-state-routes app) method path)]) 1261 | (if route 1262 | ;; Execute route handler 1263 | (begin 1264 | ;; Extract path parameters 1265 | (when (route-params route) 1266 | (request-params-set! req 1267 | (extract-path-params (route-path route) path))) 1268 | 1269 | ;; Run middleware chain 1270 | (guard (handler-error [else 1271 | (printf " [Error] Handler error: ~a\n" handler-error) 1272 | (set-status! res 500) 1273 | (set-body! res "Internal Server Error")]) 1274 | (run-middleware-chain 1275 | (app-state-middleware app) req res 1276 | (lambda (req res) 1277 | ((route-handler route) req res)))) 1278 | 1279 | ;; Send response 1280 | (send-http-response op res)) 1281 | 1282 | ;; Try static files or 404 1283 | (if (serve-static-file app path op) 1284 | (void) 1285 | (begin 1286 | (set-status! res 404) 1287 | (send-html! res 1288 | " 1289 |

404 Not Found

1290 |

The requested resource does not exist

1291 | ") 1292 | (send-http-response op res))))))))))) 1293 | (lambda () 1294 | ;; Ensure ports are always closed 1295 | (guard (e [else (void)]) 1296 | (flush-output-port op) 1297 | (close-port op)) 1298 | (guard (e [else (void)]) 1299 | (close-port ip))))) 1300 | 1301 | ;; ==================== Built-in Middleware ==================== 1302 | 1303 | ;; Logger middleware 1304 | (define (logger-middleware) 1305 | (lambda (req res next) 1306 | (printf "[~a] ~a ~a\n" 1307 | (current-date) 1308 | (request-method req) 1309 | (request-path req)) 1310 | (next))) 1311 | 1312 | ;; CORS middleware 1313 | (define (cors-middleware) 1314 | (lambda (req res next) 1315 | (set-header! res "Access-Control-Allow-Origin" "*") 1316 | (set-header! res "Access-Control-Allow-Methods" 1317 | "GET, POST, PUT, DELETE, OPTIONS") 1318 | (set-header! res "Access-Control-Allow-Headers" 1319 | "Content-Type, Authorization") 1320 | (if (string=? (request-method req) "OPTIONS") 1321 | (begin 1322 | (set-status! res 200) 1323 | (set-body! res "")) 1324 | (next)))) 1325 | 1326 | ;; Static file middleware 1327 | (define (static-middleware dir) 1328 | (lambda (req res next) 1329 | (let ([file-path (path-combine dir (request-path req))]) 1330 | (if (file-exists? file-path) 1331 | (send-file res file-path) 1332 | (next))))) 1333 | 1334 | ;; Error handling middleware 1335 | (define (error-handler-middleware) 1336 | (lambda (req res next) 1337 | (guard (e [else 1338 | (printf "Error: ~a\n" e) 1339 | (set-status! res 500) 1340 | (send-json! res 1341 | (format "{\"error\":\"~a\"}" e))]) 1342 | (next)))) 1343 | 1344 | 1345 | ;; ==================== Traditional Express Startup Interface ==================== 1346 | 1347 | ;; Listen on port (compatible with traditional approach) 1348 | (define (app-listen app host port) 1349 | (app-configure app "host" host) 1350 | (app-configure app "port" port) 1351 | 1352 | ;; If not using Igropyr application framework, use traditional approach 1353 | (if (null? (app-state-supervisor-spec app)) 1354 | (begin 1355 | (printf "\n====================================\n") 1356 | (printf " Express Server (Traditional Mode)\n") 1357 | (printf "====================================\n") 1358 | (printf "✅ Listening on ~a:~a\n" host port) 1359 | (printf "🌐 Access: http://localhost:~a/\n" port) 1360 | (printf "====================================\n\n") 1361 | 1362 | (let ([listener (listen-tcp "::" port self)]) 1363 | ;; Main event loop 1364 | (let loop () 1365 | (receive 1366 | [#(accept-tcp ,_ ,ip ,op) 1367 | (printf "✨ New connection [Active: ~a]\n" (active-connections)) 1368 | (accept-connection app ip op) 1369 | (loop)] 1370 | 1371 | [#(accept-tcp-failed ,_ ,reason ,msg) 1372 | (printf "⚠️ Connection failed: ~a ~a\n" reason msg) 1373 | (loop)] 1374 | 1375 | [(after 10000 'timeout) 1376 | (printf "💗 Server status [Active: ~a, Queue: ~a] [~a]\n" 1377 | (active-connections) (length (connection-queue)) (current-date)) 1378 | (loop)] 1379 | 1380 | [,msg 1381 | (printf "Received message: ~a\n" msg) 1382 | (loop)]))) 1383 | 1384 | ;; Use Igropyr application framework 1385 | (app-start app))) 1386 | 1387 | ;; End library definition 1388 | )) --------------------------------------------------------------------------------