Nomyx-0.6.0: src/Main.hs

-----------------------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ScopedTypeVariables #-}
    
module Main (main) where

import Prelude hiding ((.))
import System.Console.GetOpt 
import System.Environment 
import Control.Concurrent
import Control.Concurrent.STM
import Data.Maybe
import Safe
import Network.BSD
import Paths_Nomyx as PN
import Paths_Nomyx_Web as PNW
import Paths_Nomyx_Language as PNL
import System.Directory (removeDirectoryRecursive, canonicalizePath, removeFile, doesFileExist)
import Data.Time.Clock
import Control.Exception as E hiding (bracket)
import Data.Version (showVersion)
import Language.Haskell.Interpreter.Server hiding (start)
import System.FilePath ((</>))
import Control.Monad.State
import System.Exit
import Nomyx.Web.MainPage
import Nomyx.Core.Profile
import Nomyx.Core.Session
import Nomyx.Core.Multi as Multi
import Nomyx.Core.Utils
import Nomyx.Core.Types
import Nomyx.Core.Serialize as Serialize
import Nomyx.Core.Interpret
import Nomyx.Core.Test
import Nomyx.Core.Engine
import Nomyx.Core.Engine.Test as LT


-- | Entry point of the program.
main :: IO Bool
main = do
   args <- getArgs 
   (flags, _) <- nomyxOpts args
   if Version `elem` flags then do
      putStrLn $ "Nomyx " ++ showVersion PN.version
      return True
   else if Help `elem` flags then do
      putStrLn $ usageInfo header options
      return True
   else do
      putStrLn "Welcome to Nomyx!"
      putStrLn "Type \"Nomyx --help\" for usage options"  
      start flags
      return True

start :: [Flag] -> IO ()
start flags = do
   defWebDir <- PNW.getDataDir
   defSourceDir <- PNL.getDataDir
   let defSaveDir = PN.getDataDir
   hostName <- getHostName
   let port = read $ fromMaybe "8000" (findPort flags)
   let host = fromMaybe hostName (findHost flags)
   let adminPass = fromMaybe "NXPSD" (findAdminPass flags)
   let sendMail = Mails `elem` flags
   -- save directory: Nomyx.save and uploaded files
   saveDir <- case findTarFile flags of
      Just tarFile -> untar tarFile
      Nothing -> case findSaveDir flags of
         Just f -> canonicalizePath f
         Nothing -> defSaveDir
   -- data directory: web ressources and profiles
   let webDir = fromMaybe defWebDir (findWebDir flags)
   -- source directory: Nomyx-Language files (used only for display in GUI, since this library is statically linked otherwise)
   let sourceDir = fromMaybe defSourceDir (findSourceDir flags)
   let settings = Settings (Network host port) sendMail adminPass saveDir webDir sourceDir
   let mLoad = findLoadTest flags
   when (Verbose `elem` flags) $ putStrLn $ "Directories:\n" ++ "save dir = " ++  saveDir ++ "\nweb dir = " ++ webDir ++ "\nsource dir = " ++ sourceDir
   if Test `elem` flags then runTests saveDir mLoad
   else if DeleteSaveFile `elem` flags then cleanFile saveDir
   else mainLoop settings saveDir host port


