elo db api

teamsplit.hs

{- stack runghc
     --package servant-server
     --package servant-js
     --package servant
     --package text
     --package mtl
     --package lens
     --package esqueleto
     --package persistent
     --package persistent-template
     --package persistent-sqlite
     --package containers
     --resolver lts-8.5
     --install-ghc -}

-- elo db api by mmike
--
-- generates a javascript API given a specific url prefix 
-- (maybe useful for putting it behind e.g. nginx) and starts 
-- the associated server for it
--
-- quick & dirty invocation:
-- $ stack teamsplit.hs url_prefix > api.js
-- $ stack teamsplit.hs http://localhost > api.js
-- 
-- though compiling it is will let it run much faster:
-- $ stack ghc -- teamsplit.hs -O2 -threaded
-- $ ./teamsplit http://localhost > api.js

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

import           Control.Monad.IO.Class       (liftIO)
import           Control.Monad.Logger
import           Control.Monad.Trans.Resource
import qualified Data.Aeson                   as JSON
import           Data.List                    (foldl')
import           Data.Map.Strict              (Map)
import qualified Data.Map.Strict              as Map
import           Data.Proxy
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import qualified Data.Text.IO                 as T
import           Data.Word
import           Database.Esqueleto
import           Database.Persist.Sqlite      (ConnectionPool, createSqlitePool,
                                               runMigration, runSqlPersistMPool,
                                               runSqlPool)
import           Database.Persist.TH          (mkMigrate, mkPersist,
                                               persistLowerCase, share,
                                               sqlSettings)
import           GHC.Generics                 (Generic)
import qualified Network.Wai.Handler.Warp     as Warp (run)

import           Servant
import           Servant.JS
import           System.Environment

type Player = Text
type Table = Text
type MapType = Text

data RatingsTable = RatingsTable
  { name  :: !Table
  , table :: Map Player (Map MapType Word)
  } deriving (Eq, Show, Generic)

instance JSON.ToJSON RatingsTable

--------------------------------------------------------------------------------
-- db model

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Rating json
  table Table
  player Player
  map MapType
  elo Word
  UniqueRating table player map
  |]

type SqliteM = SqlPersistT (NoLoggingT (ResourceT IO))

getTables :: SqliteM [Table]
getTables = map unValue <$>
  (select . distinct . from $ \rating -> return (rating ^. RatingTable))

getPlayers :: SqliteM [Player]
getPlayers = map unValue <$>
  (select . distinct . from $ \rating -> return (rating ^. RatingPlayer))

getMapTypes :: SqliteM [MapType]
getMapTypes = map unValue <$>
  (select . distinct . from $ \rating -> return (rating ^. RatingMap))

getTable :: Table -> SqliteM RatingsTable
getTable table = RatingsTable table
  . foldl' (\acc (Entity _ Rating {..}) ->
              Map.insertWith
              Map.union
              ratingPlayer
              (Map.singleton ratingMap ratingElo)
              acc) Map.empty
  <$> (select . from $ \rating -> do
          where_ (rating^.RatingTable ==. val table)
          return rating)

setRating :: Table -> Player -> MapType -> Word -> SqliteM ()
setRating table player maptype elo = () <$ upsert Rating
  { ratingTable = table
  , ratingPlayer = player
  , ratingMap = maptype
  , ratingElo = elo
  } []

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

type Api =
       "tables" :> Get '[JSON] [Table]
  :<|> "players" :> Get '[JSON] [Player]
  :<|> "maps" :> Get '[JSON] [MapType]
  :<|> "players"
    :> "rates"
    :> Capture "table" Table
    :> Capture "player" Player
    :> Capture "map" MapType
    :> Capture "elo" Word
    :> Post '[JSON] Bool
  :<|> "players"
    :> "rates"
    :> Capture "table" Table
    :> Get '[JSON] RatingsTable

api :: Proxy Api
api = Proxy

