# HG changeset patch # User nemo # Date 1289606256 18000 # Node ID 1f5604cd99bedfe1a47b76a25f59c49cc1a5a9b8 # Parent d79ffcdd77dfb132eb31353d66452d62b0b87976# Parent 0313d5577fced1bf7e965da49599f6cf4352bcc4 This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly diff -r 0313d5577fce -r 1f5604cd99be CMakeLists.txt --- a/CMakeLists.txt Fri Nov 12 18:32:56 2010 -0500 +++ b/CMakeLists.txt Fri Nov 12 18:57:36 2010 -0500 @@ -7,7 +7,7 @@ cmake_policy(SET CMP0012 NEW) ENDIF() -#detect subversion revision (if present) +#detect Mercurial revision (if present) set(version_suffix "-dev") #UNSET THIS VARIABLE AT RELEASE TIME IF(version_suffix MATCHES "-dev") set(HW_DEV true) @@ -35,7 +35,7 @@ set(CPACK_PACKAGE_VERSION_MAJOR "0") set(CPACK_PACKAGE_VERSION_MINOR "9") -set(CPACK_PACKAGE_VERSION_PATCH "14${version_suffix}") +set(CPACK_PACKAGE_VERSION_PATCH "15${version_suffix}") #forbid in-tree building #IF (${CMAKE_SOURCE_DIR} MATCHES ${CMAKE_BINARY_DIR}) @@ -169,7 +169,7 @@ set(EXECUTABLE_OUTPUT_PATH ${PROJECT_BINARY_DIR}/bin) set(HEDGEWARS_VERSION "${CPACK_PACKAGE_VERSION_MAJOR}.${CPACK_PACKAGE_VERSION_MINOR}.${CPACK_PACKAGE_VERSION_PATCH}") -set(HEDGEWARS_PROTO_VER 32) +set(HEDGEWARS_PROTO_VER 34) if(WITH_SERVER) message(STATUS "Server is going to be built! Make sure you have GHC installed") diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/ammoSchemeModel.cpp --- a/QTfrontend/ammoSchemeModel.cpp Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/ammoSchemeModel.cpp Fri Nov 12 18:57:36 2010 -0500 @@ -45,19 +45,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(45) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(4) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(2) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(45) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(4) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(2) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; AmmoSchemeModel::AmmoSchemeModel(QObject* parent, const QString & fileName) : @@ -103,6 +104,7 @@ << "infattack" // 19 << "resetweps" // 20 << "perhogammo" // 21 + << "disablewind" // 22 << "damagefactor" // 22 << "turntime" // 23 << "health" // 24 @@ -142,19 +144,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(15) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(0) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(0) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(2) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(15) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(0) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(0) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(2) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList shoppa; @@ -181,19 +184,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(30) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(50) // sudden death 25 - << QVariant(1) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(0) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(0) // explosives 30 - << QVariant(0) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(30) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(50) // sudden death 26 + << QVariant(1) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(0) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(0) // explosives 31 + << QVariant(0) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList cleanslate; @@ -220,19 +224,20 @@ << QVariant(true) // inf. attack 19 << QVariant(true) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(45) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(4) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(2) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(45) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(4) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(2) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList minefield; @@ -259,19 +264,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(150) // damage modfier 22 - << QVariant(30) // turn time 23 - << QVariant(50) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(0) // case prob 26 - << QVariant(0) // mines time 27 - << QVariant(80) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(0) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(150) // damage modfier 23 + << QVariant(30) // turn time 24 + << QVariant(50) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(0) // case prob 27 + << QVariant(0) // mines time 28 + << QVariant(80) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(0) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList barrelmayhem; @@ -298,19 +304,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(30) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(0) // case prob 26 - << QVariant(0) // mines time 27 - << QVariant(0) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(80) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(30) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(0) // case prob 27 + << QVariant(0) // mines time 28 + << QVariant(0) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(80) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList tunnelhogs; @@ -337,19 +344,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(30) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(10) // mines number 28 - << QVariant(10) // mine dud pct 29 - << QVariant(10) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(30) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(10) // mines number 29 + << QVariant(10) // mine dud pct 30 + << QVariant(10) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList forts; @@ -376,19 +384,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(45) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(0) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(0) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(45) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(0) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(0) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList timeless; @@ -415,19 +424,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(true) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(9999) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(5) // mines number 28 - << QVariant(10) // mine dud pct 29 - << QVariant(2) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(30) // health case amt 32 - << QVariant(0) // water rise amt 33 - << QVariant(0) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(9999) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(5) // mines number 29 + << QVariant(10) // mine dud pct 30 + << QVariant(2) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(30) // health case amt 33 + << QVariant(0) // water rise amt 34 + << QVariant(0) // health dec amt 35 ; QList thinkingportals; @@ -454,19 +464,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(45) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(2) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(5) // mines number 28 - << QVariant(0) // mine dud pct 29 - << QVariant(5) // explosives 30 - << QVariant(25) // health case pct 31 - << QVariant(25) // health case amt 32 - << QVariant(47) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(45) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(2) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(5) // mines number 29 + << QVariant(0) // mine dud pct 30 + << QVariant(5) // explosives 31 + << QVariant(25) // health case pct 32 + << QVariant(25) // health case amt 33 + << QVariant(47) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; QList kingmode; @@ -493,19 +504,20 @@ << QVariant(false) // inf. attack 19 << QVariant(false) // reset weps 20 << QVariant(false) // per hog ammo 21 - << QVariant(100) // damage modfier 22 - << QVariant(45) // turn time 23 - << QVariant(100) // init health 24 - << QVariant(15) // sudden death 25 - << QVariant(5) // case prob 26 - << QVariant(3) // mines time 27 - << QVariant(3) // mines number 28 - << QVariant(20) // mine dud pct 29 - << QVariant(3) // explosives 30 - << QVariant(35) // health case pct 31 - << QVariant(30) // health case amt 32 - << QVariant(30) // water rise amt 33 - << QVariant(5) // health dec amt 34 + << QVariant(false) // no wind 22 + << QVariant(100) // damage modfier 23 + << QVariant(45) // turn time 24 + << QVariant(100) // init health 25 + << QVariant(15) // sudden death 26 + << QVariant(5) // case prob 27 + << QVariant(3) // mines time 28 + << QVariant(3) // mines number 29 + << QVariant(20) // mine dud pct 30 + << QVariant(3) // explosives 31 + << QVariant(35) // health case pct 32 + << QVariant(30) // health case amt 33 + << QVariant(30) // water rise amt 34 + << QVariant(5) // health dec amt 35 ; diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/gamecfgwidget.cpp --- a/QTfrontend/gamecfgwidget.cpp Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/gamecfgwidget.cpp Fri Nov 12 18:57:36 2010 -0500 @@ -149,13 +149,15 @@ result |= 0x00200000; // reset weaps if (schemeData(21).toBool()) result |= 0x00400000; // per hog ammo + if (schemeData(22).toBool()) + result |= 0x00800000; // no wind return result; } quint32 GameCFGWidget::getInitHealth() const { - return schemeData(24).toInt(); + return schemeData(25).toInt(); } QStringList GameCFGWidget::getFullConfig() const @@ -163,18 +165,18 @@ QStringList sl; sl.append("eseed " + pMapContainer->getCurrentSeed()); sl.append(QString("e$gmflags %1").arg(getGameFlags())); - sl.append(QString("e$damagepct %1").arg(schemeData(22).toInt())); - sl.append(QString("e$turntime %1").arg(schemeData(23).toInt() * 1000)); - sl.append(QString("e$minestime %1").arg(schemeData(27).toInt() * 1000)); - sl.append(QString("e$minesnum %1").arg(schemeData(28).toInt())); - sl.append(QString("e$sd_turns %1").arg(schemeData(25).toInt())); - sl.append(QString("e$casefreq %1").arg(schemeData(26).toInt())); - sl.append(QString("e$minedudpct %1").arg(schemeData(29).toInt())); - sl.append(QString("e$explosives %1").arg(schemeData(30).toInt())); - sl.append(QString("e$healthprob %1").arg(schemeData(31).toInt())); - sl.append(QString("e$hcaseamount %1").arg(schemeData(32).toInt())); - sl.append(QString("e$waterrise %1").arg(schemeData(33).toInt())); - sl.append(QString("e$healthdec %1").arg(schemeData(34).toInt())); + sl.append(QString("e$damagepct %1").arg(schemeData(23).toInt())); + sl.append(QString("e$turntime %1").arg(schemeData(24).toInt() * 1000)); + sl.append(QString("e$sd_turns %1").arg(schemeData(26).toInt())); + sl.append(QString("e$casefreq %1").arg(schemeData(27).toInt())); + sl.append(QString("e$minestime %1").arg(schemeData(28).toInt())); + sl.append(QString("e$minesnum %1").arg(schemeData(29).toInt())); + sl.append(QString("e$minedudpct %1").arg(schemeData(30).toInt())); + sl.append(QString("e$explosives %1").arg(schemeData(31).toInt())); + sl.append(QString("e$healthprob %1").arg(schemeData(32).toInt())); + sl.append(QString("e$hcaseamount %1").arg(schemeData(33).toInt())); + sl.append(QString("e$waterrise %1").arg(schemeData(34).toInt())); + sl.append(QString("e$healthdec %1").arg(schemeData(35).toInt())); sl.append(QString("e$template_filter %1").arg(pMapContainer->getTemplateFilter())); sl.append(QString("e$mapgen %1").arg(pMapContainer->get_mapgen())); sl.append(QString("e$maze_size %1").arg(pMapContainer->get_maze_size())); diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/hedgewars.qrc --- a/QTfrontend/hedgewars.qrc Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/hedgewars.qrc Fri Nov 12 18:57:36 2010 -0500 @@ -71,6 +71,7 @@ res/btnInfAttack.png res/btnResetWeps.png res/btnPerHogAmmo.png + res/btnNoWind.png res/iconBox.png res/iconHealth.png res/iconSuddenDeath.png diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/hwconsts.cpp.in --- a/QTfrontend/hwconsts.cpp.in Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/hwconsts.cpp.in Fri Nov 12 18:57:36 2010 -0500 @@ -36,10 +36,10 @@ int cMaxTeams = 6; QString * cDefaultAmmoStore = new QString( - "9391929422199121032235111001201000000211110101011" - "0405040541600655546554464776576666666155510101115" - "0000000000000205500000040007004000000000200000000" - "1311110312111111123114111111111111111211111101111" + "93919294221991210322351110012010000002111101010111" + "04050405416006555465544647765766666661555101011154" + "00000000000002055000000400070040000000002000000006" + "13111103121111111231141111111111111112111111011111" ); int cAmmoNumber = cDefaultAmmoStore->size() / 4; @@ -48,40 +48,40 @@ << qMakePair(QString("Default"), *cDefaultAmmoStore) << qMakePair(QString("Crazy"), QString( // TODO: Remove Piano's unlimited uses! - "9999999999999999992999999999999999299999999909999" - "1111110111111111111111111111111111111111111101111" - "0000000000000000000000000000000000000000000000000" - "1311110312111111123114111111111111111211110101111" + "99999999999999999929999999999999992999999999099999" + "11111101111111111111111111111111111111111111011111" + "00000000000000000000000000000000000000000000000000" + "13111103121111111231141111111111111112111101011111" )) << qMakePair(QString("Pro Mode"), QString( - "9090009000000000000009000000000000000000000000000" - "0000000000000000000000000000000000000000000000000" - "0000000000000205500000040007004000000000200000000" - "1111111111111111111111111111111111111111100101111" + "90900090000000000000090000000000000000000000000000" + "00000000000000000000000000000000000000000000000000" + "00000000000002055000000400070040000000002000000000" + "11111111111111111111111111111111111111111001011111" )) << qMakePair(QString("Shoppa"), QString( - "0000009900000000000000000000000000000000000000000" - "4444410044244402210112121222422000000002000400010" - "0000000000000000000000000000000000000000000000000" - "1111111111111111111111111111111111111111101101111" + "00000099000000000000000000000000000000000000000000" + "44444100442444022101121212224220000000020004000100" + "00000000000000000000000000000000000000000000000000" + "11111111111111111111111111111111111111111011011111" )) << qMakePair(QString("Clean Slate"),QString( - "1010009000010000011000000000000000000000000000001" - "0405040541600655546554464776576666666155510101115" - "0000000000000000000000000000000000000000000000000" - "1311110312111111123114111111111111111211111101111" + "10100090000100000110000000000000000000000000000010" + "04050405416006555465544647765766666661555101011154" + "00000000000000000000000000000000000000000000000000" + "13111103121111111231141111111111111112111111011111" )) << qMakePair(QString("Minefield"), QString( - "0000009900090000000300000000000000000000000000000" - "0000000000000000000000000000000000000000000000000" - "0000000000000205500000040007004000000000200000000" - "1111111111111111111111111111111111111111111101111" + "00000099000900000003000000000000000000000000000000" + "00000000000000000000000000000000000000000000000000" + "00000000000002055000000400070040000000002000000006" + "11111111111111111111111111111111111111111111011111" )) << qMakePair(QString("Thinking with Portals"), QString( - "9000009002000000002100000000000000110000090000000" - "0405040541600655546554464776576666666155510101115" - "0000000000000205500000040007004000000000200000000" - "1311110312111111123114111111111111111211111101111" + "90000090020000000021000000000000001100000900000000" + "04050405416006555465544647765766666661555101011154" + "00000000000002055000000400070040000000002000000006" + "13111103121111111231141111111111111112111111011111" )); QColor *colors[] = { diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/pages.cpp --- a/QTfrontend/pages.cpp Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/pages.cpp Fri Nov 12 18:57:36 2010 -0500 @@ -1562,6 +1562,10 @@ TBW_perhogammo->setToolTip("" + ToggleButtonWidget::tr("Per Hedgehog Ammo") + ":
" + tr("Each hedgehog has its own ammo. It does not share with the team.")); glGMLayout->addWidget(TBW_perhogammo,4,0,1,1); + TBW_nowind = new ToggleButtonWidget(gbGameModes, ":/res/btnNoWind.png"); + TBW_nowind->setToolTip("" + ToggleButtonWidget::tr("Disable Wind") + ":
" + tr("Wind will not affect weapons.")); + glGMLayout->addWidget(TBW_nowind,4,1,1,1); + // Right QLabel * l; @@ -1800,19 +1804,20 @@ mapper->addMapping(TBW_infattack, 19); mapper->addMapping(TBW_resetweps, 20); mapper->addMapping(TBW_perhogammo, 21); - mapper->addMapping(SB_DamageModifier, 22); - mapper->addMapping(SB_TurnTime, 23); - mapper->addMapping(SB_InitHealth, 24); - mapper->addMapping(SB_SuddenDeath, 25); - mapper->addMapping(SB_CaseProb, 26); - mapper->addMapping(SB_MinesTime, 27); - mapper->addMapping(SB_Mines, 28); - mapper->addMapping(SB_MineDuds, 29); - mapper->addMapping(SB_Explosives, 30); - mapper->addMapping(SB_HealthCrates, 31); - mapper->addMapping(SB_CrateHealth, 32); - mapper->addMapping(SB_WaterRise, 33); - mapper->addMapping(SB_HealthDecrease, 34); + mapper->addMapping(TBW_nowind, 22); + mapper->addMapping(SB_DamageModifier, 23); + mapper->addMapping(SB_TurnTime, 24); + mapper->addMapping(SB_InitHealth, 25); + mapper->addMapping(SB_SuddenDeath, 26); + mapper->addMapping(SB_CaseProb, 27); + mapper->addMapping(SB_MinesTime, 28); + mapper->addMapping(SB_Mines, 29); + mapper->addMapping(SB_MineDuds, 30); + mapper->addMapping(SB_Explosives, 31); + mapper->addMapping(SB_HealthCrates, 32); + mapper->addMapping(SB_CrateHealth, 33); + mapper->addMapping(SB_WaterRise, 34); + mapper->addMapping(SB_HealthDecrease, 35); mapper->toFirst(); } diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/pages.h --- a/QTfrontend/pages.h Fri Nov 12 18:32:56 2010 -0500 +++ b/QTfrontend/pages.h Fri Nov 12 18:57:36 2010 -0500 @@ -481,6 +481,7 @@ ToggleButtonWidget * TBW_infattack; ToggleButtonWidget * TBW_resetweps; ToggleButtonWidget * TBW_perhogammo; + ToggleButtonWidget * TBW_nowind; QSpinBox * SB_DamageModifier; QSpinBox * SB_TurnTime; diff -r 0313d5577fce -r 1f5604cd99be QTfrontend/res/btnNoWind.png Binary file QTfrontend/res/btnNoWind.png has changed diff -r 0313d5577fce -r 1f5604cd99be gameServer/Actions.hs --- a/gameServer/Actions.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/Actions.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,171 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} module Actions where -import Control.Concurrent.STM +import Control.Concurrent import Control.Concurrent.Chan -import Data.IntMap import qualified Data.IntSet as IntSet +import qualified Data.Set as Set import qualified Data.Sequence as Seq import System.Log.Logger -import Monad +import Control.Monad import Data.Time -import Maybe +import Data.Maybe +import Control.Monad.Reader +import Control.Monad.State.Strict +import qualified Data.ByteString.Char8 as B ----------------------------- import CoreTypes import Utils +import ClientIO +import ServerState data Action = - AnswerThisClient [String] - | AnswerAll [String] - | AnswerAllOthers [String] - | AnswerThisRoom [String] - | AnswerOthersInRoom [String] - | AnswerSameClan [String] - | AnswerLobby [String] + AnswerClients ![ClientChan] ![B.ByteString] | SendServerMessage | SendServerVars - | RoomAddThisClient Int -- roomID - | RoomRemoveThisClient String - | RemoveTeam String + | MoveToRoom RoomIndex + | MoveToLobby B.ByteString + | RemoveTeam B.ByteString | RemoveRoom | UnreadyRoomClients - | MoveToLobby - | ProtocolError String - | Warning String - | ByeClient String - | KickClient Int -- clID - | KickRoomClient Int -- clID - | BanClient String -- nick - | RemoveClientTeams Int -- clID + | JoinLobby + | ProtocolError B.ByteString + | Warning B.ByteString + | ByeClient B.ByteString + | KickClient ClientIndex + | KickRoomClient ClientIndex + | BanClient B.ByteString -- nick + | RemoveClientTeams ClientIndex | ModifyClient (ClientInfo -> ClientInfo) - | ModifyClient2 Int (ClientInfo -> ClientInfo) + | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo) | ModifyRoom (RoomInfo -> RoomInfo) | ModifyServerInfo (ServerInfo -> ServerInfo) - | AddRoom String String + | AddRoom B.ByteString B.ByteString | CheckRegistered | ClearAccountsCache | ProcessAccountInfo AccountInfo | Dump | AddClient ClientInfo + | DeleteClient ClientIndex | PingAll | StatsAction -type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] - -replaceID a (b, c, d, e) = (a, c, d, e) - -processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) - - -processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do - writeChan (sendChan $ clients ! clID) msg - return (clID, serverInfo, clients, rooms) +type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] -processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do - mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients) - return (clID, serverInfo, clients, rooms) - - -processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do - mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ - Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients) - return (clID, serverInfo, clients, rooms) - - -processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do - mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients - return (clID, serverInfo, clients, rooms) - where - roomClients = IntSet.elems $ playersIDs room - room = rooms ! rID - rID = roomID client - client = clients ! clID +processAction :: Action -> StateT ServerState IO () -processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do - mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients - return (clID, serverInfo, clients, rooms) - where - roomClients = IntSet.elems $ playersIDs room - room = rooms ! rID - rID = roomID client - client = clients ! clID - - -processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do - mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients - return (clID, serverInfo, clients, rooms) - where - roomClients = IntSet.elems $ playersIDs room - room = rooms ! 0 +processAction (AnswerClients chans msg) = do + liftIO $ map (flip seq ()) chans `seq` map (flip seq ()) msg `seq` mapM_ (flip writeChan msg) chans -processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do - mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec - return (clID, serverInfo, clients, rooms) - where - otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room) - sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators - spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients - sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients - thisClan = clientClan client - room = rooms ! rID - rID = roomID client - client = clients ! clID - - -processAction (clID, serverInfo, clients, rooms) SendServerMessage = do - writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo] - return (clID, serverInfo, clients, rooms) - where - client = clients ! clID - message si = if clientProto client < latestReleaseVersion si then +processAction SendServerMessage = do + chan <- client's sendChan + protonum <- client's clientProto + si <- liftM serverInfo get + let message = if protonum < latestReleaseVersion si then serverMessageForOldVersions si else serverMessage si + processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message] +{- -processAction (clID, serverInfo, clients, rooms) SendServerVars = do +processAction (clID, serverInfo, rnc) SendServerVars = do writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars) - return (clID, serverInfo, clients, rooms) + return (clID, serverInfo, rnc) where client = clients ! clID vars = [ - "MOTD_NEW", serverMessage serverInfo, - "MOTD_OLD", serverMessageForOldVersions serverInfo, + "MOTD_NEW", serverMessage serverInfo, + "MOTD_OLD", serverMessageForOldVersions serverInfo, "LATEST_PROTO", show $ latestReleaseVersion serverInfo ] -processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do - writeChan (sendChan $ clients ! clID) ["ERROR", msg] - return (clID, serverInfo, clients, rooms) +-} - -processAction (clID, serverInfo, clients, rooms) (Warning msg) = do - writeChan (sendChan $ clients ! clID) ["WARNING", msg] - return (clID, serverInfo, clients, rooms) +processAction (ProtocolError msg) = do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ERROR", msg] -processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do - infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg) - (_, _, newClients, newRooms) <- - if roomID client /= 0 then - processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit" - else - return (clID, serverInfo, clients, rooms) +processAction (Warning msg) = do + chan <- client's sendChan + processAction $ AnswerClients [chan] ["WARNING", msg] + +processAction (ByeClient msg) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + ri <- clientRoomA + + chan <- client's sendChan + ready <- client's isReady - mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom - writeChan (sendChan $ clients ! clID) ["BYE", msg] - return ( - 0, - serverInfo, - delete clID newClients, - adjust (\r -> r{ - playersIDs = IntSet.delete clID (playersIDs r), - playersIn = (playersIn r) - 1, - readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r - }) (roomID $ newClients ! clID) newRooms - ) + when (ri /= lobbyId) $ do + processAction $ MoveToLobby ("quit: " `B.append` msg) + liftIO $ modifyRoom rnc (\r -> r{ + --playersIDs = IntSet.delete ci (playersIDs r) + playersIn = (playersIn r) - 1, + readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r + }) ri + return () + + liftIO $ do + infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg)) + + --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom + + processAction $ AnswerClients [chan] ["BYE", msg] + + s <- get + put $! s{removedClients = ci `Set.insert` removedClients s} + +processAction (DeleteClient ci) = do + rnc <- gets roomsClients + liftIO $ removeClient rnc ci + + s <- get + put $! s{removedClients = ci `Set.delete` removedClients s} + +{- where client = clients ! clID clientNick = nick client @@ -184,46 +147,57 @@ else [AnswerAll ["LOBBY:LEFT", clientNick]] else - [] - - -processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = - return (clID, serverInfo, adjust func clID clients, rooms) - + [] +-} -processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) = - return (clID, serverInfo, adjust func cl2ID clients, rooms) - +processAction (ModifyClient f) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + liftIO $ modifyClient rnc f ci + return () -processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = - return (clID, serverInfo, clients, adjust func rID rooms) - where - rID = roomID $ clients ! clID +processAction (ModifyClient2 ci f) = do + rnc <- gets roomsClients + liftIO $ modifyClient rnc f ci + return () -processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) = - return (clID, func serverInfo, clients, rooms) +processAction (ModifyRoom f) = do + rnc <- gets roomsClients + ri <- clientRoomA + liftIO $ modifyRoom rnc f ri + return () +{- + +processAction (clID, serverInfo, rnc) (ModifyServerInfo func) = + return (clID, func serverInfo, rnc) + +-} -processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = - processAction ( - clID, - serverInfo, - adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, - adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ - adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms - ) joinMsg - where - client = clients ! clID - joinMsg = if rID == 0 then - AnswerAllOthers ["LOBBY:JOINED", nick client] - else - AnswerThisRoom ["JOINED", nick client] +processAction (MoveToRoom ri) = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + liftIO $ do + modifyClient rnc (\cl -> cl{teamsInGame = 0}) ci + modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri + + liftIO $ moveClientToRoom rnc ri ci + + chans <- liftM (map sendChan) $ roomClientsS ri + clNick <- client's nick + processAction $ AnswerClients chans ["JOINED", clNick] -processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do +processAction (MoveToLobby msg) = do + (Just ci) <- gets clientIndex + --ri <- clientRoomA + rnc <- gets roomsClients + + liftIO $ moveClientToLobby rnc ci + +{- (_, _, newClients, newRooms) <- - if roomID client /= 0 then if isMaster client then if (gameinprogress room) && (playersIn room > 1) then (changeMaster >>= (\state -> foldM processAction state @@ -231,16 +205,15 @@ AnswerOthersInRoom ["WARNING", "Admin left the room"], RemoveClientTeams clID])) else -- not in game - processAction (clID, serverInfo, clients, rooms) RemoveRoom + processAction (clID, serverInfo, rnc) RemoveRoom else -- not master foldM processAction - (clID, serverInfo, clients, rooms) + (clID, serverInfo, rnc) [AnswerOthersInRoom ["LEFT", nick client, msg], RemoveClientTeams clID] - else -- in lobby - return (clID, serverInfo, clients, rooms) - + + return ( clID, serverInfo, @@ -259,7 +232,7 @@ } insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)} changeMaster = do - processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] + processAction (newMasterId, serverInfo, rnc) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"] return ( clID, serverInfo, @@ -270,34 +243,35 @@ otherPlayersSet = IntSet.delete clID (playersIDs room) newMasterId = IntSet.findMin otherPlayersSet newMasterClient = clients ! newMasterId - +-} -processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do - let newServerInfo = serverInfo {nextRoomID = newID} +processAction (AddRoom roomName roomPassword) = do + Just clId <- gets clientIndex + rnc <- gets roomsClients + proto <- liftIO $ client'sM rnc clientProto clId + let room = newRoom{ - roomUID = newID, - masterID = clID, + masterID = clId, name = roomName, password = roomPassword, - roomProto = (clientProto client) + roomProto = proto } - processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] + rId <- liftIO $ addRoom rnc room + + processAction $ MoveToRoom rId + + chans <- liftM (map sendChan) $! roomClientsS lobbyId - processAction ( - clID, - newServerInfo, - adjust (\cl -> cl{isMaster = True}) clID clients, - insert newID room rooms - ) $ RoomAddThisClient newID - where - newID = (nextRoomID serverInfo) - 1 - client = clients ! clID + mapM_ processAction [ + AnswerClients chans ["ROOM", "ADD", roomName] + , ModifyClient (\cl -> cl{isMaster = True}) + ] - -processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do - processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room] - processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room] +{- +processAction (clID, serverInfo, rnc) (RemoveRoom) = do + processAction (clID, serverInfo, rnc) $ AnswerLobby ["ROOM", "DEL", name room] + processAction (clID, serverInfo, rnc) $ AnswerOthersInRoom ["ROOMABANDONED", name room] return (clID, serverInfo, Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients, @@ -308,139 +282,163 @@ rID = roomID client client = clients ! clID - -processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do - processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers) - return (clID, - serverInfo, - Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients, - adjust (\r -> r{readyPlayers = 0}) rID rooms) - where - room = rooms ! rID - rID = roomID client - client = clients ! clID - roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs - roomPlayersIDs = IntSet.elems $ playersIDs room +-} +processAction (UnreadyRoomClients) = do + rnc <- gets roomsClients + ri <- clientRoomA + roomPlayers <- roomClientsS ri + roomClIDs <- liftIO $ roomClientsIndicesM rnc ri + processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers) + liftIO $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs + processAction $ ModifyRoom (\r -> r{readyPlayers = 0}) -processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do - newRooms <- if not $ gameinprogress room then - do - processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName] - return $ - adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms +processAction (RemoveTeam teamName) = do + rnc <- gets roomsClients + cl <- client's id + ri <- clientRoomA + inGame <- liftIO $ room'sM rnc gameinprogress ri + chans <- liftM (map sendChan . filter (/= cl)) $ roomClientsS ri + if inGame then + mapM_ processAction [ + AnswerClients chans ["REMOVE_TEAM", teamName], + ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) + ] else - do - processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg] - return $ - adjust (\r -> r{ - teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, - leftTeams = teamName : leftTeams r, - roundMsgs = roundMsgs r Seq.|> rmTeamMsg - }) rID rooms - return (clID, serverInfo, clients, newRooms) + mapM_ processAction [ + AnswerClients chans ["EM", rmTeamMsg], + ModifyRoom (\r -> r{ + teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r, + leftTeams = teamName : leftTeams r, + roundMsgs = roundMsgs r Seq.|> rmTeamMsg + }) + ] where - room = rooms ! rID - rID = roomID client - client = clients ! clID - rmTeamMsg = toEngineMsg $ 'F' : teamName + rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName +processAction CheckRegistered = do + (Just ci) <- gets clientIndex + n <- client's nick + h <- client's host + db <- gets (dbQueries . serverInfo) + liftIO $ writeChan db $ CheckAccount ci n h + return () -processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do - writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client) - return (clID, serverInfo, clients, rooms) +{- +processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do + writeChan (dbQueries serverInfo) ClearCache + return (clID, serverInfo, rnc) where client = clients ! clID -processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do - writeChan (dbQueries serverInfo) ClearCache - return (clID, serverInfo, clients, rooms) - where - client = clients ! clID - +processAction (clID, serverInfo, rnc) (Dump) = do + writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] + return (clID, serverInfo, rnc) +-} -processAction (clID, serverInfo, clients, rooms) (Dump) = do - writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] - return (clID, serverInfo, clients, rooms) - - -processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = +processAction (ProcessAccountInfo info) = case info of HasAccount passwd isAdmin -> do - infoM "Clients" $ show clID ++ " has account" - writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"] - return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms) + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ASKPASSWORD"] Guest -> do - infoM "Clients" $ show clID ++ " is guest" - processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby + processAction JoinLobby Admin -> do - infoM "Clients" $ show clID ++ " is admin" - foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]] + mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby] + chan <- client's sendChan + processAction $ AnswerClients [chan] ["ADMIN_ACCESS"] -processAction (clID, serverInfo, clients, rooms) (MoveToLobby) = - foldM processAction (clID, serverInfo, clients, rooms) $ - (RoomAddThisClient 0) - : answerLobbyNicks - ++ [SendServerMessage] +processAction JoinLobby = do + chan <- client's sendChan + clientNick <- client's nick + (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS + mapM_ processAction $ + (AnswerClients clientsChans ["LOBBY:JOINED", clientNick]) + : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)] + ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage] - -- ++ (answerServerMessage client clients) +{- +processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) = + processAction ( + clID, + serverInfo, + adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients, + adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ + adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms + ) joinMsg where - lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients - answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks] + client = clients ! clID + joinMsg = if rID == 0 then + AnswerAllOthers ["LOBBY:JOINED", nick client] + else + AnswerThisRoom ["JOINED", nick client] + +processAction (clID, serverInfo, rnc) (KickClient kickID) = + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ ByeClient "Kicked") -processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ ByeClient "Kicked") - - -processAction (clID, serverInfo, clients, rooms) (BanClient banNick) = - return (clID, serverInfo, clients, rooms) +processAction (clID, serverInfo, rnc) (BanClient banNick) = + return (clID, serverInfo, rnc) -processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do +processAction (clID, serverInfo, rnc) (KickRoomClient kickID) = do writeChan (sendChan $ clients ! kickID) ["KICKED"] - liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked") + liftM2 replaceID (return clID) (processAction (kickID, serverInfo, rnc) $ RoomRemoveThisClient "kicked") -processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) = +processAction (clID, serverInfo, rnc) (RemoveClientTeams teamsClID) = liftM2 replaceID (return clID) $ - foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions + foldM processAction (teamsClID, serverInfo, rnc) removeTeamsActions where client = clients ! teamsClID room = rooms ! (roomID client) teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove - +-} -processAction (clID, serverInfo, clients, rooms) (AddClient client) = do - let updatedClients = insert (clientUID client) client clients - infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client)) - writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] +processAction (AddClient client) = do + rnc <- gets roomsClients + si <- gets serverInfo + liftIO $ do + ci <- addClient rnc client + forkIO $ clientRecvLoop (clientSocket client) (coreChan si) ci + forkIO $ clientSendLoop (clientSocket client) (sendChan client) ci - let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo + infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime client)) + + processAction $ AnswerClients [sendChan client] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"] +{- let newLogins = takeWhile (\(_ , time) -> (connectTime client) `diffUTCTime` time <= 11) $ lastLogins serverInfo - if isJust $ host client `Prelude.lookup` newLogins then - processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient "Reconnected too fast" - else - return (clID, serverInfo{lastLogins = (host client, connectTime client) : newLogins}, updatedClients, rooms) + if False && (isJust $ host client `Prelude.lookup` newLogins) then + processAction (ci, serverInfo{lastLogins = newLogins}, rnc) $ ByeClient "Reconnected too fast" + else + return (ci, serverInfo) +-} + -processAction (clID, serverInfo, clients, rooms) PingAll = do - (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients - processAction (clID, - serverInfo, - Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients, - newRooms) $ AnswerAll ["PING"] +processAction PingAll = do + rnc <- gets roomsClients + liftIO (allClientsM rnc) >>= mapM_ (kickTimeouted rnc) + cis <- liftIO $ allClientsM rnc + chans <- liftIO $ mapM (client'sM rnc sendChan) cis + liftIO $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis + processAction $ AnswerClients chans ["PING"] where - kickTimeouted (clID, serverInfo, clients, rooms) client = - if pingsQueue client > 0 then - processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout" - else - return (clID, serverInfo, clients, rooms) + kickTimeouted rnc ci = do + pq <- liftIO $ client'sM rnc pingsQueue ci + when (pq > 0) $ + withStateT (\as -> as{clientIndex = Just ci}) $ + processAction (ByeClient "Ping timeout") -processAction (clID, serverInfo, clients, rooms) (StatsAction) = do - writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1) - return (clID, serverInfo, clients, rooms) +processAction (StatsAction) = do + rnc <- gets roomsClients + si <- gets serverInfo + (roomsNum, clientsNum) <- liftIO $ withRoomsAndClients rnc stats + liftIO $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1) + where + stats irnc = (length $ allRooms irnc, length $ allClients irnc) + diff -r 0313d5577fce -r 1f5604cd99be gameServer/CMakeLists.txt --- a/gameServer/CMakeLists.txt Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/CMakeLists.txt Fri Nov 12 18:57:36 2010 -0500 @@ -1,43 +1,48 @@ find_program(ghc_executable ghc) if(NOT ghc_executable) - message(FATAL_ERROR "Cannot find GHC") + message(FATAL_ERROR "Cannot find GHC") endif(NOT ghc_executable) set(hwserver_sources - OfficialServer/DBInteraction.hs - Actions.hs - ClientIO.hs - CoreTypes.hs - HWProtoCore.hs - HWProtoInRoomState.hs - HWProtoLobbyState.hs - HWProtoNEState.hs - NetRoutines.hs - Opts.hs - ServerCore.hs - Utils.hs - hedgewars-server.hs - ) + OfficialServer/DBInteraction.hs + Actions.hs + ClientIO.hs + CoreTypes.hs + HWProtoCore.hs + HWProtoInRoomState.hs + HWProtoLobbyState.hs + HWProtoNEState.hs + HandlerUtils.hs + NetRoutines.hs + Opts.hs + RoomsAndClients.hs + ServerCore.hs + ServerState.hs + Store.hs + Utils.hs + hedgewars-server.hs + ) set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs) set(ghc_flags - --make ${hwserv_main} - -i${hedgewars_SOURCE_DIR}/gameServer - -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX} - -odir ${CMAKE_CURRENT_BINARY_DIR} - -hidir ${CMAKE_CURRENT_BINARY_DIR}) + -Wall + --make ${hwserv_main} + -i${hedgewars_SOURCE_DIR}/gameServer + -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX} + -odir ${CMAKE_CURRENT_BINARY_DIR} + -hidir ${CMAKE_CURRENT_BINARY_DIR}) set(ghc_flags ${haskell_compiler_flags_cmn} ${ghc_flags}) add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}" - COMMAND "${ghc_executable}" - ARGS ${ghc_flags} - MAIN_DEPENDENCY ${hwserv_main} - DEPENDS ${hwserver_sources} - ) + COMMAND "${ghc_executable}" + ARGS ${ghc_flags} + MAIN_DEPENDENCY ${hwserv_main} + DEPENDS ${hwserver_sources} + ) add_custom_target(hedgewars-server ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}") diff -r 0313d5577fce -r 1f5604cd99be gameServer/ClientIO.hs --- a/gameServer/ClientIO.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/ClientIO.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module ClientIO where import qualified Control.Exception as Exception @@ -6,45 +6,71 @@ import Control.Concurrent import Control.Monad import System.IO -import qualified Data.ByteString.UTF8 as BUTF8 -import qualified Data.ByteString as B +import Network +import Network.Socket.ByteString +import qualified Data.ByteString.Char8 as B ---------------- import CoreTypes +import RoomsAndClients +import Utils -listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () -listenLoop handle linesNumber buf chan clientID = do - str <- liftM BUTF8.toString $ B.hGetLine handle - if (linesNumber > 50) || (length str > 450) then - writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) - else - if str == "" then do - writeChan chan $ ClientMessage (clientID, buf) - yield - listenLoop handle 0 [] chan clientID - else - listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID + +pDelim :: B.ByteString +pDelim = B.pack "\n\n" + +bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) +bs2Packets buf = unfoldrE extractPackets buf + where + extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) + extractPackets buf = + let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in + let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in + if B.null bufTail then + Left bsPacket + else + if B.null bsPacket then + Left bufTail + else + Right (B.splitWith (== '\n') bsPacket, bufTail) + -clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () -clientRecvLoop handle chan clientID = - listenLoop handle 0 [] chan clientID - `catch` (\e -> clientOff (show e) >> return ()) - where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message +listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () +listenLoop sock chan ci = recieveWithBufferLoop B.empty + where + recieveWithBufferLoop recvBuf = do + recvBS <- recv sock 4096 +-- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS) + unless (B.null recvBS) $ do + let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS + forM_ packets sendPacket + recieveWithBufferLoop newrecvBuf + + sendPacket packet = writeChan chan $ ClientMessage (ci, packet) -clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() -clientSendLoop handle coreChan chan clientID = do + +clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () +clientRecvLoop s chan ci = do + msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) + clientOff msg + where + clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci] + + + +clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO () +clientSendLoop s chan ci = do answer <- readChan chan - doClose <- Exception.handle - (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do - B.hPutStrLn handle $ BUTF8.fromString $ unlines answer - hFlush handle - return $ isQuit answer + Exception.handle + (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do + sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') - if doClose then - Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle + if (isQuit answer) then + Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s else - clientSendLoop handle coreChan chan clientID + clientSendLoop s chan ci where - sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) + --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) + sendQuit e = putStrLn $ show e isQuit ("BYE":xs) = True isQuit _ = False diff -r 0313d5577fce -r 1f5604cd99be gameServer/CoreTypes.hs --- a/gameServer/CoreTypes.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/CoreTypes.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module CoreTypes where import System.IO @@ -5,102 +6,95 @@ import Control.Concurrent.STM import Data.Word import qualified Data.Map as Map -import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Sequence(Seq, empty) import Data.Time import Network import Data.Function +import Data.ByteString.Char8 as B +import RoomsAndClients + +type ClientChan = Chan [B.ByteString] data ClientInfo = ClientInfo { - clientUID :: !Int, - sendChan :: Chan [String], - clientHandle :: Handle, - host :: String, + sendChan :: ClientChan, + clientSocket :: Socket, + host :: B.ByteString, connectTime :: UTCTime, - nick :: String, - webPassword :: String, + nick :: B.ByteString, + webPassword :: B.ByteString, logonPassed :: Bool, clientProto :: !Word16, - roomID :: !Int, + roomID :: RoomIndex, pingsQueue :: !Word, isMaster :: Bool, - isReady :: Bool, + isReady :: !Bool, isAdministrator :: Bool, - clientClan :: String, + clientClan :: B.ByteString, teamsInGame :: Word } instance Show ClientInfo where - show ci = show (clientUID ci) - ++ " nick: " ++ (nick ci) - ++ " host: " ++ (host ci) + show ci = " nick: " ++ (unpack $ nick ci) ++ " host: " ++ (unpack $ host ci) instance Eq ClientInfo where - (==) = (==) `on` clientHandle + (==) = (==) `on` clientSocket data HedgehogInfo = - HedgehogInfo String String + HedgehogInfo B.ByteString B.ByteString data TeamInfo = TeamInfo { - teamownerId :: !Int, - teamowner :: String, - teamname :: String, - teamcolor :: String, - teamgrave :: String, - teamfort :: String, - teamvoicepack :: String, - teamflag :: String, + teamownerId :: ClientIndex, + teamowner :: B.ByteString, + teamname :: B.ByteString, + teamcolor :: B.ByteString, + teamgrave :: B.ByteString, + teamfort :: B.ByteString, + teamvoicepack :: B.ByteString, + teamflag :: B.ByteString, difficulty :: Int, hhnum :: Int, hedgehogs :: [HedgehogInfo] } instance Show TeamInfo where - show ti = "owner: " ++ (teamowner ti) - ++ "name: " ++ (teamname ti) - ++ "color: " ++ (teamcolor ti) + show ti = "owner: " ++ (unpack $ teamowner ti) + ++ "name: " ++ (unpack $ teamname ti) + ++ "color: " ++ (unpack $ teamcolor ti) data RoomInfo = RoomInfo { - roomUID :: !Int, - masterID :: !Int, - name :: String, - password :: String, + masterID :: ClientIndex, + name :: B.ByteString, + password :: B.ByteString, roomProto :: Word16, teams :: [TeamInfo], gameinprogress :: Bool, playersIn :: !Int, readyPlayers :: !Int, - playersIDs :: IntSet.IntSet, isRestrictedJoins :: Bool, isRestrictedTeams :: Bool, - roundMsgs :: Seq String, - leftTeams :: [String], + roundMsgs :: Seq B.ByteString, + leftTeams :: [B.ByteString], teamsAtStart :: [TeamInfo], - params :: Map.Map String [String] + params :: Map.Map B.ByteString [B.ByteString] } instance Show RoomInfo where - show ri = show (roomUID ri) - ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri) - ++ ", players: " ++ show (playersIn ri) + show ri = ", players: " ++ show (playersIn ri) ++ ", ready: " ++ show (readyPlayers ri) ++ ", teams: " ++ show (teams ri) -instance Eq RoomInfo where - (==) = (==) `on` roomUID - +newRoom :: RoomInfo newRoom = ( RoomInfo - 0 - 0 + undefined "" "" 0 @@ -108,7 +102,6 @@ False 0 0 - IntSet.empty False False Data.Sequence.empty @@ -128,23 +121,24 @@ ServerInfo { isDedicated :: Bool, - serverMessage :: String, - serverMessageForOldVersions :: String, + serverMessage :: B.ByteString, + serverMessageForOldVersions :: B.ByteString, latestReleaseVersion :: Word16, listenPort :: PortNumber, nextRoomID :: Int, - dbHost :: String, - dbLogin :: String, - dbPassword :: String, - lastLogins :: [(String, UTCTime)], + dbHost :: B.ByteString, + dbLogin :: B.ByteString, + dbPassword :: B.ByteString, + lastLogins :: [(B.ByteString, UTCTime)], stats :: TMVar StatisticsInfo, coreChan :: Chan CoreMessage, dbQueries :: Chan DBQuery } instance Show ServerInfo where - show si = "Server Info" + show _ = "Server Info" +newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo newServerInfo = ( ServerInfo True @@ -160,29 +154,31 @@ ) data AccountInfo = - HasAccount String Bool + HasAccount B.ByteString Bool | Guest | Admin deriving (Show, Read) data DBQuery = - CheckAccount Int String String + CheckAccount ClientIndex B.ByteString B.ByteString | ClearCache | SendStats Int Int deriving (Show, Read) data CoreMessage = Accept ClientInfo - | ClientMessage (Int, [String]) - | ClientAccountInfo (Int, AccountInfo) + | ClientMessage (ClientIndex, [B.ByteString]) + | ClientAccountInfo (ClientIndex, AccountInfo) | TimerAction Int - -type Clients = IntMap.IntMap ClientInfo -type Rooms = IntMap.IntMap RoomInfo + | Remove ClientIndex ---type ClientsTransform = [ClientInfo] -> [ClientInfo] ---type RoomsTransform = [RoomInfo] -> [RoomInfo] ---type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo] ---type Answer = ServerInfo -> (HandlesSelector, [String]) +instance Show CoreMessage where + show (Accept _) = "Accept" + show (ClientMessage _) = "ClientMessage" + show (ClientAccountInfo _) = "ClientAccountInfo" + show (TimerAction _) = "TimerAction" + show (Remove _) = "Remove" + +type MRnC = MRoomsAndClients RoomInfo ClientInfo +type IRnC = IRoomsAndClients RoomInfo ClientInfo -type ClientsSelector = Clients -> Rooms -> [Int] diff -r 0313d5577fce -r 1f5604cd99be gameServer/HWProtoCore.hs --- a/gameServer/HWProtoCore.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/HWProtoCore.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,8 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} module HWProtoCore where import qualified Data.IntMap as IntMap import Data.Foldable -import Maybe +import Data.Maybe +import Control.Monad.Reader -------------------------------------- import CoreTypes import Actions @@ -10,35 +12,37 @@ import HWProtoNEState import HWProtoLobbyState import HWProtoInRoomState +import HandlerUtils +import RoomsAndClients handleCmd, handleCmd_loggedin :: CmdHandler -handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]] + +handleCmd ["PING"] = answerClient ["PONG"] -handleCmd clID clients rooms ("QUIT" : xs) = - [ByeClient msg] + +handleCmd ("QUIT" : xs) = return [ByeClient msg] where msg = if not $ null xs then head xs else "" - -handleCmd clID clients _ ["PONG"] = +{- +handleCmd ["PONG"] = if pingsQueue client == 0 then [ProtocolError "Protocol violation"] else [ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})] where client = clients IntMap.! clID - +-} -handleCmd clID clients rooms cmd = - if not $ logonPassed client then - handleCmd_NotEntered clID clients rooms cmd - else - handleCmd_loggedin clID clients rooms cmd - where - client = clients IntMap.! clID +handleCmd cmd = do + (ci, irnc) <- ask + if logonPassed (irnc `client` ci) then + handleCmd_loggedin cmd + else + handleCmd_NotEntered cmd - +{- handleCmd_loggedin clID clients rooms ["INFO", asknick] = if noSuchClient then [] @@ -62,11 +66,12 @@ then if teamsInGame client > 0 then "(playing)" else "(spectating)" else "" +-} -handleCmd_loggedin clID clients rooms cmd = - if roomID client == 0 then - handleCmd_lobby clID clients rooms cmd - else - handleCmd_inRoom clID clients rooms cmd - where - client = clients IntMap.! clID + +handleCmd_loggedin cmd = do + (ci, rnc) <- ask + if clientRoom rnc ci == lobbyId then + handleCmd_lobby cmd + else + handleCmd_inRoom cmd diff -r 0313d5577fce -r 1f5604cd99be gameServer/HWProtoInRoomState.hs --- a/gameServer/HWProtoInRoomState.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/HWProtoInRoomState.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,182 +1,240 @@ +{-# LANGUAGE OverloadedStrings #-} module HWProtoInRoomState where import qualified Data.Foldable as Foldable -import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Sequence(Seq, (|>), (><), fromList, empty) import Data.List -import Maybe +import Data.Maybe +import qualified Data.ByteString.Char8 as B +import Control.Monad +import Control.Monad.Reader -------------------------------------- import CoreTypes import Actions import Utils - +import HandlerUtils +import RoomsAndClients handleCmd_inRoom :: CmdHandler -handleCmd_inRoom clID clients _ ["CHAT", msg] = - [AnswerOthersInRoom ["CHAT", clientNick, msg]] - where - clientNick = nick $ clients IntMap.! clID +handleCmd_inRoom ["CHAT", msg] = do + n <- clientNick + s <- roomOthersChans + return [AnswerClients s ["CHAT", n, msg]] -handleCmd_inRoom clID clients rooms ["PART"] = - [RoomRemoveThisClient "part"] - where - client = clients IntMap.! clID +handleCmd_inRoom ["PART"] = return [MoveToLobby "part"] +handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg] -handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs) - | null paramStrs = [ProtocolError "Empty config entry"] - | isMaster client = - [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), - AnswerOthersInRoom ("CFG" : paramName : paramStrs)] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID +handleCmd_inRoom ("CFG" : paramName : paramStrs) + | null paramStrs = return [ProtocolError "Empty config entry"] + | otherwise = do + chans <- roomOthersChans + cl <- thisClient + if isMaster cl then + return [ + ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}), + AnswerClients chans ("CFG" : paramName : paramStrs)] + else + return [ProtocolError "Not room master"] -handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) - | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo) - | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"] - | length (teams room) == 6 = [Warning "too many teams"] - | canAddNumber <= 0 = [Warning "too many hedgehogs"] - | isJust findTeam = [Warning "There's already a team with same name in the list"] - | gameinprogress room = [Warning "round in progress"] - | isRestrictedTeams room = [Warning "restricted"] - | otherwise = - [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}), - ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), - AnswerThisClient ["TEAM_ACCEPTED", name], - AnswerOthersInRoom $ teamToNet (clientProto client) newTeam, - AnswerOthersInRoom ["TEAM_COLOR", name, color] - ] +handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo) + | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"] + | otherwise = do + (ci, rnc) <- ask + r <- thisRoom + clNick <- clientNick + clChan <- thisClientChans + othersChans <- roomOthersChans + return $ + if not . null . drop 5 $ teams r then + [Warning "too many teams"] + else if canAddNumber r <= 0 then + [Warning "too many hedgehogs"] + else if isJust $ findTeam r then + [Warning "There's already a team with same name in the list"] + else if gameinprogress r then + [Warning "round in progress"] + else if isRestrictedTeams r then + [Warning "restricted"] + else + [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}), + ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}), + AnswerClients clChan ["TEAM_ACCEPTED", name], + AnswerClients othersChans $ teamToNet $ newTeam ci clNick r, + AnswerClients othersChans ["TEAM_COLOR", name, color] + ] + where + canAddNumber r = 48 - (sum . map hhnum $ teams r) + findTeam = find (\t -> name == teamname t) . teams + newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo)) + difficulty = case B.readInt difStr of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 + hhsList [] = [] + hhsList [_] = error "Hedgehogs list with odd elements number" + hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs + newTeamHHNum r = min 4 (canAddNumber r) + +handleCmd_inRoom ["REMOVE_TEAM", name] = do + (ci, rnc) <- ask + r <- thisRoom + clNick <- clientNick + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if isNothing $ findTeam r then + [Warning "REMOVE_TEAM: no such team"] + else if clNick /= teamowner team then + [ProtocolError "Not team owner!"] + else + [RemoveTeam name, + ModifyClient + (\c -> c{ + teamsInGame = teamsInGame c - 1, + clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r + }) + ] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - canAddNumber = 48 - (sum . map hhnum $ teams room) - findTeam = find (\t -> name == teamname t) $ teams room - newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo)) - difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int) - hhsList [] = [] - hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs - newTeamHHNum = min 4 canAddNumber - -handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName] - | noSuchTeam = [Warning "REMOVE_TEAM: no such team"] - | nick client /= teamowner team = [ProtocolError "Not team owner!"] - | otherwise = - [RemoveTeam teamName, - ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan}) - ] - where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room + anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams + findTeam = find (\t -> name == teamname t) . teams -handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr] - | not $ isMaster client = [ProtocolError "Not room master"] - | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = [] - | otherwise = - [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, - AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]] +handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then + [] + else + [ModifyRoom $ modifyTeam team{hhnum = hhNumber}, + AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int) - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - canAddNumber = 48 - (sum . map hhnum $ teams room) + hhNumber = case B.readInt numberStr of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 + findTeam = find (\t -> teamName == teamname t) . teams + canAddNumber = (-) 48 . sum . map hhnum . teams + -handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor] - | not $ isMaster client = [ProtocolError "Not room master"] - | noSuchTeam = [] - | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor}, - AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor], +handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do + cl <- thisClient + others <- roomOthersChans + r <- thisRoom + + let maybeTeam = findTeam r + let team = fromJust maybeTeam + + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else if isNothing maybeTeam then + [] + else + [ModifyRoom $ modifyTeam team{teamcolor = newColor}, + AnswerClients others ["TEAM_COLOR", teamName, newColor], ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})] where - noSuchTeam = isNothing findTeam - team = fromJust findTeam - findTeam = find (\t -> teamName == teamname t) $ teams room - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) + findTeam = find (\t -> teamName == teamname t) . teams -handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] = - [ModifyClient (\c -> c{isReady = not $ isReady client}), - ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}), - AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]] - where - client = clients IntMap.! clID +handleCmd_inRoom ["TOGGLE_READY"] = do + cl <- thisClient + chans <- roomClientsChans + return [ + ModifyClient (\c -> c{isReady = not $ isReady cl}), + ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}), + AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl] + ] +handleCmd_inRoom ["START_GAME"] = do + cl <- thisClient + r <- thisRoom + chans <- roomClientsChans -handleCmd_inRoom clID clients rooms ["START_GAME"] = - if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then - if enoughClans then - [ModifyRoom + if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then + if enoughClans r then + return [ + ModifyRoom (\r -> r{ gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams r} ), - AnswerThisRoom ["RUN_GAME"]] + AnswerClients chans ["RUN_GAME"] + ] + else + return [Warning "Less than two clans!"] else - [Warning "Less than two clans!"] - else - [] + return [] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room + enoughClans = not . null . drop 1 . group . map teamcolor . teams -handleCmd_inRoom clID clients rooms ["EM", msg] = - if (teamsInGame client > 0) && isLegal then - (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] - else - [] +handleCmd_inRoom ["EM", msg] = do + cl <- thisClient + r <- thisRoom + chans <- roomOthersChans + + if (teamsInGame cl > 0) && isLegal then + return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive] + else + return [] where - client = clients IntMap.! clID (isLegal, isKeepAlive) = checkNetCmd msg -handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] = - if isMaster client then - [ModifyRoom + +handleCmd_inRoom ["ROUNDFINISHED"] = do + cl <- thisClient + r <- thisRoom + chans <- roomClientsChans + + if isMaster cl && (gameinprogress r) then + return $ (ModifyRoom (\r -> r{ gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []} - ), - UnreadyRoomClients - ] ++ answerRemovedTeams - else - [] + )) + : UnreadyRoomClients + : answerRemovedTeams chans r + else + return [] where - client = clients IntMap.! clID - room = rooms IntMap.! (roomID client) - answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room + answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams + +handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID - +handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do + cl <- thisClient + return $ + if not $ isMaster cl then + [ProtocolError "Not room master"] + else + [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] -handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"] - | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})] - | otherwise = [ProtocolError "Not room master"] - where - client = clients IntMap.! clID - +{- handleCmd_inRoom clID clients rooms ["KICK", kickNick] = [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)] where @@ -192,5 +250,5 @@ where client = clients IntMap.! clID engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20") - -handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"] +-} +handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"] diff -r 0313d5577fce -r 1f5604cd99be gameServer/HWProtoLobbyState.hs --- a/gameServer/HWProtoLobbyState.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/HWProtoLobbyState.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,73 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} module HWProtoLobbyState where import qualified Data.Map as Map -import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Foldable as Foldable -import Maybe +import Data.Maybe import Data.List import Data.Word +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B -------------------------------------- import CoreTypes import Actions import Utils +import HandlerUtils +import RoomsAndClients -answerAllTeams protocol teams = concatMap toAnswer teams +{-answerAllTeams protocol teams = concatMap toAnswer teams where toAnswer team = [AnswerThisClient $ teamToNet protocol team, AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team], AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]] - +-} handleCmd_lobby :: CmdHandler -handleCmd_lobby clID clients rooms ["LIST"] = - [AnswerThisClient ("ROOMS" : roomsInfoList)] + +handleCmd_lobby ["LIST"] = do + (ci, irnc) <- ask + let cl = irnc `client` ci + rooms <- allRoomInfos + let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r)) + return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)] where - roomsInfoList = concatMap roomInfo sameProtoRooms - sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList - roomsList = IntMap.elems rooms - protocol = clientProto client - client = clients IntMap.! clID - roomInfo room - | clientProto client < 28 = [ + roomInfo irnc room = [ + showB $ gameinprogress room, name room, - show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")", - show $ gameinprogress room - ] - | otherwise = [ - show $ gameinprogress room, - name room, - show $ playersIn room, - show $ length $ teams room, - nick $ clients IntMap.! (masterID room), + showB $ playersIn room, + showB $ length $ teams room, + nick $ irnc `client` masterID room, head (Map.findWithDefault ["+gen+"] "MAP" (params room)), head (Map.findWithDefault ["Default"] "SCHEME" (params room)), head (Map.findWithDefault ["Default"] "AMMO" (params room)) ] -handleCmd_lobby clID clients _ ["CHAT", msg] = - [AnswerOthersInRoom ["CHAT", clientNick, msg]] - where - clientNick = nick $ clients IntMap.! clID + +handleCmd_lobby ["CHAT", msg] = do + n <- clientNick + s <- roomOthersChans + return [AnswerClients s ["CHAT", n, msg]] + +handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword] + | illegalName newRoom = return [Warning "Illegal room name"] + | otherwise = do + rs <- allRoomInfos + cl <- thisClient + return $ if isJust $ find (\room -> newRoom == name room) rs then + [Warning "Room exists"] + else + [ + AddRoom newRoom roomPassword, + AnswerClients [sendChan cl] ["NOT_READY", nick cl] + ] + + +handleCmd_lobby ["CREATE_ROOM", newRoom] = + handleCmd_lobby ["CREATE_ROOM", newRoom, ""] -handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, roomPassword] - | haveSameRoom = [Warning "Room exists"] - | illegalName newRoom = [Warning "Illegal room name"] - | otherwise = - [RoomRemoveThisClient "", -- leave lobby - AddRoom newRoom roomPassword, - AnswerThisClient ["NOT_READY", clientNick] - ] +handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do + (ci, irnc) <- ask + let ris = allRooms irnc + cl <- thisClient + let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris + let jRI = fromJust maybeRI + let jRoom = irnc `room` jRI + let jRoomClients = map (client irnc) $! roomClients irnc jRI -- no lazyness here! + return $ + if isNothing maybeRI then + [Warning "No such rooms"] + else if isRestrictedJoins jRoom then + [Warning "Joining restricted"] + else if roomPassword /= password jRoom then + [Warning "Wrong password"] + else + [ + MoveToRoom jRI, + AnswerClients (map sendChan $ cl : jRoomClients) ["NOT_READY", nick cl] + ] + ++ [ AnswerClients [sendChan cl] $ "JOINED" : map nick jRoomClients | playersIn jRoom /= 0] + ++ (map (readynessMessage cl) jRoomClients) + where - clientNick = nick $ clients IntMap.! clID - haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms + readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c] -handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] = - handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""] +{- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword] | noSuchRoom = [Warning "No such room"] @@ -83,12 +112,6 @@ ++ answerTeams ++ watchRound where - noSuchRoom = isNothing mbRoom - mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms - jRoom = fromJust mbRoom - rID = roomUID jRoom - client = clients IntMap.! clID - roomClientsIDs = IntSet.elems $ playersIDs jRoom answerNicks = [AnswerThisClient $ "JOINED" : map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0] @@ -100,7 +123,7 @@ roomClientsIDs toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs - + answerFullConfig = map toAnswer (leftConfigPart ++ rightConfigPart) (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") (Map.toList $ params jRoom) @@ -114,12 +137,12 @@ answerAllTeams (clientProto client) (teamsAtStart jRoom) else answerAllTeams (clientProto client) (teams jRoom) - +-} -handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] = - handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""] - +handleCmd_lobby ["JOIN_ROOM", roomName] = + handleCmd_lobby ["JOIN_ROOM", roomName, ""] +{- handleCmd_lobby clID clients rooms ["FOLLOW", asknick] = if noSuchClient || roomID followClient == 0 then [] @@ -180,6 +203,7 @@ [ClearAccountsCache | isAdministrator client] where client = clients IntMap.! clID +-} -handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"] +handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"] diff -r 0313d5577fce -r 1f5604cd99be gameServer/HWProtoNEState.hs --- a/gameServer/HWProtoNEState.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/HWProtoNEState.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,54 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} module HWProtoNEState where import qualified Data.IntMap as IntMap -import Maybe +import Data.Maybe import Data.List import Data.Word +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B -------------------------------------- import CoreTypes import Actions import Utils +import RoomsAndClients handleCmd_NotEntered :: CmdHandler -handleCmd_NotEntered clID clients _ ["NICK", newNick] - | not . null $ nick client = [ProtocolError "Nickname already chosen"] - | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient ""] - | illegalName newNick = [ByeClient "Illegal nickname"] - | otherwise = - ModifyClient (\c -> c{nick = newNick}) : - AnswerThisClient ["NICK", newNick] : - [CheckRegistered | clientProto client /= 0] +handleCmd_NotEntered ["NICK", newNick] = do + (ci, irnc) <- ask + let cl = irnc `client` ci + if not . B.null $ nick cl then return [ProtocolError "Nickname already chosen"] + else + if haveSameNick irnc (nick cl) then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""] + else + if illegalName newNick then return [ByeClient "Illegal nickname"] + else + return $ + ModifyClient (\c -> c{nick = newNick}) : + AnswerClients [sendChan cl] ["NICK", newNick] : + [CheckRegistered | clientProto cl /= 0] where - client = clients IntMap.! clID - haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients + haveSameNick irnc clNick = isJust $ find (\cl -> newNick == clNick) $ map (client irnc) $ allClients irnc + +handleCmd_NotEntered ["PROTO", protoNum] = do + (ci, irnc) <- ask + let cl = irnc `client` ci + if clientProto cl > 0 then return [ProtocolError "Protocol already known"] + else + if parsedProto == 0 then return [ProtocolError "Bad number"] + else + return $ + ModifyClient (\c -> c{clientProto = parsedProto}) : + AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] : + [CheckRegistered | not . B.null $ nick cl] + where + parsedProto = case B.readInt protoNum of + Just (i, t) | B.null t -> fromIntegral i + otherwise -> 0 -handleCmd_NotEntered clID clients _ ["PROTO", protoNum] - | clientProto client > 0 = [ProtocolError "Protocol already known"] - | parsedProto == 0 = [ProtocolError "Bad number"] - | otherwise = - ModifyClient (\c -> c{clientProto = parsedProto}) : - AnswerThisClient ["PROTO", show parsedProto] : - [CheckRegistered | (not . null) (nick client)] - where - client = clients IntMap.! clID - parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16) +handleCmd_NotEntered ["PASSWORD", passwd] = do + (ci, irnc) <- ask + let cl = irnc `client` ci + if passwd == webPassword cl then + return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl] + else + return [ByeClient "Authentication failed"] -handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] = - if passwd == webPassword client then - [ModifyClient (\cl -> cl{logonPassed = True}), - MoveToLobby] ++ adminNotice - else - [ByeClient "Authentication failed"] - where - client = clients IntMap.! clID - adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client] - +{- handleCmd_NotEntered clID clients _ ["DUMP"] = if isAdministrator (clients IntMap.! clID) then [Dump] else [] - +-} -handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"] +handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"] diff -r 0313d5577fce -r 1f5604cd99be gameServer/HandlerUtils.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/HandlerUtils.hs Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,45 @@ +module HandlerUtils where + +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B + +import RoomsAndClients +import CoreTypes +import Actions + +thisClient :: Reader (ClientIndex, IRnC) ClientInfo +thisClient = do + (ci, rnc) <- ask + return $ rnc `client` ci + +thisRoom :: Reader (ClientIndex, IRnC) RoomInfo +thisRoom = do + (ci, rnc) <- ask + let ri = clientRoom rnc ci + return $ rnc `room` ri + +clientNick :: Reader (ClientIndex, IRnC) B.ByteString +clientNick = liftM nick thisClient + +roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan] +roomOthersChans = do + (ci, rnc) <- ask + let ri = clientRoom rnc ci + return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri) + +roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan] +roomClientsChans = do + (ci, rnc) <- ask + let ri = clientRoom rnc ci + return $ map (sendChan . client rnc) (roomClients rnc ri) + +thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan] +thisClientChans = do + (ci, rnc) <- ask + return $ [sendChan (rnc `client` ci)] + +answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action] +answerClient msg = thisClientChans >>= return . (: []) . flip AnswerClients msg + +allRoomInfos :: Reader (a, IRnC) [RoomInfo] +allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask diff -r 0313d5577fce -r 1f5604cd99be gameServer/NetRoutines.hs --- a/gameServer/NetRoutines.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/NetRoutines.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,46 +1,41 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module NetRoutines where -import Network import Network.Socket import System.IO -import Control.Concurrent import Control.Concurrent.Chan -import Control.Concurrent.STM import qualified Control.Exception as Exception import Data.Time +import Control.Monad ----------------------------- import CoreTypes -import ClientIO import Utils +import RoomsAndClients -acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO () -acceptLoop servSock coreChan clientCounter = do +acceptLoop :: Socket -> Chan CoreMessage -> IO () +acceptLoop servSock chan = forever $ do Exception.handle (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $ do - (socket, sockAddr) <- Network.Socket.accept servSock + (sock, sockAddr) <- Network.Socket.accept servSock - cHandle <- socketToHandle socket ReadWriteMode - hSetBuffering cHandle LineBuffering clientHost <- sockAddr2String sockAddr currentTime <- getCurrentTime - - sendChan <- newChan + + sendChan' <- newChan let newClient = (ClientInfo - nextID - sendChan - cHandle + sendChan' + sock clientHost currentTime "" "" False 0 - 0 + lobbyId 0 False False @@ -49,12 +44,5 @@ undefined ) - writeChan coreChan $ Accept newClient - - forkIO $ clientRecvLoop cHandle coreChan nextID - forkIO $ clientSendLoop cHandle coreChan sendChan nextID + writeChan chan $ Accept newClient return () - - acceptLoop servSock coreChan nextID - where - nextID = clientCounter + 1 diff -r 0313d5577fce -r 1f5604cd99be gameServer/OfficialServer/DBInteraction.hs --- a/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/OfficialServer/DBInteraction.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} module OfficialServer.DBInteraction ( startDBConnection @@ -11,8 +11,7 @@ import qualified Control.Exception as Exception import Control.Monad import qualified Data.Map as Map -import Monad -import Maybe +import Data.Maybe import System.Log.Logger import Data.Time ------------------------ @@ -21,7 +20,7 @@ localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] -fakeDbConnection serverInfo = do +fakeDbConnection serverInfo = forever $ do q <- readChan $ dbQueries serverInfo case q of CheckAccount clUid _ clHost -> do @@ -30,8 +29,6 @@ ClearCache -> return () SendStats {} -> return () - fakeDbConnection serverInfo - #if defined(OFFICIAL_SERVER) pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = diff -r 0313d5577fce -r 1f5604cd99be gameServer/OfficialServer/extdbinterface.hs --- a/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/OfficialServer/extdbinterface.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module Main where @@ -26,7 +26,7 @@ case q of CheckAccount clUid clNick _ -> do statement <- prepare dbConn dbQueryAccount - execute statement [SqlString $ clNick] + execute statement [SqlByteString $ clNick] passAndRole <- fetchRow statement finish statement let response = @@ -47,7 +47,7 @@ dbConnectionLoop mySQLConnectionInfo = - Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $ + Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ bracket (connectMySQL mySQLConnectionInfo) (disconnect) diff -r 0313d5577fce -r 1f5604cd99be gameServer/Opts.hs --- a/gameServer/Opts.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/Opts.hs Fri Nov 12 18:57:36 2010 -0500 @@ -3,10 +3,12 @@ getOpts, ) where -import System +import System.Environment import System.Console.GetOpt import Network import Data.Maybe ( fromMaybe ) +import qualified Data.ByteString.Char8 as B + import CoreTypes import Utils @@ -30,9 +32,9 @@ where readDedicated = fromMaybe True (maybeRead str :: Maybe Bool) -readDbLogin str opts = opts{dbLogin = str} -readDbPassword str opts = opts{dbPassword = str} -readDbHost str opts = opts{dbHost = str} +readDbLogin str opts = opts{dbLogin = B.pack str} +readDbPassword str opts = opts{dbPassword = B.pack str} +readDbHost str opts = opts{dbHost = B.pack str} getOpts :: ServerInfo -> IO ServerInfo getOpts opts = do diff -r 0313d5577fce -r 1f5604cd99be gameServer/RoomsAndClients.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/RoomsAndClients.hs Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,196 @@ +module RoomsAndClients( + RoomIndex(), + ClientIndex(), + MRoomsAndClients(), + IRoomsAndClients(), + newRoomsAndClients, + addRoom, + addClient, + removeRoom, + removeClient, + modifyRoom, + modifyClient, + lobbyId, + moveClientToLobby, + moveClientToRoom, + clientRoomM, + clientExists, + client, + room, + client'sM, + room'sM, + allClientsM, + clientsM, + roomClientsM, + roomClientsIndicesM, + withRoomsAndClients, + allRooms, + allClients, + clientRoom, + showRooms, + roomClients + ) where + + +import Store +import Control.Monad + + +data Room r = Room { + roomClients' :: [ClientIndex], + room' :: r + } + + +data Client c = Client { + clientRoom' :: RoomIndex, + client' :: c + } + + +newtype RoomIndex = RoomIndex ElemIndex + deriving (Eq) +newtype ClientIndex = ClientIndex ElemIndex + deriving (Eq, Show, Read, Ord) + +instance Show RoomIndex where + show (RoomIndex i) = 'r' : show i + +unRoomIndex :: RoomIndex -> ElemIndex +unRoomIndex (RoomIndex r) = r + +unClientIndex :: ClientIndex -> ElemIndex +unClientIndex (ClientIndex c) = c + + +newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) +newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) + + +lobbyId :: RoomIndex +lobbyId = RoomIndex firstIndex + + +newRoomsAndClients :: r -> IO (MRoomsAndClients r c) +newRoomsAndClients r = do + rooms <- newStore + clients <- newStore + let rnc = MRoomsAndClients (rooms, clients) + ri <- addRoom rnc r + when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" + return rnc + + +roomAddClient :: ClientIndex -> Room r -> Room r +roomAddClient cl room = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr + +roomRemoveClient :: ClientIndex -> Room r -> Room r +roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr + + +addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex +addRoom (MRoomsAndClients (rooms, _)) room = do + i <- addElem rooms (Room [] room) + return $ RoomIndex i + + +addClient :: MRoomsAndClients r c -> c -> IO ClientIndex +addClient (MRoomsAndClients (rooms, clients)) client = do + i <- addElem clients (Client lobbyId client) + modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId) + return $ ClientIndex i + +removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () +removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) + | room == lobbyId = error "Cannot delete lobby" + | otherwise = do + clIds <- liftM roomClients' $ readElem rooms ri + forM_ clIds (moveClientToLobby rnc) + removeElem rooms ri + + +removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () +removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do + RoomIndex ri <- liftM clientRoom' $ readElem clients ci + modifyElem rooms (roomRemoveClient cl) ri + removeElem clients ci + + +modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () +modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri + +modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () +modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci + +moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () +moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do + modifyElem rooms (roomRemoveClient cl) riFrom + modifyElem rooms (roomAddClient cl) riTo + modifyElem clients (\c -> c{clientRoom' = rt}) ci + + +moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () +moveClientToLobby rnc ci = do + room <- clientRoomM rnc ci + moveClientInRooms rnc room lobbyId ci + + +moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () +moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci + + +clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool +clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci + +clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex +clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) + +client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a +client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci) + +room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a +room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri) + +allClientsM :: MRoomsAndClients r c -> IO [ClientIndex] +allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients + +clientsM :: MRoomsAndClients r c -> IO [c] +clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci) + +roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex] +roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) + +roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c] +roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci) + +withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a +withRoomsAndClients (MRoomsAndClients (rooms, clients)) f = + withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c)) + +---------------------------------------- +----------- IRoomsAndClients ----------- + +showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String +showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) + where + showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r))) + showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c)) + + +allRooms :: IRoomsAndClients r c -> [RoomIndex] +allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms + +allClients :: IRoomsAndClients r c -> [ClientIndex] +allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients + +clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex +clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci) + +client :: IRoomsAndClients r c -> ClientIndex -> c +client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) + +room :: IRoomsAndClients r c -> RoomIndex -> r +room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri) + +roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex] +roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri) diff -r 0313d5577fce -r 1f5604cd99be gameServer/ServerCore.hs --- a/gameServer/ServerCore.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/ServerCore.hs Fri Nov 12 18:57:36 2010 -0500 @@ -2,69 +2,75 @@ import Network import Control.Concurrent -import Control.Concurrent.STM import Control.Concurrent.Chan import Control.Monad import qualified Data.IntMap as IntMap import System.Log.Logger +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Set as Set +import qualified Data.ByteString.Char8 as B -------------------------------------- import CoreTypes import NetRoutines -import Utils import HWProtoCore import Actions import OfficialServer.DBInteraction +import ServerState -timerLoop :: Int -> Chan CoreMessage -> IO() +timerLoop :: Int -> Chan CoreMessage -> IO () timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan -firstAway (_, a, b, c) = (a, b, c) -reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) -reactCmd serverInfo clID cmd clients rooms = - liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd +reactCmd :: [B.ByteString] -> StateT ServerState IO () +reactCmd cmd = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) + forM_ actions processAction -mainLoop :: ServerInfo -> Clients -> Rooms -> IO () -mainLoop serverInfo clients rooms = do - r <- readChan $ coreChan serverInfo - - (newServerInfo, mClients, mRooms) <- - case r of - Accept ci -> - liftM firstAway $ processAction - (clientUID ci, serverInfo, clients, rooms) (AddClient ci) +mainLoop :: StateT ServerState IO () +mainLoop = forever $ do + get >>= \s -> put $! s + + si <- gets serverInfo + r <- liftIO $ readChan $ coreChan si + + case r of + Accept ci -> processAction (AddClient ci) + + ClientMessage (ci, cmd) -> do + liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd) - ClientMessage (clID, cmd) -> do - debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) - if clID `IntMap.member` clients then - reactCmd serverInfo clID cmd clients rooms - else - do - debugM "Clients" "Message from dead client" - return (serverInfo, clients, rooms) + removed <- gets removedClients + when (not $ ci `Set.member` removed) $ do + as <- get + put $! as{clientIndex = Just ci} + reactCmd cmd + + Remove ci -> do + liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci + processAction (DeleteClient ci) - ClientAccountInfo (clID, info) -> - if clID `IntMap.member` clients then - liftM firstAway $ processAction - (clID, serverInfo, clients, rooms) - (ProcessAccountInfo info) - else - do - debugM "Clients" "Got info for dead client" - return (serverInfo, clients, rooms) + --else + --do + --debugM "Clients" "Message from dead client" + --return (serverInfo, rnc) - TimerAction tick -> - liftM firstAway $ - foldM processAction (0, serverInfo, clients, rooms) $ - PingAll : [StatsAction | even tick] - + ClientAccountInfo (ci, info) -> do + rnc <- gets roomsClients + exists <- liftIO $ clientExists rnc ci + when (exists) $ do + as <- get + put $! as{clientIndex = Just ci} + processAction (ProcessAccountInfo info) + return () - {- let hadRooms = (not $ null rooms) && (null mrooms) - in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ - mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} + TimerAction tick -> + mapM_ processAction $ + PingAll : [StatsAction | even tick] - mainLoop newServerInfo mClients mRooms startServer :: ServerInfo -> Socket -> IO () startServer serverInfo serverSocket = do @@ -74,14 +80,15 @@ acceptLoop serverSocket (coreChan serverInfo) - 0 return () - - forkIO $ timerLoop 0 $ coreChan serverInfo + + --forkIO $ timerLoop 0 $ coreChan serverInfo startDBConnection serverInfo - forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) + rnc <- newRoomsAndClients newRoom - forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" \ No newline at end of file + forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc) + + forever $ threadDelay (60 * 60 * 10^6) diff -r 0313d5577fce -r 1f5604cd99be gameServer/ServerState.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/ServerState.hs Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,43 @@ +module ServerState + ( + module RoomsAndClients, + clientRoomA, + ServerState(..), + client's, + allClientsS, + roomClientsS + ) where + +import Control.Monad.State.Strict +import Data.Set as Set +---------------------- +import RoomsAndClients +import CoreTypes + +data ServerState = ServerState { + clientIndex :: !(Maybe ClientIndex), + serverInfo :: !ServerInfo, + removedClients :: !(Set.Set ClientIndex), + roomsClients :: !MRnC + } + + +clientRoomA :: StateT ServerState IO RoomIndex +clientRoomA = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + liftIO $ clientRoomM rnc ci + +client's :: (ClientInfo -> a) -> StateT ServerState IO a +client's f = do + (Just ci) <- gets clientIndex + rnc <- gets roomsClients + liftIO $ client'sM rnc f ci + +allClientsS :: StateT ServerState IO [ClientInfo] +allClientsS = gets roomsClients >>= liftIO . clientsM + +roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo] +roomClientsS ri = do + rnc <- gets roomsClients + liftIO $ roomClientsM rnc ri diff -r 0313d5577fce -r 1f5604cd99be gameServer/Store.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/Store.hs Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,145 @@ +module Store( + ElemIndex(), + MStore(), + IStore(), + newStore, + addElem, + removeElem, + readElem, + writeElem, + modifyElem, + elemExists, + firstIndex, + indicesM, + withIStore, + withIStore2, + (!), + indices + ) where + +import qualified Data.Array.IArray as IA +import qualified Data.Array.IO as IOA +import qualified Data.IntSet as IntSet +import Data.IORef +import Control.Monad + + +newtype ElemIndex = ElemIndex Int + deriving (Eq, Show, Read, Ord) +newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e)) +newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e) + + +firstIndex :: ElemIndex +firstIndex = ElemIndex 0 + +-- MStore code +initialSize :: Int +initialSize = 10 + + +growFunc :: Int -> Int +growFunc a = a * 3 `div` 2 + + +newStore :: IO (MStore e) +newStore = do + newar <- IOA.newArray_ (0, initialSize - 1) + new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar) + return (MStore new) + + +growStore :: MStore e -> IO () +growStore (MStore ref) = do + (busyElems, freeElems, arr) <- readIORef ref + (_, m') <- IOA.getBounds arr + let newM' = growFunc (m' + 1) - 1 + newArr <- IOA.newArray_ (0, newM') + sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']] + writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr) + + +growIfNeeded :: MStore e -> IO () +growIfNeeded m@(MStore ref) = do + (_, freeElems, _) <- readIORef ref + when (IntSet.null freeElems) $ growStore m + + +addElem :: MStore e -> e -> IO ElemIndex +addElem m@(MStore ref) element = do + growIfNeeded m + (busyElems, freeElems, arr) <- readIORef ref + let (n, freeElems') = IntSet.deleteFindMin freeElems + IOA.writeArray arr n element + writeIORef ref (IntSet.insert n busyElems, freeElems', arr) + return $ ElemIndex n + + +removeElem :: MStore e -> ElemIndex -> IO () +removeElem (MStore ref) (ElemIndex n) = do + (busyElems, freeElems, arr) <- readIORef ref + IOA.writeArray arr n (error $ "Store: no element " ++ show n) + writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr) + + +readElem :: MStore e -> ElemIndex -> IO e +readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n + + +writeElem :: MStore e -> ElemIndex -> e -> IO () +writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el + + +modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO () +modifyElem (MStore ref) f (ElemIndex n) = do + (_, _, arr) <- readIORef ref + IOA.readArray arr n >>= IOA.writeArray arr n . f + +elemExists :: MStore e -> ElemIndex -> IO Bool +elemExists (MStore ref) (ElemIndex n) = do + (_, free, _) <- readIORef ref + return $ n `IntSet.notMember` free + +indicesM :: MStore e -> IO [ElemIndex] +indicesM (MStore ref) = do + (busy, _, _) <- readIORef ref + return $ map ElemIndex $ IntSet.toList busy + + +-- A way to see MStore elements in pure code via IStore +m2i :: MStore e -> IO (IStore e) +m2i (MStore ref) = do + (a, _, c') <- readIORef ref + c <- IOA.unsafeFreeze c' + return $ IStore (a, c) + +i2m :: (MStore e) -> IStore e -> IO () +i2m (MStore ref) (IStore (_, arr)) = do + (b, e, _) <- readIORef ref + a <- IOA.unsafeThaw arr + writeIORef ref (b, e, a) + +withIStore :: MStore e -> (IStore e -> a) -> IO a +withIStore m f = do + i <- m2i m + let res = f i + res `seq` i2m m i + return res + + +withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a +withIStore2 m1 m2 f = do + i1 <- m2i m1 + i2 <- m2i m2 + let res = f i1 i2 + res `seq` i2m m1 i1 + i2m m2 i2 + return res + + +-- IStore code +(!) :: IStore e -> ElemIndex -> e +(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i + +indices :: IStore e -> [ElemIndex] +indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy diff -r 0313d5577fce -r 1f5604cd99be gameServer/Utils.hs --- a/gameServer/Utils.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/Utils.hs Fri Nov 12 18:57:36 2010 -0500 @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Utils where import Control.Concurrent @@ -13,36 +14,33 @@ import System.IO import qualified Data.List as List import Control.Monad -import Maybe +import Data.Maybe ------------------------------------------------- import qualified Codec.Binary.Base64 as Base64 -import qualified Data.ByteString.UTF8 as BUTF8 -import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as BW import CoreTypes -sockAddr2String :: SockAddr -> IO String -sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr +sockAddr2String :: SockAddr -> IO B.ByteString +sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = - return $ (foldr1 (.) + return $ B.pack $ (foldr1 (.) $ List.intersperse (\a -> ':':a) $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) [] -toEngineMsg :: String -> String -toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg)) - where - encodedMsg = BUTF8.fromString msg +toEngineMsg :: B.ByteString -> B.ByteString +toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg)) -fromEngineMsg :: String -> Maybe String -fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength) +fromEngineMsg :: B.ByteString -> Maybe B.ByteString +fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack where removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing removeLength _ = Nothing -checkNetCmd :: String -> (Bool, Bool) -checkNetCmd msg = check decoded +checkNetCmd :: B.ByteString -> (Bool, Bool) +checkNetCmd = check . liftM B.unpack . fromEngineMsg where - decoded = fromEngineMsg msg check Nothing = (False, False) check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+') check _ = (False, False) @@ -54,29 +52,17 @@ [(x, rest)] | all isSpace rest -> Just x _ -> Nothing -teamToNet :: Word16 -> TeamInfo -> [String] -teamToNet protocol team - | protocol < 30 = [ - "ADD_TEAM", - teamname team, - teamgrave team, - teamfort team, - teamvoicepack team, - teamowner team, - show $ difficulty team - ] - ++ hhsInfo - | otherwise = [ - "ADD_TEAM", - teamname team, - teamgrave team, - teamfort team, - teamvoicepack team, - teamflag team, - teamowner team, - show $ difficulty team - ] - ++ hhsInfo +teamToNet :: TeamInfo -> [B.ByteString] +teamToNet team = + "ADD_TEAM" + : teamname team + : teamgrave team + : teamfort team + : teamvoicepack team + : teamflag team + : teamowner team + : (B.pack $ show $ difficulty team) + : hhsInfo where hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team @@ -90,10 +76,10 @@ else t : replaceTeam team teams -illegalName :: String -> Bool -illegalName = all isSpace +illegalName :: B.ByteString -> Bool +illegalName = all isSpace . B.unpack -protoNumber2ver :: Word16 -> String +protoNumber2ver :: Word16 -> B.ByteString protoNumber2ver 17 = "0.9.7-dev" protoNumber2ver 19 = "0.9.7" protoNumber2ver 20 = "0.9.8-dev" @@ -116,3 +102,13 @@ putStr msg hFlush stdout getLine + + +unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b) +unfoldrE f b = + case f b of + Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b') + Left new_b -> ([], new_b) + +showB :: Show a => a -> B.ByteString +showB = B.pack .show diff -r 0313d5577fce -r 1f5604cd99be gameServer/hedgewars-server.cabal --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/hedgewars-server.cabal Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,32 @@ +Name: hedgewars-server +Version: 0.1 +Synopsis: hedgewars server +Description: hedgewars server +Homepage: http://www.hedgewars.org/ +License: GPL-2 +Author: unC0Rr +Maintainer: unC0Rr@hedgewars.org +Category: Game +Build-type: Simple +Cabal-version: >=1.2 + + +Executable hedgewars-server + main-is: hedgewars-server.hs + + Build-depends: + base >= 4, + unix, + containers, + array, + bytestring, + network-bytestring, + network, + time, + stm, + mtl, + dataenc, + hslogger, + process + + ghc-options: -O2 \ No newline at end of file diff -r 0313d5577fce -r 1f5604cd99be gameServer/hedgewars-server.hs --- a/gameServer/hedgewars-server.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/hedgewars-server.hs Fri Nov 12 18:57:36 2010 -0500 @@ -2,23 +2,15 @@ module Main where -import Network.Socket -import qualified Network -import Network.BSD +import Network import Control.Concurrent.STM import Control.Concurrent.Chan -#if defined(NEW_EXCEPTIONS) -import qualified Control.OldException as Exception -#else import qualified Control.Exception as Exception -#endif import System.Log.Logger ----------------------------------- import Opts import CoreTypes -import OfficialServer.DBInteraction import ServerCore -import Utils #if !defined(mingw32_HOST_OS) @@ -26,10 +18,12 @@ #endif +setupLoggers :: IO () setupLoggers = updateGlobalLogger "Clients" (setLevel INFO) +main :: IO () main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; @@ -38,11 +32,11 @@ setupLoggers - stats <- atomically $ newTMVar (StatisticsInfo 0 0) + stats' <- atomically $ newTMVar (StatisticsInfo 0 0) dbQueriesChan <- newChan - coreChan <- newChan - serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan - + coreChan' <- newChan + serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan + #if defined(OFFICIAL_SERVER) dbHost' <- askFromConsole "DB host: " dbLogin' <- askFromConsole "login: " @@ -52,14 +46,7 @@ let serverInfo = serverInfo' #endif - - proto <- getProtocolNumber "tcp" Exception.bracket - (socket AF_INET Stream proto) + (Network.listenOn $ Network.PortNumber $ listenPort serverInfo) sClose - (\sock -> do - setSocketOption sock ReuseAddr 1 - bindSocket sock (SockAddrInet (listenPort serverInfo) iNADDR_ANY) - listen sock maxListenQueue - startServer serverInfo sock - ) + (startServer serverInfo) diff -r 0313d5577fce -r 1f5604cd99be gameServer/stresstest.hs --- a/gameServer/stresstest.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/stresstest.hs Fri Nov 12 18:57:36 2010 -0500 @@ -6,7 +6,7 @@ import System.IO import Control.Concurrent import Network -import Control.Exception +import Control.OldException import Control.Monad import System.Random @@ -14,24 +14,24 @@ import System.Posix #endif -session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT", "lobby 1", "", "CREATE", room, "", "CHAT", "room 1", "", "QUIT", "bye-bye", ""] -session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "bye-bye", ""] -session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "QUIT", "bye-bye", ""] +session1 nick room = ["NICK", nick, "", "PROTO", "32", "", "PING", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""] +session2 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROOM", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""] +session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""] emulateSession sock s = do - mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s + mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s hFlush sock threadDelay 225000 -testing = Control.Exception.handle print $ do +testing = Control.OldException.handle print $ do putStrLn "Start" sock <- connectTo "127.0.0.1" (PortNumber 46631) num1 <- randomRIO (70000::Int, 70100) num2 <- randomRIO (0::Int, 2) num3 <- randomRIO (0::Int, 5) - let nick1 = show num1 - let room1 = show num2 + let nick1 = 'n' : show num1 + let room1 = 'r' : show num2 case num2 of 0 -> emulateSession sock $ session1 nick1 room1 1 -> emulateSession sock $ session2 nick1 room1 @@ -40,7 +40,7 @@ putStrLn "Finish" forks = forever $ do - delay <- randomRIO (10000::Int, 19000) + delay <- randomRIO (30000::Int, 59000) threadDelay delay forkIO testing diff -r 0313d5577fce -r 1f5604cd99be gameServer/stresstest2.hs --- a/gameServer/stresstest2.hs Fri Nov 12 18:32:56 2010 -0500 +++ b/gameServer/stresstest2.hs Fri Nov 12 18:57:36 2010 -0500 @@ -6,7 +6,7 @@ import System.IO import Control.Concurrent import Network -import Control.Exception +import Control.OldException import Control.Monad import System.Random @@ -14,22 +14,28 @@ import System.Posix #endif -testing = Control.Exception.handle print $ do - delay <- randomRIO (100::Int, 300) - threadDelay delay +session1 nick room = ["NICK", nick, "", "PROTO", "32", ""] + + + +testing = Control.OldException.handle print $ do + putStrLn "Start" sock <- connectTo "127.0.0.1" (PortNumber 46631) - hClose sock -forks i = do - delay <- randomRIO (50::Int, 190) - if i `mod` 10 == 0 then putStr (show i) else putStr "." - hFlush stdout - threadDelay delay - forkIO testing - forks (i + 1) + num1 <- randomRIO (70000::Int, 70100) + num2 <- randomRIO (0::Int, 2) + num3 <- randomRIO (0::Int, 5) + let nick1 = 'n' : show num1 + let room1 = 'r' : show num2 + mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300::Int, 590) >>= threadDelay) $ session1 nick1 room1 + mapM_ (\x -> hPutStrLn sock x >> hFlush sock) $ concatMap (\x -> ["CHAT_MSG", show x, ""]) [1..] + hClose sock + putStrLn "Finish" + +forks = testing main = withSocketsDo $ do #if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing; #endif - forks 1 + forks diff -r 0313d5577fce -r 1f5604cd99be gameServer/stresstest3.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gameServer/stresstest3.hs Fri Nov 12 18:57:36 2010 -0500 @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import IO +import System.IO +import Control.Concurrent +import Network +import Control.OldException +import Control.Monad +import System.Random +import Control.Monad.State +import Data.List + +#if !defined(mingw32_HOST_OS) +import System.Posix +#endif + +type SState = Handle +io = liftIO + +readPacket :: StateT SState IO [String] +readPacket = do + h <- get + p <- io $ hGetPacket h [] + return p + where + hGetPacket h buf = do + l <- hGetLine h + if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf + +waitPacket :: String -> StateT SState IO Bool +waitPacket s = do + p <- readPacket + return $ head p == s + +sendPacket :: [String] -> StateT SState IO () +sendPacket s = do + h <- get + io $ do + mapM_ (hPutStrLn h) s + hPutStrLn h "" + hFlush h + +emulateSession :: StateT SState IO () +emulateSession = do + n <- io $ randomRIO (100000::Int, 100100) + waitPacket "CONNECTED" + sendPacket ["NICK", "test" ++ (show n)] + waitPacket "NICK" + sendPacket ["PROTO", "31"] + waitPacket "PROTO" + b <- waitPacket "LOBBY:JOINED" + --io $ print b + sendPacket ["QUIT", "BYE"] + return () + +testing = Control.OldException.handle print $ do + putStr "+" + sock <- connectTo "127.0.0.1" (PortNumber 46631) + evalStateT emulateSession sock + --hClose sock + putStr "-" + hFlush stdout + +forks = forM_ [1..100] $ const $ do + delay <- randomRIO (10000::Int, 30000) + threadDelay delay + forkIO testing + +main = withSocketsDo $ do +#if !defined(mingw32_HOST_OS) + installHandler sigPIPE Ignore Nothing; +#endif + forks diff -r 0313d5577fce -r 1f5604cd99be hedgewars/GSHandlers.inc --- a/hedgewars/GSHandlers.inc Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/GSHandlers.inc Fri Nov 12 18:57:36 2010 -0500 @@ -318,6 +318,7 @@ if Gear^.AdvBounce > 1 then dec(Gear^.AdvBounce); if isFalling then Gear^.dY := Gear^.dY + cGravity; + if (GameFlags and gfMoreWind) <> 0 then Gear^.dX := Gear^.dX + cWindSpeed * _4 / Gear^.Radius; Gear^.X := Gear^.X + Gear^.dX; Gear^.Y := Gear^.Y + Gear^.dY; @@ -512,7 +513,7 @@ procedure doStepShell(Gear: PGear); begin AllInactive := false; - Gear^.dX := Gear^.dX + cWindSpeed; + if (GameFlags and gfMoreWind) = 0 then Gear^.dX := Gear^.dX + cWindSpeed; doStepFallingGear(Gear); if (Gear^.State and gstCollision) <> 0 then begin @@ -704,6 +705,7 @@ var i, x, y: LongWord; oX, oY: hwFloat; + trail: PVisualGear; begin AllInactive := false; inc(Gear^.Timer); @@ -750,6 +752,29 @@ cLaserSighting := false; if (Ammoz[Gear^.AmmoType].Ammo.NumPerTurn <= CurrentHedgehog^.MultiShootAttacks) and ((GameFlags and gfArtillery) = 0) then cArtillery := false; + + // Bullet trail + trail := AddVisualGear( + hwround(CurrentHedgehog^.Gear^.X) + GetLaunchX(CurrentHedgehog^.CurAmmoType, hwSign(CurrentHedgehog^.Gear^.dX), CurrentHedgehog^.Gear^.Angle), + hwround(CurrentHedgehog^.Gear^.Y) + GetLaunchY(CurrentHedgehog^.CurAmmoType, CurrentHedgehog^.Gear^.Angle), + vgtLineTrail + ); + if trail <> nil then + begin + trail^.dX := Gear^.X.QWordValue / _1.QWordValue; + trail^.dY := Gear^.Y.QWordValue / _1.QWordValue; + + // reached edge of land. assume infinite beam. Extend it way out past camera + if (hwRound(Gear^.X) and LAND_WIDTH_MASK <> 0) + or (hwRound(Gear^.Y) and LAND_HEIGHT_MASK <> 0) then + begin + trail^.dX := trail^.dX + (CurrentHedgehog^.Gear^.dX * LAND_WIDTH).QWordValue / _1.QWordValue; + trail^.dY := trail^.dY + (CurrentHedgehog^.Gear^.dY * LAND_WIDTH).QWordValue / _1.QWordValue; + end; + + trail^.Timer := 200; + end; + Gear^.doStep := @doStepShotIdle end; end; @@ -2059,6 +2084,10 @@ 2: for i:= -19 to 19 do FollowGear := AddGear(hwRound(Gear^.X) + i div 3, hwRound(Gear^.Y), gtFlame, 0, _0_001 * i, _0, 0); + 3: FollowGear := AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtDrill, gsttmpFlag, cBombsSpeed * + Gear^.Tag, _0, 0); + //4: FollowGear := AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtWaterMelon, 0, cBombsSpeed * + // Gear^.Tag, _0, 5000); end; Gear^.dX := Gear^.dX + int2hwFloat(30 * Gear^.Tag) end; @@ -2700,6 +2729,8 @@ Gear^.X := Gear^.X + Gear^.dX; Gear^.Y := Gear^.Y + Gear^.dY; DrawTunnel(oX, oY, Gear^.dX, Gear^.dY, 2, 6); + if (Gear^.Timer mod 30) = 0 then + AddVisualGear(hwRound(Gear^.X + _20 * Gear^.dX), hwRound(Gear^.Y + _20 * Gear^.dY), vgtDust); if (CheckGearDrowning(Gear)) then begin StopSound(Gear^.SoundChannel); @@ -2718,7 +2749,10 @@ begin //out of time or exited ground StopSound(Gear^.SoundChannel); - doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound); + if (Gear^.State and gsttmpFlag) <> 0 then + doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound) + else + doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound); DeleteGear(Gear); exit end; @@ -2734,7 +2768,9 @@ begin AllInactive := false; - Gear^.dX := Gear^.dX + cWindSpeed; + if (Gear^.State and gsttmpFlag) = 0 then + Gear^.dX := Gear^.dX + cWindSpeed; + oldDx := Gear^.dX; oldDy := Gear^.dY; @@ -2760,7 +2796,10 @@ else begin //explode right on contact with HH - doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound); + if (Gear^.State and gsttmpFlag) <> 0 then + doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound) + else + doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound); DeleteGear(Gear); exit; end; @@ -3046,6 +3085,7 @@ Gear^.Timer := GameTicks end end; + if not isUnderwater and ((GameFlags and gfMoreWind) <> 0) then HHGear^.dX := HHGear^.dX + cWindSpeed * _4 / HHGear^.Radius; // erases them all at once :-/ if (Gear^.Timer <> 0) and (GameTicks - Gear^.Timer > 250) then @@ -3164,19 +3204,20 @@ Gear^.Tag := 1; if (HHGear^.Message and gmUp) <> 0 then - begin + begin if (not HHGear^.dY.isNegative) or (HHGear^.Y > -_256) then HHGear^.dY := HHGear^.dY - move; dec(Gear^.Health, fuel); Gear^.MsgParam := Gear^.MsgParam or gmUp; - end; + end; if (HHGear^.Message and gmLeft) <> 0 then move.isNegative := true; if (HHGear^.Message and (gmLeft or gmRight)) <> 0 then - begin + begin HHGear^.dX := HHGear^.dX + (move * _0_1); dec(Gear^.Health, fuel div 5); Gear^.MsgParam := Gear^.MsgParam or (HHGear^.Message and (gmLeft or gmRight)); - end; + end; + if (GameFlags and gfMoreWind) <> 0 then HHGear^.dX := HHGear^.dX + cWindSpeed * _4 / HHGear^.Radius; if Gear^.Health < 0 then Gear^.Health := 0; if ((GameTicks and $FF) = 0) and (Gear^.Health < 500) then @@ -3184,16 +3225,15 @@ AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtFeather); if (HHGear^.Message and gmAttack <> 0) then - begin + begin HHGear^.Message := HHGear^.Message and not gmAttack; if Gear^.FlightTime > 0 then - begin - AddGear(hwRound(Gear^.X), hwRound(Gear^.Y) + 32, gtEgg, 0, Gear^.dX * _0_5, Gear^.dY, 0) - ; + begin + AddGear(hwRound(Gear^.X), hwRound(Gear^.Y) + 32, gtEgg, 0, Gear^.dX * _0_5, Gear^.dY, 0); PlaySound(sndBirdyLay); dec(Gear^.FlightTime) + end; end; - end; if HHGear^.Message and (gmUp or gmPrecise or gmLeft or gmRight) <> 0 then Gear^.State := Gear^.State and not gsttmpFlag; @@ -3215,25 +3255,25 @@ or (((GameTicks and $1FF) = 0) and (not HHGear^.dY.isNegative) and TestCollisionYwithGear( HHGear, 1)) or ((Gear^.Message and gmAttack) <> 0) then - begin + begin with HHGear^ do - begin + begin Message := 0; Active := true; State := State or gstMoving - end; + end; Gear^.State := Gear^.State or gstAnimation or gstTmpFlag; if HHGear^.dY < _0 then - begin + begin Gear^.dX := HHGear^.dX; Gear^.dY := HHGear^.dY; - end; + end; Gear^.Timer := 0; Gear^.doStep := @doStepBirdyDisappear; CurAmmoGear := nil; isCursorVisible := false; AfterAttack; - end + end end; //////////////////////////////////////////////////////////////////////////////// @@ -4198,7 +4238,7 @@ Gear^.doStep := @doStepHammerHitWork end; - +//////////////////////////////////////////////////////////////////////////////// procedure doStepResurrectorWork(Gear: PGear); var graves: TPGearArray; @@ -4313,3 +4353,5 @@ end end; +//////////////////////////////////////////////////////////////////////////////// + diff -r 0313d5577fce -r 1f5604cd99be hedgewars/GearDrawing.inc --- a/hedgewars/GearDrawing.inc Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/GearDrawing.inc Fri Nov 12 18:57:36 2010 -0500 @@ -126,22 +126,7 @@ //if (abs(lx-tx)>8) or (abs(ly-ty)>8) then begin - glDisable(GL_TEXTURE_2D); - glEnable(GL_LINE_SMOOTH); - - glLineWidth(1.0); - - Tint($FF, $00, $00, $C0); - VertexBuffer[0].X:= hx + WorldDx; - VertexBuffer[0].Y:= hy + WorldDy; - VertexBuffer[1].X:= tx + WorldDx; - VertexBuffer[1].Y:= ty + WorldDy; - - glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); - glDrawArrays(GL_LINES, 0, Length(VertexBuffer)); - Tint($FF, $FF, $FF, $FF); - glEnable(GL_TEXTURE_2D); - glDisable(GL_LINE_SMOOTH); + DrawLine(hx, hy, tx, ty, 1.0, $FF, $00, $00, $C0); end; end; // draw crosshair @@ -438,7 +423,8 @@ case amt of amAirAttack, - amMineStrike: DrawRotated(sprHandAirAttack, sx, oy, sign, 0); + amMineStrike, + amDrillStrike: DrawRotated(sprHandAirAttack, sx, oy, sign, 0); amPickHammer: DrawHedgehog(sx, sy, sign, 1, diff -r 0313d5577fce -r 1f5604cd99be hedgewars/HHHandlers.inc --- a/hedgewars/HHHandlers.inc Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/HHHandlers.inc Fri Nov 12 18:57:36 2010 -0500 @@ -305,6 +305,8 @@ gtResurrector, 0, _0, _0, 0); CurAmmoGear^.SoundChannel := LoopSound(sndResurrector); end; + amDrillStrike: AddGear(CurWeapon^.Pos, 0, gtAirAttack, 3, _0, _0, 0); + //amMelonStrike: AddGear(CurWeapon^.Pos, 0, gtAirAttack, 4, _0, _0, 0); end; uStats.AmmoUsed(CurAmmoType); diff -r 0313d5577fce -r 1f5604cd99be hedgewars/VGSHandlers.inc --- a/hedgewars/VGSHandlers.inc Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/VGSHandlers.inc Fri Nov 12 18:57:36 2010 -0500 @@ -133,6 +133,16 @@ end; //////////////////////////////////////////////////////////////////////////////// +procedure doStepLineTrail(Gear: PVisualGear; Steps: Longword); +begin +Steps := Steps; +if Gear^.Timer <= Steps then + DeleteVisualGear(Gear) +else + dec(Gear^.Timer, Steps) +end; + +//////////////////////////////////////////////////////////////////////////////// procedure doStepEgg(Gear: PVisualGear; Steps: Longword); begin Gear^.X:= Gear^.X + Gear^.dX * Steps; diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uAIAmmoTests.pas --- a/hedgewars/uAIAmmoTests.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uAIAmmoTests.pas Fri Nov 12 18:57:36 2010 -0500 @@ -101,7 +101,8 @@ (proc: nil; flags: 0), // amFlamethrower (proc: @TestGrenade; flags: 0), // amSMine (proc: @TestFirePunch; flags: 0), // amHammer - (proc: nil; flags: 0) // amResurrector + (proc: nil; flags: 0), // amResurrector + (proc: nil; flags: 0) // amDrillStrike ); const BadTurn = Low(LongInt) div 4; diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uConsts.pas --- a/hedgewars/uConsts.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uConsts.pas Fri Nov 12 18:57:36 2010 -0500 @@ -89,7 +89,7 @@ gtHellishBomb, gtWaterUp, gtDrill, gtBallGun, gtBall, gtRCPlane, // 40 gtSniperRifleShot, gtJetpack, gtMolotov, gtExplosives, gtBirdy, // 45 gtEgg, gtPortal, gtPiano, gtGasBomb, gtSineGunShot, gtFlamethrower, // 51 - gtSMine, gtPoisonCloud, gtHammer, gtHammerHit, gtResurrector); + gtSMine, gtPoisonCloud, gtHammer, gtHammerHit, gtResurrector); // 56 // Gears that are _only_ of visual nature (e.g. background stuff, visual effects, speechbubbles, etc.) TVisualGearType = (vgtFlake, vgtCloud, vgtExplPart, vgtExplPart2, vgtFire, @@ -97,7 +97,7 @@ vgtSteam, vgtAmmo, vgtSmoke, vgtSmokeWhite, vgtHealth, vgtShell, vgtDust, vgtSplash, vgtDroplet, vgtSmokeRing, vgtBeeTrace, vgtEgg, vgtFeather, vgtHealthTag, vgtSmokeTrace, vgtEvilTrace, vgtExplosion, - vgtBigExplosion, vgtChunk, vgtNote); + vgtBigExplosion, vgtChunk, vgtNote, vgtLineTrail); TGearsType = set of TGearType; @@ -134,7 +134,7 @@ amRCPlane, amLowGravity, amExtraDamage, amInvulnerable, amExtraTime, // 35 amLaserSight, amVampiric, amSniperRifle, amJetpack, amMolotov, amBirdy, amPortalGun, // 42 amPiano, amGasBomb, amSineGun, amFlamethrower, amSMine, amHammer, // 48 - amResurrector); + amResurrector, amDrillStrike); TCrateType = (HealthCrate, AmmoCrate, UtilityCrate); @@ -355,6 +355,7 @@ gfResetWeps = $00200000; gfPerHogAmmo = $00400000; gfDisableWind = $00800000; // only lua for now + gfMoreWind = $01000000; // NOTE: When adding new game flags, ask yourself // if a "game start notice" would be useful. If so, // add one in uWorld.pas - look for "AddGoal". @@ -2183,6 +2184,7 @@ ejectX: 0; ejectY: 0), +// Ressurrector (NameId: sidResurrector; NameTex: nil; Probability: 0; @@ -2205,6 +2207,33 @@ PosCount: 1; PosSprite: sprWater; ejectX: 0; + ejectY: 0), + +// DrillStrike + (NameId: sidDrillStrike; + NameTex: nil; + Probability: 200; + NumberInCase: 1; + Ammo: (Propz: ammoprop_NoCrosshair or + ammoprop_NeedTarget or + ammoprop_AttackingPut or + ammoprop_DontHold or + ammoprop_NotBorder; + Count: 1; + NumPerTurn: 0; + Timer: 0; + Pos: 0; + AmmoType: amDrillStrike; + AttackVoice: sndIncoming); + Slot: 5; + TimeAfterTurn: 0; + minAngle: 0; + maxAngle: 0; + isDamaging: true; + SkipTurns: 6; + PosCount: 2; + PosSprite: sprAmAirplane; + ejectX: 0; ejectY: 0) ); diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uGears.pas --- a/hedgewars/uGears.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uGears.pas Fri Nov 12 18:57:36 2010 -0500 @@ -365,9 +365,9 @@ gear^.Elasticity:= _0_55; gear^.Friction:= _0_995; if cMinesTime < 0 then - gear^.Timer:= getrandom(6)*1000 + gear^.Timer:= getrandom(51)*100 else - gear^.Timer:= cMinesTime*1; + gear^.Timer:= cMinesTime*1000; end; gtSMine: begin gear^.Health:= 10; diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uLocale.pas --- a/hedgewars/uLocale.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uLocale.pas Fri Nov 12 18:57:36 2010 -0500 @@ -30,7 +30,7 @@ sidLowGravity, sidExtraDamage, sidInvulnerable, sidExtraTime, sidLaserSight, sidVampiric, sidSniperRifle, sidJetpack, sidMolotov, sidBirdy, sidPortalGun, sidPiano, sidGasBomb, sidSineGun, sidFlamethrower, - sidSMine, sidHammer, sidResurrector); + sidSMine, sidHammer, sidResurrector, sidDrillStrike); TMsgStrId = (sidStartFight, sidDraw, sidWinner, sidVolume, sidPaused, sidConfirm, sidSuddenDeath, sidRemaining, sidFuel, sidSync, diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uMisc.pas --- a/hedgewars/uMisc.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uMisc.pas Fri Nov 12 18:57:36 2010 -0500 @@ -758,7 +758,7 @@ cMapGen := 0; // MAPGEN_REGULAR cMazeSize := 0; cHedgehogTurnTime := 45000; - cMinesTime := 3000; + cMinesTime := 3; cMaxAIThinkTime := 9000; cCloudsNumber := 9; cHealthCaseProb := 35; diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uStore.pas --- a/hedgewars/uStore.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uStore.pas Fri Nov 12 18:57:36 2010 -0500 @@ -57,6 +57,7 @@ procedure DrawFromRect(X, Y, W, H: LongInt; r: PSDL_Rect; SourceTexture: PTexture); procedure DrawFromRect(X, Y: LongInt; r: PSDL_Rect; SourceTexture: PTexture); procedure DrawHedgehog(X, Y: LongInt; Dir: LongInt; Pos, Step: LongWord; Angle: real); +procedure DrawLine(X0, Y0, X1, Y1, Width: Single; r, g, b, a: Byte); procedure DrawFillRect(r: TSDL_Rect); procedure DrawCircle(X, Y, Radius: LongInt; Width: Single; r, g, b, a: Byte); procedure DrawRoundRect(rect: PSDL_Rect; BorderColor, FillColor: Longword; Surface: PSDL_Surface; Clear: boolean); @@ -791,6 +792,32 @@ glPopMatrix end; +procedure DrawLine(X0, Y0, X1, Y1, Width: Single; r, g, b, a: Byte); +var VertexBuffer: array [0..3] of TVertex2f; +begin + glDisable(GL_TEXTURE_2D); + glEnable(GL_LINE_SMOOTH); + + glPushMatrix; + glTranslatef(WorldDx, WorldDy, 0); + glLineWidth(Width); + + Tint(r, g, b, a); + VertexBuffer[0].X:= X0; + VertexBuffer[0].Y:= Y0; + VertexBuffer[1].X:= X1; + VertexBuffer[1].Y:= Y1; + + glVertexPointer(2, GL_FLOAT, 0, @VertexBuffer[0]); + glDrawArrays(GL_LINES, 0, Length(VertexBuffer)); + Tint($FF, $FF, $FF, $FF); + + glPopMatrix; + + glEnable(GL_TEXTURE_2D); + glDisable(GL_LINE_SMOOTH); +end; + procedure DrawFillRect(r: TSDL_Rect); var VertexBuffer: array [0..3] of TVertex2f; begin diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uVisualGears.pas --- a/hedgewars/uVisualGears.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uVisualGears.pas Fri Nov 12 18:57:36 2010 -0500 @@ -117,7 +117,8 @@ @doStepExplosion, @doStepBigExplosion, @doStepChunk, - @doStepNote + @doStepNote, + @doStepLineTrail ); function AddVisualGear(X, Y: LongInt; Kind: TVisualGearType; State: LongWord = 0): PVisualGear; @@ -406,6 +407,7 @@ case Gear^.Kind of vgtSmokeTrace: if Gear^.State < 8 then DrawSprite(sprSmokeTrace, round(Gear^.X) + WorldDx, round(Gear^.Y) + WorldDy, Gear^.State); vgtEvilTrace: if Gear^.State < 8 then DrawSprite(sprEvilTrace, round(Gear^.X) + WorldDx, round(Gear^.Y) + WorldDy, Gear^.State); + vgtLineTrail: DrawLine(Gear^.X, Gear^.Y, Gear^.dX, Gear^.dY, 1.0, $FF, min(Gear^.Timer, $C0), min(Gear^.Timer, $80), min(Gear^.Timer, $FF)); end; if (cReducedQuality and rqFancyBoom) = 0 then case Gear^.Kind of diff -r 0313d5577fce -r 1f5604cd99be hedgewars/uWorld.pas --- a/hedgewars/uWorld.pas Fri Nov 12 18:32:56 2010 -0500 +++ b/hedgewars/uWorld.pas Fri Nov 12 18:57:36 2010 -0500 @@ -149,14 +149,14 @@ ScreenFadeSpeed:= 1; // modified mine timers? -if cMinesTime <> 3000 then +if cMinesTime <> 3 then begin if cMinesTime = 0 then g:= AddGoal(g, gfAny, gidNoMineTimer) else if cMinesTime < 0 then g:= AddGoal(g, gfAny, gidRandomMineTimer) else - g:= AddGoal(g, gfAny, gidMineTimer, cMinesTime div 1000); + g:= AddGoal(g, gfAny, gidMineTimer, cMinesTime); end; // if the string has been set, show it for (default timeframe) seconds diff -r 0313d5577fce -r 1f5604cd99be share/hedgewars/Data/Locale/en.txt --- a/share/hedgewars/Data/Locale/en.txt Fri Nov 12 18:32:56 2010 -0500 +++ b/share/hedgewars/Data/Locale/en.txt Fri Nov 12 18:57:36 2010 -0500 @@ -50,6 +50,7 @@ 00:47=Sticky Mine 00:48=Hammer 00:49=Resurrector +00:50=Drill Strike 01:00=Let's fight! 01:01=Round draw @@ -431,6 +432,7 @@ 03:47=Stick these somewhere useful! 03:48=It's Hammer time! 03:49=Does what you guess +03:50=Moles fan ; Weapon Descriptions (use | as line breaks) 04:00=Attack your enemies using a simple grenade.|It will explode once its timer reaches zero.|1-5: Set grenade's timer|Attack: Hold to throw with more power