@@ -0,0 +1,125 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Control.Concurrent
3+import Control.Concurrent.Async
4+import Network
5+import Network.Wai
6+import Network.Wai.Handler.Warp (defaultSettings)
7+import Network.Wai.Handler.WarpTLS
8+import Network.HTTP.Types (status200)
9+import Network.Socket (Socket(..), mkSocket, SocketStatus(..))
10+import Blaze.ByteString.Builder (copyByteString)
11+import Data.Monoid
12+import qualified Data.Conduit as C
13+import qualified Data.Conduit.List as CL
14+import System.Environment (getEnv)
15+import System.Posix.Process
16+import System.Posix.Signals
17+
18+envSocketName = "GRACEFUL_PONG_SOCKET"
19+
20+fromSocket2Env sock = [(envSocketName, show (fd, addrFamily, socketType, protocolNumber))]
21+ where
22+ MkSocket fd addrFamily socketType protocolNumber _socketStatus = sock
23+
24+handleSIGHUP 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
31+
32+waitpid pid = do
33+ mstatus <- getProcessStatus False True pid
34+ case mstatus of
35+ Nothing -> waitpid pid
36+ Just status -> return status
37+
38+handleSIGTERM proc finish =
39+ takeMVar proc >>=
40+ signalProcess softwareTermination >>
41+ putMVar finish ()
42+
43+child (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
50+
51+parent = 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
62+
63+main = do
64+ (getEnv envSocketName >>= child . read) `catch` const parent
65+
66+app 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
75+
76+builderWithLen = ResponseBuilder
77+ status200
78+ [ ("Content-Type", "text/plain")
79+ , ("Content-Length", "4")
80+ ]
81+ $ copyByteString "PONG"
82+
83+builderNoLen = ResponseBuilder
84+ status200
85+ [ ("Content-Type", "text/plain")
86+ ]
87+ $ copyByteString "PONG"
88+
89+sourceWithLen = ResponseSource
90+ status200
91+ [ ("Content-Type", "text/plain")
92+ , ("Content-Length", "4")
93+ ]
94+ $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
95+
96+sourceNoLen = ResponseSource
97+ status200
98+ [ ("Content-Type", "text/plain")
99+ ]
100+ $ CL.sourceList [C.Chunk $ copyByteString "PONG"]
101+
102+fileWithLen = ResponseFile
103+ status200
104+ [ ("Content-Type", "text/plain")
105+ , ("Content-Length", "4")
106+ ]
107+ "pong.txt"
108+ Nothing
109+
110+fileNoLen = ResponseFile
111+ status200
112+ [ ("Content-Type", "text/plain")
113+ ]
114+ "pong.txt"
115+ Nothing
116+
117+index 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+ ]