IOResolverTests.hs (4202B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOResolverTests (ioResolverTests) where 3 import qualified IO.Resolver as D 4 import qualified IO.Resources as R 5 import qualified IO.Driver as V 6 import Runtime (T(..), ofString, ofNumber, ofList) 7 import Control.Exception 8 import Control.Concurrent 9 import Control.Monad 10 import Data.IORef 11 import System.Timeout (timeout) 12 import Test.Tasty 13 import Test.Tasty.HUnit 14 15 category name reply = case reply of Left p -> R.category p @?= name; _ -> assertFailure name 16 address = R.IPv4 (127,0,0,1) 1234 17 ioResolverTests = localOption (mkTimeout 30000000) $ testGroup "IO host resolver" 18 [ testCase "invalid inputs fail before touching resolver" $ do 19 touched <- newIORef False 20 let query = writeIORef touched True >> pure [] 21 forM_ ["","bad name","bad/name","a\0b","λ",replicate 254 'a'] $ \host -> 22 D.resolveWith host 80 1 query >>= category "invalid-argument" 23 forM_ [(-1,1),(65536,1),(80,0),(80,65)] $ \(port,limit) -> 24 D.resolveWith "localhost" port limit query >>= category "invalid-bound" 25 readIORef touched >>= (@?= False) 26 , testCase "prefix is bounded without demanding an excess endpoint or tail" $ do 27 D.resolveWith "localhost" 1234 1 (pure [address]) >>= (@?= Right (D.Resolution [address] False)) 28 D.resolveWith "localhost" 1234 1 (pure (address:error "excess endpoint forced":error "excess tail forced")) 29 >>= (@?= Right (D.Resolution [address] True)) 30 D.resolveWith "localhost" 1234 1 (pure []) >>= (@?= Right (D.Resolution [] False)) 31 , testCase "host order and duplicates are preserved, not silently reprioritized" $ 32 D.resolveWith "localhost" 1234 3 (pure [address,address,R.IPv4 (127,0,0,2) 1234,address]) 33 >>= (@?= Right (D.Resolution [address,address,R.IPv4 (127,0,0,2) 1234] True)) 34 , testCase "resolver IO errors are ordinary and bounded; unrelated faults are not" $ do 35 D.resolveWith "localhost" 80 1 (ioError (userError (replicate 1000 'x'))) >>= \reply -> case reply of 36 Left p -> do 37 R.category p @?= "resolution-failed" 38 assertBool "bounded diagnostic" (length (R.detail p) <= 512) 39 R.progress p @?= "none" 40 _ -> assertFailure "failure swallowed" 41 actual <- try (D.resolveWith "localhost" 80 1 (throwIO (ErrorCall "unexpected"))) 42 case actual of Left (_ :: ErrorCall) -> pure (); Right _ -> assertFailure "fault converted to ordinary result" 43 , testCase "numeric/localhost host resolution preserves requested port and family" $ do 44 D.resolveTCP "127.0.0.1" D.IPv4Only 1234 64 >>= \reply -> case reply of 45 Right (D.Resolution values False) -> do 46 assertBool "numeric endpoint missing" (address `elem` values) 47 assertBool "unexpected endpoint" (all (== address) values) 48 _ -> assertFailure (show reply) 49 D.resolveTCP "localhost" D.AnyFamily 4321 1 >>= \reply -> case reply of 50 Right (D.Resolution [value] _) -> case value of 51 R.IPv4 _ port -> port @?= 4321 52 R.IPv6 _ _ port -> port @?= 4321 53 _ -> assertFailure (show reply) 54 , testCase "cancellation is not swallowed as a resolver error" $ do 55 entered <- newEmptyMVar; gate <- newEmptyMVar; done <- newEmptyMVar 56 worker <- forkFinally (D.resolveWith "localhost" 80 1 (putMVar entered () >> takeMVar gate)) (putMVar done) 57 takeMVar entered 58 killThread worker 59 timeout 3000000 (takeMVar done) >>= \reply -> case reply of 60 Just (Left _) -> pure () 61 _ -> assertFailure "cancellation became a result" 62 , testCase "wire host bound does not demand excess characters" $ do 63 let host = foldr Fork (Fork (error "excess character forced") (error "excess tail forced")) 64 (replicate 253 (ofNumber 97)) 65 action = Fork (ofNumber 10) (Fork (ofString "resolver") (Fork (ofNumber 1) 66 (Fork (ofString "resolve") (ofList [host,ofString "any",ofNumber 80,ofNumber 1])))) 67 V.runDetailed action >>= \outcome -> case outcome of 68 V.Completed value -> value @?= Fork Leaf (Fork 69 (ofList (map ofString ["invalid-argument","resolver/resolve","","none"])) Leaf) 70 _ -> assertFailure "invalid host executed" 71 ]