socketson-0.1.0.0: src/Network/Socketson/Protocol.hs
{-# LANGUAGE OverloadedStrings #-}
module Network.Socketson.Protocol where
-- data:
import Data.Aeson (FromJSON, ToJSON,
eitherDecode, encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.Serialize (Serialize (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
-- either transformer stuff:
import Control.Error.Util (note)
import Control.Monad.Error.Class
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Either
import Data.Either.Combinators
-- websockets:
import qualified Network.WebSockets as WS
-- types:
import qualified Network.HTTP.Types.URI as HT
-- concurrent:
import Control.Concurrent.MVar.Lifted
-- exception:
import Control.Exception (catch, finally, throw)
-- monad:
import Control.Monad
-- intern:
import Network.Socketson.Internal.Utils
import Network.Socketson.ProtocolException
import Network.Socketson.Report
import Network.Socketson.ServerState
import Network.Socketson.SessionStore
-- random:
import Crypto.Random
import Crypto.Random.DRBG
-- | Possible reactions to an incoming data object and current session data.
data Reaction a =
Send a
| Close
| None
socketsonapp :: (ToJSON sobj, FromJSON rcv, Serialize sessd)
=> MVar ServerState
-- ^ global server state as an mvar.
-> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))
-- ^ protocl function.
-> WS.ServerApp
socketsonapp mstate pf pcon =
eitherT (\e -> return ())
(\_ -> return ())
(do { n <- _appT mstate pf pcon; report n (Info Low "Exit app thread.") } `catchError` (report "global" . Error) )
where
_appT mstate pf pcon =
do
-------------
-- Handshake:
(nick, skey, mData, con) <- modifyMVarT mstate $
\state -> do (_nick, _skey, _mData, _mGen, _con) <- handshake state pcon
return (_updateState state _mGen, (_nick, _skey, _mData, _con))
report nick (Info Middle "Accepted connection.")
----------------
-- protocol loop: (WebSockets signals the close request via exceptions; so we handle exceptions already inline.)
liftIO $ _loop mstate nick con skey mData pf
report nick (Info Middle "Loop escaped, client disconnected.")
-------------
return nick
{- The protocol loop exits if an exception happens. We invoke it again, if the exception just needs to get reported. If the exception was a close request (or any which implicates a disconnect), we disconnect the connection and change state. -}
_loop mstate nick con skey mData pf =
eitherT
(\e -> case e of
ConnectionException WS.ConnectionClosed -> _disconnect mstate con nick False -- close internally
ConnectionException (WS.CloseRequest _ _) -> _disconnect mstate con nick True -- send close
e -> do { runEitherT $ report nick (Error e); _loop mstate nick con skey mData pf } )-- error reported. Continue loop.
(\_ -> _disconnect mstate con nick True)
(protocolLoop mstate nick con skey mData pf)
_disconnect mstate con nick friendly =
do runEitherT (report nick (Info Low "Closing connection ... "))
when friendly $ WS.sendClose con ("Close connection to socketson." :: BS.ByteString)
modifyMVar_ mstate $ \state -> return $ decClients state
_updateState :: ServerState -> Maybe CtrDRBG -> ServerState
_updateState state mg =
case mg of
Just g -> incClients state { randomGen = g }
Nothing -> incClients state
{-| Every communication starts with one of two possible handshakes:
1. open a new session,
2. restore an existing session.
A handshake produces (or retrieves)
- identifier of client,
- session key,
- maybe session data,
- maybe a iterated random generator and
- a connection handle.
A handshake may fail on:
1. No capacity, too many clients are connected already.
2. No session exists for given session key.
3. Failure while generating a new session key.
4. Invalid request path.
-}
handshake :: (Serialize a) => ServerState
-> WS.PendingConnection
-> EitherT ProtocolException IO (T.Text, BS.ByteString, Maybe a, Maybe CtrDRBG, WS.Connection)
handshake state pcon =
do hoistEither $ checkCapacity state
case HT.decodePath (WS.requestPath (WS.pendingRequest pcon)) of
-- open request:
(["open"], [("id", Just ident')]) ->
let ident = T.decodeUtf8 ident' in
do (skey, g) <- hoistEither (genSessionKey state)
con <- establish pcon skey
return (ident, skey, Nothing, Just g, con)
-- restore request:
("restore" : [skey'], [("id", Just ident')]) ->
let skey = T.encodeUtf8 skey'
ident = T.decodeUtf8 ident' in
do sessD <- restoreSessionData state skey
con <- establish pcon skey
return (ident, skey, Just sessD, Nothing, con)
-- invalid request:
_ -> left InvalidRequestPath
where
checkCapacity :: ServerState -> Either ProtocolException ()
checkCapacity state =
unless (existsCapacity state) $ Left TooManyClientsConnected
genSessionKey :: ServerState -> Either ProtocolException (BS.ByteString, CtrDRBG)
genSessionKey state =
mapLeft (CannotGenerateRandomNumber . show) (genBytes 1024 $ randomGen state)
establish :: WS.PendingConnection -> BS.ByteString -> EitherT ProtocolException IO WS.Connection
establish pcon skey =
let skey' = B64.encode skey
in do con <- liftIO $ WS.acceptRequest pcon
liftIO $ WS.forkPingThread con 30
liftIO $ WS.sendBinaryData con skey'
return con
{-| After a successful handshake, the communication goes into the 'protocolLoop'. It stays in the loop until an exception happens. Since an exception might be just a signal (WebSockets throws exceptions if the client wants to close the connection), we handle some of them already in 'socketsonapp'.
For more information on what the protocol loop does, look at the `README.md`.
-}
protocolLoop :: (ToJSON sobj, FromJSON rcv, Serialize sessd)
=> MVar ServerState
-> T.Text
-> WS.Connection
-> BS.ByteString
-> Maybe sessd
-> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))
-> EitherT ProtocolException IO ()
protocolLoop mstate nick con skey sessionData pf =
do report nick (Info Low "Waiting for incoming object ...")
rcvObj <- recvObject con
report nick (Info Low "Received object.")
-- ^ receive JSON string and decode it into object.
(sessd, react) <- mapLeftT UserException $ pf sessionData rcvObj
-- ^ apply the protocol function and return new session data and reaction.
case sessd of
Just sdata' -> liftIO (withMVar mstate $ \state -> saveSessionData state skey sdata')
_ -> return ()
-- ^ save the new session data.
case react of -- decide on reaction:
None -> protocolLoop mstate nick con skey sessd pf
Send encObj -> do { sndObject con encObj; protocolLoop mstate nick con skey sessd pf }
Close -> return ()
where
recvObject :: (FromJSON rcv) => WS.Connection -> EitherT ProtocolException IO rcv
recvObject con =
do recv <- tryTWS $ WS.receiveData con
hoistEither $ mapLeft CannotParseRecvObject (eitherDecode recv)
sndObject :: (ToJSON sobj) => WS.Connection -> sobj -> EitherT ProtocolException IO ()
sndObject con msg = let emsg = encode msg
tmsg = LT.toStrict $ LT.decodeUtf8 emsg
in tryTWS $ WS.sendBinaryData con emsg