{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Nomyx.Api.Api where import GHC.Generics import Data.Proxy import Data.Yaml import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe) import Data.List (intercalate) import Data.Maybe import Data.Typeable import qualified Data.Text as T import Data.Swagger import Data.Swagger.Schema import Servant.API import Servant.Client import Servant import Network.URI (URI (..), URIAuth (..), parseURI) import Network.Wai.Parse import Nomyx.Api.Model.Player import Nomyx.Api.Model.Error import Nomyx.Api.Model.NewPlayer import Nomyx.Core.Session hiding (getModules) import Nomyx.Core.Types import Nomyx.Core.Profile import Nomyx.Language.Types import Control.Concurrent.STM import Control.Monad.State import Control.Monad.Trans.Either import Control.Monad.Except import System.Log.Logger import Test.QuickCheck -- * API definition type NomyxApi = PlayerApi :<|> RuleTemplateApi type PlayerApi = "players" :> Get '[JSON] [ProfileData] :<|> "players" :> ReqBody '[JSON] PlayerSettings :> Post '[JSON] ProfileData :<|> "players" :> Capture "id" Int :> Get '[JSON] ProfileData :<|> "players" :> Capture "id" Int :> Delete '[JSON] () type RuleTemplateApi = "templates" :> BasicAuth "foo-realm" PlayerNumber :> Get '[JSON] Library -- get all templates :<|> "templates" :> BasicAuth "foo-realm" PlayerNumber :> ReqBody '[JSON] Library :> Put '[JSON] () -- replace all templates nomyxApi :: Proxy NomyxApi nomyxApi = Proxy serverPath :: String serverPath = "https://api.nomyx.net/v1" server :: TVar Session -> Server NomyxApi server tv = ((playersGet tv) :<|> (playersPost tv) :<|> (playerGet tv) :<|> (playerDelete tv)) :<|> ((templatesGet tv) :<|> (templatesPut tv)) -- * Players API playersGet :: TVar Session -> ExceptT ServantErr IO [ProfileData] playersGet tv = do s <- liftIO $ atomically $ readTVar tv pds <- liftIO $ getAllProfiles s return pds playersPost :: TVar Session -> PlayerSettings -> ExceptT ServantErr IO ProfileData playersPost tv ps = do liftIO $ updateSession tv (newPlayer 2 ps) s <- liftIO $ atomically $ readTVar tv pds <- liftIO $ getAllProfiles s return $ head pds playerGet :: TVar Session -> PlayerNumber -> ExceptT ServantErr IO ProfileData playerGet tv pn = do s <- liftIO $ atomically $ readTVar tv mpd <- liftIO $ getProfile s pn case mpd of Just pd -> return pd Nothing -> throwError $ err410 { errBody = "Player does not exist." } playerDelete :: TVar Session -> PlayerNumber -> ExceptT ServantErr IO () playerDelete tv pn = error "not supported" -- * Templates API templatesGet :: TVar Session -> PlayerNumber -> ExceptT ServantErr IO Library templatesGet tv _ = do s <- liftIO $ atomically $ readTVar tv return $ _mLibrary $ _multi s templatesPost :: TVar Session -> PlayerNumber -> RuleTemplate -> ExceptT ServantErr IO () templatesPost tv _ rt = do liftIO $ updateSession tv (newRuleTemplate 1 rt) return () templatesPut :: TVar Session -> PlayerNumber -> Library -> ExceptT ServantErr IO () templatesPut tv pn lib = liftIO $ do debug $ "templatesPut library: " ++ (show lib) updateSession tv (updateLibrary pn lib) return () debug, info :: (MonadIO m) => String -> m () debug s = liftIO $ debugM "Nomyx.Api.Api" s info s = liftIO $ infoM "Nomyx.Api.Api" s