gameServer/OfficialServer/GameReplayStore.hs
author unc0rr
Sat, 27 Dec 2014 22:09:31 +0300
branch0.9.21
changeset 10721 9b789de8e5df
parent 10460 8dcea9087d75
child 11046 47a8c19ecb60
permissions -rw-r--r--
Workaround bug (each time losing room master status, even when joining mutliple rooms, new instance of NetAmmoSchemeModel created, receiving schemeConfig and modifying its 43rd member, thus the last model which accepts this signal has the string cut down several times, workaround creates copy of qstringlist to avoid modifying shared message instance. Proper fix would delete unneeded instances of NetAmmoSchemeModel, but who cares)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     2
 * Hedgewars, a free turn based strategy game
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     3
 * Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com>
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10086
diff changeset
    18
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    19
{-# LANGUAGE ScopedTypeVariables #-}
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    20
module OfficialServer.GameReplayStore where
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    21
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    22
import Data.Time
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    23
import Control.Exception as E
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    24
import qualified Data.Map as Map
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    25
import Data.Sequence()
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    26
import System.Log.Logger
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5143
diff changeset
    27
import Data.Maybe
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    28
import Data.Unique
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    29
import Control.Monad
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    30
import Data.List
8482
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
    31
import qualified Data.ByteString as B
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
    32
import System.Directory
10051
cc6f62d7aea2 Show which file has failed
unc0rr
parents: 9662
diff changeset
    33
import Control.DeepSeq
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    34
---------------
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    35
import CoreTypes
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    36
import EngineInteraction
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    37
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    38
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    39
pickReplayFile :: Int -> [String] -> IO String
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    40
pickReplayFile p blackList = do
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    41
    files <- liftM (filter (\f -> sameProto f && notBlacklisted f)) $ getDirectoryContents "replays"
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    42
    if (not $ null files) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    43
        return $ "replays/" ++ head files
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    44
        else
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    45
        return ""
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    46
    where
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    47
        sameProto = (isSuffixOf ('.' : show p))
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    48
        notBlacklisted = flip notElem blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    49
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    50
saveReplay :: RoomInfo -> IO ()
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    51
saveReplay r = do
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5143
diff changeset
    52
    let gi = fromJust $ gameInfo r
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    53
    when (allPlayersHaveRegisteredAccounts gi) $ do
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    54
        time <- getCurrentTime
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    55
        u <- liftM hashUnique newUnique
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    56
        let fileName = "replays/" ++ show time ++ "-" ++ show u ++ "." ++ show (roomProto r)
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    57
        let replayInfo = (teamsAtStart gi, Map.toList $ mapParams r, Map.toList $ params r, roundMsgs gi)
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    58
        E.catch
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    59
            (writeFile fileName (show replayInfo))
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    60
            (\(e :: IOException) -> warningM "REPLAYS" $ "Couldn't write to " ++ fileName ++ ": " ++ show e)
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    61
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    62
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    63
loadReplay :: Int -> [String] -> IO (Maybe CheckInfo, [B.ByteString])
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    64
loadReplay p blackList = E.handle (\(e :: SomeException) -> warningM "REPLAYS" "Problems reading replay" >> return (Nothing, [])) $ do
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    65
    fileName <- pickReplayFile p blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    66
    if (not $ null fileName) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    67
        loadFile fileName
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    68
        else
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    69
        return (Nothing, [])
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    70
    where
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    71
        loadFile :: String -> IO (Maybe CheckInfo, [B.ByteString])
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    72
        loadFile fileName = E.handle (\(e :: SomeException) ->
10086
4a7ce724357f This should help server bypass malformed replays
unc0rr
parents: 10051
diff changeset
    73
                    warningM "REPLAYS" ("Problems reading " ++ fileName ++ ": " ++ show e) >> return (Just $ CheckInfo fileName [], [])) $ do
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    74
            (teams, params1, params2, roundMsgs) <- liftM read $ readFile fileName
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    75
            return $ (
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    76
                Just (CheckInfo fileName teams)
10051
cc6f62d7aea2 Show which file has failed
unc0rr
parents: 9662
diff changeset
    77
                , let d = replayToDemo teams (Map.fromList params1) (Map.fromList params2) (reverse roundMsgs) in d `deepseq` d
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    78
                )
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    79
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    80
moveFailedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    81
moveFailedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    82
    renameFile fn ("failed/" ++ drop 8 fn)
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    83
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    84
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    85
moveCheckedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    86
moveCheckedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    87
    renameFile fn ("checked/" ++ drop 8 fn)