module Development.Bake.Server.Start(
startServer
) where
import Development.Bake.Core.Type
import General.Web
import General.HTML
import Development.Bake.Core.Message
import Development.Bake.Core.Run
import General.Extra
import General.BigString
import Development.Bake.Server.Brain
import Development.Bake.Server.Web
import Development.Bake.Server.Stats
import Development.Bake.Server.Memory
import Development.Bake.Server.Store
import Control.Applicative
import System.Time.Extra
import Control.DeepSeq
import Control.Exception.Extra
import Data.List.Extra
import Data.Maybe
import Data.Tuple.Extra
import Control.Monad.Extra
import System.Console.CmdArgs.Verbosity
import System.FilePath
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Paths_bake
import Prelude
startServer :: (Stringy state, Stringy patch, Stringy test)
=> Port -> [Author] -> Seconds -> String -> Bool -> Oven state patch test -> IO ()
startServer port authors timeout admin fake (concrete -> (prettys, oven)) = do
extra <- newWorker
var <- newCVar =<< if fake then initialiseFake oven prettys else initialise oven prettys authors extra
forkSlave $ forever $ do
sleep timeout
now <- getCurrentTime
let prune = expire (addSeconds (negate timeout) now)
modifyCVar_ var $ \s -> do
let s2 = prune s
bad <- clientChange s s2
return $ bad s2
putStrLn $ "Started server on port " ++ show port
server port $ \i@Input{..} -> do
whenLoud $ print i
handle_ (fmap OutputError . showException) $ do
now <- getCurrentTime
let prune = expire (addSeconds (negate timeout) now)
res <-
if null inputURL then do
fmap OutputHTML $ web admin inputArgs . prune =<< readCVar var
else if ["html"] `isPrefixOf` inputURL then do
datadir <- getDataDir
return $ OutputFile $ datadir </> "html" </> last inputURL
else if inputURL == ["dump"] then do
mem <- readCVar var
storeSave "temp.sqlite" $ store mem
return $ OutputFile "temp.sqlite"
else if inputURL == ["alive"] then do
Memory{store} <- readCVar var
let xs = sortOn (paQueued . storePatch store) $ Set.toList $ storeAlive store
return $ OutputString $ unlines $ map fromPatch xs
else if inputURL == ["active"] then do
Memory{active} <- readCVar var
return $ OutputString $ unlines $ map fromPatch $ snd active
else if inputURL == ["state"] then do
Memory{active} <- readCVar var
return $ OutputString $ unlines [fromState $ fst active]
else if inputURL == ["skip"] then do
Memory{store} <- readCVar var
return $ OutputString $ unlines $ map fromTest $ Map.keys $ storeSkip store
else if ["api"] `isPrefixOf` inputURL then
case messageFromInput i{inputURL = drop 1 inputURL} of
Left e -> return $ OutputError $ "Encoding error when turning input into message, " ++ e ++ "\n\n" ++ take 100 (show i)
Right v -> do
evaluate $ rnf v
res <- modifyCVar var $ \s -> do
case v of
AddPatch _ p -> extra $ do
res <- patchExtra (fst $ active s) $ Just p
storeExtraAdd (store s) (Right p) res
_ -> return ()
(s2,q) <- recordIO $ (["brain",lower $ fst $ word1 $ show v],) <$> prod (prune s) v
when (fst (active s2) /= fst (active s)) $ extra $ do
res <- patchExtra (fst $ active s2) Nothing
storeExtraAdd (store s2) (Left $ fst $ active s2) res
bad <- clientChange s s2
when (fatal s == [] && fatal s2 /= []) $ do
void $ notifyAdmins s2 "Fatal error" $ pre_ $ summary $ head $ fatal s2
return (bad s2,q)
return $ case res of
Just (Left e) -> OutputError e
Just (Right q) -> questionToOutput $ Just q
Nothing -> questionToOutput Nothing
else
return OutputMissing
evaluate $ force res
clientChange :: Memory -> Memory -> IO (Memory -> Memory)
clientChange s1 s2 = do
let before = Map.keysSet $ Map.filter ciAlive $ clients s1
let after = Map.keysSet $ Map.filter ciAlive $ clients s2
let f msg xs = sequence [notifyAdmins s2 (msg ++ ": " ++ fromClient x) $ str_ "" | x <- Set.toList xs]
a <- f "Client added" $ after `Set.difference` before
b <- f "Client timed out" $ before `Set.difference` after
return $ foldr (.) id $ a ++ b
initialiseFake :: Oven State Patch Test -> Prettys -> IO Memory
initialiseFake oven prettys = do
store <- newStore False "bake-store"
mem <- newMemory oven prettys store (stateFailure, Answer (bigStringFromString "Initial state created by view mode") Nothing [] False)
return mem{fatal = ["View mode, database is read-only"]}
initialise :: Oven State Patch Test -> Prettys -> [Author] -> Worker -> IO Memory
initialise oven prettys admins extra = do
now <- getCurrentTime
putStrLn "Initialising server, computing initial state..."
(res, answer) <- runInit
let state0 = fromMaybe stateFailure res
putStrLn $ "Initial state: " ++ maybe "!FAILURE!" fromState res
store <- newStore False "bake-store"
when (isJust res) $ do
extra $ storeExtraAdd store (Left state0) =<< patchExtra state0 Nothing
mem <- newMemory oven prettys store (state0, answer)
mem <- return mem{admins = admins ,fatal = ["Failed to initialise, " ++ bigStringToString (aStdout answer) | isNothing res]}
bad <- if isJust res then notifyAdmins mem "Starting" $ str_ "Server starting" else
notifyAdmins mem "Fatal error during initialise" $
str_ "Failed to initialise" <> br_ <> pre_ (bigStringWithString (aStdout answer) summary)
return $ bad mem
patchExtra :: State -> Maybe Patch -> IO (T.Text, TL.Text)
patchExtra s p = do
(ex,ans) <- runExtra s p
case ex of
Just x -> return x
Nothing -> do
let failSummary = T.pack $ renderHTML $ i_ $ str_ "Error when computing patch information"
let failDetail = TL.pack $ renderHTML $ pre_ $ str_ (bigStringToString $ aStdout ans)
return (failSummary, failDetail)