{-# LANGUAGE ScopedTypeVariables #-}
module Happstack.Server.Helpers
( smartserver, exactdir, smartserver',getData',vhosts,vhost, cleanUpLockFile, scrapeUrl, websiteUp
) where
import Network.Stream
import qualified Network.HTTP as HTTP
import Data.Char (toLower)
import Data.List (isInfixOf)
import Network.URI (parseURI)
import System.FilePath ((</>))
import System.Timeout (timeout)
import Control.Monad.Error
import System.Directory (getCurrentDirectory, doesFileExist, removeFile)
import qualified Control.Exception as E
import Data.IORef
import Happstack.Server
import Happstack.State
import System.Environment
import Control.Concurrent
import System.Time
import Control.Monad
import Debug.Trace.Helpers
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Char8 as B
import System.Exit
-- run the happs server on some port
-- include cookie fix, various other enhancements that make things simpler
smartserver' :: (Methods st, Component st, ToMessage b, Monad m, Functor m) =>
(m (Maybe (Either Response a, FilterFun Response)) ->
IO (Maybe (Either Response b, FilterFun Response))) ->
Conf -> ServerPartT m a -> Proxy st -> IO ()
smartserver' f conf handler stateProxy = do
putStrLn . ( "starting happs server" ++ ) =<< time
control <- startSystemState stateProxy -- start the HAppS state system
putStrLn . ( "happs state started" ++ ) =<< time
-- if the web server throws an error within 3 seconds, exit app gracefully (is there a better way to handle this?)
(webserverTid,result) <- catchStartupErrorInForkIO (simpleHTTP' f conf handler) 3
case result of
Left e -> do putStrLn $ "smartserver' couldn't start http server: " ++ (show e)
stateShutdown control
exitWith $ ExitFailure 0
_ -> putStrLn . ( ( "simpleHttp started on port " ++ (show . port $ conf) ++ "\n" ++
"shut down with ctrl-c" ) ++) =<< time
waitForTermination
killThread webserverTid
stateShutdown control
time = return . ("\ntime: " ++ ) . show =<< getClockTime
stateShutdown control = do
putStrLn . ( "creating checkpoint: " ++ ) =<< time
createCheckpoint control
putStrLn . ( "shutting down system: " ++ ) =<< time
shutdownSystem control
putStrLn . ( "exiting: " ++ ) =<< time
smartserver :: (Methods st, Component st, ToMessage a) =>
Conf -> ServerPartT IO a -> Proxy st -> IO ()
smartserver = smartserver' id
exactdir :: (Monad m) => String -> ServerPartT m a -> ServerPartT m a
exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath)
spsIf :: (Monad m) => (Request -> Bool) -> ServerPartT m a -> ServerPartT m a
spsIf p sps = do
rq <- askRq
if p rq
then sps
else mzero
getData' :: (ServerMonad m, FromData a, MonadPlus m) => m a
getData' = getData >>= maybe mzero return
-- | multiple vhosts to a server, eg
-- | vhosts [("mysite.com",80),("www.mysite.com",80)] mySiteController
vhosts hosts sp = msum . map (\h -> vhost h sp) $ hosts
{- | vhost doms h = msum . map (\d -> site d h) doms
similar to apache vhost. given (domain,port) and a main request handler, handle requests if it's the specified domain and port
vhost ("mysite.com",80) mySiteController
-}
vhost :: (String,Int) -> ServerPartT IO Response -> ServerPartT IO Response
vhost vh@(domain, port) sp = do
(p :: Int) <- liftM ( snd . rqPeer ) askRq
(d :: String) <- (B.unpack . fromMaybe (error "Happstack.Helpers.Server.vhost, no host header")) `liftM` getHeaderM "host"
guardRq $ \rq -> (d,p) == vh
sp
{-| If a forked IO action throws an exception within a certain amount of time, return the exception along with the threadId.
wait time needs to be long enough for the exception to arise, so when in doubt, err on the side of longer wait time
-}
catchStartupErrorInForkIO :: IO () -> Int -> IO (ThreadId, Either E.SomeException ())
catchStartupErrorInForkIO ioAction waitSeconds = do
eIOref <- newIORef $ Right ()
tid <- forkIO $ ioAction `E.catch` (\e -> writeIORef eIOref (Left e))
threadDelay $ waitSeconds * (10^6)
new <- readIORef eIOref
return (tid,new)
-- This is useful if you have a web server that crashes, but sometimes leaves the lock file hanging around.
-- But sometimes, due to unknown reasons, has a false restart that should quickly exit because the lock file exists and the app is really running.
-- What this function does is clean up the lock file, but only if a curl request for the actual web site fails.
-- This feels like risky business, try to find a better way (unclear on what the race condition, if any, is exactly but uneasy...)
-- Another danger is, what if the generated lock file doesn't match the actual lock file? (like if the underlying library call changes?)
cleanUpLockFile thisprog checkurl teststring waitSecs = do
progName <- getProgName
-- prevents inadvertent running from inside ghci.
unless (thisprog == progName) $ error $ "prog name isn't " ++ progName ++ " exiting: " ++ progName
lockFile <- liftM (</> "_local" </> progName ++ "_state.lock") getCurrentDirectory
putStrLn $ "cleanUpLockFile, lock file: " ++ lockFile
lock_fileExists <- doesFileExist lockFile
when lock_fileExists $ do
up <- websiteUp waitSecs checkurl teststring
if up
then do
threadDelay $ 2 * 10^6
error $ " cleanUpLockFile: " ++ progName ++ " is already running. That's odd. Exiting now."
else removeFile lockFile
websiteUp secsWaitRequest url teststring = do
let timeoutSecs n = timeout $ (10^6) * n
mbEtR <- timeoutSecs secsWaitRequest $ runErrorT $ scrapeUrl url
case mbEtR of
Nothing -> do putStrLn $ "scrapeUrl returned nothing after " ++ (show secsWaitRequest) ++ "seconds, so we conclude it's donwn"
return False
Just etR -> case etR of
Left e -> return False
Right s -> return $ isInfixOf (lc teststring) (lc s)
scrapeUrl :: String -> ErrorT String IO String
scrapeUrl url = do
rq <- ErrorT $ case Network.URI.parseURI url of
Nothing -> return . Left $ "bad url: " ++ url
Just uri -> return . Right $ HTTP.Request uri HTTP.GET [] ""
ErrorT $ do r <- catch ( HTTP.simpleHTTP rq )
( \e -> return . Left . Network.Stream.ErrorMisc . show $ e)
case r of
Right x -> return . Right . HTTP.rspBody $ x
Left y -> return . Left $ "web fetch failed: " ++ (show rq)
lc = map toLower