server :: ConnectionPool -> Server Api
server pool =
  sql getTables
  :<|> sql getPlayers
  :<|> sql getMapTypes
  :<|> (\table player maptype elo -> do
           sql (setRating table player maptype elo)
           return True)
  :<|> sql . getTable
  where
    sql :: SqlPersistT (NoLoggingT (ResourceT IO)) a -> Handler a
    sql f = liftIO (runSqlPersistMPool f pool)

makeApplication :: IO Application
makeApplication = do
  pool <- runStderrLoggingT (createSqlitePool "teamsplit.sqlite" 10)
  runSqlPool (runMigration migrateAll) pool
  return (serve api (server pool))

main :: IO ()
main = do
  host:_ <- getArgs

  T.putStrLn "// generated js API"
  T.putStrLn (jsForAPI api (vanillaJSWith
                            defCommonGeneratorOptions{urlPrefix = T.pack host}))

  Warp.run 80 =<< makeApplication

generates something like:

// generated js API

var getTables = function(onSuccess, onError) {
  var xhr = new XMLHttpRequest();
  xhr.open('GET', '//tables', true);
  xhr.setRequestHeader('Accept', 'application/json');
  xhr.onreadystatechange = function () {
    var res = null;
    if (xhr.readyState === 4) {
      if (xhr.status === 204 || xhr.status === 205) {
        onSuccess();
      } else if (xhr.status >= 200 && xhr.status < 300) {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onSuccess(res);
      } else {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onError(res);
      }
    }
  };
  xhr.send(null);
};

var getPlayers = function(onSuccess, onError) {
  var xhr = new XMLHttpRequest();
  xhr.open('GET', '//players', true);
  xhr.setRequestHeader('Accept', 'application/json');
  xhr.onreadystatechange = function () {
    var res = null;
    if (xhr.readyState === 4) {
      if (xhr.status === 204 || xhr.status === 205) {
        onSuccess();
      } else if (xhr.status >= 200 && xhr.status < 300) {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onSuccess(res);
      } else {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onError(res);
      }
    }
  };
  xhr.send(null);
};

var getMaps = function(onSuccess, onError) {
  var xhr = new XMLHttpRequest();
  xhr.open('GET', '//maps', true);
  xhr.setRequestHeader('Accept', 'application/json');
  xhr.onreadystatechange = function () {
    var res = null;
    if (xhr.readyState === 4) {
      if (xhr.status === 204 || xhr.status === 205) {
        onSuccess();
      } else if (xhr.status >= 200 && xhr.status < 300) {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onSuccess(res);
      } else {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onError(res);
      }
    }
  };
  xhr.send(null);
};

var postPlayersRatesByTableByPlayerByMapByElo = function(table, player, map, elo, onSuccess, onError) {
  var xhr = new XMLHttpRequest();
  xhr.open('POST', '//players/rates/' + encodeURIComponent(table) + '/' + encodeURIComponent(player) + '/' + encodeURIComponent(map) + '/' + encodeURIComponent(elo) + '', true);
  xhr.setRequestHeader('Accept', 'application/json');
  xhr.onreadystatechange = function () {
    var res = null;
    if (xhr.readyState === 4) {
      if (xhr.status === 204 || xhr.status === 205) {
        onSuccess();
      } else if (xhr.status >= 200 && xhr.status < 300) {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onSuccess(res);
      } else {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onError(res);
      }
    }
  };
  xhr.send(null);
};

var getPlayersRatesByTable = function(table, onSuccess, onError) {
  var xhr = new XMLHttpRequest();
  xhr.open('GET', '//players/rates/' + encodeURIComponent(table) + '', true);
  xhr.setRequestHeader('Accept', 'application/json');
  xhr.onreadystatechange = function () {
    var res = null;
    if (xhr.readyState === 4) {
      if (xhr.status === 204 || xhr.status === 205) {
        onSuccess();
      } else if (xhr.status >= 200 && xhr.status < 300) {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onSuccess(res);
      } else {
        try { res = JSON.parse(xhr.responseText); } catch (e) { onError(e); }
        if (res) onError(res);
      }
    }
  };
  xhr.send(null);
};