{-# LANGUAGE ScopedTypeVariables #-}
module Happstack.Server.Helpers
    ( smartserver, exactdir, smartserver',getData',vhosts,vhost
    ) where
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)