diff --git a/dbapi.cabal b/dbapi.cabal index 14f0b90b0..9250400fa 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -16,7 +16,7 @@ executable dbapi default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , hasql, hasql-backend, hasql-postgres + , hasql >= 0.2.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -34,7 +34,7 @@ executable dbapi , transformers , bcrypt, base64-string , network-uri >= 2.6 - , resource-pool, process + , resource-pool , blaze-builder , vector , mtl @@ -58,7 +58,7 @@ Test-Suite spec Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , hasql, hasql-backend, hasql-postgres + , hasql >= 0.2.0, hasql-backend, hasql-postgres , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/src/App.hs b/src/App.hs index 317d11835..0f4db393a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,7 +2,6 @@ module App (app) where import Control.Monad (join) -import Data.Monoid ( (<>) ) import Control.Arrow ((***)) import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) @@ -13,7 +12,6 @@ import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -import Data.ByteString.Char8 hiding (zip, map, elem) import Data.String.Conversions (cs) import Data.List (sortBy) import qualified Data.Set as S @@ -25,6 +23,8 @@ import Network.HTTP.Base (urlEncodeVars) import Network.Wai import Data.Aeson +import Data.Coerce +import Data.Monoid import qualified Hasql as H import qualified Hasql.Postgres as H @@ -53,8 +53,8 @@ app req = then return $ responseLBS status416 [] "HTTP Range error" else do let qt = QualifiedTable schema (cs table) - let select = - ("select ",[]) <> + let select = coerce $ + ("select ",[],mempty) <> parentheticT ( whereT qq $ countRows qt ) <> commaq <> ( @@ -102,7 +102,7 @@ app req = ([table], "POST") -> handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) - H.unit $ insertInto qt (map cs $ keys obj) (elems obj) + H.unit . coerce $ insertInto qt (map cs $ keys obj) (elems obj) primaryKeys <- map cs <$> primaryKeyColumns qt let primaries = filterWithKey (const . (`elem` primaryKeys)) obj let params = urlEncodeVars @@ -126,7 +126,7 @@ app req = let cols = map cs $ keys obj if S.fromList tableCols == S.fromList cols then do let vals = elems obj - H.unit $ iffNotT + H.unit . coerce $ iffNotT (whereT qq $ update qt cols vals) (insertInto qt cols vals) return $ responseLBS status204 [ jsonH ] "" @@ -140,6 +140,7 @@ app req = handleJsonObj req $ \obj -> H.tx Nothing $ do let qt = QualifiedTable schema (cs table) H.unit + $ coerce $ whereT qq $ update qt (map cs $ keys obj) (elems obj) return $ responseLBS status204 [ jsonH ] "" @@ -173,15 +174,15 @@ contentRangeH from to total = <> cs (show total) ) -requestedSchema :: RequestHeaders -> ByteString +requestedSchema :: RequestHeaders -> Text requestedSchema hdrs = case verStr of Just [[_, ver]] -> ver _ -> "1" where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String - accept = lookup hAccept hdrs :: Maybe ByteString - verStr = (=~ verRegex) <$> accept :: Maybe [[ByteString]] + accept = cs <$> lookup hAccept hdrs :: Maybe Text + verStr = (=~ verRegex) <$> accept :: Maybe [[Text]] jsonH :: Header jsonH = (hContentType, "application/json") diff --git a/src/Auth.hs b/src/Auth.hs index ac4675df9..4b87243b5 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -2,12 +2,13 @@ module Auth where import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS import Control.Monad (mzero) import Control.Applicative ( (<*>), (<$>) ) import Crypto.BCrypt +import Data.Text import qualified Hasql as H import qualified Hasql.Postgres as H +import Data.String.Conversions (cs) data AuthUser = AuthUser { userId :: String @@ -22,7 +23,7 @@ instance JSON.FromJSON AuthUser where v JSON..: "role" parseJSON _ = mzero -type DbRole = BS.ByteString +type DbRole = Text data LoginAttempt = NoCredentials @@ -31,23 +32,23 @@ data LoginAttempt = | LoginSuccess DbRole deriving (Eq, Show) -checkPass :: BS.ByteString -> BS.ByteString -> Bool -checkPass = validatePassword +checkPass :: Text -> Text -> Bool +checkPass = (. cs) . validatePassword . cs -setRole :: BS.ByteString -> H.Tx H.Postgres s () +setRole :: Text -> H.Tx H.Postgres s () setRole role = H.unit $ [H.q| set role ?|] role resetRole :: H.Tx H.Postgres s () resetRole = H.unit [H.q|reset role|] -addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ()) +addUser :: Text -> Text -> Text -> IO(H.Tx H.Postgres s ()) addUser identity pass role = do - Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass + Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) return $ H.unit $ [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|] identity hashed role -signInRole :: BS.ByteString -> BS.ByteString -> H.Tx H.Postgres s LoginAttempt +signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt signInRole user pass = do u <- H.single $ [H.q|select pass, rolname from dbapi.auth where id = ?|] user return $ maybe LoginFailed (\r -> diff --git a/src/PgQuery.hs b/src/PgQuery.hs index a0147dde6..14070ccf6 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module PgQuery where import RangeQuery @@ -8,8 +9,8 @@ import qualified Hasql.Backend as H import Data.Text hiding (map) import Text.Regex.TDFA ( (=~) ) import Text.Regex.TDFA.Text () -import qualified Data.ByteString.Char8 as BS import qualified Network.HTTP.Types.URI as Net +import qualified Data.ByteString.Char8 as BS import Data.Monoid import Data.Maybe (fromMaybe, mapMaybe) import Data.Functor ( (<$>) ) @@ -18,29 +19,32 @@ import Data.String.Conversions (cs) import qualified Data.Aeson as JSON import qualified Data.List as L -type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres +type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All) + +type StatementT = DynamicSQL -> DynamicSQL + data QualifiedTable = QualifiedTable { - qtSchema :: BS.ByteString -, qtName :: BS.ByteString + qtSchema :: Text +, qtName :: Text } deriving (Show) data OrderTerm = OrderTerm { - otTerm :: BS.ByteString + otTerm :: Text , otDirection :: BS.ByteString } limitT :: Maybe NonnegRange -> StatementT limitT r q = - q <> (" LIMIT " <> limit <> " OFFSET " <> (cs . show) offset <> " ", []) + q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty) where - limit = cs $ fromMaybe "ALL" $ show . rangeLimit <$> r - offset = fromMaybe 0 $ rangeOffset <$> r + limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r + offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r whereT :: Net.Query -> StatementT whereT params q = if L.null params then q - else q <> (" where ",[]) <> conjunction + else q <> (" where ",[],mempty) <> conjunction where cols = [ col | col <- params, fst col `notElem` ["order"] ] conjunction = mconcat $ L.intersperse andq (map wherePred cols) @@ -49,69 +53,70 @@ orderT :: [OrderTerm] -> StatementT orderT ts q = if L.null ts then q - else q <> (" order by ",[]) <> clause + else q <> (" order by ",[],mempty) <> clause where clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> H.Statement H.Postgres - queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " " - <> otDirection t <> " " - , []) + queryTerm :: OrderTerm -> DynamicSQL + queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> otDirection t <> " " + , [], mempty) parentheticT :: StatementT -parentheticT (sql, params) = - (" (" <> sql <> ") ", params) +parentheticT (sql, params, pre) = + (" (" <> sql <> ") ", params, pre) -iffNotT :: H.Statement H.Postgres -> StatementT -iffNotT (aq, ap) (bq, bp) = +iffNotT :: DynamicSQL -> StatementT +iffNotT (aq, ap, apre) (bq, bp, bpre) = ("WITH aaa AS (" <> aq <> " returning *) " <> bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp + , All $ getAll apre && getAll bpre ) -countRows :: QualifiedTable -> H.Statement H.Postgres +countRows :: QualifiedTable -> DynamicSQL countRows t = - ("select count(1) from " <> fromQt t, []) + ("select count(1) from " <> fromQt t, [], mempty) asJsonWithCount :: StatementT -asJsonWithCount (sql, params) = ( +asJsonWithCount (sql, params, pre) = ( "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t" - , params + , params, pre ) -selectStar :: QualifiedTable -> H.Statement H.Postgres +selectStar :: QualifiedTable -> DynamicSQL selectStar t = - ("select * from " <> fromQt t, []) + ("select * from " <> fromQt t, [], mempty) -insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> - H.Statement H.Postgres +insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL insertInto t [] _ = - ("insert into " <> fromQt t <> " default values returning *", []) + ("insert into " <> fromQt t <> " default values returning *", [], mempty) insertInto t cols vals = ("insert into " <> fromQt t <> " (" <> - BS.intercalate ", " (map pgFmtIdent cols) <> + cs (intercalate ", " (map pgFmtIdent cols)) <> ") values (" <> - BS.intercalate ", " (map (const "?") vals) <> - ") returning *" + cs (intercalate ", " (map (const "?") vals)) <> + ")" , map pgParam vals + , mempty ) -update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] -> - H.Statement H.Postgres +update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL update t cols vals = ("update " <> fromQt t <> " set (" <> - BS.intercalate ", " (map pgFmtIdent cols) <> + cs (intercalate ", " (map pgFmtIdent cols)) <> ") = (" <> - BS.intercalate ", " (map (const "?") vals) <> ")" + cs (intercalate ", " (map (const "?") vals)) <> ")" , map pgParam vals + , mempty ) -wherePred :: Net.QueryItem -> H.Statement H.Postgres +wherePred :: Net.QueryItem -> DynamicSQL wherePred (col, predicate) = - (" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value]) + (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> " ", [], mempty) where - opCode:rest = BS.split '.' $ fromMaybe "." predicate - value = BS.intercalate "." rest + opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate + value = intercalate "." rest op = case opCode of "eq" -> "=" "gt" -> ">" @@ -123,41 +128,41 @@ wherePred (col, predicate) = orderParse :: Net.Query -> [OrderTerm] orderParse q = - mapMaybe orderParseTerm . BS.split ',' $ cs order + mapMaybe orderParseTerm . split (==',') $ cs order where order = fromMaybe "" $ join (lookup "order" q) -orderParseTerm :: BS.ByteString -> Maybe OrderTerm +orderParseTerm :: Text -> Maybe OrderTerm orderParseTerm s = - case BS.split '.' s of + case split (=='.') s of [d,c] -> if d `elem` ["asc", "desc"] - then Just $ OrderTerm (cs c) $ + then Just $ OrderTerm c $ if d == "asc" then "asc" else "desc" else Nothing _ -> Nothing -commaq :: H.Statement H.Postgres -commaq = (", ", []) +commaq :: DynamicSQL +commaq = (", ", [], mempty) -andq :: H.Statement H.Postgres -andq = (" and ", []) +andq :: DynamicSQL +andq = (" and ", [], mempty) -pgFmtIdent :: BS.ByteString -> BS.ByteString +pgFmtIdent :: Text -> Text pgFmtIdent x = let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in - cs $ if escaped =~ danger + if escaped =~ danger then "\"" <> escaped <> "\"" else escaped - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString + 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) + cs $ if escaped =~ ("\\\\" :: Text) then "E" <> slashed else slashed @@ -165,7 +170,7 @@ trimNullChars :: Text -> Text trimNullChars = Data.Text.takeWhile (/= '\x0') fromQt :: QualifiedTable -> BS.ByteString -fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) +fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) pgParam :: JSON.Value -> H.StatementArgument H.Postgres pgParam (JSON.Number n) = H.renderValue n diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 0ba1cfaf7..89e85c58c 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -7,7 +7,6 @@ import Data.Text hiding (foldl, map, zipWith, concat) import Data.Aeson import Data.Functor.Identity import qualified Data.Vector as V -import qualified Data.ByteString.Char8 as BS import Data.String.Conversions (cs) import Control.Applicative ( (<*>) ) @@ -19,9 +18,9 @@ import qualified Hasql as H import qualified Hasql.Backend as H import qualified Hasql.Postgres as H -foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey) +foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey) foreignKeys table = do - r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- H.list $ [H.q| + r :: [(Text, Text, Text)] <- H.list $ [H.q| select kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name from information_schema.table_constraints AS tc @@ -39,7 +38,7 @@ foreignKeys table = do addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m -tables :: BS.ByteString -> H.Tx H.Postgres s [Table] +tables :: Text -> H.Tx H.Postgres s [Table] tables schema = H.list $ [H.q| select table_schema, table_name, @@ -85,9 +84,9 @@ columns table = do return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols -primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString] +primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text] primaryKeyColumns table = do - r :: [Identity BS.ByteString] <- H.list $ [H.q| + r :: [Identity Text] <- H.list $ [H.q| select kc.column_name from information_schema.table_constraints tc, @@ -101,19 +100,6 @@ primaryKeyColumns table = do return $ map runIdentity r --- instance FromRow Table where --- fromRow = Table <$> field <*> field <*> (toBool <$> field) - --- instance FromRow Column where --- fromRow = Column <$> --- field <*> field <*> field <*> field --- <*> (toBool <$> field) --- <*> field --- <*> (toBool <$> field) --- <*> field <*> field <*> field --- <*> (vanishNull . splitOn "," <$> field) --- <*> return Nothing - vanishNull :: [a] -> Maybe [a] vanishNull xs = if L.null xs then Nothing else Just xs @@ -151,9 +137,9 @@ instance H.RowParser H.Postgres Column where table = H.parseResult $ r V.! 1 name = H.parseResult $ r V.! 2 position = H.parseResult $ r V.! 3 - nullable = H.parseResult $ r V.! 4 + nullable = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text) typ = H.parseResult $ r V.! 5 - updatable = H.parseResult $ r V.! 6 + updatable = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text) maxLen = H.parseResult $ r V.! 7 precision = H.parseResult $ r V.! 8 defValue = H.parseResult $ r V.! 9 @@ -169,7 +155,7 @@ instance H.RowParser H.Postgres Table where parseRow r = let schema = H.parseResult $ r V.! 0 name = H.parseResult $ r V.! 2 - insertable = H.parseResult $ r V.! 3 in + insertable = toBool <$> (H.parseResult $ r V.! 3 :: Either Text Text) in if V.length r /= 3 then Left "Wrong number of fields in Table" else Table <$> schema <*> name <*> insertable diff --git a/test/Main.hs b/test/Main.hs index a3380388c..115171702 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -13,7 +13,7 @@ main :: IO () main = do roles <- loadFixture "roles" schema <- loadFixture "schema" - H.session pgSettings testSettings $ do + H.session pgSettings testSettings $ H.tx Nothing $ do H.unit [H.q| drop schema if exists "1" cascade |] H.unit [H.q| drop schema if exists private cascade |] @@ -26,4 +26,4 @@ main = do loadFixture :: FilePath -> IO(H.Statement H.Postgres) loadFixture name = do query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql" - return (query, []) + return (query, [], False)