{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import Control.Concurrent (forkIO, killThread) import Control.Monad (liftM, msum) import Control.Monad.Trans (lift, liftIO) import Data.Time (getCurrentTime, getCurrentTimeZone, utcToLocalTime) import Extra.URI (relURI) import Happstack.Data (Typeable, deriveSerialize) import Happstack.Server (parseConfig, Conf(port, validator), wdgHTMLValidator, simpleHTTP, withDataFn, lookPairs, ServerPartT(..), Method(..), method, setHeader, dir, seeOther, Response, toResponse, ok) import Happstack.Server.Extra (debug404) import Happstack.State (Proxy(..), shutdownSystem, Version, mkMethods, Component(..), End, startSystemState, waitForTermination,) import HSP import System.Cmd (system) import System.Environment (getArgs) import System.IO (hPutStrLn, stderr) -- Import instance ToMessage XML import Happstack.Server.HSP.HTML() main :: IO () main = do control <- startSystemState entryPoint eConf <- liftM parseConfig getArgs let conf = case eConf of Left e -> error (unlines e) Right c -> c { port = 8080, validator = Just wdgHTMLValidator } tid <- forkIO $ simpleHTTP conf $ msum $ impl hPutStrLn stderr $ "running on port " ++ show (port conf) ++ "..." waitForTermination killThread tid shutdownSystem control entryPoint :: Proxy State entryPoint = Proxy impl :: [ServerPartT IO Response] impl = [ dir "restart" $ method GET $ do result <- liftIO (system "whoami && /etc/init.d/reportserver stop && sleep 1 && /etc/init.d/reportserver start") zone <- liftIO getCurrentTimeZone now <- liftIO (getCurrentTime >>= return . utcToLocalTime zone) seeOther (relURI "/" [("message", "Restarted at " ++ show now ++", result=" ++ show result)]) (toResponse ()) , withDataFn lookPairs $ \ pairs -> method GET $ do ok . doHtml . toResponse =<< lift (evalHSP (page pairs) Nothing) , debug404 ] page :: [(String, String)] -> HSP XML page pairs = withMetaData html4Strict $ Restart Button

<% maybe "" id (lookup "message" pairs) %>
doHtml :: Response -> Response doHtml res = setHeader "Content-Type" "text/html; charset=UTF-8" res -- STATE data State = State deriving Typeable $(mkMethods ''State []) $(deriveSerialize ''State) instance Version State instance Component State where type Dependencies State = End initialValue = State