I am attempting to create a server that returns two different values from a route depending if a user has visited it before. I have the following code:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Web.Scotty
main = do
putStrLn "Starting Server..."
scotty 3000 $ do
get "/" $ do
-- if first time
text "hello!"
-- if second time
text "hello, again!"
I have two questions:
1. How can I check if a user has requested the route before?
2. Where and how can I persist application state?
You can use STM to keep a mutable variable in memory:
import Control.Concurrent.STM.TVar
main = do
putStrLn "Starting Server..."
state <- newTVarIO :: IO VisitorsData
scotty 3000 $ do
get "/" $ do
visitorsData <- readTVarIO state
-- if the visitor's ID/cookie is in visitorsData
text "hello!"
-- if new visitor, add them to visitorsData
atomically $ modifyTVar state $ insertVisitor visitorId visitorsData
-- if second time
text "hello, again!"
(If you expect to scale this to a complex server, you'll want to pass the TVar around in the form of a ReaderT pattern)
Related
Can I modify my state using IO via the Scotty API? Currently, I have a state transformer inside IO monad to modify state with user input. But I want to achieve this via the Scotty API.
This is my state transformer types I currently have that I use to keep modifying the state type and allow for IO actions.
-- State Transformer type inside IO monad
type STIO st a = STM st IO a
-- State transformer inside a monad
newtype STM st m a = S (st -> m (a, st))
... and with this lift functions to lift an action into the IO monad:
lift :: Monad m => m a -> STM st m a
lift mx = S (\s -> do
x <- mx
return (x, s))
This is my current bare bones Scotty server:
port = 8080
main = server
server :: IO ()
server = do
print ("Starting Server at port " ++ show port)
scotty port $ do
get "/start" $ do
json ("{starting: "++"True"++"}")
In my head I am wanting something along these lines, but unsure how to implement it:
type State = Int
server :: STIO State ()
server = do
print ("Starting Server at port " ++ show port)
lift $ scotty port $ do
get "/start" $ do
updateCounterByOneInState
counter <- getCounterFromState
json $ "{count: " ++ counter ++ "}"
Is something like this even possible, or am I just getting confused?
Scotty, like all WAI applications, needs to be prepared to handle multiple concurrent requests in separate threads. This poses a bit of a problem for your STIO monad, since it doesn't directly support concurrent access to the state. You'd need to arrange to load the state, run the handlers, and save the state in a way that's concurrency-safe.
Technically, you can do this with help from the functions in Web.Scotty.Trans, but it's not a very good idea. For example, the following self-contained example stores the state in a concurrency-safe MVar:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
import Web.Scotty.Trans as W
import Control.Monad.State as S
import Control.Concurrent.MVar
import Network.Wai.Handler.Warp (Port)
import Data.Text.Lazy (Text)
type STIO s = StateT s IO
scottySTIO :: MVar s -> Port -> ScottyT Text (STIO s) () -> (STIO s) ()
scottySTIO sref p = scottyT p $ \act -> do
s <- takeMVar sref
(r, !s') <- runStateT act s
putMVar sref s'
return r
server :: STIO Int ()
server = do
let port = 8080
liftIO $ print ("Starting Server at port " ++ show port)
s <- S.get
sref <- liftIO $ newMVar s
scottySTIO sref port $ do
W.get "/start" $ do
modify (+1)
counter <- S.get
json $ "{count: " ++ show counter ++ "}"
main :: IO ()
main = evalStateT server 0
This will "work", but it will exhibit horrible concurrency performance because it ends up serializing all requests in their entirety, instead of just protecting critical code sections. It really only makes sense if you already have a huge amount of code running in the STIO monad, you don't want to modify any of it, and you're willing to take the performance hit.
Most of the time, it will be much easier to refactor your design to store the state in a concurrency-safe manner and access it directly from IO. For example, the counter can be stored in a single MVar and safely accessed in a short critical section:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
import Web.Scotty
import Control.Concurrent.MVar
import Control.Monad.IO.Class
main :: IO ()
main = do
let port = 8080
print ("Starting Server at port " ++ show port)
sref <- newMVar (0 :: Int)
scotty port $ do
get "/start" $ do
-- start of critical section
counter <- liftIO $ takeMVar sref
let !counter' = counter + 1
liftIO $ putMVar sref counter'
-- end of critical section
json $ "{count: " ++ show counter' ++ "}"
Is there a standard way to start two scotty servers in the same application? In a toy project I'm trying:
main :: IO ()
main = do
scotty 3000 $ do
get "/" $ do
text "hello"
scotty 4000 $ do
post "/" $ do
text "world"
The first server spins up but the second one does not. It could also be a flaw in the way I'm understanding Haskell IO. Thanks!
The scotty procedure does not return, it takes over control and continually serves requests to the webroutes. If it did return then you'd have an issue with control flow - how would you keep the port open for when a request arrived?
One solution is to put each call to scotty in a separate thread. For example:
#!/usr/bin/env cabal
{- cabal:
build-depends: base, scotty
-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Web.Scotty
main :: IO ()
main = do
forkIO $ scotty 3000 $ do
get "/" $ do
text "hello"
scotty 4000 $ do
post "/" $ do
text "world"
With operation of:
% curl -XPOST localhost:4000
world%
% curl -XGET localhost:3000
hello%
I would use async:
import Control.Concurrent.Async
main :: IO ()
main = do
a1 <- async $ scotty 3000 $ do
get "/" $ do
text "hello"
a2 <- async $ scotty 4000 $ do
post "/" $ do
text "world"
waitAnyCatchCancel [a1, a2]
I have the following Scotty app which tries to use STM to keep a count of API calls served:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Web.Scotty
import Data.Monoid (mconcat)
import Control.Concurrent.STM
import Control.Monad.IO.Class
main :: IO ()
main = do
counter <- newTVarIO 0
scotty 3000 $
get "/:word" $ do
liftIO $ atomically $ do
counter' <- readTVar counter
writeTVar counter (counter' + 1)
liftIO $ do
counter' <- atomically (readTVar counter)
print counter'
beam <- param "word"
html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
I "load test" the API like this:
ab -c 100 -n 100000 http://127.0.0.1:3000/z
However, the API serves roughly about 16 thousand requests and then gets "stuck" - ab stops with error apr_socket_recv: Operation timed out (60).
I think I'm misusing STM, but not sure what I'm doing wrong. Any suggestions?
Quick guess here. 16,000 is about the number of available TCP ports. Is is possible you have not closed any connections and therefore run out of open ports for ab?
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'm writing a simple script to run bunch of tasks in parallel using the Shelly library but I want to limit the max number of tasks running at any one time. The script takes a file with an input on each line and runs a task for that input. There are a few hundred inputs in the file and I want to limit to around 16 processes at a time.
The current script actually limits to 1 (well tries to) using a QSem with an initial count of 1. I seem to be missing something though because when I run on a test file with 4 inputs I see this:
Starting
Starting
Starting
Starting
Done
Done
Done
Done
So the threads are not blocking on the QSem as I would expect, they're all running simultaneously. I've even gone so far as to implement my own semaphores both on MVar and TVar and neither worked the way I expected. I'm obviously missing something fundamental but what? I've also tried compiling the code and running it as a binary.
#!/usr/bin/env runhaskell
{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable, OverloadedStrings #-}
import Shelly
import Prelude hiding (FilePath)
import Text.Shakespeare.Text (lt)
import qualified Data.Text.Lazy as LT
import Control.Monad (forM)
import System.Environment (getArgs)
import qualified Control.Concurrent.QSem as QSem
import Control.Concurrent (forkIO, MVar, putMVar, newEmptyMVar, takeMVar)
-- Define max number of simultaneous processes
maxProcesses :: IO QSem.QSem
maxProcesses = QSem.newQSem 1
bkGrnd :: ShIO a -> ShIO (MVar a)
bkGrnd proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
sem <- maxProcesses
QSem.waitQSem sem
putStrLn "Starting"
-- Run the shell command
result <- shelly $ silently proc
liftIO $ putMVar mvar result
putStrLn "Done"
-- Signal that this process is done and another can run.
QSem.signalQSem sem
return mvar
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
As I said in my comment, each call to bkGrnd creates its own semaphonre, allowing every thread to continue without waiting. I would try something like this instead, where the semaphore is created in the main and passed each time to bkGrnd.
bkGrnd :: QSem.QSem -> ShIO a -> ShIO (MVar a)
bkGrnd sem proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
QSem.waitQSem sem
--
-- code continues as before
--
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
sem <- maxProcesses
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd sem $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
You have an answer, but I need to add: QSem and QSemN are not thread safe if killThread or asynchronous thread death is possible.
My bug report and patch are GHC trac ticket #3160. The fixed code is available as a new library called SafeSemaphore with module Control.Concurrent.MSem, MSemN, MSampleVar, and a bonus FairRWLock.
Isn't it better
bkGrnd sem proc = do
QSem.waitQSem sem
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
...
so not even forkIO until you get the semaphore?