{-# LANGUAGE ScopedTypeVariables #-}
module Happstack.Server.Helpers
    ( smartserver, exactdir, smartserver',getData',vhosts,vhost
    ) where

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
-- 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
      tid <- forkIO $ simpleHTTP' f conf handler
      putStrLn . ( ( "simpleHttp started on port " ++ (show . port $ conf) ++ "\n" ++
                 "shut down with ctrl-c" ) ++) =<< time
      waitForTermination
      killThread tid
      putStrLn . ( "creating checkpoint: " ++ ) =<< time
      createCheckpoint control

      putStrLn .  ( "shutting down system: " ++ ) =<< time
      shutdownSystem control 
      putStrLn .  ( "exiting: " ++ ) =<< time
         where time = return . ("\ntime: " ++ ) . show  =<< getClockTime

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