Type restrictions for the Haskell Websockets library

websockets-type-tagging-draft.hs

{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans (liftIO)
import System.Random (randomRIO)

--------------------------------------------------------------------------------

data Message = Text String | Binary String

class Protocol p where
    version         :: p -> String
    sendMessage     :: p -> Message -> IO ()
    implementations :: [p]

type WebSockets p a = ReaderT p IO a

getVersion :: Protocol p => WebSockets p String
getVersion = version `fmap` ask

--------------------------------------------------------------------------------

data Hybi00_ = Hybi00_ deriving (Show)

instance Protocol Hybi00_ where
    version _ = "Hybi00"
    sendMessage _ (Text str) = putStrLn $ "[Hybi00] " ++ str
    sendMessage _ (Binary _) = error "Hybi00 cannot send binary!"
    implementations = [Hybi00_]

data Hybi00 = forall p. Protocol p => Hybi00 p

instance Protocol Hybi00 where
    version     (Hybi00 p) = version p
    sendMessage (Hybi00 p) = sendMessage p
    implementations        = [Hybi00 Hybi10_, Hybi00 Hybi00_]

--------------------------------------------------------------------------------

data Hybi10_ = Hybi10_ deriving (Show)

instance Protocol Hybi10_ where
    version _ = "Hybi10"
    sendMessage _ (Text str)   = putStrLn $ "[Hybi10, Text] "   ++ str
    sendMessage _ (Binary str) = putStrLn $ "[Hybi10, Binary] " ++ str
    implementations = [Hybi10_]

data Hybi10 = forall p. Protocol p => Hybi10 p

instance Protocol Hybi10 where
    version     (Hybi10 p) = version p
    sendMessage (Hybi10 p) = sendMessage p
    implementations        = [Hybi10 Hybi10_]

--------------------------------------------------------------------------------

class Protocol p => TextProtocol p
instance TextProtocol Hybi00
instance TextProtocol Hybi10

class Protocol p => BinaryProtocol p
instance BinaryProtocol Hybi10

sendText :: TextProtocol p => String -> WebSockets p ()
sendText text = ask >>= liftIO . flip sendMessage (Text text)

sendBinary :: BinaryProtocol p => String -> WebSockets p ()
sendBinary binary = ask >>= liftIO . flip sendMessage (Binary binary)

runWebSockets :: Protocol p => WebSockets p () -> IO ()
runWebSockets ws = do
    -- Choose an implementation. In more realistic situations, the client and
    -- server will negotiate about this.
    let impls = implementations
    r <- randomRIO (0, length impls - 1)
    let implementation = impls !! r

    -- Run using the selected implementation
    runReaderT ws implementation

--------------------------------------------------------------------------------

-- | A very simple program
program00 :: TextProtocol p => WebSockets p ()
program00 = sendText "Hello, world!"

-- | A more complex program (we require features from a later spec)
program10 :: (TextProtocol p, BinaryProtocol p) => WebSockets p ()
program10 = do
    sendText   "Hello, world!"
    sendBinary "Hello, world!"