{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module LabyrinthServer where
import Control.Applicative
import Control.Concurrent
import Control.Exception (bracket)
import Control.Lens hiding ((.=))
import Control.Monad
import Control.Monad.IO.Class
import Data.Acid ( AcidState
, EventResult
, EventState
, openLocalStateFrom
, QueryEvent
, UpdateEvent
)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local (createCheckpointAndClose)
import Data.Aeson
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString.Lazy as BS
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.String as S
import Network.Wai.Handler.Warp
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import System.Environment
import System.FilePath.Posix
import System.Random
import Text.Hamlet (hamletFile)
import Text.Julius (juliusFile)
import Text.Lucius (luciusFile)
import Yesod hiding (update)
import Yesod.Static
import Labyrinth hiding (performMove)
import LabyrinthServer.Data
import LabyrinthServer.JSON
newId :: (MonadIO m) => m String
newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z')
envVar :: String -> IO (Maybe String)
envVar var = do
env <- liftM M.fromList getEnvironment
return $ M.lookup var env
envVarWithDefault :: String -> String -> IO String
envVarWithDefault def var =
liftM (fromMaybe def) (envVar var)
getDataPath :: IO String
getDataPath = do
dataDir <- envVarWithDefault "." "OPENSHIFT_DATA_DIR"
return $ dataDir </> "state"
data WatchTarget = GameList | GameLog GameId
deriving (Eq, Ord)
type WSType = WS.Hybi00
type WSSink = WS.Sink WSType
data LabyrinthServer = LabyrinthServer { lsGames :: AcidState Games
, lsStatic :: Static
, lsWatchers :: MVar (M.Map WatchTarget [WSSink])
}
staticFiles "static"
mkYesod "LabyrinthServer" [parseRoutes|
/ HomeR GET
/games GamesR GET
/game NewGameR POST
/game/#GameId GameR GET
/game/#GameId/move MakeMoveR POST
/game/#GameId/delete DeleteGameR DELETE
/examples ExampleMovesR GET
/static StaticR Static lsStatic
|]
instance Yesod LabyrinthServer where
defaultLayout = mainLayout
makeServer :: FilePath -> (LabyrinthServer -> IO a) -> IO a
makeServer dataPath cont = do
static <- static "static"
bracket
(openLocalStateFrom dataPath noGames)
createCheckpointAndClose $
\acid -> do
watchers <- newMVar M.empty
cont $ LabyrinthServer acid static watchers
labyrinthMain :: IO ()
labyrinthMain = do
dataPath <- getDataPath
makeServer dataPath $ \server -> do
port <- liftM read $ envVarWithDefault "8080" "PORT"
ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP"
app <- toWaiApp server
let intercept = WaiWS.intercept $ wsHandler server
let settings = defaultSettings { settingsPort = port
, settingsHost = Host ip
, settingsIntercept = intercept
}
runSettings settings app
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 site rq = do
let path = T.unpack $ E.decodeUtf8 $ WS.requestPath 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
addCORSHeader :: MonadHandler m => m ()
addCORSHeader = addHeader "Access-Control-Allow-Origin" "*"
returnCORSJson :: (MonadHandler m, ToJSON a) => a -> m Value
returnCORSJson v = do
addCORSHeader
returnJson v
addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m ()
addWatcher site watch sink =
liftIO $ modifyMVar_ (lsWatchers site) $ \watchers ->
return $ M.insertWith (++) watch [sink] watchers
query :: (QueryEvent event, EventState event ~ Games)
=> event
-> Handler (EventResult event)
query ev = do
site <- getYesod
let acid = lsGames site
query' acid ev
update :: (UpdateEvent event, EventState event ~ Games)
=> WatchTarget
-> event
-> Handler (EventResult event)
update watch ev = do
site <- getYesod
let acid = lsGames site
res <- update' acid ev
notifyWatchers site watch
return res
notifyWatchers :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m ()
notifyWatchers site watch = liftIO $ withMVar (lsWatchers site) $ \watchersMap -> do
let watchers = fromMaybe [] $ M.lookup watch watchersMap
value <- watchTargetValue site watch
forM_ watchers $ \sink ->
WS.sendSink sink $ WS.textData $ encode value
watchTargetValue :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m Value
watchTargetValue site GameList = do
let acid = lsGames site
result <- query' acid GetGames
return $ toJSON result
watchTargetValue site (GameLog gameId) = do
let acid = lsGames site
result <- query' acid $ GetGame gameId
return $ toJSON result
immediateResponse :: WatchTarget -> Handler Value
immediateResponse target = do
site <- getYesod
result <- watchTargetValue site target
returnCORSJson result
mainLayout :: Widget -> Handler Html
mainLayout widget = do
p <- widgetToPageContent widget
giveUrlRenderer $(hamletFile "templates/layout.hamlet")
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/jquery/2.0.3/jquery.min.js"
addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/handlebars.js/1.0.0/handlebars.min.js"
toWidget $(juliusFile "templates/index.julius")
toWidget $(luciusFile "templates/index.lucius")
$(whamletFile "templates/index.hamlet")
getGamesR :: Handler Value
getGamesR = immediateResponse GameList
named :: T.Text -> FieldSettings LabyrinthServer
named name = FieldSettings "" Nothing Nothing (Just name) []
newGameForm :: Html
-> MForm Handler (FormResult LabyrinthParams, Widget)
newGameForm = renderDivs $ LabyrinthParams
<$> (LabyrinthFeatures <$> areq checkBoxField (named "pits") (Just True)
<*> areq checkBoxField (named "rivers") (Just True))
<*> areq intField (named "width") Nothing
<*> areq intField (named "height") Nothing
<*> areq intField (named "players") Nothing
postNewGameR :: Handler Value
postNewGameR = postForm newGameForm $ \params -> do
lab <- createLabyrinth params
gameId <- newId
res <- update GameList $ AddGame gameId lab
returnCORSJson (if res then "ok" else "bad game" :: String)
getGameR :: GameId -> Handler Value
getGameR gameId = immediateResponse (GameLog gameId)
data PlayerMove = PlayerMove { pmplayer :: PlayerId
, pmmove :: T.Text
}
makeMoveForm :: Html
-> MForm Handler (FormResult PlayerMove, Widget)
makeMoveForm = renderDivs $ PlayerMove
<$> areq intField (named "player") Nothing
<*> areq textField (named "move") Nothing
parseMove' :: T.Text -> Either String Move
parseMove' str = case eitherDecode (BS.fromStrict $ E.encodeUtf8 str) of
Left err -> parseMove (T.unpack str)
Right m -> Right m
postMakeMoveR :: GameId -> Handler Value
postMakeMoveR gameId = postForm makeMoveForm $ \playerMove -> do
let PlayerMove playerId moveStr = playerMove
case parseMove' moveStr of
Left err -> returnCORSJson $ object ["error" .= err]
Right move -> do
res <- update (GameLog gameId) $ PerformMove gameId playerId move
returnCORSJson res
deleteDeleteGameR :: GameId -> Handler Value
deleteDeleteGameR gameId = do
update GameList $ RemoveGame gameId
returnCORSJson ("ok" :: String)
getExampleMovesR :: Handler Value
getExampleMovesR = returnCORSJson $ Sensitive True exampleMoves