content: {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections, ViewPatterns #-}
  
  -- | Define a continuous integration system.
  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
                      -- prune but don't save, will reprune on the next ping
                      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
  
  
  -- | Get information about a patch
  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)
  