From 077a0c8cdba592edba781976cb16b906bbf71b68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jarl=20Andr=C3=A9=20H=C3=BCbenthal?= Date: Wed, 13 Nov 2024 21:35:22 +0100 Subject: [PATCH] logging like a crazy person --- src/Network/HTTP/Pool/ConnectionPool.idr | 13 ++++++++--- src/Network/HTTP/Pool/Worker.idr | 21 +++++++++++++++--- tests/src/ClientTest.idr | 8 ++++--- tests/src/Test.idr | 28 ++++++++++++------------ 4 files changed, 47 insertions(+), 23 deletions(-) diff --git a/src/Network/HTTP/Pool/ConnectionPool.idr b/src/Network/HTTP/Pool/ConnectionPool.idr index d1aa908..e12ecad 100644 --- a/src/Network/HTTP/Pool/ConnectionPool.idr +++ b/src/Network/HTTP/Pool/ConnectionPool.idr @@ -91,10 +91,13 @@ total_active_connections protocol manager = do close_worker : Worker e -> IO () close_worker worker = do - -- putStrLn "closing \{show worker}" + putStrLn "closing \{show worker}" close worker.socket + putStrLn "Closed worker.socket" let f = \w => w.uuid /= worker.uuid - modifyIORef worker.parent.workers (filter f) + res <- modifyIORef worker.parent.workers (filter f) + putStrLn "Modified io ref" + pure res close_pool : {e : _} -> Condition -> Pool e -> IO () close_pool cond pool = do @@ -104,17 +107,19 @@ close_pool cond pool = do traverse_ (flip channelPut (Left ConnectionClosed) . response) remaining -- close all sockets + putStrLn ("Traversing close_worker") workers <- readIORef pool.workers traverse_ close_worker workers -- broadcast kill event + putStrLn ("Broadcasting kill \{show workers}") broadcast queue (Kill $ Just cond) wait_for_worker_close : {e : _} -> Mutex -> Condition -> List (Pool e) -> IO () wait_for_worker_close mutex cond pools = do conditionWaitTimeout cond mutex 1000000 workers <- traverse (\p => readIORef p.workers) pools - -- putStrLn "waiting for pool close: \{show workers}" + putStrLn "waiting for pool close: \{show workers}" if null (join workers) then pure () else wait_for_worker_close mutex cond pools has_idle_worker : Pool e -> IO Bool @@ -144,6 +149,7 @@ spawn_worker fetcher throw cert_check protocol hostname pool = do 0 <- connect sock (Hostname hostname.domain) (cast port) | err => throw $ SocketError "unable to connect to \{hostname_str}: \{show err}" let closer = close_worker worker + putStrLn "Running worker_handle" worker_handle sock idle_ref closer fetcher throw cert_check protocol hostname_str min_by : (ty -> ty -> Ordering) -> List1 ty -> ty @@ -197,6 +203,7 @@ export pure () evict_all manager = do + putStrLn "Evict all" pools <- readIORef manager.pools condition <- makeCondition mutex <- makeMutex diff --git a/src/Network/HTTP/Pool/Worker.idr b/src/Network/HTTP/Pool/Worker.idr index 10fc3f4..ab8bc52 100644 --- a/src/Network/HTTP/Pool/Worker.idr +++ b/src/Network/HTTP/Pool/Worker.idr @@ -54,9 +54,11 @@ worker_write handle remaining stream = do worker_write handle (remaining - should_take) rest worker_finish : Maybe ConnectionAction -> (1 _ : Handle' t_ok t_closed) -> L1 IO (LogicOkOrError t_ok t_closed) -worker_finish (Just KeepAlive) handle = +worker_finish (Just KeepAlive) handle = do + putStrLn "Keeping alive" pure1 (True # handle) worker_finish _ handle = do + putStrLn "Closing handle" handle <- close handle pure1 (False # handle) @@ -154,12 +156,15 @@ worker_logic request handle = do liftIO1 $ throw (SocketError "error while reading response header: \{error}") pure1 (False # handle) + putStrLn "Hello you" + let Right response = deserialize_http_response $ (ltrim line <+> "\n") -- for some reason the end line sometimes is not sent | Left err => do handle <- close handle liftIO1 $ throw (SocketError "error parsing http response headers: \{err}") pure1 (False # handle) let connection_action = lookup_header response.headers Connection + putStrLn "Hello you" channel <- liftIO1 (makeChannel {a=(Either (HttpError e) (Maybe (List Bits8)))}) let schedule_response = MkScheduleResponse response channel @@ -168,10 +173,15 @@ worker_logic request handle = do let encodings = join $ toList (forget <$> lookup_header response.headers TransferEncoding) if elem Chunked encodings then do + putStrLn "Chunked" (True # handle) <- worker_read_chunked handle channel | (False # handle) => pure1 (False # handle) - worker_finish connection_action handle + putStrLn "Chunked finished" + res <- worker_finish connection_action handle + putStrLn "worker_finish finished" + pure1 res else do + putStrLn "Non chunked" let Just content_length = lookup_header response.headers ContentLength | Nothing => do handle <- close handle @@ -183,9 +193,11 @@ worker_logic request handle = do worker_loop : {e : _} -> IORef Bool -> IO () -> Queue (Event e) -> (1 _ : Handle' t_ok ()) -> L IO () worker_loop idle_ref closer queue handle = do + putStrLn "worker_loop" liftIO1 $ writeIORef idle_ref True Request request <- liftIO1 $ recv queue | Kill condition => do + putStrLn "Received kill" close handle liftIO1 closer case condition of @@ -202,9 +214,11 @@ worker_handle : {e : _} -> Socket -> IORef Bool -> IO () -> Queue (Event e) -> ( worker_handle socket idle_ref closer fetcher throw cert_checker protocol hostname = LIO.run $ do let handle = socket_to_handle socket case protocol of - HTTP => + HTTP => do + putStrLn "worker_handle::HTTP" worker_loop idle_ref closer fetcher handle HTTPS => do + putStrLn "worker_handle::HTTPS" (True # handle) <- tls_handshake hostname (X25519 ::: [SECP256r1, SECP384r1]) @@ -213,4 +227,5 @@ worker_handle socket idle_ref closer fetcher throw cert_checker protocol hostnam handle (cert_checker hostname) | (False # (err # ())) => liftIO1 $ throw $ SocketError "error during TLS handshake: \{err}" + putStrLn "worker_handle :: running worker_loop" worker_loop idle_ref closer fetcher handle diff --git a/tests/src/ClientTest.idr b/tests/src/ClientTest.idr index dd0aca0..f7e6953 100644 --- a/tests/src/ClientTest.idr +++ b/tests/src/ClientTest.idr @@ -117,9 +117,11 @@ export test_chunked_transfer_encoding : EitherT String IO () test_chunked_transfer_encoding = map_error show $ with_client {e=()} new_client_default $ \client => do putStrLn "sending request stream" - (response, content) <- request client GET (url' "https://httpbin.org/stream/2") [] () + (response, content) <- request client GET (url' "https://httpbin.org/stream/3") [] () putStrLn "response header received" printLn response - content <- toList_ content - putStrLn $ maybe "Nothing" id $ utf8_pack $ content + -- (content, _) <- toList content + -- putStrLn "println content" + -- printLn $ utf8_pack $ content + putStrLn "closing client" close client \ No newline at end of file diff --git a/tests/src/Test.idr b/tests/src/Test.idr index c133b28..7487af2 100644 --- a/tests/src/Test.idr +++ b/tests/src/Test.idr @@ -24,17 +24,17 @@ run tests = do export main : IO () -main = run - [ run_test "decompress random.bin.gz" test_gzip_uncompressed - , run_test "decompress hello.gz" test_gzip_fixed_huffman - , run_test "decompress jabberwock.txt.gz" test_gzip_text - , run_test "decompress jabberwocky.jpg.gz" test_gzip_jpg - , run_test "decompress concatenated.gz" test_gzip_concated - , run_test "http close w/out read" test_close_without_read - , run_test "http cookie jar" test_cookie - , run_test "http httpbin deflate" test_json_deflate - , run_test "http httpbin gzip" test_json_gzip - , run_test "http httpbin post" test_post - , run_test "http openbsd redirect" test_redirect - --, run_test "chunked transfer encoding" test_chunked_transfer_encoding - ] +main = run + [ --run_test "decompress random.bin.gz" test_gzip_uncompressed + -- , run_test "decompress hello.gz" test_gzip_fixed_huffman + -- , run_test "decompress jabberwock.txt.gz" test_gzip_text + -- , run_test "decompress jabberwocky.jpg.gz" test_gzip_jpg + -- , run_test "decompress concatenated.gz" test_gzip_concated + -- , run_test "http close w/out read" test_close_without_read + -- , run_test "http cookie jar" test_cookie + -- , run_test "http httpbin deflate" test_json_deflate + -- , run_test "http httpbin gzip" test_json_gzip + -- , run_test "http httpbin post" test_post + -- , run_test "http openbsd redirect" test_redirect + run_test "chunked transfer encoding" test_chunked_transfer_encoding + ]