diff --git a/dbapi.cabal b/dbapi.cabal index 1ff77708b..39811709d 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -14,8 +14,9 @@ executable dbapi ghc-options: -Wall -W -Werror -O2 default-language: Haskell2010 default-extensions: OverloadedStrings + other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , HDBC, HDBC-postgresql + , postgresql-simple >= 0.4.7.0 , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -24,6 +25,7 @@ executable dbapi , scientific, time , aeson, network >= 2.6 , bytestring, text, split, string-conversions + , stringsearch , containers, unordered-containers , optparse-applicative >= 0.9.1 && < 0.10 , regex-base, regex-tdfa @@ -33,6 +35,7 @@ executable dbapi , bcrypt, base64-string , network-uri >= 2.6 , resource-pool, process + , blaze-builder Other-Modules: Dbapi , PgStructure , PgQuery @@ -51,7 +54,7 @@ Test-Suite spec Other-Modules: Dbapi, Spec, SpecHelper Build-Depends: base, hspec2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , HDBC, HDBC-postgresql + , postgresql-simple >= 0.4.7.0 , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive @@ -60,6 +63,7 @@ Test-Suite spec , http-types, scientific, time , bytestring, aeson, network >= 2.6 , text, optparse-applicative + , stringsearch , unordered-containers , regex-base , string-conversions @@ -72,3 +76,4 @@ Test-Suite spec , split , network-uri >= 2.6 , resource-pool + , blaze-builder diff --git a/src/PgQuery.hs b/src/PgQuery.hs index f3b193b76..11f657911 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,262 +1,93 @@ --- {{{ Imports -module PgQuery ( - getRows -, insert -, update -, upsert -, addUser -, signInRole -, setRole -, resetRole -, checkPass -, pgFmtIdent -, pgFmtLit -, RangedResult(..) -, LoginAttempt(..) -, DbRole -) where +module PgQuery where -import Data.Text (Text, splitOn, intercalate, replace, takeWhile) -import Data.String.Conversions (cs) -import Data.Functor ( (<$>) ) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>), mconcat) -import qualified Data.Map as M - -import Text.Regex.TDFA ((=~)) -import Text.Regex.TDFA.Text () - -import Control.Monad (join) - -import qualified RangeQuery as R +import RangeQuery +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.List as L - -import Database.HDBC hiding (colType, colNullable) -import Database.HDBC.PostgreSQL - +import Data.ByteString.Search (split) import qualified Network.HTTP.Types.URI as Net - -import Types (SqlRow(..), getRow, sqlRowColumns, sqlRowValues) -import Crypto.BCrypt (hashPasswordUsingPolicy, fastBcryptHashingPolicy, validatePassword) - --- }}} +import Blaze.ByteString.Builder.ByteString (fromByteString) +import Data.Text hiding (map, intersperse, split) +import Data.Monoid +import Data.Maybe (fromMaybe) +import Data.Functor ( (<$>) ) +import Data.String.Conversions (cs) +import qualified Data.List as L data RangedResult = RangedResult { rrFrom :: Int , rrTo :: Int , rrTotal :: Int -, rrBody :: BL.ByteString +, rrBody :: BS.ByteString } deriving (Show) -type Schema = Text -type DbRole = BS.ByteString - -data LoginAttempt = - NoCredentials - | MalformedAuth - | LoginFailed - | LoginSuccess DbRole - deriving (Eq, Show) - -getRows :: Schema -> Text -> Net.Query -> Maybe R.NonnegRange -> Connection -> IO RangedResult -getRows schema table qq range conn = do - r <- quickQuery conn (cs query) [] - - return $ case r of - [[total, _, SqlNull]] -> RangedResult offset 0 (fromSql total) "[]" - [[total, limited_total, json]] -> - RangedResult offset (offset + fromSql limited_total - 1) - (fromSql total) (fromSql json) - _ -> RangedResult 0 0 0 "[]" - - where - offset = fromMaybe 0 $ R.offset <$> range - query = globalAndLimitedCounts schema table qq <> jsonArrayRows ( - selectStarClause schema table - <> whereClause qq - <> orderClause qq - <> limitClause range) - - -whereClause :: Net.Query -> Text -whereClause qs = - if null qs then "" else " where " <> conjunction - - where - cols = [ col | col <- qs, fst col `notElem` ["order"] ] - conjunction = mconcat $ L.intersperse " and " (map wherePred cols) - - -orderClause :: Net.Query -> Text -orderClause qs = do - let order = fromMaybe "" $ join $ lookup "order" qs - terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order - termPred = mconcat $ L.intersperse ", " (map orderTermSql terms) - - if null terms - then "" - else " order by " <> termPred - - where - parseOrderTerm :: Text -> Maybe OrderTerm - parseOrderTerm s = - case splitOn "." s of - [d,c] -> - if d `elem` ["asc", "desc"] - then Just $ OrderTerm d c - else Nothing - _ -> Nothing - - orderTermSql :: OrderTerm -> Text - orderTermSql t = pgFmtIdent (otColumn t) <> " " <> otDirection t - +type CompleteQuery = (Query, [Action]) +type CompleteQueryT = CompleteQuery -> CompleteQuery +type JsonQuery = CompleteQuery +data QualifiedTable = QualifiedTable { + qtSchema :: Text +, qtName :: Text +} deriving (Show) data OrderTerm = OrderTerm { - otDirection :: Text -, otColumn :: Text + otTerm :: BS.ByteString +, otDirection :: BS.ByteString } +limitT :: Maybe NonnegRange -> CompleteQueryT +limitT r q = + q <> (" LIMIT ? OFFSET ? ", [toField limit, toField offset]) + where + limit = fromMaybe "ALL" $ show . rangeLimit <$> r + offset = fromMaybe 0 $ rangeOffset <$> r -wherePred :: Net.QueryItem -> Text -wherePred (column, predicate) = - pgFmtIdent (cs column) <> " " <> op <> " " <> pgFmtLit (cs value) +whereT :: Net.Query -> CompleteQueryT +whereT params q = + if L.null params + then q + else q <> conjunction + where + cols = [ col | col <- params, fst col `notElem` ["order"] ] + conjunction = mconcat $ L.intersperse (" and ",[]) (map wherePred cols) + +orderT :: [OrderTerm] -> CompleteQueryT +orderT ts q = + if L.null ts + then q + else q <> (" order by ",[]) <> clause + where + clause = mconcat $ L.intersperse (", ",[]) (map queryTerm ts) + queryTerm :: OrderTerm -> CompleteQuery + queryTerm t = + (" ? ? ", + [EscapeIdentifier (otTerm t), Plain (fromByteString $ otDirection t)] + ) + -- order = fromMaybe "" $ join (lookup "order" qs) + -- terms = mapMaybe parseOrderTerm $ splitOn "," $ cs order + -- termPred = mconcat $ L.intersperse ", " (map orderTermSql terms) + +wherePred :: Net.QueryItem -> CompleteQuery +wherePred (col, predicate) = + (" ? ? ? ", [EscapeIdentifier col, Plain op, toField value]) where opCode:rest = BS.split '.' $ fromMaybe "." predicate value = BS.intercalate "." rest - op = case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - _ -> "=" + op = fromByteString $ case opCode of + "eq" -> "=" + "gt" -> ">" + "lt" -> "<" + "gte" -> ">=" + "lte" -> "<=" + "neq" -> "<>" + _ -> "=" -limitClause :: Maybe R.NonnegRange -> Text -limitClause range = - cs $ " LIMIT " <> limit <> " OFFSET " <> show offset <> " " - - where - limit = fromMaybe "ALL" $ show <$> (R.limit =<< range) - offset = fromMaybe 0 $ R.offset <$> range - -globalAndLimitedCounts :: Schema -> Text -> Net.Query -> Text -globalAndLimitedCounts schema table qq = - " select " - <> "(select count(1) from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " - <> whereClause qq - <> "), count(t), " - -selectStarClause :: Schema -> Text -> Text -selectStarClause schema table = - " select * from " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " " - -jsonArrayRows :: Text -> Text -jsonArrayRows q = - "array_to_json(array_agg(row_to_json(t))) from (" <> q <> ") t" - -insert :: Schema -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue) -insert schema table row conn = do - stmt <- prepare conn $ cs sql - _ <- execute stmt $ sqlRowValues row - Just m <- fetchRowMap stmt - return m - - where sql = insertClause schema table row - -addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Connection -> IO () -addUser identity pass role conn = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy $ cs pass - _ <- quickQuery conn - "insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)" - $ map toSql [identity, hashed, role] - return () - -signInRole :: BS.ByteString -> BS.ByteString -> Connection -> IO LoginAttempt -signInRole user pass conn = do - u <- quickQuery conn "select pass, rolname from dbapi.auth where id = ?" [toSql user] - return $ case u of - [[hashed, role]] -> - if checkPass (fromSql hashed) (cs pass) - then LoginSuccess $ fromSql role - else LoginFailed - _ -> LoginFailed - -checkPass :: BS.ByteString -> BS.ByteString -> Bool -checkPass = validatePassword - -upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> - IO (M.Map String SqlValue) -upsert schema table row qq conn = do - stmt <- prepare conn $ cs $ upsertClause schema table row qq - _ <- execute stmt $ join $ replicate 2 $ sqlRowValues row - m <- fetchRowMap stmt - return $ fromMaybe M.empty m - -update :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> - IO (M.Map String SqlValue) -update schema table row qq conn = do - stmt <- prepare conn $ cs $ updateClause schema table row qq - _ <- execute stmt $ sqlRowValues row - m <- fetchRowMap stmt - return $ fromMaybe M.empty m - -placeholders :: Text -> SqlRow -> Text -placeholders symbol = intercalate ", " . map (const symbol) . getRow - -insertClause :: Schema -> Text -> SqlRow -> Text -insertClause schema table (SqlRow []) = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " default values returning *" -insertClause schema table row = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") values (" <> placeholders "?" row <> ") returning *" - -insertClauseViaSelect :: Schema -> Text -> SqlRow -> Text -insertClauseViaSelect schema table row = - "insert into " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") select " <> placeholders "?" row - -updateClause :: Schema -> Text -> SqlRow -> Net.Query -> Text -updateClause schema table row qq = - "update " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " set (" <> - intercalate ", " (map pgFmtIdent (sqlRowColumns row)) - <> ") = (" <> placeholders "?" row <> ")" - <> whereClause qq - -upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> Text -upsertClause schema table row qq = - "with upsert as (" <> updateClause schema table row qq - <> " returning *) " <> insertClauseViaSelect schema table row - <> " where not exists (select * from upsert) returning *" - -pgFmtIdent :: Text -> Text -pgFmtIdent x = - let escaped = replace "\"" "\"\"" (trimNullChars x) in - if escaped =~ danger - then "\"" <> escaped <> "\"" - else escaped - - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text - -pgFmtLit :: Text -> Text -pgFmtLit x = - let trimmed = trimNullChars x - escaped = "'" <> replace "'" "''" trimmed <> "'" - slashed = replace "\\" "\\\\" escaped in - if escaped =~ ("\\\\" :: Text) - then "E" <> slashed - else slashed - -trimNullChars :: Text -> Text -trimNullChars = Data.Text.takeWhile (/= '\x0') - -setRole :: Connection -> DbRole -> IO () -setRole conn role = runRaw conn $ "set role " <> cs role - -resetRole :: Connection -> IO () -resetRole conn = runRaw conn "reset role" +orderParseTerm :: BS.ByteString -> Maybe OrderTerm +orderParseTerm s = + case split "." s of + [d,c] -> + if d `elem` ["asc", "desc"] + then Just $ OrderTerm (cs c) $ + if d == "asc" then "asc" else "desc" + else Nothing + _ -> Nothing diff --git a/src/RangeQuery.hs b/src/RangeQuery.hs index 45b6dfdbc..6eb4bfedf 100644 --- a/src/RangeQuery.hs +++ b/src/RangeQuery.hs @@ -1,8 +1,16 @@ -module RangeQuery where +module RangeQuery ( + rangeParse +, rangeRequested +, rangeLimit +, rangeOffset +, NonnegRange +) where import Control.Applicative import Network.HTTP.Types.Header +import qualified Data.ByteString.Char8 as BS + import Data.Ranged.Boundaries import Data.Ranged.Ranges @@ -14,6 +22,33 @@ import Data.Maybe (fromMaybe, listToMaybe) type NonnegRange = Range Int +rangeParse :: BS.ByteString -> Maybe NonnegRange +rangeParse range = do + let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString + + parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) + + let [_, from, to] = readMaybe . cs <$> parsedRange + let lower = fromMaybe emptyRange (rangeGeq <$> from) + let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) + + return $ rangeIntersection lower upper + +rangeRequested :: RequestHeaders -> Maybe NonnegRange +rangeRequested = (rangeParse =<<) . lookup hRange + +rangeLimit :: NonnegRange -> Maybe Int +rangeLimit range = + case [rangeLower range, rangeUpper range] + of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + _ -> Nothing + +rangeOffset :: NonnegRange -> Int +rangeOffset range = + case rangeLower range + of BoundaryBelow from -> from + _ -> error "range without lower bound" -- should never happen + rangeGeq :: Int -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll @@ -21,33 +56,3 @@ rangeGeq n = rangeLeq :: Int -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n) - -parseRange :: String -> Maybe NonnegRange -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 NonnegRange -requestedRange hdrs = parseRange =<< cs <$> lookup hRange hdrs - -requestedContentRange :: RequestHeaders -> Maybe NonnegRange -requestedContentRange hdrs = parseRange =<< cs <$> lookup "Content-Range" 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 - _ -> error "range without lower bound" -- should never happen