WebUtils.hs

{-# LANGUAGE OverloadedStrings #-}
module DarcsDen.WebUtils where

import Control.Exception
import Control.Monad.Trans
import Data.List (find)
import Data.Maybe (isNothing)
import Data.Monoid (mconcat)
import HSP (XML, evalHSP, renderXML, renderAsHTML)
import Snap.Core
import Snap.Util.FileServe
import System.FilePath
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8 (pack)
import qualified Data.Map as M

import DarcsDen.Pages.HSPage ( HSPage )
import DarcsDen.State.Session
import DarcsDen.State.Repository (getRepository)
import DarcsDen.State.Util (repoDir)
import DarcsDen.Util (fromBS, toBS)


type Page = Session -> Snap ()


notFound :: Snap ()
notFound = notFoundPage ""

notFoundPage :: BS.ByteString -> Snap ()
notFoundPage msg = do
  putResponse
    $ setResponseStatus 404 "Not Found"
    $ setContentType "text/html; charset=utf-8"
    emptyResponse
  r <- getRequest
  writeBS $ errorPageLayout r "background-color:#ffe; color:orange;" "not found" msg
  withResponse finishWith

tobs :: String -> BS.ByteString
tobs = B8.pack

exceptionPage :: SomeException -> Snap ()
exceptionPage e = do
  r <- getRequest
  errorPage' $ errorPageLayout r "background-color:#fee; color:red;" "error" (tobs $ show e)

errorPage :: BS.ByteString -> Snap ()
errorPage msg = do
  r <- getRequest
  errorPage' $ errorPageLayout r "background-color:#fee; color:red;" "error" msg

errorPageLayout :: Request -> BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString
errorPageLayout req style title content =
  BS.intercalate "\n" $
   ["<html>"
   ,"<body style='text-align:center;'>"
   ,mconcat ["<div style='margin:auto; display:inline-block; padding:1em 3em;",style,"'>"]
   ,mconcat ["<h1 style='font-family:sans-serif; font-size:4em; margin:0;'>",title,"</h1>"]
   ,"<p style='font-family:sans-serif; font-size:1em;'>"
   ,mconcat ["Sorry.. your ", B8.pack $ show $ rqMethod req, " request to ", rqURI req, " failed. The details have been logged."]
   ,"</p>"
   ,"<pre style='font-family:sans-serif; font-size:1em;'>"
   ,humaniseError content
   ,"</pre>"
   ,"</div>"
   ,"</body>"
   ,"</html>"
   ]

humaniseError :: BS.ByteString -> BS.ByteString
humaniseError msg
  -- the most common cause of errors
  | match "thread killed"
    || (match "user error (internal error: server error: GET http://127.0.0.1:5984"
        && match "users/_view/by_email"
        && match "Content-Length: 0") =
    -- "That strange couchdb users by email error happened. We don't know the cause yet."
    -- "This request took too long and timed out. We need someone to add caching and background jobs to <a href=\"http://hub.darcs.net/simon/darcsden/browse/src/DarcsDen/Handler/Repository/Browse.hs\">darcsden</a>."
    "This request took too long and timed out."

  | match "failed to read patch" =
    "This request took too long and timed out, or there was a problem reading this patch."

  | match "CouchDB" || match "http://127.0.0.1:5984" =
    "There was a problem querying the database."

  | match "ExceptionAlreadyCaught" =
    "ExceptionAlreadyCaught. Hmm, that's unusual."

  | otherwise = msg

  where match = (`BS.isInfixOf` msg)

errorPage' :: BS.ByteString -> Snap ()
errorPage' html = do
  putResponse
    $ setResponseStatus 500 "Internal Server Error"
    $ setContentType "text/html; charset=utf-8"
    emptyResponse
  writeBS html
  withResponse finishWith
    -- finishWith
    --   $ setResponseStatus 500 "Internal Server Error"
    --   . setContentType "text/html; charset=utf-8"
    --   . setContentLength (fromIntegral $ B.length p)
    --   . modifyResponseBody (>==> enumBuilder (fromByteString p))
    --   $ emptyResponse
-- import Snap.Iteratee ((>==>), enumBuilder)

redirectTo :: String -> Snap ()
redirectTo dest = do
    putResponse (setResponseStatus 302 "Found" emptyResponse)
    withResponse (finishWith . addHeader "Location" (toBS dest))

withSession :: Page -> Snap ()
withSession p = do
    r <- getRequest
    case find ((== "DarcsDenSession") . cookieName) (rqCookies r) of
        Nothing -> withNewSession p
        Just (Cookie { cookieValue = sid }) -> do
            ms <- getSession sid
            case ms of
                Just s -> p s
                Nothing -> withNewSession p

withNewSession :: Page -> Snap ()
withNewSession r = do
    ms <- newSession

    case ms of
        Just s -> do
            modifyResponse $ addResponseCookie
                Cookie { cookieName = "DarcsDenSession"
                       , cookieValue = sID s
                       , cookieExpires = Just (sExpire s)
                       , cookieDomain = Nothing
                       , cookiePath = Just "/"
                       , cookieSecure = False
                       , cookieHttpOnly = False
                       }
            r s
        Nothing -> errorPage "Session could not be created."

repoServe :: String -> Snap ()
repoServe b = do
    mo <- getParam "user"
    mr <- getParam "repo"
    case (mo, mr) of
        (Just owner, Just repo) -> do
            private <- fmap isNothing (getRepository (fromBS owner, fromBS repo))
            if private
              then notFound
              else serveDirectory (repoDir (fromBS owner) (fromBS repo) </> b)
        _ ->
            notFound

input :: String -> String -> Snap String
input p d = do
    param <- getParam (toBS p)
    return (maybe d fromBS param)

getInputs :: Snap [(String, String)]
getInputs = fmap
    (map (\(k, vs) -> (fromBS k, vs >>= fromBS)) . M.toList)
    (withRequest (return . rqParams))

-- Page helpers
doPage' :: (XML -> String) -> BS.ByteString -> HSPage -> Page
doPage' render contentType p s = do
    (_, page) <- liftIO $ evalHSP Nothing (p s)
    modifyResponse (addHeader "Content-Type" contentType)
    writeBS (toBS $ render page)
    clearNotifications s

doPage :: HSPage -> Page
doPage = doPage' (("<!DOCTYPE html>\n" ++) . renderAsHTML) "text/html; charset=utf-8"

doAtomPage :: HSPage -> Page
doAtomPage = doPage' (("<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" ++) . renderXML) "application/atom+xml; charset=utf-8"