{-# 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" $ ["" ,"" ,mconcat ["

"] ,mconcat ["

",title,"

"] ,"

" ,mconcat ["Sorry.. your ", B8.pack $ show $ rqMethod req, " request to ", rqURI req, " failed. The details have been logged."] ,"

" ,"

"
   ,humaniseError content
   ,"

" ,"

" ,"" ,"" ] 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 darcsden." "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' (("\n" ++) . renderAsHTML) "text/html; charset=utf-8" doAtomPage :: HSPage -> Page doAtomPage = doPage' (("\n" ++) . renderXML) "application/atom+xml; charset=utf-8"