Fix warnings, lint, and ambiguous hasql imports

This commit is contained in:
Joe Nelson
2015-01-28 20:37:19 -08:00
parent 3151aa2ebc
commit da6318f5a2
9 changed files with 118 additions and 116 deletions
+3 -3
View File
@@ -30,7 +30,7 @@ executable postgrest
, scientific, time
, aeson, network >= 2.6
, bytestring, text, split, string-conversions
, stringsearch, parsec
, stringsearch
, containers, unordered-containers
, optparse-applicative >= 0.9.1 && < 0.10
, regex-base, regex-tdfa
@@ -58,7 +58,7 @@ Test-Suite spec
default-extensions: OverloadedStrings, ScopedTypeVariables
other-extensions: QuasiQuotes
Hs-Source-Dirs: test, src
ghc-options: -Wall -W
ghc-options: -Wall -W -Werror
Main-Is: Main.hs
Other-Modules: App, Auth, Config, Spec, SpecHelper
Build-Depends: base, hspec >= 2.1.2, QuickCheck
@@ -73,7 +73,7 @@ Test-Suite spec
, http-types, scientific, time
, bytestring, aeson, network >= 2.6
, text, optparse-applicative
, stringsearch, parsec
, stringsearch
, unordered-containers
, regex-base
, string-conversions
+9 -7
View File
@@ -27,16 +27,15 @@ import Data.Aeson
import Data.Monoid
import qualified Data.Vector as V
import qualified Hasql as H
import qualified Hasql.Backend as H hiding (Tx)
import qualified Hasql.Postgres as H
import qualified Hasql.Backend as B
import qualified Hasql.Postgres as P
import Auth
import PgQuery
import RangeQuery
import PgStructure
import Text.Parsec hiding (Column)
app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
app :: BL.ByteString -> Request -> H.Tx P.Postgres s Response
app reqBody req =
case (path, verb) of
([], _) -> do
@@ -55,7 +54,7 @@ app reqBody req =
then return $ responseLBS status416 [] "HTTP Range error"
else do
let qt = QualifiedTable schema (cs table)
let select = (H.Stmt "select " V.empty True) <>
let select = B.Stmt "select " V.empty True <>
parentheticT (
whereT qq $ countRows qt
) <> commaq <> (
@@ -175,7 +174,10 @@ app reqBody req =
range = rangeRequested hdrs
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
sqlError :: t
sqlError = undefined
isSqlError :: t
isSqlError = undefined
rangeStatus :: Int -> Int -> Int -> Status
@@ -207,8 +209,8 @@ requestedSchema hdrs =
jsonH :: Header
jsonH = (hContentType, "application/json")
handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)
-> H.Tx H.Postgres s Response
handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-> H.Tx P.Postgres s Response
handleJsonObj reqBody handler = do
let p = eitherDecode reqBody
case p of
+7 -7
View File
@@ -9,8 +9,8 @@ import Data.Text
import Data.Monoid
import qualified Data.Vector as V
import qualified Hasql as H
import qualified Hasql.Backend as H hiding (Tx)
import qualified Hasql.Postgres as H
import qualified Hasql.Backend as B
import qualified Hasql.Postgres as P
import Data.String.Conversions (cs)
import PgQuery (pgFmtLit)
@@ -47,20 +47,20 @@ data LoginAttempt =
checkPass :: Text -> Text -> Bool
checkPass = (. cs) . validatePassword . cs
setRole :: Text -> H.Tx H.Postgres s ()
setRole role = H.unitEx $ H.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
setRole :: Text -> H.Tx P.Postgres s ()
setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
resetRole :: H.Tx H.Postgres s ()
resetRole :: H.Tx P.Postgres s ()
resetRole = H.unitEx [H.stmt|reset role|]
addUser :: Text -> Text -> Text -> H.Tx H.Postgres s ()
addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()
addUser identity pass role = do
let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
H.unitEx $
[H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
identity (cs hashed :: Text) role
signInRole :: Text -> Text -> H.Tx H.Postgres s LoginAttempt
signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
signInRole user pass = do
u <- H.maybeEx $ [H.stmt|select pass, rolname from postgrest.auth where id = ?|] user
return $ maybe LoginFailed (\r ->
+12 -10
View File
@@ -1,8 +1,10 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
module Error (PgError, errResponse) where
import qualified Hasql as H
import qualified Hasql.Postgres as H
import qualified Hasql.Postgres as P
import qualified Network.HTTP.Types.Status as HT
import qualified Data.Aeson as JSON
import qualified Data.Text as T
@@ -11,33 +13,33 @@ import Data.String.Conversions (cs)
import Data.String.Utils(replace)
import Network.Wai(Response, responseLBS)
type PgError = H.SessionError H.Postgres
type PgError = H.SessionError P.Postgres
errResponse :: PgError -> Response
errResponse e = responseLBS (httpStatus e) [] (JSON.encode e)
instance JSON.ToJSON PgError where
toJSON (H.TxError (H.ErroneousResult c m d h)) = JSON.object [
toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [
"code" .= (cs c::T.Text),
"message" .= (cs m::T.Text),
"details" .= (fmap cs d::Maybe T.Text),
"hint" .= (fmap cs h::Maybe T.Text)]
toJSON (H.TxError (H.NoResult d)) = JSON.object [
toJSON (H.TxError (P.NoResult d)) = JSON.object [
"message" .= ("No response from server"::T.Text),
"details" .= (fmap cs d::Maybe T.Text)]
toJSON (H.TxError (H.UnexpectedResult m)) = JSON.object ["message" .= m]
toJSON (H.TxError H.NotInTransaction) = JSON.object [
toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]
toJSON (H.TxError P.NotInTransaction) = JSON.object [
"message" .= ("Not in transaction"::T.Text)]
toJSON (H.CxError (H.CantConnect d)) = JSON.object [
toJSON (H.CxError (P.CantConnect d)) = JSON.object [
"message" .= ("Can't connect to the database"::T.Text),
"details" .= (fmap cs d::Maybe T.Text)]
toJSON (H.CxError (H.UnsupportedVersion v)) = JSON.object [
toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [
"message" .= ("Postgres version "++version++" is not supported") ]
where version = replace "0" "." (show v)
toJSON (H.ResultError m) = JSON.object ["message" .= m]
httpStatus :: PgError -> HT.Status
httpStatus (H.TxError (H.ErroneousResult codeBS _ _ _)) =
httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
let code = cs codeBS in
case code of
'0':'8':_ -> HT.status503 -- pg connection err
@@ -63,5 +65,5 @@ httpStatus (H.TxError (H.ErroneousResult codeBS _ _ _)) =
"42P01" -> HT.status404 -- undefined table
"42501" -> HT.status404 -- insufficient privilege
_ -> HT.status400
httpStatus (H.TxError (H.NoResult _)) = HT.status503
httpStatus (H.TxError (P.NoResult _)) = HT.status503
httpStatus _ = HT.status500
+3 -4
View File
@@ -8,7 +8,6 @@ import Error(errResponse)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Exception
import Data.String.Conversions (cs)
import Network.Wai (strictRequestBody)
import Network.Wai.Middleware.Cors (cors)
@@ -18,7 +17,7 @@ import Network.Wai.Middleware.Static (staticPolicy, only)
import Data.List (intercalate)
import Data.Version (versionBranch)
import qualified Hasql as H
import qualified Hasql.Postgres as H
import qualified Hasql.Postgres as P
import Options.Applicative hiding (columns)
import Config (AppConfig(..), argParser, corsPolicy)
@@ -33,7 +32,7 @@ main = do
Prelude.putStrLn $ "Listening on port " ++
(show $ configPort conf :: String)
let pgSettings = H.ParamSettings (cs $ configDbHost conf)
let pgSettings = P.ParamSettings (cs $ configDbHost conf)
(fromIntegral $ configDbPort conf)
(cs $ configDbUser conf)
(cs $ configDbPass conf)
@@ -50,7 +49,7 @@ main = do
poolSettings <- maybe (fail "Improper session settings") return $
H.poolSettings (fromIntegral $ configPool conf) 30
pool :: H.Pool H.Postgres
pool :: H.Pool P.Postgres
<- H.acquirePool pgSettings poolSettings
runSettings appSettings $ middle $ \req respond -> do
+5 -5
View File
@@ -9,7 +9,7 @@ import Data.Text
-- import Data.Pool(withResource, Pool)
import qualified Hasql as H
import qualified Hasql.Postgres as H
import qualified Hasql.Postgres as P
import Data.String.Conversions(cs)
import Network.HTTP.Types.Header (hLocation, hAuthorization)
@@ -23,8 +23,8 @@ import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
import Codec.Binary.Base64.String (decode)
authenticated :: forall s. Text -> Text ->
(Request -> H.Tx H.Postgres s Response) ->
Request -> H.Tx H.Postgres s Response
(Request -> H.Tx P.Postgres s Response) ->
Request -> H.Tx P.Postgres s Response
authenticated currentRole anon app req = do
attempt <- httpRequesterRole (requestHeaders req)
case attempt of
@@ -36,7 +36,7 @@ authenticated currentRole anon app req = do
NoCredentials -> if anon /= currentRole then runInRole anon else app req
where
httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s LoginAttempt
httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
httpRequesterRole hdrs = do
let auth = fromMaybe "" $ lookup hAuthorization hdrs
case split (==' ') (cs auth) of
@@ -46,7 +46,7 @@ authenticated currentRole anon app req = do
_ -> return MalformedAuth
_ -> return NoCredentials
runInRole :: Text -> H.Tx H.Postgres s Response
runInRole :: Text -> H.Tx P.Postgres s Response
runInRole r = do
setRole r
res <- app req
+30 -29
View File
@@ -5,8 +5,9 @@ module PgQuery where
import RangeQuery
import qualified Hasql.Postgres as H
import qualified Hasql.Backend as H
import qualified Hasql as H
import qualified Hasql.Postgres as P
import qualified Hasql.Backend as B
import Data.Text hiding (map, empty)
import Text.Regex.TDFA ( (=~) )
@@ -23,11 +24,11 @@ import qualified Data.Aeson as JSON
import qualified Data.List as L
import Data.Scientific (isInteger, formatScientific, FPFormat(..))
type PStmt = H.Stmt H.Postgres
type PStmt = H.Stmt P.Postgres
instance Monoid PStmt where
mappend (H.Stmt query params prep) (H.Stmt query' params' prep') =
H.Stmt (query <> query') (params <> params') (prep && prep')
mempty = H.Stmt "" empty True
mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
B.Stmt (query <> query') (params <> params') (prep && prep')
mempty = B.Stmt "" empty True
type StatementT = PStmt -> PStmt
data QualifiedTable = QualifiedTable {
@@ -42,7 +43,7 @@ data OrderTerm = OrderTerm {
limitT :: Maybe NonnegRange -> StatementT
limitT r q =
q <> H.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
where
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
@@ -51,7 +52,7 @@ whereT :: Net.Query -> StatementT
whereT params q =
if L.null cols
then q
else q <> H.Stmt " where " empty True <> conjunction
else q <> B.Stmt " where " empty True <> conjunction
where
cols = [ col | col <- params, fst col `notElem` ["order"] ]
conjunction = mconcat $ L.intersperse andq (map wherePred cols)
@@ -60,22 +61,22 @@ orderT :: [OrderTerm] -> StatementT
orderT ts q =
if L.null ts
then q
else q <> H.Stmt " order by " empty True <> clause
else q <> B.Stmt " order by " empty True <> clause
where
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
queryTerm :: OrderTerm -> PStmt
queryTerm t = H.Stmt
queryTerm t = B.Stmt
(" " <> cs (pgFmtIdent $ otTerm t) <> " "
<> cs (otDirection t) <> " ")
empty True
parentheticT :: StatementT
parentheticT s =
s { H.stmtTemplate = " (" <> H.stmtTemplate s <> ") " }
s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
iffNotT :: PStmt -> StatementT
iffNotT (H.Stmt aq ap apre) (H.Stmt bq bp bpre) =
H.Stmt
iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
B.Stmt
("WITH aaa AS (" <> aq <> " returning *) " <>
bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
(ap <> bp)
@@ -83,32 +84,32 @@ iffNotT (H.Stmt aq ap apre) (H.Stmt bq bp bpre) =
countT :: StatementT
countT s =
s { H.stmtTemplate = "WITH qqq AS (" <> H.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
countRows :: QualifiedTable -> PStmt
countRows t = H.Stmt ("select count(1) from " <> fromQt t) empty True
countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
asJsonWithCount :: StatementT
asJsonWithCount s = s { H.stmtTemplate =
asJsonWithCount s = s { B.stmtTemplate =
"count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
<> H.stmtTemplate s <> ") t" }
<> B.stmtTemplate s <> ") t" }
asJsonRow :: StatementT
asJsonRow s = s { H.stmtTemplate = "row_to_json(t) from (" <> H.stmtTemplate s <> ") t" }
asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
selectStar :: QualifiedTable -> PStmt
selectStar t = H.Stmt ("select * from " <> fromQt t) empty True
selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
returningStarT :: StatementT
returningStarT s = s { H.stmtTemplate = H.stmtTemplate s <> " RETURNING *" }
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
deleteFrom :: QualifiedTable -> PStmt
deleteFrom t = H.Stmt ("delete from " <> fromQt t) empty True
deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertInto t [] _ = H.Stmt
insertInto t [] _ = B.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertInto t cols vals = H.Stmt
insertInto t cols vals = B.Stmt
("insert into " <> fromQt t <> " (" <>
intercalate ", " (map pgFmtIdent cols) <>
") values ("
@@ -117,9 +118,9 @@ insertInto t cols vals = H.Stmt
empty True
insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertSelect t [] _ = H.Stmt
insertSelect t [] _ = B.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertSelect t cols vals = H.Stmt
insertSelect t cols vals = B.Stmt
("insert into " <> fromQt t <> " ("
<> intercalate ", " (map pgFmtIdent cols)
<> ") select "
@@ -127,7 +128,7 @@ insertSelect t cols vals = H.Stmt
empty True
update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
update t cols vals = H.Stmt
update t cols vals = B.Stmt
("update " <> fromQt t <> " set ("
<> intercalate ", " (map pgFmtIdent cols)
<> ") = ("
@@ -136,7 +137,7 @@ update t cols vals = H.Stmt
empty True
wherePred :: Net.QueryItem -> PStmt
wherePred (col, predicate) = H.Stmt
wherePred (col, predicate) = B.Stmt
(" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ")
empty True
@@ -169,10 +170,10 @@ orderParseTerm s =
_ -> Nothing
commaq :: PStmt
commaq = H.Stmt ", " empty True
commaq = B.Stmt ", " empty True
andq :: PStmt
andq = H.Stmt " and " empty True
andq = B.Stmt " and " empty True
pgFmtIdent :: Text -> Text
pgFmtIdent x =
+47 -48
View File
@@ -3,25 +3,20 @@
module PgStructure where
import PgQuery (QualifiedTable(..))
import Data.Functor ( (<$>) )
import Data.Text hiding (foldl, map, zipWith, concat)
import Data.Aeson
import Data.Functor.Identity
import qualified Data.Vector as V
import Data.String.Conversions (cs)
import Control.Applicative ( (<*>) )
import qualified Data.List as L
import qualified Data.Map as Map
import qualified Hasql as H
import qualified Hasql.Backend as H hiding (Tx)
import qualified Hasql.Postgres as H
import qualified Hasql.Postgres as P
foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
foreignKeys table = do
r :: [(Text, Text, Text)] <- H.listEx $ [H.stmt|
r <- H.listEx $ [H.stmt|
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
@@ -36,61 +31,65 @@ foreignKeys table = do
return $ foldl addKey Map.empty r
where
addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey
addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m
tables :: Text -> H.Tx H.Postgres s [Table]
tables schema =
map table <$> (H.listEx $ [H.stmt|
tables :: Text -> H.Tx P.Postgres s [Table]
tables schema = do
rows <- H.listEx $
[H.stmt|
select table_schema, table_name,
is_insertable_into
from information_schema.tables
where table_schema = ?
order by table_name
|] schema)
|] schema
return $ map tableFromRow rows
columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
columns :: QualifiedTable -> H.Tx P.Postgres s [Column]
columns table = do
cols <- H.listEx $ [H.stmt|
select info.table_schema as schema, info.table_name as table_name,
info.column_name as name, info.ordinal_position as position,
info.is_nullable as nullable, info.data_type as col_type,
info.is_updatable as updatable,
info.character_maximum_length as max_len,
info.numeric_precision as precision,
info.column_default as default_value,
array_to_string(enum_info.vals, ',') as enum
from (
select table_schema, table_name, column_name, ordinal_position,
is_nullable, data_type, is_updatable,
character_maximum_length, numeric_precision,
column_default, udt_name
from information_schema.columns
where table_schema = ? and table_name = ?
) as info
left outer join (
select n.nspname as s,
t.typname as n,
array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
from pg_type t
join pg_enum e on t.oid = e.enumtypid
join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
group by s, n
) as enum_info
on (info.udt_name = enum_info.n)
order by position |] (qtSchema table) (qtName table)
select info.table_schema as schema, info.table_name as table_name,
info.column_name as name, info.ordinal_position as position,
info.is_nullable as nullable, info.data_type as col_type,
info.is_updatable as updatable,
info.character_maximum_length as max_len,
info.numeric_precision as precision,
info.column_default as default_value,
array_to_string(enum_info.vals, ',') as enum
from (
select table_schema, table_name, column_name, ordinal_position,
is_nullable, data_type, is_updatable,
character_maximum_length, numeric_precision,
column_default, udt_name
from information_schema.columns
where table_schema = ? and table_name = ?
) as info
left outer join (
select n.nspname as s,
t.typname as n,
array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
from pg_type t
join pg_enum e on t.oid = e.enumtypid
join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
group by s, n
) as enum_info
on (info.udt_name = enum_info.n)
order by position |]
(qtSchema table) (qtName table)
fks <- foreignKeys table
return $ map ((addFK fks) . column) cols
return $ map (addFK fks . columnFromRow) cols
where
addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
primaryKeyColumns table = do
r :: [Identity Text] <- H.listEx $ [H.stmt|
r <- H.listEx $ [H.stmt|
select kc.column_name
from
information_schema.table_constraints tc,
@@ -135,13 +134,13 @@ data Column = Column {
, colFK :: Maybe ForeignKey
} deriving (Show)
table :: (Text, Text, Text) -> Table
table (s, n, i) = Table s n (toBool i)
tableFromRow :: (Text, Text, Text) -> Table
tableFromRow (s, n, i) = Table s n (toBool i)
column :: (Text, Text, Text, Int, Text, Text, Text,
columnFromRow :: (Text, Text, Text, Int, Text, Text, Text,
Maybe Int, Maybe Int, Maybe Text, Text)
-> Column
column (s, t, n, pos, nul, typ, u, l, p, d, e) =
columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
Column s t n pos (toBool nul) typ (toBool u) l p d (split (==',') e) Nothing
+2 -3
View File
@@ -14,9 +14,7 @@ import Data.String.Conversions (cs)
import Data.Monoid
import Data.Text hiding (map)
import qualified Data.Vector as V
-- import Control.Exception.Base (bracket, finally)
import Control.Monad (void)
import Control.Exception
import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
hRange, hAuthorization)
@@ -28,7 +26,7 @@ import qualified Data.ByteString.Char8 as BS
import Network.Wai.Middleware.Cors (cors)
import System.Process (readProcess)
import App (app, sqlError, isSqlError)
import App (app)
import Config (AppConfig(..), corsPolicy)
import Middleware
import Error(errResponse)
@@ -44,6 +42,7 @@ cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "post
testSettings :: PoolSettings
testSettings = fromMaybe (error "bad settings") $ H.poolSettings 1 30
pgSettings :: H.Settings
pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"
withApp :: ActionWith Application -> IO ()