gameServer/OfficialServer/GameReplayStore.hs
author nemo
Wed, 30 Dec 2015 23:30:00 -0500
changeset 11473 023db094b22d
parent 11341 e6e748d021d0
permissions -rw-r--r--
Some themers expressed desire to have translucent themes. While the current AA stuff in uLandGraphics won't really allow this to work with LandBackTex properly, seems to me it should be safe to allow alpha for LandTex. Our LandTex should all have alpha of 255 on the existing themes.
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
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
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
11246
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11046
diff changeset
    19
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
5143
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
11341
e6e748d021d0 - Fix check which was supposed to prevent sending same record to different checkers
unc0rr
parents: 11320
diff changeset
    41
    files <- liftM (filter (\f -> sameProto f && notBlacklisted ("replays/" ++ 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
11341
e6e748d021d0 - Fix check which was supposed to prevent sending same record to different checkers
unc0rr
parents: 11320
diff changeset
    47
        sameProto = isSuffixOf ('.' : show p)
9662
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) ->
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11246
diff changeset
    73
                    warningM "REPLAYS" ("Problems reading " ++ fileName ++ ": " ++ show e) >> return (Just $ CheckInfo fileName [] Nothing, [])) $ 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
11246
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11046
diff changeset
    75
            let d = replayToDemo teams (Map.fromList params1) (Map.fromList params2) (reverse roundMsgs)
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11046
diff changeset
    76
            d `deepseq` return $ (
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11246
diff changeset
    77
                Just (CheckInfo fileName teams (fst d))
11246
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11046
diff changeset
    78
                , snd d
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    79
                )
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    80
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    81
moveFailedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    82
moveFailedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    83
    renameFile fn ("failed/" ++ drop 8 fn)
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    84
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    85
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    86
moveCheckedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    87
moveCheckedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    88
    renameFile fn ("checked/" ++ drop 8 fn)