jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

WIP: More files converted to Hasql

Browse Source
This commit is contained in:
Joe Nelson
2014-12-06 17:42:19 -08:00
parent 8ebfbccd08
commit 70d9641e35
6 changed files with 117 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dbapi.cabal
+4 -1
View File
@@ -36,7 +36,9 @@ executable dbapi
, network-uri >= 2.6
, resource-pool, process
, blaze-builder
, vector
Other-Modules: App
, Auth
, Config
, PgStructure
, PgQuery
@@ -52,7 +54,7 @@ Test-Suite spec
Hs-Source-Dirs: test, src
ghc-options: -Wall -W -Werror
Main-Is: Main.hs
Other-Modules: App, Config, Spec, SpecHelper
Other-Modules: App, Auth, Config, Spec, SpecHelper
Build-Depends: base, hspec2, QuickCheck
, hspec-wai >= 0.5.0, hspec-wai-json
, hasql, hasql-backend, hasql-postgres
@@ -78,3 +80,4 @@ Test-Suite spec
, network-uri >= 2.6
, resource-pool
, blaze-builder
, vector
src/App.hs
-1
View File
@@ -23,7 +23,6 @@ import Network.HTTP.Base (urlEncodeVars)
import Network.Wai
import Data.Aeson
import Database.PostgreSQL.Simple
import qualified Hasql as H
import qualified Hasql.Postgres as H
src/Auth.hs
+17 -17
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}
module Auth where
import qualified Data.Aeson as JSON
@@ -7,7 +8,6 @@ import Control.Applicative ( (<*>), (<$>) )
import Crypto.BCrypt
import qualified Hasql as H
import qualified Hasql.Postgres as H
import GHC.Int
data AuthUser = AuthUser {
userId :: String
@@ -20,7 +20,7 @@ instance JSON.FromJSON AuthUser where
v JSON..: "id" <*>
v JSON..: "pass" <*>
v JSON..: "role"
parseJSON _ = mzero
parseJSON _ = mzero
type DbRole = BS.ByteString
@@ -34,25 +34,25 @@ data LoginAttempt =
checkPass :: BS.ByteString -> BS.ByteString -> Bool
checkPass = validatePassword
setRole :: Connection -> DbRole -> IO Int64
setRole conn role = execute conn "set role ?" (Only role)
setRole :: BS.ByteString -> H.Tx H.Postgres s ()
setRole role = H.unit $ [H.q| set role ?|] role
resetRole :: Connection -> IO Int64
resetRole = flip execute_ "reset role"
resetRole :: H.Tx H.Postgres s ()
resetRole = H.unit [H.q|reset role|]
addUser :: Connection -> BS.ByteString -> BS.ByteString -> BS.ByteString -> IO Int64
addUser c identity pass role = do
addUser :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO(H.Tx H.Postgres s ())
addUser identity pass role = do
Just hashed <- hashPasswordUsingPolicy fastBcryptHashingPolicy pass
execute c
"insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)"
(identity, hashed, role)
return $ H.unit $
[H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
identity hashed role
signInRole :: Connection -> BS.ByteString -> BS.ByteString -> IO LoginAttempt
signInRole c user pass = do
u <- query c "select pass, rolname from dbapi.auth where id = ?" $ Only user
return $ case u of
[[hashed, role]] ->
signInRole :: BS.ByteString -> BS.ByteString -> 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 ->
let (hashed, role) = r in
if checkPass hashed pass
then LoginSuccess role
else LoginFailed
_ -> LoginFailed
) u
src/PgQuery.hs
+22 -19
View File
@@ -1,22 +1,21 @@
module PgQuery where
import RangeQuery
import qualified Hasql as H
import qualified Hasql.Postgres as H
import qualified Hasql.Backend as H
import Data.Text hiding (map)
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
import Text.Regex.TDFA ( (=~) )
import Text.Regex.TDFA.Text ()
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Search (split)
import qualified Network.HTTP.Types.URI as Net
import Blaze.ByteString.Builder.ByteString (fromByteString)
import Data.Monoid
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Functor ( (<$>) )
import Control.Monad (join)
import Data.String.Conversions (cs)
import Data.Aeson (Value(..), encode)
import qualified Data.Aeson as JSON
import qualified Data.List as L
type StatementT = H.Statement H.Postgres -> H.Statement H.Postgres
@@ -54,8 +53,8 @@ orderT ts q =
where
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
queryTerm :: OrderTerm -> H.Statement H.Postgres
queryTerm t = (" " <> (pgFmtIdent $ otTerm t) <> " "
<> otDirection t <> " "
queryTerm t = (" " <> pgFmtIdent (otTerm t) <> " "
<> otDirection t <> " "
, [])
parentheticT :: StatementT
@@ -83,7 +82,7 @@ selectStar :: QualifiedTable -> H.Statement H.Postgres
selectStar t =
("select * from " <> fromQt t, [])
insertInto :: QualifiedTable -> [BS.ByteString] -> [Value] ->
insertInto :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
H.Statement H.Postgres
insertInto t [] _ =
("insert into " <> fromQt t <> " default values returning *", [])
@@ -93,26 +92,22 @@ insertInto t cols vals =
") values (" <>
BS.intercalate ", " (map (const "?") vals) <>
") returning *"
, vals
, map pgParam vals
)
rawJsonValue :: Value -> BS.ByteString
rawJsonValue (String s) = cs s
rawJsonValue v = cs $ encode v
update :: QualifiedTable -> [BS.ByteString] -> [Value] ->
update :: QualifiedTable -> [BS.ByteString] -> [JSON.Value] ->
H.Statement H.Postgres
update t cols vals =
("update " <> fromQt t <> " set (" <>
BS.intercalate ", " (map pgFmtIdent cols) <>
") = (" <>
BS.intercalate ", " (map (const "?") vals) <> ")"
, vals
, map pgParam vals
)
wherePred :: Net.QueryItem -> H.Statement H.Postgres
wherePred (col, predicate) =
(" " <> pgFmtIdent col <> " " <> op <> " ? ", [value])
(" " <> pgFmtIdent col <> " " <> op <> " ? ", [H.renderValue value])
where
opCode:rest = BS.split '.' $ fromMaybe "." predicate
@@ -128,13 +123,13 @@ wherePred (col, predicate) =
orderParse :: Net.Query -> [OrderTerm]
orderParse q =
mapMaybe orderParseTerm . BS.split "," $ cs order
mapMaybe orderParseTerm . BS.split ',' $ cs order
where
order = fromMaybe "" $ join (lookup "order" q)
orderParseTerm :: BS.ByteString -> Maybe OrderTerm
orderParseTerm s =
case BS.split "." s of
case BS.split '.' s of
[d,c] ->
if d `elem` ["asc", "desc"]
then Just $ OrderTerm (cs c) $
@@ -171,3 +166,11 @@ trimNullChars = Data.Text.takeWhile (/= '\x0')
fromQt :: QualifiedTable -> BS.ByteString
fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
pgParam :: JSON.Value -> H.StatementArgument H.Postgres
pgParam (JSON.Number n) = H.renderValue n
pgParam (JSON.String s) = H.renderValue s
pgParam (JSON.Bool b) = H.renderValue b
pgParam JSON.Null = H.renderValue (Nothing :: Maybe String)
pgParam (JSON.Object o) = H.renderValue $ JSON.encode o
pgParam (JSON.Array a) = H.renderValue $ JSON.encode a
src/PgStructure.hs
+74 -43
View File
@@ -1,23 +1,27 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, ScopedTypeVariables #-}
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 qualified Data.ByteString.Char8 as BS
import Data.String.Conversions (cs)
import Control.Applicative ( (<*>) )
import qualified Data.List as L
import qualified Data.Map as Map
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.FromRow
import qualified Hasql as H
import qualified Hasql.Backend as H
import qualified Hasql.Postgres as H
foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey)
foreignKeys c table = do
r <- query c [sql|
foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map BS.ByteString ForeignKey)
foreignKeys table = do
r :: [(BS.ByteString, BS.ByteString, BS.ByteString)] <- 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
@@ -28,29 +32,27 @@ foreignKeys c table = do
where constraint_type = 'FOREIGN KEY'
and tc.table_name=? and tc.table_schema = ?
order by kcu.column_name
|]
(qtName table, qtSchema table)
|] (qtName table) (qtSchema table)
return $ foldl addKey Map.empty r
where
addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m
addKey _ _ = error "foreignKeys: should never happen"
addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
tables :: Connection -> Text -> IO [Table]
tables c schema =
query c [sql|
tables :: BS.ByteString -> H.Tx H.Postgres s [Table]
tables schema =
H.list $ [H.q|
select table_schema, table_name,
is_insertable_into
from information_schema.tables
where table_schema = ?
order by table_name
|] $ Only schema
|] schema
columns :: Connection -> QualifiedTable -> IO [Column]
columns c table = do
cols <- query c [sql|
columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
columns table = do
cols <- H.list $ [H.q|
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,
@@ -77,15 +79,15 @@ columns c table = do
group by s, n
) as enum_info
on (info.udt_name = enum_info.n)
order by position |] (qtSchema table, qtName table)
order by position |] (qtSchema table) (qtName table)
fks <- foreignKeys c table
return $ map (\col -> col { colFK = Map.lookup (colName col) fks }) cols
fks <- foreignKeys table
return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
primaryKeyColumns :: Connection -> QualifiedTable -> IO [Text]
primaryKeyColumns c table = do
r <- query c [sql|
primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [BS.ByteString]
primaryKeyColumns table = do
r :: [Identity BS.ByteString] <- H.list $ [H.q|
select kc.column_name
from
information_schema.table_constraints tc,
@@ -95,28 +97,22 @@ primaryKeyColumns c table = do
and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema
and kc.constraint_name = tc.constraint_name
and kc.table_schema = ?
and kc.table_name = ? |] (qtSchema table, qtName table)
return $ concat r
and kc.table_name = ? |] (qtSchema table) (qtName table)
return $ map runIdentity r
data Table = Table {
tableSchema :: Text
, tableName :: Text
, tableInsertable :: Bool
} deriving (Show)
-- instance FromRow Table where
-- fromRow = Table <$> field <*> field <*> (toBool <$> field)
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
-- 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
@@ -124,6 +120,12 @@ vanishNull xs = if L.null xs then Nothing else Just xs
toBool :: Text -> Bool
toBool = (== "YES")
data Table = Table {
tableSchema :: Text
, tableName :: Text
, tableInsertable :: Bool
} deriving (Show)
data ForeignKey = ForeignKey {
fkTable::Text, fkCol::Text
} deriving (Eq, Show)
@@ -143,6 +145,35 @@ data Column = Column {
, colFK :: Maybe ForeignKey
} deriving (Show)
instance H.RowParser H.Postgres Column where
parseRow r =
let schema = H.parseResult $ r V.! 0
table = H.parseResult $ r V.! 1
name = H.parseResult $ r V.! 2
position = H.parseResult $ r V.! 3
nullable = H.parseResult $ r V.! 4
typ = H.parseResult $ r V.! 5
updatable = H.parseResult $ r V.! 6
maxLen = H.parseResult $ r V.! 7
precision = H.parseResult $ r V.! 8
defValue = H.parseResult $ r V.! 9
enum = H.parseResult $ r V.! 10 in
if V.length r /= 11
then Left "Wrong number of fields in Column"
else Column <$> schema <*> table <*> name <*> position <*> nullable
<*> typ <*> updatable <*> maxLen <*> precision
<*> defValue <*> enum <*> return Nothing
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
if V.length r /= 3
then Left "Wrong number of fields in Table"
else Table <$> schema <*> name <*> insertable
instance ToJSON Column where
toJSON c = object [
"schema" .= colSchema c
src/Types.hs
-1
View File
@@ -9,7 +9,6 @@ import Data.HashMap.Strict (foldlWithKey')
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Calendar (showGregorian)
import Control.Monad (mzero)
instance JSON.FromJSON SqlValue where