From f6a4a98e7479cfa4c2a08325b408e1b10d6e92e5 Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Mon, 28 Jul 2014 17:16:55 -0700
Subject: [PATCH] Parse range queries

---
 Main.hs       |  3 ++-
 PgQuery.hs    |  1 -
 RangeQuery.hs | 38 ++++++++++++++++++++++++++++++++++++++
 dbapi.cabal   |  5 ++++-
 4 files changed, 44 insertions(+), 3 deletions(-)
 create mode 100644 RangeQuery.hs

diff --git a/Main.hs b/Main.hs
index c047ebbd0..bd08fca9e 100644
--- a/Main.hs
+++ b/Main.hs
@@ -21,10 +21,11 @@ import qualified Data.ByteString.Char8 as BS
 
 import PgStructure (printTables, printColumns)
 import PgQuery     (selectWhere)
+import RangeQuery
 
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
-import Text.Regex.Posix ((=~))
+import Text.Regex.TDFA ((=~))
 import Text.Read (readMaybe)
 
 data AppConfig = AppConfig {
diff --git a/PgQuery.hs b/PgQuery.hs
index 836b58f76..82fa7d264 100644
--- a/PgQuery.hs
+++ b/PgQuery.hs
@@ -31,7 +31,6 @@ selectWhere ver table qq conn = do
           \  from (select * from %I.%I) t"
         [toSql ver, toSql table]
 
-
 whereClause :: Connection -> Query -> IO BS.ByteString
 whereClause _    [] = return ""
 whereClause conn qs =
diff --git a/RangeQuery.hs b/RangeQuery.hs
new file mode 100644
index 000000000..9de732527
--- /dev/null
+++ b/RangeQuery.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RangeQuery where
+
+import Control.Applicative
+import Network.HTTP.Types.Header
+
+import Data.Ranged.Boundaries
+import Data.Ranged.Ranges
+
+import qualified Data.ByteString.Char8 as BS
+import Text.Regex.TDFA ((=~))
+import Text.Read (readMaybe)
+
+import Data.Maybe (fromMaybe, listToMaybe)
+
+rangeGeq :: Int -> Range Int
+rangeGeq n =
+  head $ rangeUnion (singletonRange n) $ Range (BoundaryAbove n) BoundaryAboveAll
+
+rangeLeq :: Int -> Range Int
+rangeLeq n =
+  head $ rangeUnion (singletonRange n) $ Range BoundaryBelowAll (BoundaryBelow n)
+
+parseRange :: String -> Maybe(Range Int)
+parseRange range = do
+  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: String
+
+  parsedRange <- listToMaybe (range =~ rangeRegex :: [[String]])
+
+  let [_, from, to] = readMaybe <$> parsedRange
+  let lower = fromMaybe emptyRange   (rangeGeq <$> from)
+  let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
+
+  return $ rangeIntersection lower upper
+
+requestedRange :: RequestHeaders -> Maybe(Range Int)
+requestedRange hdrs = parseRange =<< BS.unpack <$> lookup hRange hdrs
diff --git a/dbapi.cabal b/dbapi.cabal
index 8ed3ee099..a6818d129 100644
--- a/dbapi.cabal
+++ b/dbapi.cabal
@@ -15,6 +15,7 @@ executable dbapi
   ghc-options:         -Wall
   other-modules:       PgStructure
                      , PgQuery
+                     , RangeQuery
   other-extensions:    OverloadedStrings
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql
@@ -22,6 +23,8 @@ executable dbapi
                      , bytestring, aeson, network
                      , text, optparse-applicative
                      , unordered-containers
-                     , http-media, regex-posix
+                     , regex-base
+                     , http-media, regex-tdfa
+                     , Ranged-sets
   -- hs-source-dirs:
   default-language:    Haskell2010