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           Control.Monad
  14 import           Data.Binary
  15
  16 import           Crypto.PubKey.RSA.Types (PublicKey)
  17
  18 import           BinaryInstances
  19 import           Lock
  20 import           Metagame
  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  -> GetLock <$> get
 109             4  -> liftM2 GetUserInfo get get
 110             5  -> GetHint <$> get
 111             6  -> GetSolution <$> get
 112             7  -> liftM4 DeclareSolution get get get get
 113             8  -> liftM3 SetLock get get get
 114             9  -> GetRandomNames <$> get
 115             10 -> ResetPassword <$> get
 116             11 -> GetRetired <$> get
 117             12 -> 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  -> ServerMessage <$> get
 145             2  -> ServerError <$> get
 146             3  -> ServedServerInfo <$> get
 147             4  -> ServedLock <$> get
 148             5  -> ServedUserInfo <$> get
 149             6  -> ServedUserInfoDeltas <$> get
 150             7  -> ServedSolution <$> get
 151             8  -> ServedHint <$> get
 152             9  -> ServedRandomNames <$> get
 153             10 -> return ServerCodenameFree
 154             11 -> return ServerFresh
 155             12 -> ServedRetired <$> get
 156             13 -> 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