{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.WebSockets.Snap
( runWebSocketsSnap
, runWebSocketsSnapWith
) where
import Control.Concurrent (forkIO, myThreadId, threadDelay)
import Control.Exception (Exception (..),
SomeException (..), handle,
throwTo, finally)
import Data.IORef (IORef, newIORef, readIORef,
writeIORef)
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BSBuilder
import qualified Data.ByteString.Builder.Extra as BSBuilder
import qualified Data.ByteString.Char8 as BC
import Data.Typeable (Typeable, cast)
import qualified Network.WebSockets as WS
import qualified Network.WebSockets.Connection as WS
import qualified Network.WebSockets.Stream as WS
import qualified Snap.Core as Snap
import qualified Snap.Types.Headers as Headers
import qualified System.IO.Streams as Streams
data Chunk
= Chunk ByteString
| Eof
| Error SomeException
deriving (Int -> Chunk -> ShowS
[Chunk] -> ShowS
Chunk -> String
(Int -> Chunk -> ShowS)
-> (Chunk -> String) -> ([Chunk] -> ShowS) -> Show Chunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Chunk] -> ShowS
$cshowList :: [Chunk] -> ShowS
show :: Chunk -> String
$cshow :: Chunk -> String
showsPrec :: Int -> Chunk -> ShowS
$cshowsPrec :: Int -> Chunk -> ShowS
Show)
data ServerAppDone = ServerAppDone
deriving (ServerAppDone -> ServerAppDone -> Bool
(ServerAppDone -> ServerAppDone -> Bool)
-> (ServerAppDone -> ServerAppDone -> Bool) -> Eq ServerAppDone
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerAppDone -> ServerAppDone -> Bool
$c/= :: ServerAppDone -> ServerAppDone -> Bool
== :: ServerAppDone -> ServerAppDone -> Bool
$c== :: ServerAppDone -> ServerAppDone -> Bool
Eq, Eq ServerAppDone
Eq ServerAppDone
-> (ServerAppDone -> ServerAppDone -> Ordering)
-> (ServerAppDone -> ServerAppDone -> Bool)
-> (ServerAppDone -> ServerAppDone -> Bool)
-> (ServerAppDone -> ServerAppDone -> Bool)
-> (ServerAppDone -> ServerAppDone -> Bool)
-> (ServerAppDone -> ServerAppDone -> ServerAppDone)
-> (ServerAppDone -> ServerAppDone -> ServerAppDone)
-> Ord ServerAppDone
ServerAppDone -> ServerAppDone -> Bool
ServerAppDone -> ServerAppDone -> Ordering
ServerAppDone -> ServerAppDone -> ServerAppDone
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ServerAppDone -> ServerAppDone -> ServerAppDone
$cmin :: ServerAppDone -> ServerAppDone -> ServerAppDone
max :: ServerAppDone -> ServerAppDone -> ServerAppDone
$cmax :: ServerAppDone -> ServerAppDone -> ServerAppDone
>= :: ServerAppDone -> ServerAppDone -> Bool
$c>= :: ServerAppDone -> ServerAppDone -> Bool
> :: ServerAppDone -> ServerAppDone -> Bool
$c> :: ServerAppDone -> ServerAppDone -> Bool
<= :: ServerAppDone -> ServerAppDone -> Bool
$c<= :: ServerAppDone -> ServerAppDone -> Bool
< :: ServerAppDone -> ServerAppDone -> Bool
$c< :: ServerAppDone -> ServerAppDone -> Bool
compare :: ServerAppDone -> ServerAppDone -> Ordering
$ccompare :: ServerAppDone -> ServerAppDone -> Ordering
$cp1Ord :: Eq ServerAppDone
Ord, Int -> ServerAppDone -> ShowS
[ServerAppDone] -> ShowS
ServerAppDone -> String
(Int -> ServerAppDone -> ShowS)
-> (ServerAppDone -> String)
-> ([ServerAppDone] -> ShowS)
-> Show ServerAppDone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerAppDone] -> ShowS
$cshowList :: [ServerAppDone] -> ShowS
show :: ServerAppDone -> String
$cshow :: ServerAppDone -> String
showsPrec :: Int -> ServerAppDone -> ShowS
$cshowsPrec :: Int -> ServerAppDone -> ShowS
Show, Typeable)
instance Exception ServerAppDone where
toException :: ServerAppDone -> SomeException
toException ServerAppDone
ServerAppDone = ServerAppDone -> SomeException
forall e. Exception e => e -> SomeException
SomeException ServerAppDone
ServerAppDone
fromException :: SomeException -> Maybe ServerAppDone
fromException (SomeException e
e) = e -> Maybe ServerAppDone
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e
runWebSocketsSnap
:: Snap.MonadSnap m
=> WS.ServerApp
-> m ()
runWebSocketsSnap :: ServerApp -> m ()
runWebSocketsSnap = ConnectionOptions -> ServerApp -> m ()
forall (m :: * -> *).
MonadSnap m =>
ConnectionOptions -> ServerApp -> m ()
runWebSocketsSnapWith ConnectionOptions
WS.defaultConnectionOptions
runWebSocketsSnapWith
:: Snap.MonadSnap m
=> WS.ConnectionOptions
-> WS.ServerApp
-> m ()
runWebSocketsSnapWith :: ConnectionOptions -> ServerApp -> m ()
runWebSocketsSnapWith ConnectionOptions
options ServerApp
app = do
Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
Snap.getRequest
EscapeHttpHandler -> m ()
forall (m :: * -> *). MonadSnap m => EscapeHttpHandler -> m ()
Snap.escapeHttp (EscapeHttpHandler -> m ()) -> EscapeHttpHandler -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int -> Int) -> IO ()
tickle InputStream ByteString
readEnd OutputStream Builder
writeEnd -> do
ThreadId
thisThread <- IO ThreadId
myThreadId
Stream
stream <- IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
WS.makeStream (InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
readEnd)
(\Maybe ByteString
v -> do
Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write ((ByteString -> Builder) -> Maybe ByteString -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Builder
BSBuilder.lazyByteString Maybe ByteString
v) OutputStream Builder
writeEnd
Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
BSBuilder.flush) OutputStream Builder
writeEnd
)
IORef Bool
done <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
let options' :: ConnectionOptions
options' = ConnectionOptions
options
{ connectionOnPong :: IO ()
WS.connectionOnPong = do
(Int -> Int) -> IO ()
tickle (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
45)
ConnectionOptions -> IO ()
WS.connectionOnPong ConnectionOptions
options
}
pc :: PendingConnection
pc = PendingConnection :: ConnectionOptions
-> RequestHead
-> (Connection -> IO ())
-> Stream
-> PendingConnection
WS.PendingConnection
{ pendingOptions :: ConnectionOptions
WS.pendingOptions = ConnectionOptions
options'
, pendingRequest :: RequestHead
WS.pendingRequest = Request -> RequestHead
fromSnapRequest Request
rq
, pendingOnAccept :: Connection -> IO ()
WS.pendingOnAccept = ((Int -> Int) -> IO ()) -> IORef Bool -> Connection -> IO ()
forkPingThread (Int -> Int) -> IO ()
tickle IORef Bool
done
, pendingStream :: Stream
WS.pendingStream = Stream
stream
}
(ServerApp
app PendingConnection
pc IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> ServerAppDone -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
thisThread ServerAppDone
ServerAppDone) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
done Bool
True
forkPingThread :: ((Int -> Int) -> IO ()) -> IORef Bool -> WS.Connection -> IO ()
forkPingThread :: ((Int -> Int) -> IO ()) -> IORef Bool -> Connection -> IO ()
forkPingThread (Int -> Int) -> IO ()
tickle IORef Bool
done Connection
conn = do
ThreadId
_ <- IO () -> IO ThreadId
forkIO IO ()
pingThread
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
pingThread :: IO ()
pingThread = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
let loop :: IO ()
loop = do
Bool
d <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
done
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
d (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendPing Connection
conn (String -> ByteString
BC.pack String
"ping")
(Int -> Int) -> IO ()
tickle (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
60)
Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
IO ()
loop in
IO ()
loop
ignore :: SomeException -> IO ()
ignore :: SomeException -> IO ()
ignore SomeException
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fromSnapRequest :: Snap.Request -> WS.RequestHead
fromSnapRequest :: Request -> RequestHead
fromSnapRequest Request
rq = RequestHead :: ByteString -> Headers -> Bool -> RequestHead
WS.RequestHead
{ requestPath :: ByteString
WS.requestPath = Request -> ByteString
Snap.rqURI Request
rq
, requestHeaders :: Headers
WS.requestHeaders = Headers -> Headers
Headers.toList (Request -> Headers
Snap.rqHeaders Request
rq)
, requestSecure :: Bool
WS.requestSecure = Request -> Bool
Snap.rqIsSecure Request
rq
}