Protocol.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module Protocol where
  12
  13 import Data.Binary
  14 import Control.Monad
  15
  16 import Crypto.Types.PubKey.RSA (PublicKey)
  17
  18 import BinaryInstances
  19 import Metagame
  20 import Lock
  21
  22 type ProtocolVersion = Int
  23 protocolVersion = 1 :: ProtocolVersion
  24
  25 data ClientRequest = ClientRequest ProtocolVersion (Maybe Auth) Action
  26     deriving (Eq, Ord, Show, Read)
  27
  28 type VersionedUInfo = (Int, UserInfo)
  29
  30 data Action
  31     = Authenticate
  32     | Register
  33     | ResetPassword Password
  34     | SetEmail String
  35     | GetServerInfo
  36     | GetPublicKey
  37     | GetLock LockSpec
  38     | GetRetired Codename
  39     | GetUserInfo Codename (Maybe Int)
  40     | GetHint NoteInfo
  41     | GetSolution NoteInfo
  42     | DeclareSolution Solution LockSpec ActiveLock LockIndex
  43     | SetLock Lock LockIndex Solution
  44     | GetRandomNames Int
  45     | UndefinedAction
  46     deriving (Eq, Ord, Show, Read)
  47
  48 data Auth = Auth {authUser :: Codename, authPasswd :: Password}
  49     deriving (Eq, Ord, Show, Read)
  50 type Password = String
  51
  52 needsAuth :: Action -> Bool
  53 needsAuth GetServerInfo = False
  54 needsAuth GetPublicKey = False
  55 needsAuth (GetLock _) = False
  56 needsAuth (GetUserInfo _ _) = False
  57 needsAuth (GetRetired _) = False
  58 needsAuth (GetRandomNames _) = False
  59 needsAuth _ = True
  60
  61 data ServerResponse
  62     = ServerAck
  63     | ServerMessage String
  64     | ServerError String
  65     | ServedServerInfo ServerInfo
  66     | ServedPublicKey PublicKey
  67     | ServedLock Lock
  68     | ServedRetired [LockSpec]
  69     | ServedUserInfo VersionedUInfo
  70     | ServedUserInfoDeltas [UserInfoDelta]
  71     | ServedSolution Solution
  72     | ServedHint Hint
  73     | ServedRandomNames [Codename]
  74     | ServerCodenameFree
  75     | ServerFresh
  76     | ServerUndefinedResponse
  77     deriving (Eq, Show, Read)
  78
  79 data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String}
  80     deriving (Eq, Ord, Show, Read)
  81 defaultServerInfo locksize = ServerInfo locksize ""
  82
  83 instance Binary ClientRequest where
  84     put (ClientRequest pv mauth act) = putPackedInt pv >> put mauth >> put act
  85     get = liftM3 ClientRequest getPackedInt get get
  86
  87 instance Binary Action where
  88     put Authenticate = put (0::Word8)
  89     put Register = put (1::Word8)
  90     put GetServerInfo = put (2::Word8)
  91     put (GetLock lspec) = put (3::Word8) >> put lspec
  92     put (GetUserInfo name version) = put (4::Word8) >> put name >> put version
  93     put (GetHint lspec) = put (5::Word8) >> put lspec
  94     put (GetSolution lspec) = put (6::Word8) >> put lspec
  95     put (DeclareSolution soln lspec alock idx) = put (7::Word8) >> put soln >> put lspec >> put alock >> put idx
  96     put (SetLock lock li soln) = put (8::Word8) >> put lock >> put li >> put soln
  97     put (GetRandomNames n) = put (9::Word8) >> put n
  98     put (ResetPassword pw) = put (10::Word8) >> put pw
  99     put (GetRetired name) = put (11::Word8) >> put name
 100     put (SetEmail address) = put (12::Word8) >> put address
 101     put GetPublicKey = put (13::Word8)
 102     get = do
 103         tag <- get :: Get Word8
 104         case tag of
 105             0 -> return Authenticate
 106             1 -> return Register
 107             2 -> return GetServerInfo
 108             3 -> liftM GetLock get
 109             4 -> liftM2 GetUserInfo get get
 110             5 -> liftM GetHint get
 111             6 -> liftM GetSolution get
 112             7 -> liftM4 DeclareSolution get get get get
 113             8 -> liftM3 SetLock get get get
 114             9 -> liftM GetRandomNames get
 115             10 -> liftM ResetPassword get
 116             11 -> liftM GetRetired get
 117             12 -> liftM SetEmail get
 118             13 -> return GetPublicKey
 119             _ -> return UndefinedAction
 120
 121 instance Binary Auth where
 122     put (Auth name pw) = put name >> put pw
 123     get = liftM2 Auth get get
 124
 125 instance Binary ServerResponse where
 126     put ServerAck = put (0::Word8)
 127     put (ServerMessage mesg) = put (1::Word8) >> put mesg
 128     put (ServerError err) = put (2::Word8) >> put err
 129     put (ServedServerInfo sinfo) = put (3::Word8) >> put sinfo
 130     put (ServedLock lock) = put (4::Word8) >> put lock
 131     put (ServedUserInfo info) = put (5::Word8) >> put info
 132     put (ServedUserInfoDeltas info) = put (6::Word8) >> put info
 133     put (ServedSolution soln) = put (7::Word8) >> put soln
 134     put (ServedHint hint) = put (8::Word8) >> put hint
 135     put (ServedRandomNames names) = put (9::Word8) >> put names
 136     put (ServerCodenameFree) = put (10::Word8)
 137     put (ServerFresh) = put (11::Word8)
 138     put (ServedRetired lss) = put (12::Word8) >> put lss
 139     put (ServedPublicKey publicKey) = put (13::Word8) >> put (show publicKey)
 140     get = do
 141         tag <- get :: Get Word8
 142         case tag of
 143             0 -> return ServerAck
 144             1 -> liftM ServerMessage get
 145             2 -> liftM ServerError get
 146             3 -> liftM ServedServerInfo get
 147             4 -> liftM ServedLock get
 148             5 -> liftM ServedUserInfo get
 149             6 -> liftM ServedUserInfoDeltas get
 150             7 -> liftM ServedSolution get
 151             8 -> liftM ServedHint get
 152             9 -> liftM ServedRandomNames get
 153             10 -> return ServerCodenameFree
 154             11 -> return ServerFresh
 155             12 -> liftM ServedRetired get
 156             13 -> liftM (ServedPublicKey . read) get
 157             _ -> return ServerUndefinedResponse
 158 instance Binary ServerInfo where
 159     put (ServerInfo sz str) = put sz >> put str
 160     get = liftM2 ServerInfo get get