darcsden-1.1: src/WebServer.hs

{-# LANGUAGE OverloadedStrings, CPP #-}
module Main where

import Blaze.ByteString.Builder (fromByteString, toByteString)
import Blaze.ByteString.Builder.Char8 (fromShow)
-- #ifdef DEBUG
-- import Blaze.ByteString.Builder.Char8 (fromString)
-- #endif
#ifdef WIN32
import Control.Concurrent (forkIO, killThread)
#endif
import Control.Exception
import Control.Monad.Trans
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 (pack)
import Data.Monoid (mconcat)
import Snap.Core
import Snap.Http.Server
import System.Directory (getCurrentDirectory)
import System.Environment
import OpenSSL (withOpenSSL)
import System.IO ( Handle, stdout, hPutStrLn )
#ifdef WIN32
import System.Win32.SystemServices.Wrapper ( defineService, Service(..) )
#endif

-- import DarcsDen.Debug
import DarcsDen.Handler
import DarcsDen.Settings
import DarcsDen.State.Util (runDB, withRedis, createFreshState)
import DarcsDen.WebUtils (exceptionPage)


main :: IO ()
main = withOpenSSL $ do
    cwd <- liftIO getCurrentDirectory
    as <- getArgs
    go False stdout cwd as

go :: Bool -> Handle -> FilePath -> [String] -> IO ()
go noVerboseSnap outH cwd as =
    case as of
        ("--install":_) -> runDB $ createFreshState True

        ("--root":root:as') -> go noVerboseSnap outH root as'

#ifdef WIN32
        ("--service":as') ->
            defineService $
                Service {
                    serviceName = "Darcsden",
                    -- when wrapping as a service, we have to take care that the
                    -- service code doesn't try to use stdout/stderr, as they
                    -- don't exist. This means stopping Snap from being verbose,
                    -- and redirecting our own output to the service wrapper's log.
                    serviceStart = \debugH -> forkIO (go True debugH cwd as'),
                    serviceStop = killThread
                }
#endif

        [] -> do
            checkDBs
            hPutStrLn outH "darcsden running on port 8900"
            startHTTP 8900 hostname cwd

        ("--port":p:_) -> do
            checkDBs
            hPutStrLn outH $ "darcsden running on port " ++ p
            startHTTP (read p) hostname cwd

        _ ->
            putStr . unlines $
                [ "usage:"
                , "  darcsden --readme    : figure out how to use this thing"
                , "  darcsden --install   : set up CouchDB databases"
                , "  darcsden             : start webserver with defaults"
                , "  darcsden --port PORT : start webserver on given port"
                , "  darcsden --root DIR  : select root directory (defaults to current directory)"
#ifdef WIN32
                , "  darcsden --service   : run as a Windows service"
#endif
                ]
  where
    checkDBs = do
        hPutStrLn outH "checking couchdb..."
        runDB (return ())

        hPutStrLn outH "checking redis..."
        withRedis (return ())

    startHTTP p h d = httpServe (config p h) (handler d)

    config p h
        = setAccessLog (ConfigFileLog $ accessLog)
        . setErrorLog (ConfigFileLog $ errorLog)
        . setPort p
        . setHostname (B8.pack h)
        . setDefaultTimeout maxRequestTime
        . setErrorHandler errorHandler
        . (if noVerboseSnap then setVerbose False else id)
        $ defaultConfig

errorHandler :: SomeException -> Snap ()
errorHandler e = do
    r <- getRequest
    logError $ errorLogMsg e r
    exceptionPage e

errorLogMsg :: SomeException -> Request -> B.ByteString
errorLogMsg e r =
  toByteString $ mconcat $
  [ fromByteString "During processing of request from "
  , fromByteString $ rqRemoteAddr r
  , fromByteString ":"
  , fromShow $ rqRemotePort r
  , fromByteString "\n"
  , fromByteString "Request handler threw an exception:\n"
  , fromShow e
-- #ifdef DEBUG
--   , fromByteString "Request:\n"
--   , fromString $ show r
--   , fromByteString "\n"
-- #endif
  ]