gameServer/OfficialServer/GameReplayStore.hs
author unc0rr
Tue, 04 Mar 2014 00:40:23 +0400
changeset 10175 c92668840ea8
parent 10086 4a7ce724357f
child 10460 8dcea9087d75
permissions -rw-r--r--
Remove game/preview functions split in library mode, just let normal procedure run instead: - Remove tons of HWLIBRARY ifdefs - Override ParamCount and ParamStr to let GetParams work - Small fixes here and there
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables #-}
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     2
module OfficialServer.GameReplayStore where
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     3
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     4
import Data.Time
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     5
import Control.Exception as E
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     6
import qualified Data.Map as Map
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     7
import Data.Sequence()
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
     8
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
     9
import Data.Maybe
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    10
import Data.Unique
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    11
import Control.Monad
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    12
import Data.List
8482
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
    13
import qualified Data.ByteString as B
5656a73fe3c3 Fix official server build
unc0rr
parents: 8479
diff changeset
    14
import System.Directory
10051
cc6f62d7aea2 Show which file has failed
unc0rr
parents: 9662
diff changeset
    15
import Control.DeepSeq
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    16
---------------
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    17
import CoreTypes
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    18
import EngineInteraction
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    19
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    20
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    21
pickReplayFile :: Int -> [String] -> IO String
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    22
pickReplayFile p blackList = do
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    23
    files <- liftM (filter (\f -> sameProto f && notBlacklisted f)) $ getDirectoryContents "replays"
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    24
    if (not $ null files) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    25
        return $ "replays/" ++ head files
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    26
        else
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    27
        return ""
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    28
    where
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    29
        sameProto = (isSuffixOf ('.' : show p))
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    30
        notBlacklisted = flip notElem blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    31
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    32
saveReplay :: RoomInfo -> IO ()
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    33
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
    34
    let gi = fromJust $ gameInfo r
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    35
    when (allPlayersHaveRegisteredAccounts gi) $ do
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    36
        time <- getCurrentTime
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    37
        u <- liftM hashUnique newUnique
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    38
        let fileName = "replays/" ++ show time ++ "-" ++ show u ++ "." ++ show (roomProto r)
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    39
        let replayInfo = (teamsAtStart gi, Map.toList $ mapParams r, Map.toList $ params r, roundMsgs gi)
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    40
        E.catch
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    41
            (writeFile fileName (show replayInfo))
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    42
            (\(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
    43
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    44
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    45
loadReplay :: Int -> [String] -> IO (Maybe CheckInfo, [B.ByteString])
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    46
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
    47
    fileName <- pickReplayFile p blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    48
    if (not $ null fileName) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    49
        loadFile fileName
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    50
        else
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    51
        return (Nothing, [])
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    52
    where
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    53
        loadFile :: String -> IO (Maybe CheckInfo, [B.ByteString])
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    54
        loadFile fileName = E.handle (\(e :: SomeException) ->
10086
4a7ce724357f This should help server bypass malformed replays
unc0rr
parents: 10051
diff changeset
    55
                    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
    56
            (teams, params1, params2, roundMsgs) <- liftM read $ readFile fileName
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    57
            return $ (
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    58
                Just (CheckInfo fileName teams)
10051
cc6f62d7aea2 Show which file has failed
unc0rr
parents: 9662
diff changeset
    59
                , 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
    60
                )
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    61
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    62
moveFailedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    63
moveFailedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    64
    renameFile fn ("failed/" ++ drop 8 fn)
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    65
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    66
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    67
moveCheckedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    68
moveCheckedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    69
    renameFile fn ("checked/" ++ drop 8 fn)