Using the websockets library in the following way
{-# LANGUAGE OverloadedStrings #-}
module Main where
import System.IO
import System.IO.Unsafe
import Network.Socket hiding (recv)
import Network.WebSockets
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as B
import Debug.Trace
import Control.Applicative
fetch :: IO B.ByteString
fetch = do
B.putStrLn "connected"
[v4] <- getAddrInfo Nothing (Just "127.0.0.1") (Just "3000")
c <- socket (addrFamily v4) Stream 0x6
c `connect` (addrAddress v4)
recv c 512000
proxy :: TextProtocol p => WebSockets p ()
proxy = sendTextData . unsafePerformIO $! fetch
app :: Request -> WebSockets Hybi00 ()
app r = acceptRequest r >> r `traceShow` proxy
main :: IO ()
main = withSocketsDo $! runServer "0.0.0.0" 4000 app
causes fetch to occur only once and all websocket clients receive the same not fresh data.
How can I do arbitrary IO with websockets?
How can I get the above example to work with fresh fetches?
I would love to hear any suggestions or complete solutions. A way of doing it without touching iteratee would be exceptionally appreciated.
The WebSockets monad is an instance of the MonadIO typeclass, so you can do arbitrary IO-operations with the liftIO function.
In this case I'm guessing you want to do
proxy = liftIO fetch >>= sendTextData
You also need to add the import
import Control.Monad.IO.Class
Related
I would like for my default handler to be able to catch all of the exceptions that my App throws but in order for this to happen I need to manually call raise after manually adding some exception catching around my IO code.
below is an example minimal server:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Lib
( someFunc
) where
import Web.Scotty.Trans
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.Except
import Data.Text.Lazy as TL
data AppEnv = AppEnv
{ appStuff :: String
}
newtype App a = App
{ unApp :: ReaderT AppEnv IO a
} deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadThrow)
someFunc :: IO ()
someFunc = do
let run a = runReaderT (unApp $ App a) (AppEnv "APPY STUFF")
scottyT 8080 run $ do
defaultHandler $ \(e :: TL.Text) -> do
liftIO $ print "HERE"
liftIO $ print $ showError e
html $ "Something Went Seriously Wrong"
get "/" $ do
(r :: (Either TL.Text String)) <- liftIO $ runExceptT $ do
(uId) <- lift $ readFile "./helloworld.txt"
return $ ("hello")
liftIO $ print r
case r of
Left l -> raise l
Right s -> (html "hello world")
get "/catch-this" $ do
error "Catch Me"
(html "hello world")
notFound $ do
html "That is not a valid route"
I would like to be able to catch all of my uncaught exceptions in my default handler however this is not the default behavior of scotty that only happens if you call raise. I could wrap all of my ActionM code blocks in ExceptT however this seems like a messy/mechanical way of solving this problem. I mostly want to do this for logging purposes so I can report out to Sentry or Log to a file and this would make it much more convenient.
I figured I'd throw this in there as I recently was looking for this same solution again. It's unfortunate but I was never able to get the behavior that I wanted out of scotty.
Fortunately since scotty is just a nice library to create WAI application's you can get a nice work around using the Settings type from warp and the Options type from scotty.
Below is an example of how you can approach this:
{-# LANGUAGE OverloadedStrings #-}
module Lib
( someFunc
) where
import Web.Scotty.Trans
import Data.Text
import qualified Data.Text.Lazy as TL
import Control.Monad.IO.Class
import Control.Exception
import Network.HTTP.Types
import System.IO.Error
import Network.Wai.Handler.Warp
import Network.Wai
myOpts :: Options
myOpts = Options 1 mySettings
mySettings :: Settings
mySettings = setOnExceptionResponse myHandler $ setPort 3002 $ defaultSettings
myHandler :: SomeException -> Response
myHandler se = responseLBS status500 [] "HERE WE ARE"
someFunc :: IO ()
someFunc = do
scottyOptsT myOpts id routes
myExceptions :: (MonadIO m) => TL.Text -> ActionT TL.Text m ()
myExceptions t = do
liftIO $ print t
html "error"
routes :: (MonadIO m) => ScottyT TL.Text m ()
routes = do
defaultHandler $ \str -> do
liftAndCatchIO $ print str
status status500
json ("welp you thought"::Text)
get "/:here" $ do
liftIO $ ioError $ userError "Hahah"
text "here"
You can then tap further into the Settings type provided by warp so that you could maybe log all the error messages or perform some custom action using the following methods setOnException setOnExceptionResponse.
I had a weird problem with ByteString socket programming. I have minimized the issue to the following short scripts:
-- ByteString.hs
{-# LANGUAGE OverloadedStrings #-}
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Network.BSD
import System.IO
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
connectMud :: HostName
-> String
-> IO Handle
connectMud hostname port = do
addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
setSocketOption sock KeepAlive 1
connect sock (addrAddress serveraddr)
h <- socketToHandle sock ReadWriteMode
hSetBuffering h (BlockBuffering Nothing)
return h
main:: IO ()
main =
C8.putStrLn "connecting, please wait" >> connectMud "aardwolf.org" "4000"
>>= BS.hGetContents >>= C8.putStrLn
and
--ByteString_Lazy.hs
{-# LANGUAGE OverloadedStrings #-}
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Network.BSD
import System.IO
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as C8
connectMud :: HostName
-> String
-> IO Handle
connectMud hostname port = do
addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
setSocketOption sock KeepAlive 1
connect sock (addrAddress serveraddr)
h <- socketToHandle sock ReadWriteMode
hSetBuffering h (BlockBuffering Nothing)
return h
main:: IO ()
main =
C8.putStrLn "connecting, please wait" >> connectMud "aardwolf.org" "4000"
>>= BS.hGetContents >>= C8.putStrLn
The only difference between these two short scripts is that one is using Data.ByteString and the other one Data.ByteString.Lazy. The lazy version works fine but the strict version does not seem to receive any output at all. Any thoughts?
I would guess that it has to do with the differing behavior of the two hGetContents functions in question (the lazy version vs the strict version).
The strict version "reads a handle's entire contents strictly into a ByteString." But you're trying to read from a stream, so the EOF is never encountered.
Compare with the behavior of the lazy version:
Read entire handle contents lazily into a ByteString. Chunks are read on demand, using the default chunk size.
Once EOF is encountered, the Handle is closed.
Problem trying to unit test routes. Scotty, Persistent, and Hspec-WAI.
Unlike Yesod or Spock, Scotty doesn't have a nice place to store database handlers. I've got it working by having one massive "do" that starts up the database, keeps the database pool as a local variable, then uses that variable.
app :: IO ()
app = do
-- allocate_database $ \pool
-- scotty 8080 $do
-- handleSomeRoute pool
However, Hspec-WAI wants it in the IO Application form.
scottyApp :: ScottyM () -> IO Application
Is there a sane way to inject the DB connection pool into a scottyApp ?
Here's how you can do it. Basically you open the database before you make the hspec call:
{-# LANGUAGE OverloadedStrings #-}
import Test.Hspec
import Test.Hspec.Wai
import Network.Wai (Application)
import qualified Web.Scotty as S
allocate_db :: (Int -> IO a) -> IO a
allocate_db = undefined
handleSomeRoute :: Int -> S.ScottyM ()
handleSomeRoute = undefined
main2 :: IO ()
main2 = allocate_db $ \pool -> do
let app' = handleSomeRoute pool
hspec $ with (S.scottyApp app') $ do
describe "GET /" $ do
it "responds with 200" $ do
get "/" `shouldRespondWith` 200
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 have a simple WAI application (Warp in this case) that responds to all web requests with "Hi". I also want it to display "Said hi" on the server each time a request is processed. How do I perform IO inside my WAI response handler? Here's my application:
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.HTTP.Types (status200)
import Network.Wai.Handler.Warp (run)
main :: IO ()
main = do
putStrLn "http://localhost:3000/"
run 3000 app
app :: Application
app _ = return hello
hello = responseLBS status200 [("Content-Type", "text/plain")] "Hi"
The type of a WAI application is:
type Application = Request -> Iteratee ByteString IO Response
This means that a WAI application runs in an Iteratee monad transformer over IO, so you'll have to use liftIO to perform regular IO actions.
import Control.Monad.Trans
app _ = do
liftIO $ putStrLn "Said hi"
return hello