Nomyx-0.2.3: src/Main.hs
-----------------------------------------------------------------------------
--
-- Module : Main
-- Copyright :
-- License : AllRightsReserved
--
-- Maintainer :
-- Stability :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
{-# LANGUAGE GADTs, DoAndIfThenElse #-}
module Main (main) where
import Prelude hiding ((.))
import System.Console.GetOpt
import System.Environment
import Web.MainPage
import Control.Concurrent
import Interpret
import Control.Concurrent.STM
import qualified System.Posix.Signals as S
import Control.Monad.CatchIO hiding (catch)
import Control.Monad.Trans
import Language.Nomyx.Test as LT
import Data.Maybe
import Safe
import Network.BSD
import System.Posix.Daemonize
import Types
import Serialize
import Paths_Nomyx as PN
import System.Directory
import Data.Time.Clock
import Language.Nomyx hiding (getCurrentTime)
import Control.Exception as E hiding (bracket)
import Test
import Utils
import Data.Version (showVersion)
import Control.Category
import Multi
import Language.Haskell.Interpreter.Server hiding (start)
import Data.Acid (openLocalStateFrom)
import System.FilePath ((</>))
import Happstack.Auth.Core.Auth (initialAuthState)
import Data.Acid.Local (createCheckpointAndClose)
import Happstack.Auth.Core.Profile (initialProfileState)
import System.Unix.Directory
defaultLogFile :: FilePath
defaultLogFile = "Nomyx.save"
-- | Entry point of the program.
main :: IO Bool
main = do
args <- getArgs
(flags, _) <- nomyxOpts args
if (Version `elem` flags) then do
putStrLn $ "Nomyx " ++ showVersion version
return True
else do
putStrLn "Welcome to Nomyx!"
case (Daemon `elem` flags) of
True -> (daemonize $ start flags) >> return True
False -> start flags >> return True
start :: [Flag] -> IO ()
start flags = do
serverCommandUsage
--start the haskell interpreter
sh <- protectHandlers startInterpreter
if Test `elem` flags then do
putStrLn $ "\nNomyx Language Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests)
ts <- playTests sh
putStrLn $ "\nNomyx Game Tests results:\n" ++ (concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts)
putStrLn $ "All Tests Pass: " ++ (show $ allTests && (all snd ts))
else do
--creating game structures
logFile <- case (findSaveFile flags) of
Just f -> return f
Nothing -> return defaultLogFile
port <- case (findPort flags) of
Just p -> return $ read p
Nothing -> return $ 8000
host <- case (findHost flags) of
Just h -> return h
Nothing -> getHostName >>= return
logFilePath <- getDataFileName logFile
let settings sendMail = Settings logFilePath (Network host port) sendMail
dataDir <- getDataDir
let profilesDir = dataDir </> "profiles"
when (NoReadSaveFile `elem` flags) $ do
removeRecursiveSafely profilesDir
removeFile (_logFilePath $ settings True)
multi <- case (findLoadTest flags) of
Just testName -> loadTestName (settings False) testName sh
Nothing -> Main.loadMulti (settings True) sh
--main loop
withAcid (Just profilesDir) $ \acid -> do
tvSession <- atomically $ newTVar (Session sh multi acid)
--start the web server
forkIO $ launchWebServer tvSession (Network host port)
forkIO $ launchTimeEvents tvSession
serverLoop tvSession logFile
loadMulti :: Settings -> ServerHandle -> IO Multi
loadMulti set sh = do
fileExists <- doesFileExist $ _logFilePath $ set
multi <- case fileExists of
True -> do
putStrLn "Loading previous game"
Serialize.loadMulti set sh `E.catch`
(\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))
False -> return $ defaultMulti set
return multi
-- | a loop that will handle server commands
serverLoop :: TVar Session -> FilePath -> IO ()
serverLoop ts f = do
s <- getLine
case s of
"d" -> do
s <- atomically $ readTVar ts
putStrLn $ displayMulti $ _multi s
pfs <- getAllProfiles s
putStrLn $ show pfs
serverLoop ts f
"s" -> do
putStrLn "saving state..."
(Session _ m _) <- atomically $ readTVar ts
fp <- getDataFileName f
save fp m
serverLoop ts f
"q" -> return ()
_ -> do
putStrLn "command not recognized"
serverLoop ts f
serverCommandUsage :: IO ()
serverCommandUsage = do
putStrLn "Server commands:"
putStrLn "s -> save state"
putStrLn "d -> debug"
putStrLn "q -> quit"
-- | Launch mode
data Flag
= Verbose | Version | Test | HostName String | Port String | LogFile FilePath | Daemon | LoadTest String | NoReadSaveFile
deriving (Show, Eq)
-- | launch options description
options :: [OptDescr Flag]
options =
[ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
, Option ['V','?'] ["version"] (NoArg Version) "show version number"
, Option ['t'] ["tests"] (NoArg Test) "perform routine check"
, Option ['h'] ["host"] (ReqArg HostName "Hostname") "specify host name"
, Option ['p'] ["port"] (ReqArg Port "Port") "specify port"
, Option ['r'] ["read"] (ReqArg LogFile "SaveFile") "specify save file (default is Nomyx.save)"
, Option ['n'] ["noread"] (NoArg NoReadSaveFile) "don't read save file, just overwrite"
, Option ['d'] ["daemon"] (NoArg Daemon) "run in daemon mode"
, Option ['l'] ["loadtest"] (ReqArg LoadTest "TestName") "specify name of test to load"
]
nomyxOpts :: [String] -> IO ([Flag], [String])
nomyxOpts argv =
case getOpt Permute options argv of
(o,n,[] ) -> return (o,n)
(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where header = "Usage: Nomyx [OPTION...]"
findPort :: [Flag] -> Maybe String
findPort fs = headMay $ catMaybes $ map isPort fs where
isPort (Port a) = Just a
isPort _ = Nothing
findHost :: [Flag] -> Maybe String
findHost fs = headMay $ catMaybes $ map isHost fs where
isHost (HostName a) = Just a
isHost _ = Nothing
findLoadTest :: [Flag] -> Maybe String
findLoadTest fs = headMay $ catMaybes $ map isLoadTest fs where
isLoadTest (LoadTest a) = Just a
isLoadTest _ = Nothing
findSaveFile :: [Flag] -> Maybe FilePath
findSaveFile fs = headMay $ catMaybes $ map isSaveFile fs where
isSaveFile (LogFile a) = Just a
isSaveFile _ = Nothing
helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler
helper handler signal = liftIO $ S.installHandler signal handler Nothing
signals :: [S.Signal]
signals = [ S.sigQUIT
, S.sigINT
, S.sigHUP
, S.sigTERM
]
saveHandlers :: MonadCatchIO m => m [S.Handler]
saveHandlers = liftIO $ mapM (helper S.Ignore) signals
restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]
restoreHandlers h = liftIO . sequence $ zipWith helper h signals
protectHandlers :: MonadCatchIO m => m a -> m a
protectHandlers a = bracket saveHandlers restoreHandlers $ const a
triggerTimeEvent :: TVar Session -> UTCTime -> IO()
triggerTimeEvent tm t = do
(Session sh m a) <- atomically $ readTVar tm
m' <- execWithMulti t (Multi.triggerTimeEvent t) m
atomically $ writeTVar tm (Session sh m' a)
save (_mSettings >>>_logFilePath $ m') m'
launchTimeEvents :: TVar Session -> IO()
launchTimeEvents tm = do
now <- getCurrentTime
--putStrLn $ "tick " ++ (show now)
(Session _ m _) <- atomically $ readTVar tm
timeEvents <- getTimeEvents now m
when (length timeEvents /= 0) $ putStrLn "found time event(s)"
mapM_ (Main.triggerTimeEvent tm) timeEvents
--sleep 1 second roughly
threadDelay 1000000
launchTimeEvents tm
withAcid :: Maybe FilePath -- ^ state directory
-> (Profiles -> IO a) -- ^ action
-> IO a
withAcid mBasePath f =
let basePath = fromMaybe "_state" mBasePath in
bracket (openLocalStateFrom (basePath </> "auth") initialAuthState) (createCheckpointAndClose) $ \auth ->
bracket (openLocalStateFrom (basePath </> "profile") initialProfileState) (createCheckpointAndClose) $ \profile ->
bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createCheckpointAndClose) $ \profileData ->
f (Profiles auth profile profileData)