diff --git a/dbapi.cabal b/dbapi.cabal index a86d96440..a6d882652 100644 --- a/dbapi.cabal +++ b/dbapi.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs index 51f99c2d5..041dd9838 100644 --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Auth.hs b/src/Auth.hs index be905e8fa..ac4675df9 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 754209141..fa8050728 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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 diff --git a/src/PgStructure.hs b/src/PgStructure.hs index f2e3cbf20..0ba1cfaf7 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index 350f022cf..27e323357 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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