{-# 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
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