diff --git a/src/App.hs b/src/App.hs index 0f4db393a..ad8721cd3 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} -module App (app) where +module App (app, sqlErrHandler, isSqlError) where import Control.Monad (join) import Control.Arrow ((***)) import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) +-- import Control.Exception.Base import Data.Text hiding (map) import Data.Maybe (fromMaybe) @@ -26,6 +27,7 @@ import Data.Aeson import Data.Coerce import Data.Monoid import qualified Hasql as H +import qualified Hasql.Backend as HB import qualified Hasql.Postgres as H import PgQuery @@ -158,6 +160,17 @@ app req = allOrigins = ("Access-Control-Allow-Origin", "*") :: Header +isSqlError :: HB.Error -> Maybe HB.Error +isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x +isSqlError _ = Nothing + +sqlErrHandler :: HB.Error -> IO Response +sqlErrHandler (HB.ErroneousResult err) = do + return $ if "42P01" `isInfixOf` err + then responseLBS status404 [] "" + else responseLBS status400 [] (cs err) +sqlErrHandler _ = error "just for debugging" + rangeStatus :: Int -> Int -> Int -> Status rangeStatus from to total | from > total = status416 diff --git a/src/Main.hs b/src/Main.hs index bc6ec3c8d..bd4decb9c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ import Middleware import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (runReaderT, ask) +import Control.Exception import Data.String.Conversions (cs) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Handler.Warp hiding (Connection) @@ -44,13 +45,14 @@ main = do middle = (if configSecure conf then redirectInsecure else id) . gzip def . cors corsPolicy . clientErrors - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in + . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) - H.session pgSettings sessSettings $ do - session' <- flip runReaderT <$> ask - let runApp req respond = respond =<< session' (app req) in + H.session pgSettings sessSettings $ do + session' <- flip runReaderT <$> ask + let runApp req respond = + respond =<< catchJust isSqlError (session' $ app req) sqlErrHandler - liftIO $ runSettings appSettings $ middle runApp + liftIO $ runSettings appSettings $ middle runApp -- . authenticated (cs $ configAnonRole conf) $ app where diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index a86d7c567..0c966ad64 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -12,6 +12,7 @@ import Data.String.Conversions (cs) import Control.Monad.Reader (runReaderT, ask) -- import Control.Monad (void) import Control.Applicative ( (<$>) ) +import Control.Exception import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization) @@ -22,7 +23,7 @@ import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS -- import Network.Wai.Middleware.Cors (cors) -import App (app) +import App (app, sqlErrHandler, isSqlError) -- import Config (corsPolicy, AppConfig(..)) -- import Auth (addUser) @@ -44,7 +45,8 @@ withApp perform = perform $ \req resp -> H.session pgSettings testSettings $ do session' <- flip runReaderT <$> ask - liftIO $ resp =<< session' (app req) + liftIO $ resp =<< catchJust isSqlError (session' $ app req) + sqlErrHandler rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]