mainLoop :: Settings -> FilePath -> HostName -> Port -> IO ()
mainLoop settings saveDir host port = do
   serverCommandUsage
   --start the haskell interpreter
   sh <- protectHandlers $ startInterpreter saveDir
   --creating game structures
   multi <- Main.loadMulti settings sh
   --main loop
   withAcid (Just $ saveDir </> 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

loadMulti :: Settings -> ServerHandle -> IO Multi
loadMulti set sh = do
   fileExists <- doesFileExist $ getSaveFile set
   if fileExists then do
      putStrLn $ "Loading game: " ++ getSaveFile set
      Serialize.loadMulti set sh `E.catch` (\e -> (putStrLn $ "Error while loading logged events, log file discarded\n" ++ (show (e::ErrorCall))) >> (return $ defaultMulti set))
   else do
      let defMulti = defaultMulti set
      execStateT (newGame' "Default game" (GameDesc "This is the default game." "") 0 True sh) defMulti


runTests :: FilePath -> Maybe String -> IO ()
runTests saveDir mTestName = do
   sh <- protectHandlers $ startInterpreter saveDir
   putStrLn $ "\nNomyx Language Tests results:\n" ++ concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") LT.tests
   ts <- playTests saveDir sh mTestName
   putStrLn $ "\nNomyx Game Tests results:\n" ++ concatMap (\(a,b) -> a ++ ": " ++ (show b) ++ "\n") ts
   let pass = allTests && all snd ts
   putStrLn $ "All Tests Pass: " ++ show pass
   if pass then exitSuccess else exitFailure

cleanFile :: FilePath -> IO ()
cleanFile saveDir = do
   putStrLn "Deleting save files"
   let catchExp io = io `catch` (\(e::SomeException)-> print e)
   catchExp $ removeDirectoryRecursive $ saveDir </> profilesDir
   catchExp $ removeDirectoryRecursive $ saveDir </> uploadDir
   catchExp $ removeFile               $ saveDir </> saveFile

-- | a loop that will handle server commands
serverLoop :: TVar Session -> IO ()
serverLoop ts = do
   s <- getLine
   case s of
      "d" -> do
         s <- atomically $ readTVar ts
         print $ _multi s
         pfs <- getAllProfiles s
         print pfs
      _ -> putStrLn "command not recognized"
   serverLoop ts

serverCommandUsage :: IO ()
serverCommandUsage = do
   putStrLn "Server commands:"
   putStrLn "d      -> debug"
   putStrLn "Ctrl-C -> quit"

-- | Launch mode 
data Flag = Verbose
          | Version
          | Test
          | HostName String
          | Port String
          | LoadTest String
          | DeleteSaveFile
          | AdminPass String
          | Mails
          | Help
          | SaveDir FilePath
          | WebDir FilePath
          | SourceDir FilePath
          | TarFile FilePath
       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 ['h'] ["host"]      (ReqArg HostName "Hostname")   "specify host name"
     , Option ['p'] ["port"]      (ReqArg Port "Port")           "specify port"
     , Option ['n'] ["delete"]    (NoArg DeleteSaveFile)         "delete all save files"
     , Option ['t'] ["tests"]     (NoArg Test)                   "perform routine check"
     , Option ['l'] ["loadtest"]  (ReqArg LoadTest "TestName")   "specify name of test to load (in combination with -t i.e. -t -l \"testName\")"
     , Option ['a'] ["adminPass"] (ReqArg AdminPass "AdminPass") "specify the admin password (default is NXPSD)"
     , Option ['m'] ["mails"]     (NoArg Mails)                  "send mails (default is no)"
     , Option ['?'] ["help"]      (NoArg Help)                   "display usage options (this screen)"
     , Option ['r'] ["saveDir"]   (ReqArg SaveDir "SaveDir")     "specify save directory (for Nomyx.save and uploads)"
     , Option ['f'] ["dataDir"]   (ReqArg WebDir "WebDir")       "specify data directory (for profiles and website files)"
     , Option ['s'] ["sourceDir"] (ReqArg SourceDir "SourceDir") "specify source directory (for Nomyx-Language files)"
     , Option ['T'] ["tar"]       (ReqArg TarFile "TarFile")     "specify tar file (containing Nomyx.save and uploads)"
     ]
    
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))

header :: String
header = "Usage: Nomyx [OPTION...]"

findPort :: [Flag] -> Maybe String
findPort fs = headMay $ mapMaybe isPort fs where
    isPort (Port a) = Just a
    isPort _ = Nothing

findHost :: [Flag] -> Maybe String
findHost fs = headMay $ mapMaybe isHost fs where
    isHost (HostName a) = Just a
    isHost _ = Nothing

findLoadTest :: [Flag] -> Maybe String
findLoadTest fs = headMay $ mapMaybe isLoadTest fs where
    isLoadTest (LoadTest a) = Just a
    isLoadTest _ = Nothing

findSaveDir :: [Flag] -> Maybe FilePath
findSaveDir fs = headMay $ mapMaybe isSaveDir fs where
    isSaveDir (SaveDir a) = Just a
    isSaveDir _ = Nothing

findAdminPass :: [Flag] -> Maybe String
findAdminPass fs = headMay $ mapMaybe isAdminPass fs where
    isAdminPass (AdminPass a) = Just a
    isAdminPass _ = Nothing

findWebDir :: [Flag] -> Maybe String
findWebDir fs = headMay $ mapMaybe isWebDir fs where
    isWebDir (WebDir a) = Just a
    isWebDir _ = Nothing

findSourceDir :: [Flag] -> Maybe String
findSourceDir fs = headMay $ mapMaybe isSourceDir fs where
    isSourceDir (SourceDir a) = Just a
    isSourceDir _ = Nothing

findTarFile :: [Flag] -> Maybe String
findTarFile fs = headMay $ mapMaybe isTarFile fs where
    isTarFile (TarFile a) = Just a
    isTarFile _ = Nothing


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 m'

launchTimeEvents :: TVar Session -> IO()
launchTimeEvents tm = do
    now <- getCurrentTime
    --putStrLn $ "tick " ++ (show now)
    (Session _ m _) <- atomically $ readTVar tm
    timeEvents <- getTimeEvents now m
    when (not $ null timeEvents) $ putStrLn "found time event(s)"
    mapM_ (Main.triggerTimeEvent tm) timeEvents
    --sleep 1 second roughly
    threadDelay 1000000
    launchTimeEvents tm