gameServer/OfficialServer/GameReplayStore.hs
author koda
Fri, 17 Jan 2014 16:31:36 +0100
changeset 10004 eb0b520564bb
parent 9662 47dbd9601342
child 10051 cc6f62d7aea2
permissions -rw-r--r--
use bundled physfs on win and osx
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
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    15
---------------
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    16
import CoreTypes
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    17
import EngineInteraction
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 5996
diff changeset
    18
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    19
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    20
pickReplayFile :: Int -> [String] -> IO String
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    21
pickReplayFile p blackList = do
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    22
    files <- liftM (filter (\f -> sameProto f && notBlacklisted f)) $ getDirectoryContents "replays"
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    23
    if (not $ null files) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    24
        return $ "replays/" ++ head files
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    25
        else
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    26
        return ""
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    27
    where
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    28
        sameProto = (isSuffixOf ('.' : show p))
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    29
        notBlacklisted = flip notElem blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    30
5143
649d87819682 Start implementation of archivements/ratings on server side: replay saving routine
unc0rr
parents:
diff changeset
    31
saveReplay :: RoomInfo -> IO ()
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    32
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
    33
    let gi = fromJust $ gameInfo r
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    34
    when (allPlayersHaveRegisteredAccounts gi) $ do
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    35
        time <- getCurrentTime
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    36
        u <- liftM hashUnique newUnique
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    37
        let fileName = "replays/" ++ show time ++ "-" ++ show u ++ "." ++ show (roomProto r)
8423
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    38
        let replayInfo = (teamsAtStart gi, Map.toList $ mapParams r, Map.toList $ params r, roundMsgs gi)
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    39
        E.catch
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    40
            (writeFile fileName (show replayInfo))
8aa450f6cf2c Fix official server build
unc0rr
parents: 8371
diff changeset
    41
            (\(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
    42
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    43
9662
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    44
loadReplay :: Int -> [String] -> IO (Maybe CheckInfo, [B.ByteString])
47dbd9601342 Ensure checkers don't check same replay simultaneously
unc0rr
parents: 8511
diff changeset
    45
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
    46
    fileName <- pickReplayFile p blackList
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    47
    if (not $ null fileName) then
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    48
        loadFile fileName
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    49
        else
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    50
        return (Nothing, [])
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    51
    where
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    52
        loadFile :: String -> IO (Maybe CheckInfo, [B.ByteString])
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    53
        loadFile fileName = E.handle (\(e :: SomeException) ->
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    54
                    warningM "REPLAYS" ("Problems reading " ++ fileName ++ ": " ++ show e) >> return (Nothing, [])) $ do
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8423
diff changeset
    55
            (teams, params1, params2, roundMsgs) <- liftM read $ readFile fileName
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    56
            return $ (
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    57
                Just (CheckInfo fileName teams)
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    58
                , replayToDemo teams (Map.fromList params1) (Map.fromList params2) (reverse roundMsgs)
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    59
                )
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    60
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    61
moveFailedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    62
moveFailedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    63
    renameFile fn ("failed/" ++ drop 8 fn)
8509
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    64
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    65
eda9f2106d8d Sort checked files into dirs
unc0rr
parents: 8502
diff changeset
    66
moveCheckedRecord :: String -> IO ()
8511
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    67
moveCheckedRecord fn = E.handle (\(e :: SomeException) -> warningM "REPLAYS" $ show e) $
4f899fbce66d Catch exceptions when moving files
unc0rr
parents: 8509
diff changeset
    68
    renameFile fn ("checked/" ++ drop 8 fn)