I'd like to implement a 'graceful shutdown' command for my webapp (as opposed to my first instinct, which is to just ask people to kill the process)
My first two attempts consisted of
liftIO exitSuccess
E.yield (responseLBS statusOK [G.contentType "text/plain"] "") E.EOF
Both of which just cheerfully returned a result to the client and continued listening. Is there anything an application can do to kill the server? Is this even a reasonable thing to want to do?
I confess I don't have a very strong understanding of iteratee, only enough to know that I can consume my input and that Iteratee is a MonadIO instance.
Use an MVar. Block the main thread until the MVar has been signaled, then cleanup and exit.
Call exitImmediately. One of the fastest ways to tear down the process, and also terribly annoying to debug. I don't believe finalizers/brackets/finally blocks will be called on the way down, depending on your application it may corrupt state.
Throw an exception to the main thread. Warp.run doesn't catch exceptions, so this works by allowing the default exception handler on the main thread (and the main thread only) to terminate the process.
As others have mentioned, using an MVar is probably the best option. I included the others for the sake of completeness, but they do have their place. throwTo is used somewhat in the base library and I've worked on a few applications that use the C equivalent of exitImmediately: exit(), though I haven't run across any Haskell apps that use this method.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Concurrent (MVar, ThreadId, forkIO, myThreadId, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (Exception, throwTo)
import Control.Monad.Trans (liftIO)
import Data.ByteString (ByteString)
import Data.Data (Data, Typeable)
import Data.Enumerator (Iteratee)
import Network.HTTP.Types
import Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp
import System.Exit (ExitCode (ExitSuccess))
import System.Posix.Process (exitImmediately)
data Shutdown = Shutdown deriving (Data, Typeable, Show)
instance Exception Shutdown
app :: ThreadId -> MVar () -> Request -> Iteratee ByteString IO Response
app mainThread shutdownMVar Request{pathInfo = pathInfo} = do
liftIO $ case pathInfo of
["shutdownByThrowing"] -> throwTo mainThread Shutdown
["shutdownByMVar"] -> putMVar shutdownMVar ()
["shutdownByExit"] -> exitImmediately ExitSuccess
_ -> return ()
return $ responseLBS statusOK [headerContentType "text/plain"] "ok"
main :: IO ()
main = do
mainThread <- myThreadId
shutdownMVar <- newEmptyMVar
forkIO $ Warp.run 3000 (app mainThread shutdownMVar)
takeMVar shutdownMVar
Related
I tried building a simple client-server program following this tutorial about Haskell's network-conduit library.
This is the client, which concurrently sends a file to the server and receives the answer:
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent.Async (concurrently)
import Data.Functor (void)
import Conduit
import Data.Conduit.Network
main = runTCPClient (clientSettings 4000 "localhost") $ \server ->
void $ concurrently
(runConduitRes $ sourceFile "input.txt" .| appSink server)
(runConduit $ appSource server .| stdoutC)
And this is the server, which counts the occurrences of each word and sends the result back to the client:
{-# LANGUAGE OverloadedStrings #-}
import Data.ByteString.Char8 (pack)
import Data.Foldable (toList)
import Data.HashMap.Lazy (empty, insertWith)
import Data.Word8 (isAlphaNum)
import Conduit
import Data.Conduit.Network
import qualified Data.Conduit.Combinators as CC
main = runTCPServer (serverSettings 4000 "*") $ \appData -> do
hashMap <- runConduit $ appSource appData
.| CC.splitOnUnboundedE (not . isAlphaNum)
.| foldMC insertInHashMap empty
runConduit $ yield (pack $ show $ toList hashMap)
.| iterMC print
.| appSink appData
insertInHashMap x v = do
return (insertWith (+) v 1 x)
The problem is that the server doesn't reach the yield phase until I manually shut down the client and therefore never answers to it. I noticed that removing the concurrency from the client and keeping only the part in which it sends data to the server, everything works fine.
So, how can I preserve the receiving part of the client without breaking the flow?
You have a deadlock: the client is waiting for the server to respond before it closes the connection, but the server is unaware that the client is done sending data and is waiting for more. This is basically the problem described at https://cr.yp.to/tcpip/twofd.html:
When the generate-data program finishes, the same fd is still open in the consume-data program, so the kernel has no idea that it should send a FIN.
In your case, the fix needs to go on the client side. You need to call shutdown with ShutdownSend on the socket once conduit is done sending the contents of input.txt over it.
Here's one way to do so (I'm not sure if there's a nicer one):
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent.Async (concurrently)
import Data.Functor (void)
import Data.Foldable (traverse_)
import Conduit
import Data.Conduit.Network
import Data.Streaming.Network (appRawSocket)
import Network.Socket (shutdown, ShutdownCmd(..))
main = runTCPClient (clientSettings 4000 "localhost") $ \server ->
void $ concurrently
((runConduitRes $ sourceFile "input.txt" .| appSink server) >> doneWriting server)
(runConduit $ appSource server .| stdoutC)
doneWriting = traverse_ (`shutdown` ShutdownSend) . appRawSocket
Side note: you don't really need concurrency in the client in this case, since there will never be anything to read from the server until you're done writing to the server. You could just do the reading after the writing and shutdown.
I have a simple forked conduit setup, with two inputs feeding one single output....
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString as B
import Data.Conduit
import Data.Conduit.TMChan
import Data.Conduit.Network
main::IO ()
main = do
runTCPClient (clientSettings 3000 "127.0.0.1") $ \server -> do
runResourceT $ do
input <- mergeSources [
transPipe liftIO (appSource server),
infiniteSource
] 2
input $$ transPipe liftIO (appSink server)
infiniteSource::MonadIO m=>Source m B.ByteString
infiniteSource = do
liftIO $ threadDelay 10000000
yield "infinite source"
infiniteSource
(here I connect to a tcp socket, then combine the socket input with a timed infinite source, then respond back to the socket)
This works great, until the connection is dropped.... Because the second input still exists, the conduit keeps running. (In this case, the program does end when the timed input fires and there is no socket to write to, but this isn't always the case in my real example).
What is the proper way to shut down the full conduit when one of the inputs is closed?
I tried to brute force a crash by adding the following
crashOnEndOfStream::MonadIO m=>Conduit B.ByteString m B.ByteString
crashOnEndOfStream = do
awaitForever $ yield
error "the peer connection has disconnected" --tried with error
liftIO $ exitWith ExitSuccess --also tried with exitWith
but because the input conduit runs in a thread, the executable was immune to runtime exceptions shutting it down (plus, there is probably a smoother way to shut stuff down than halting the program).
the Source created by mergeSources keeps a count of unclosed sources. It's only closed when the count reaches 0 i.e. every upstream source is closed. This mechanism and the underlying TBMChannel is hidden from user code so you have no way to change its behavior.
One possible solution is to create the channel and the source manually with some medium-level functions exported by Data.Conduit.TMChan, so you can finalize the source by closing the TBMChannel. I haven't tested the code below since your program is not runnable on my machine.
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import qualified Data.ByteString as B
import Data.Conduit
import Data.Conduit.Network
import Data.Conduit.TMChan
main::IO ()
main = do
runTCPClient (clientSettings 3000 "127.0.0.1") $ \server -> do
runResourceT $ do
-- create the TBMChannel
chan <- liftIO $ newTBMChanIO 2
let
-- everything piped to the sink will appear at the source
chanSink = sinkTBMChan chan True
chanSource = sourceTBMChan chan
tid1 <- resourceForkIO $ appSource server $$ chanSink
tid2 <- resourceForkIO $ infiniteSource $$ chanSink
chanSource $$ transPipe liftIO (appSink server)
-- and call 'closeTBMChan chan' when you want to exit.
-- 'chanSource' will be closed when the underlying TBMChannel is closed.
infiniteSource :: MonadIO m => Source m B.ByteString
infiniteSource = do
liftIO $ threadDelay 10000000
yield "infinite source"
infiniteSource
I want to write a simple webserver in haskell which provides the current time. The time should be returned in json format.
Here is what I have so far:
{-# LANGUAGE DeriveDataTypeable #-}
import Happstack.Server
import Text.JSON.Generic
import Data.Time
import System.IO.Unsafe
data TimeStr = TimeStr {time :: String} deriving (Data, Typeable)
main = simpleHTTP nullConf $ ok $ toResponse $ encodeJSON (TimeStr $ show (unsafePerformIO getCurrentTime))
I am aware that unsafePerformIO should be avoided, yet I could not find a better solution yet. Maybe this is where the problem lies? I have a very basic understanding of monads.
The result is the following:
{"time":"2014-10-16 16:11:38.834251 UTC"}
The problem is that when I refresh localhost:8000 the time doesn't change. Is there some sort of memoization going on?
unsafePerformIO :: IO a -> a
This is the "back door" into the IO monad, allowing IO computation to be performed at any time. For this to be safe, the IO computation should be free of side effects and independent of its environment.
getCurrentTime is dependent on its environment, so unsafePerformIO is not the way to go. However, given a MonadIO, we can use liftIO in order to lift the action into the appropriate monad. Lets have a look at the types to find out where we can plug it in:
-- http://hackage.haskell.org/package/happstack-server-7.3.9/docs/Happstack-Server-SimpleHTTP.html
simpleHTTP :: ToMessage a => Conf -> ServerPartT IO a -> IO ()
ServerPartT is an instance of MonadIO, so we could definitely plug it in here. Lets check ok:
ok :: FilterMonad Response m => a -> m a
-- nope: ^^^
So we really need to get the current time before we prepare the response. After all, this makes sense: when you create the response, all heavy work has been done, you know what response code you can use and you don't need to check whether the file or entry in the database exists. After all, you were going to sent an 200 OK, right?
This leaves us with the following solution:
{-# LANGUAGE DeriveDataTypeable #-}
import Happstack.Server
import Text.JSON.Generic
import Data.Time
import System.IO.Unsafe
import Control.Monad.IO.Class (liftIO)
data TimeStr = TimeStr {time :: String} deriving (Data, Typeable)
main = simpleHTTP nullConf $ do
currentTime <- liftIO getCurrentTime
ok $ toResponse $ encodeJSON (TimeStr $ show currentTime)
Lessons learned
Don't use unsafePerformIO.
Don't use unsafePerformIO, unless you're really sure what you're actually doing.
Use liftIO if you want to use an IO action in an instance of MonadIO.
I've written a small server which accepts registrations as POST requests and persists them by appending them to a file. As soon as I put this server under load (I use Apache JMeter with 50 concurrent threads and a repeat count of 10, and the post consists of one field with ~7k of text data), I get lots of "resource busy, file is locked" errors:
02/Nov/2013:18:07:11 +0100 [Error#yesod-core] registrations.txt: openFile: resource busy (file is locked) #(yesod-core-1.2.4.2:Yesod.Core.Class.Yesod ./Yesod/Core/Class/Yesod.hs:485:5)
Here is a stripped-down version of the code:
{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings, TypeFamilies #-}
import Yesod
import Text.Hamlet
import Control.Applicative ((<$>), (<*>))
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, pack, unpack)
import Data.String
import System.IO (withFile, IOMode(..), hPutStrLn)
data Server = Server
data Registration = Registration
{ text :: Text
}
deriving (Show, Read)
mkYesod "Server" [parseRoutes|
/reg RegR POST
|]
instance Yesod Server
instance RenderMessage Server FormMessage where
renderMessage _ _ = defaultFormMessage
postRegR :: Handler Html
postRegR = do
result <- runInputPost $ Registration
<$> ireq textField "text"
liftIO $ saveRegistration result
defaultLayout [whamlet|<p>#{show result}|]
saveRegistration :: Registration -> IO ()
saveRegistration r = withFile "registrations.txt" AppendMode (\h -> hPutStrLn h $ "+" ++ show r)
main :: IO ()
main = warp 8080 Server
I compiled the code on purpose without -threaded, and the OS shows only a single thread running. Nonetheless it looks to me like the requests are not completely serialised, and a new request is already handled before the old one has been written to disk.
Could you tell me how I can avoid the error message and ensure that all requests are handled successfully? Performance is not an issue yet.
It's perfectly OK to write to a Handle from several threads. In fact, Handles have MVars inside them to prevent weird concurrent behaviour. What you probably want is not to handle [sic] MVars by hand (which can lead to deadlock if, for instance, a handler throws an exception) but lift the withFile call outside the individual handler threads. The file stays open all the time - opening it on each request would be slow anyway.
I don't know much about Yesod, but I'd recommend something like this (probably doesn't compile):
data Server = Server { handle :: Handle }
postRegR :: Handler Html
postRegR = do
h <- handle `fmap` getYesod
result <- runInputPost $ Registration
<$> ireq textField "text"
liftIO $ saveRegistration h result
defaultLayout [whamlet|<p>#{show result}|]
saveRegistration :: Handle -> Registration -> IO ()
saveRegistration h r = hPutStrLn h $ "+" ++ show r
main :: IO ()
main = withFile "registrations.txt" AppendMode $ \h -> warp 8080 (Server h)
-- maybe there's a better way?
Aside: if you wanted to file to be written asynchronously you could write to a queue (if it were a log file or something), but in your use case you probably want to let the user know if their registration failed, so I'd recommend staying with this form.
Even without -threaded the Haskell runtime will have several "green threads" running cooperatively. You need to use Control.Concurrent to limit access to the file because you cannot have several threads writing to it at once.
The easiest way is to have an MVar () in your Server and have each request "take" the unit from the MVar before opening the file and then put it back after the file operation has been completed. You can use bracket to ensure that the lock is released even if writing the file fails. E.g. something like
import Control.Concurrent
import Control.Exception (bracket_)
type Lock = MVar ()
data Server = Server { fileLock :: Lock }
saveRegistration :: Registration -> Lock -> IO ()
saveRegistration r lock = bracket_ acquire release updateFile where
acquire = takeMVar lock
release = putMVar lock ()
updateFile =
withFile "registrations.txt" AppendMode (\h -> hPutStrLn h $ "+" ++ show r)
I tried the following approach:
import System.Exit
import System.Posix.Signals
import Control.Concurrent (threadDelay)
main :: IO ()
main = do
installHandler keyboardSignal (Catch (do exitSuccess)) Nothing
threadDelay (1000000000)
But it only outputs:
^CTest.hs: ExitSuccess
on Ctrl-C, instead of exiting. How should I do it properly?
From the docs of installHandler:
a handler is installed which will invoke action in a new thread when (or shortly after) the signal is received.
and exitWith:
Note: in GHC, exitWith should be called from the main program thread in order to exit the process. When called from another thread, exitWith will throw an ExitException as normal, but the exception will not cause the process itself to exit.
So an exitSuccess handler doesn't end the process, and that's expected (although unexpected ;) behaviour.
If you want immediate action,
import System.Exit
import System.Posix.Signals
import Control.Concurrent
main :: IO ()
main = do
tid <- myThreadId
installHandler keyboardSignal (Catch (killThread tid)) Nothing
threadDelay (1000000000)
kills the thread immediately upon receiving the signal.
Less drastic, if you want a successful exit, would be
import System.Exit
import System.Posix.Signals
import Control.Concurrent
import qualified Control.Exception as E
main :: IO ()
main = do
tid <- myThreadId
installHandler keyboardSignal (Catch (E.throwTo tid ExitSuccess)) Nothing
threadDelay (10000000)
I think it will also work reliably, but I'm not entirely sure.