diff --git a/Main.hs b/Main.hs index bd08fca9e..416ed0f62 100644 --- a/Main.hs +++ b/Main.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- {{{ Imports + module Main where import Control.Applicative @@ -28,6 +30,12 @@ import qualified Data.Text as T import Text.Regex.TDFA ((=~)) import Text.Read (readMaybe) +import Data.Ranged.Ranges (emptyRange) + +import Debug.Trace + +-- }}} + data AppConfig = AppConfig { configDbUri :: String , configPort :: Int } @@ -49,26 +57,33 @@ main = do where describe = progDesc "create a REST API to an existing Postgres database" +traceThis :: (Show a) => a -> a +traceThis x = trace (show x) x + app :: AppConfig -> Application app config req respond = do r <- try $ case path of [] -> responseLBS status200 [json] <$> (printTables ver =<< conn) - [table] -> responseLBS status200 [json] <$> + [table] -> if range == Just emptyRange + then return $ responseLBS status416 [] "HTTP Range error" + else responseLBS status200 [json] <$> ( if verb == methodOptions then printColumns ver table =<< conn - else selectWhere (T.pack $ show ver) table qq =<< conn ) + else + selectWhere (T.pack $ show ver) table qq range =<< conn ) _ -> return $ responseLBS status404 [] "" respond $ either sqlErrorHandler id r where - path = pathInfo req - verb = requestMethod req - json = (hContentType, "application/json") - conn = connectPostgreSQL $ configDbUri config - qq = queryString req - ver = fromMaybe 1 $ requestedVersion (requestHeaders req) + path = pathInfo req + verb = requestMethod req + json = (hContentType, "application/json") + conn = connectPostgreSQL $ configDbUri config + qq = queryString req + ver = fromMaybe 1 $ requestedVersion (requestHeaders req) + range = requestedRange (requestHeaders req) requestedVersion :: RequestHeaders -> Maybe Int requestedVersion hdrs = diff --git a/PgQuery.hs b/PgQuery.hs index 82fa7d264..606f7e902 100644 --- a/PgQuery.hs +++ b/PgQuery.hs @@ -7,6 +7,7 @@ import Data.Maybe (fromMaybe) import Data.List (intercalate) import Data.Monoid ((<>)) +import qualified RangeQuery as R import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BS @@ -16,20 +17,24 @@ import Database.HDBC.PostgreSQL import Network.HTTP.Types.URI -selectWhere :: T.Text -> T.Text -> Query -> Connection -> IO BL.ByteString -selectWhere ver table qq conn = do +selectWhere :: T.Text -> T.Text -> Query -> Maybe R.NonnegRange -> Connection -> IO BL.ByteString +selectWhere ver table qq range conn = do s <- selectSql w <- whereClause conn qq r <- quickQuery conn (BS.unpack $ s <> w) [] + return $ case r of [[json]] -> fromSql json _ -> "" :: BL.ByteString where + limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) + offset = fromMaybe 0 (R.offset <$> range) selectSql = pgFormat conn "select array_to_json(array_agg(row_to_json(t)))\ - \ from (select * from %I.%I) t" - [toSql ver, toSql table] + \ from (select * from %I.%I LIMIT %s OFFSET %s) t" + [toSql ver, toSql table, toSql limit, toSql offset] + whereClause :: Connection -> Query -> IO BS.ByteString whereClause _ [] = return "" @@ -41,7 +46,7 @@ whereClause conn qs = clause = BS.intercalate " and " <$> preds preds :: IO [BS.ByteString] - preds = sequence $ map (wherePred conn) qs + preds = mapM (wherePred conn) qs wherePred :: Connection -> QueryItem -> IO BS.ByteString diff --git a/RangeQuery.hs b/RangeQuery.hs index 1ef361bae..00d6d78a7 100644 --- a/RangeQuery.hs +++ b/RangeQuery.hs @@ -14,15 +14,17 @@ import Text.Read (readMaybe) import Data.Maybe (fromMaybe, listToMaybe) -rangeGeq :: Int -> Range Int +type NonnegRange = Range Int + +rangeGeq :: Int -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll -rangeLeq :: Int -> Range Int +rangeLeq :: Int -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n) -parseRange :: String -> Maybe(Range Int) +parseRange :: String -> Maybe NonnegRange parseRange range = do let rangeRegex = "^([0-9]+)-([0-9]*)$" :: String @@ -34,5 +36,17 @@ parseRange range = do return $ rangeIntersection lower upper -requestedRange :: RequestHeaders -> Maybe(Range Int) +requestedRange :: RequestHeaders -> Maybe NonnegRange requestedRange hdrs = parseRange =<< BS.unpack <$> lookup hRange hdrs + +limit :: NonnegRange -> Maybe Int +limit range = + case [rangeLower range, rangeUpper range] + of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing + +offset :: NonnegRange -> Int +offset range = + case rangeLower range + of BoundaryBelow from -> from + _ -> 0 -- should never happen