darcsden-1.0: 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
import Control.Exception
import Control.Monad (forM_)
import Control.Monad.Trans
import Database.CouchDB
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 DarcsDen.Debug
import DarcsDen.Handler
import DarcsDen.Settings
import DarcsDen.State.Schema
import DarcsDen.State.Util (runDB, withRedis)
import DarcsDen.WebUtils (exceptionPage)


main :: IO ()
main = do
    cwd <- liftIO getCurrentDirectory
    as <- getArgs
    case as of
        ("--install":_) -> runDB $ do
            liftIO (putStrLn "creating databases...")

            createDB "repositories"
            createDB "users"
            createDB "issues"
            createDB "comments"

            liftIO (putStrLn "creating repository design documents...")
            forM_ repoDesigns $ \js ->
                newDoc (db "repositories") js

            liftIO (putStrLn "creating user design documents...")
            forM_ userDesigns $ \js ->
                newDoc (db "users") js

            liftIO (putStrLn "creating issue design documents...")
            forM_ issueDesigns $ \js ->
                newDoc (db "issues") js

            liftIO (putStrLn "creating comment design documents...")
            forM_ commentDesigns $ \js ->
                newDoc (db "comments") js

            liftIO (putStrLn "All set!")

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

        ("--port":p:_) -> do
            checkDBs
            putStrLn $ "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"
                ]
  where
    checkDBs = do
        putStrLn "checking couchdb..."
        runDB (return ())

        putStrLn "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
#ifdef DEBUG
        -- . setVerbose False
#endif
        $ 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
  ]