labyrinth-server 0.1.3.0 → 0.1.4.0
raw patch · 2 files changed
+72/−37 lines, 2 filesdep ~wai-websocketsdep ~websockets
Dependency ranges changed: wai-websockets, websockets
Files
- labyrinth-server.cabal +5/−5
- src/LabyrinthServer.hs +67/−32
labyrinth-server.cabal view
@@ -1,5 +1,5 @@ name: labyrinth-server-version: 0.1.3.0+version: 0.1.4.0 synopsis: A complicated turn-based game - Web server description: Players take turns in a labyrinth, competing with each other to pick a treasure and carry it out. They only know@@ -41,8 +41,8 @@ , acid-state ==0.12.* , yesod ==1.2.* , yesod-static ==1.2.*- , websockets ==0.7.*- , wai-websockets ==1.3.*+ , websockets ==0.8.*+ , wai-websockets >=1.3.2.0 && < 1.4 , warp ==1.3.* , utf8-string ==0.3.* , unordered-containers ==0.2.*@@ -75,8 +75,8 @@ , acid-state ==0.12.* , yesod ==1.2.* , yesod-static ==1.2.*- , websockets ==0.7.*- , wai-websockets ==1.3.*+ , websockets ==0.8.*+ , wai-websockets >=1.3.2.0 && < 1.4 , warp ==1.3.* , utf8-string ==0.3.* , unordered-containers ==0.2.*
src/LabyrinthServer.hs view
@@ -7,7 +7,7 @@ import Control.Applicative import Control.Concurrent-import Control.Exception (bracket)+import Control.Exception (bracket, fromException, handleJust) import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.IO.Class@@ -24,6 +24,7 @@ import Data.Aeson import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy as BS+import Data.Function import Data.List import qualified Data.Map as M import Data.Maybe@@ -43,7 +44,7 @@ import Text.Julius (juliusFile) import Text.Lucius (luciusFile) -import Yesod hiding (update)+import Yesod hiding (delete, update) import Yesod.Static import Labyrinth hiding (performMove)@@ -71,13 +72,22 @@ data WatchTarget = GameList | GameLog GameId deriving (Eq, Ord) -type WSType = WS.Hybi00+data ConnectionInfo = ConnectionInfo { ciId :: String+ , ciConn :: WS.Connection+ }+instance Eq ConnectionInfo where+ (==) = (==) `on` ciId -type WSSink = WS.Sink WSType+mkConnInfo :: WS.Connection -> IO ConnectionInfo+mkConnInfo conn = do+ id <- newId+ return $ ConnectionInfo id conn +type Watchers = M.Map WatchTarget [ConnectionInfo]+ data LabyrinthServer = LabyrinthServer { lsGames :: AcidState Games , lsStatic :: Static- , lsWatchers :: MVar (M.Map WatchTarget [WSSink])+ , lsWatchers :: MVar Watchers } staticFiles "static"@@ -123,37 +133,41 @@ instance RenderMessage LabyrinthServer FormMessage where renderMessage _ _ = defaultFormMessage -postForm :: (Html -> MForm Handler (FormResult a, Widget))- -> (a -> Handler Value)- -> Handler Value-postForm form handler = do- ((result, _), _) <- runFormPostNoToken form- case result of- FormSuccess value -> handler value- FormFailure errors -> returnCORSJson errors--wsHandler :: LabyrinthServer -> WS.Request -> WS.WebSockets WSType ()+wsHandler :: LabyrinthServer -> WS.PendingConnection -> IO () wsHandler site rq = do- let path = T.unpack $ E.decodeUtf8 $ WS.requestPath rq+ let path = T.unpack $ E.decodeUtf8 $ WS.requestPath $ WS.pendingRequest rq -- TODO: parse path better let watch = if path == "/games" then GameList else GameLog $ drop 6 path- WS.acceptRequest rq- sink <- WS.getSink- addWatcher site watch sink+ conn <- WS.acceptRequest rq+ ci <- mkConnInfo conn+ addWatcher site watch ci+ forever $ handleConnClosed (removeWatcher site watch ci) $ do+ -- Ignore all received messages+ WS.receive conn+ return () -addCORSHeader :: MonadHandler m => m ()-addCORSHeader = addHeader "Access-Control-Allow-Origin" "*"+handleConnClosed :: IO a -> IO a -> IO a+handleConnClosed handler = handleJust whenClosed (const handler)+ where whenClosed e = case fromException e :: Maybe WS.ConnectionException of+ Just ce -> Just ce+ _ -> Nothing -returnCORSJson :: (MonadHandler m, ToJSON a) => a -> m Value-returnCORSJson v = do- addCORSHeader- returnJson v+withWatchers :: LabyrinthServer -> (Watchers -> IO Watchers) -> IO ()+withWatchers site = modifyMVar_ $ lsWatchers site -addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m ()-addWatcher site watch sink =- liftIO $ modifyMVar_ (lsWatchers site) $ \watchers ->- return $ M.insertWith (++) watch [sink] watchers+addWatcher :: LabyrinthServer -> WatchTarget -> ConnectionInfo -> IO ()+addWatcher site watch ci = withWatchers site $ \watchers ->+ return $ M.insertWith (++) watch [ci] watchers +removeWatcher :: LabyrinthServer -> WatchTarget -> ConnectionInfo -> IO ()+removeWatcher site watch ci = withWatchers site $ \watchers ->+ return $ removeWatcher' watch ci watchers++removeWatcher' :: WatchTarget -> ConnectionInfo -> Watchers -> Watchers+removeWatcher' watch ci = M.update (nullMaybe . delete ci) watch+ where nullMaybe [] = Nothing+ nullMaybe x = Just x+ query :: (QueryEvent event, EventState event ~ Games) => event -> Handler (EventResult event)@@ -174,11 +188,15 @@ return res notifyWatchers :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m ()-notifyWatchers site watch = liftIO $ withMVar (lsWatchers site) $ \watchersMap -> do+notifyWatchers site watch = liftIO $ withWatchers site $ \watchersMap -> do let watchers = fromMaybe [] $ M.lookup watch watchersMap value <- watchTargetValue site watch- forM_ watchers $ \sink ->- WS.sendSink sink $ WS.textData $ encode value+ let notifyOne watchersMap ci = handleConnClosed+ (return $ removeWatcher' watch ci watchersMap)+ $ do+ WS.sendTextData (ciConn ci) (encode value)+ return watchersMap+ foldM notifyOne watchersMap watchers watchTargetValue :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m Value watchTargetValue site GameList = do@@ -195,6 +213,23 @@ site <- getYesod result <- watchTargetValue site target returnCORSJson result++postForm :: (Html -> MForm Handler (FormResult a, Widget))+ -> (a -> Handler Value)+ -> Handler Value+postForm form handler = do+ ((result, _), _) <- runFormPostNoToken form+ case result of+ FormSuccess value -> handler value+ FormFailure errors -> returnCORSJson errors++addCORSHeader :: MonadHandler m => m ()+addCORSHeader = addHeader "Access-Control-Allow-Origin" "*"++returnCORSJson :: (MonadHandler m, ToJSON a) => a -> m Value+returnCORSJson v = do+ addCORSHeader+ returnJson v mainLayout :: Widget -> Handler Html mainLayout widget = do