Accept range headers

TODO: response headers and proper codes

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 =

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

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