author  unc0rr 
Sun, 26 Jan 2014 02:17:04 +0400  
changeset 10076  b235e520ea21 
parent 8401  87410ae372f6 
child 10077  ca67740f19b2 
permissions  rwrr 
8372
3c193ec03e09
Logon procedure for checkers, introduce invisible clients
unc0rr
parents:
8371
diff
changeset

1 
{# LANGUAGE OverloadedStrings, CPP #} 
1804  2 
module HWProtoNEState where 
3 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

4 
import Control.Monad.Reader 
10076  5 
import qualified Data.ByteString.Lazy as BL 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

6 
import qualified Data.ByteString.Char8 as B 
10076  7 
import Data.Digest.Pure.SHA 
1804  8 
 
9 
import CoreTypes 

10 
import Actions 

11 
import Utils 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

12 
import RoomsAndClients 
1804  13 

4989  14 
handleCmd_NotEntered :: CmdHandler 
1804  15 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

16 
handleCmd_NotEntered ["NICK", newNick] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

17 
(ci, irnc) < ask 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

18 
let cl = irnc `client` ci 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8372
diff
changeset

19 
if not . B.null $ nick cl then return [ProtocolError $ loc "Nickname already chosen"] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

20 
else 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8372
diff
changeset

21 
if illegalName newNick then return [ByeClient $ loc "Illegal nickname"] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

22 
else 
4991  23 
return $ 
24 
ModifyClient (\c > c{nick = newNick}) : 

25 
AnswerClients [sendChan cl] ["NICK", newNick] : 

26 
[CheckRegistered  clientProto cl /= 0] 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

27 

1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

28 
handleCmd_NotEntered ["PROTO", protoNum] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

29 
(ci, irnc) < ask 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

30 
let cl = irnc `client` ci 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8372
diff
changeset

31 
if clientProto cl > 0 then return [ProtocolError $ loc "Protocol already known"] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

32 
else 
8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8372
diff
changeset

33 
if parsedProto == 0 then return [ProtocolError $ loc "Bad number"] 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

34 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

35 
return $ 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

36 
ModifyClient (\c > c{clientProto = parsedProto}) : 
5030
42746c5d4a80
Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents:
4991
diff
changeset

37 
AnswerClients [sendChan cl] ["PROTO", showB parsedProto] : 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

38 
[CheckRegistered  not . B.null $ nick cl] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

39 
where 
5090  40 
parsedProto = readInt_ protoNum 
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1834
diff
changeset

41 

3536  42 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

43 
handleCmd_NotEntered ["PASSWORD", passwd] = do 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

44 
(ci, irnc) < ask 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

45 
let cl = irnc `client` ci 
1879  46 

10076  47 
if clientProto cl < 48 && passwd == webPassword cl then 
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

48 
return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"]  isAdministrator cl] 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

49 
else 
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

50 
return [ByeClient "Authentication failed"] 
1879  51 

1804  52 

10076  53 
handleCmd_NotEntered ["PASSWORD", passwd, clientSalt] = do 
54 
(ci, irnc) < ask 

55 
let cl = irnc `client` ci 

56 

57 
let clientHash = h [clientSalt, serverSalt cl, webPassword cl, showB $ clientProto cl, "!hedgewars"] 

58 
let serverHash = h [serverSalt cl, clientSalt, webPassword cl, showB $ clientProto cl, "!hedgewars"] 

59 

60 
if passwd == clientHash then 

61 
return $ 

62 
AnswerClients [sendChan cl] ["SERVER_AUTH", serverHash] 

63 
: JoinLobby 

64 
: [AnswerClients [sendChan cl] ["ADMIN_ACCESS"]  isAdministrator cl] 

65 
else 

66 
return [ByeClient "Authentication failed"] 

67 
where 

68 
h = B.pack . showDigest . sha1 . BL.fromChunks 

69 

8372
3c193ec03e09
Logon procedure for checkers, introduce invisible clients
unc0rr
parents:
8371
diff
changeset

70 
#if defined(OFFICIAL_SERVER) 
8371  71 
handleCmd_NotEntered ["CHECKER", protoNum, newNick, password] = do 
72 
(ci, irnc) < ask 

73 
let cl = irnc `client` ci 

74 

8401
87410ae372f6
Server messages localization using Qt's l10n subsystem:
unc0rr
parents:
8372
diff
changeset

75 
if parsedProto == 0 then return [ProtocolError $ loc "Bad number"] 
8371  76 
else 
77 
return $ [ 

78 
ModifyClient (\c > c{clientProto = parsedProto, nick = newNick, webPassword = password, isChecker = True}) 

79 
, CheckRegistered] 

80 
where 

81 
parsedProto = readInt_ protoNum 

8372
3c193ec03e09
Logon procedure for checkers, introduce invisible clients
unc0rr
parents:
8371
diff
changeset

82 
#endif 
8371  83 

4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset

84 
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"] 