CrapJsonWebsocketServer.hs

-- don't do it like this, especially the json!

import Network.WebSockets (shakeHands, getFrame, putFrame)
import Network (listenOn, PortID(PortNumber), accept, withSocketsDo)
import System.IO (Handle, hClose)
import qualified Data.ByteString as B (append, null)
import Data.ByteString.UTF8 (fromString) -- this is from utf8-string
import Control.Monad (forever)
import Control.Concurrent (forkIO, threadDelay)
import Data.List (intercalate)
import System.Random

-- Accepts clients, spawns a single handler for each one.
main :: IO ()
main = withSocketsDo $ do
 socket <- listenOn (PortNumber 12345)
 putStrLn "Listening on port 12345."
 forever $ do
   (h, _, _) <- accept socket
   forkIO (talkTo h)

-- Shakes hands with client. If no error, starts talking.
talkTo :: Handle -> IO ()
talkTo h = do
 request <- shakeHands h
 case request of
   Left err -> print err
   Right  _ -> do
     putFrame h (fromString "{\"welcome\":\"hello from my websocket server\"}")
     putStrLn $ "Shook hands with "++show h ++" sent welcome message."
     talkLoop h

-- -----------------------------------------------------------
-- handler
-- -----------------------------------------------------------

-- Talks to client without listening.  Just sends continually.
spraff :: Handle -> IO ()
spraff h = do
  ds <- makeDatapoints
  putFrame h $ fromString $ datapointsToJSONString ds
  threadDelay $ 3 * 1000000 -- don't do this
  putStrLn $ "sent json to "++show h
  spraff h

-- Talks to the client (by echoing messages back) until EOF.
talkLoop :: Handle -> IO ()
talkLoop h = do
 msg <- getFrame h
 if B.null msg
    then do
      putStrLn "EOF encountered. Closing handle."
      hClose h
    else do
      ds <- makeDatapoints
      putStrLn $ "got message " ++ show msg
      putFrame h $ fromString $ datapointsToJSONString ds
      threadDelay $ 3 * 1000000 -- don't do this
      talkLoop h

-- -----------------------------------------------------------
-- json stuff 
-- -----------------------------------------------------------

-- timestamp then value
type DataPoint = (Integer, Int)

-- hardcoded json sample
sampleJSON :: String
sampleJSON = "{\"timedata\":[[21963682872000,3640],[21963682872000,2185],[21963682904000,2165],[21963682969000,5731]]}"

makeDatapoints :: IO [DataPoint]
makeDatapoints = mapM makeD [1..20]
  where 
    makeD :: Int -> IO DataPoint
    makeD i = do r <- randomRIO (0,20)
                 return $ (fromIntegral i, r::Int)

datapointsToJSONString :: [DataPoint] -> String
datapointsToJSONString ds = header ++ body ++ footer
  where
    header = "{\"timedata\":["
    footer = "]}"
    body = intercalate "," $ map (\(i,v) -> "[" ++ show i++ "," ++ show v ++"]") ds