git.iko.soy/typeable/wai
on warp-3.2.27-conn-closed-by-pear help sign in
typeable/wai/warp-tls/graceful-pong.hs
125 lines 3.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2import Control.Concurrent
3import Control.Concurrent.Async
4import Network
5import Network.Wai
6import Network.Wai.Handler.Warp (defaultSettings)
7import Network.Wai.Handler.WarpTLS
8import Network.HTTP.Types (status200)
9import Network.Socket (Socket(..), mkSocket, SocketStatus(..))
10import Blaze.ByteString.Builder (copyByteString)
11import Data.Monoid
12import qualified Data.Conduit as C
13import qualified Data.Conduit.List as CL
14import System.Environment (getEnv)
15import System.Posix.Process
16import System.Posix.Signals
18envSocketName = "GRACEFUL_PONG_SOCKET"
20fromSocket2Env sock = [(envSocketName, show (fd, addrFamily, socketType, protocolNumber))]
21 where
22 MkSocket fd addrFamily socketType protocolNumber _socketStatus = sock
24handleSIGHUP proc spawn =
25 modifyMVar_ proc $ \oldpid -> do
26 pid <- spawn
27 signalProcess lostConnection oldpid
28 status <- waitpid oldpid
29 print (oldpid, status)
30 return pid
32waitpid pid = do
33 mstatus <- getProcessStatus False True pid
34 case mstatus of
35 Nothing -> waitpid pid
36 Just status -> return status
38handleSIGTERM proc finish =
39 takeMVar proc >>=
40 signalProcess softwareTermination >>
41 putMVar finish ()
43child (fd, addrFamily, socketType, protocolNumber) = do
44 sock <- mkSocket fd addrFamily socketType protocolNumber Listening
45 putStrLn "https://localhost:3000/"
46 finish <- newEmptyMVar
47 let sighup = Catch $ putMVar finish ()
48 _handler <- installHandler lostConnection sighup Nothing
49 runTLSSocket (TLSSettings "certificate.pem" "key.pem") defaultSettings sock app `race_` takeMVar finish
51parent = do
52 sock <- listenOn $ PortNumber $ toEnum 3000
53 let env = Just $ fromSocket2Env sock
54 spawn = forkProcess $ executeFile "./graceful-pong" False [] env
55 proc <- spawn >>= newMVar
56 finish <- newEmptyMVar
57 let sighup = Catch $ handleSIGHUP proc spawn
58 sigterm = Catch $ handleSIGTERM proc finish
59 _handler <- installHandler lostConnection sighup Nothing
60 _handler <- installHandler softwareTermination sigterm Nothing
61 takeMVar finish
63main = do
64 (getEnv envSocketName >>= child . read) `catch` const parent
66app req = return $
67 case rawPathInfo req of
68 "/builder/withlen" -> builderWithLen
69 "/builder/nolen" -> builderNoLen
70 "/file/withlen" -> fileWithLen
71 "/file/nolen" -> fileNoLen
72 "/source/withlen" -> sourceWithLen
73 "/source/nolen" -> sourceNoLen
74 x -> index x
76builderWithLen = ResponseBuilder
77 status200
78 [ ("Content-Type", "text/plain")
79 , ("Content-Length", "4")
80 ]
81 $ copyByteString "PONG"
83builderNoLen = ResponseBuilder
84 status200
85 [ ("Content-Type", "text/plain")
86 ]
87 $ copyByteString "PONG"
89sourceWithLen = ResponseSource
90 status200
91 [ ("Content-Type", "text/plain")
92 , ("Content-Length", "4")
93 ]
94 $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
96sourceNoLen = ResponseSource
97 status200
98 [ ("Content-Type", "text/plain")
99 ]
100 $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
102fileWithLen = ResponseFile
103 status200
104 [ ("Content-Type", "text/plain")
105 , ("Content-Length", "4")
106 ]
107 "pong.txt"
108 Nothing
110fileNoLen = ResponseFile
111 status200
112 [ ("Content-Type", "text/plain")
113 ]
114 "pong.txt"
115 Nothing
117index p = ResponseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString
118 [ "<p><a href='/builder/withlen'>builder withlen</a></p>\n"
119 , "<p><a href='/builder/nolen'>builder nolen</a></p>\n"
120 , "<p><a href='/file/withlen'>file withlen</a></p>\n"
121 , "<p><a href='/file/nolen'>file nolen</a></p>\n"
122 , "<p><a href='/source/withlen'>source withlen</a></p>\n"
123 , "<p><a href='/source/nolen'>source nolen</a></p>\n"
124 , p
125 ]