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

code cleanup

Browse Source
This commit is contained in:
Ruslan Talpa
2015-09-25 11:51:37 +03:00
parent 770e04c04a
commit c42832f1c5
12 changed files with 272 additions and 269 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+19 -14
View File
@@ -1,11 +1,15 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept module PostgREST.App (
-- added app
, sqlError
, isSqlError
, contentTypeForAccept
, jsonH , jsonH
, requestedSchema , requestedSchema
, TableOptions(..) , TableOptions(..)
) where ) where
import Control.Monad (join) import Control.Monad (join)
import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Control.Applicative import Control.Applicative
@@ -53,7 +57,7 @@ import PostgREST.Functions
import Prelude import Prelude
app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
app dbstructure conf reqBody role req = app dbstructure conf reqBody dbrole req =
case (path, verb) of case (path, verb) of
-- ([], _) -> do -- ([], _) -> do
-- body <- encode <$> tables (cs schema) -- body <- encode <$> tables (cs schema)
@@ -67,11 +71,11 @@ app dbstructure conf reqBody role req =
-- $ encode (TableOptions cols pkey) -- $ encode (TableOptions cols pkey)
([], _) -> do ([], _) -> do
let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables let body = encode $ filter (filterTableAcl dbrole) $ filter (((cs schema)==).tableSchema) allTables
return $ responseLBS status200 [jsonH] $ cs body return $ responseLBS status200 [jsonH] $ cs body
([table], "OPTIONS") -> do ([table], "OPTIONS") -> do
let qt = Table schema table --let qt = Table schema table
let cols = filter (filterCol schema table) allColumns let cols = filter (filterCol schema table) allColumns
let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
let body = encode (TableOptions cols pkeys) let body = encode (TableOptions cols pkeys)
@@ -218,13 +222,13 @@ app dbstructure conf reqBody role req =
Right toBeInserted -> do Right toBeInserted -> do
rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
--primaryKeys <- primaryKeyColumns qt --pKeys <- primaryKeyColumns qt
let responses = flip map inserted $ \obj -> do let responses = flip map inserted $ \obj -> do
let primaries = let primaries =
if Prelude.null primaryKeys if Prelude.null pKeys
then obj then obj
else M.filterWithKey (const . (`elem` primaryKeys)) obj else M.filterWithKey (const . (`elem` pKeys)) obj
let params = urlEncodeVars let params = urlEncodeVars
$ map (\t -> (cs $ fst t, cs (paramFilter $ snd t))) $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
$ sortBy (comparing fst) $ M.toList primaries $ sortBy (comparing fst) $ M.toList primaries
@@ -253,10 +257,10 @@ app dbstructure conf reqBody role req =
([table], "PUT") -> ([table], "PUT") ->
handleJsonObj reqBody $ \obj -> do handleJsonObj reqBody $ \obj -> do
let qt = qualify table let qt = qualify table
primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
--primaryKeys <- primaryKeyColumns qt --pKeys <- primaryKeyColumns qt
let specifiedKeys = map (cs . fst) qq let specifiedKeys = map (cs . fst) qq
if S.fromList primaryKeys /= S.fromList specifiedKeys if S.fromList pKeys /= S.fromList specifiedKeys
then return $ responseLBS status405 [] then return $ responseLBS status405 []
"You must speficy all and only primary keys as params" "You must speficy all and only primary keys as params"
else do else do
@@ -317,8 +321,9 @@ app dbstructure conf reqBody role req =
allColumns = columns dbstructure allColumns = columns dbstructure
allPrimaryKeys = primaryKeys dbstructure allPrimaryKeys = primaryKeys dbstructure
--allTablesAcl = tablesAcl dbstructure --allTablesAcl = tablesAcl dbstructure
filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t
filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t filterCol _ _ _ = False
filterPk sc table (PrimaryKey{pkSchema=s, pkTable=t}) = s==sc && table==t
filterTableAcl :: Text -> Table -> Bool filterTableAcl :: Text -> Table -> Bool
filterTableAcl r (Table{tableAcl=a}) = r `elem` a filterTableAcl r (Table{tableAcl=a}) = r `elem` a
src/PostgREST/Auth.hs
+20 -19
View File
@@ -1,27 +1,28 @@
{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PostgREST.Auth where module PostgREST.Auth where
import Data.Aeson import Control.Applicative
import Control.Monad (mzero) import Control.Monad (mzero)
import Control.Applicative import Crypto.BCrypt
import Crypto.BCrypt import Data.Aeson
import Data.Text import Data.Map
import Data.Monoid import Data.Monoid
import Data.Map import Data.String.Conversions (cs)
import qualified Data.Vector as V import Data.Text
import qualified Hasql as H import qualified Data.Vector as V
import qualified Hasql.Backend as B import qualified Hasql as H
import qualified Hasql.Postgres as P import qualified Hasql.Backend as B
import qualified Web.JWT as JWT import qualified Hasql.Postgres as P
import Data.String.Conversions (cs) import PostgREST.PgQuery (pgFmtLit)
import PostgREST.PgQuery (pgFmtLit) import Prelude
import qualified Web.JWT as JWT
import Prelude import System.IO.Unsafe
import System.IO.Unsafe
data AuthUser = AuthUser { data AuthUser = AuthUser {
userId :: String userId :: String
, userPass :: String , userPass :: String
, userRole :: String , userRole :: String
} deriving (Show) } deriving (Show)
src/PostgREST/Config.hs
+20 -19
View File
@@ -1,27 +1,28 @@
module PostgREST.Config where module PostgREST.Config where
import Network.Wai
import Control.Applicative import Control.Applicative
import Data.Text (strip) import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Char8 as BS import Data.String.Conversions (cs)
import Data.String.Conversions (cs) import Data.Text (strip)
import Options.Applicative hiding (columns) import Network.Wai
import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
import Prelude import Options.Applicative hiding (columns)
import Prelude
data AppConfig = AppConfig { data AppConfig = AppConfig {
configDbName :: String configDbName :: String
, configDbPort :: Int , configDbPort :: Int
, configDbUser :: String , configDbUser :: String
, configDbPass :: String , configDbPass :: String
, configDbHost :: String , configDbHost :: String
, configPort :: Int , configPort :: Int
, configAnonRole :: String , configAnonRole :: String
, configSecure :: Bool , configSecure :: Bool
, configPool :: Int , configPool :: Int
, configV1Schema :: String , configV1Schema :: String
, configJwtSecret :: String , configJwtSecret :: String
} }
src/PostgREST/Error.hs
+12 -10
View File
@@ -1,18 +1,20 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module PostgREST.Error (PgError, errResponse) where module PostgREST.Error (PgError, errResponse) where
import qualified Hasql as H
import qualified Hasql.Postgres as P import Data.Aeson ((.=))
import qualified Data.Aeson as JSON
import Data.String.Conversions (cs)
import Data.String.Utils (replace)
import qualified Data.Text as T
import qualified Hasql as H
import qualified Hasql.Postgres as P
import Network.HTTP.Types.Header
import qualified Network.HTTP.Types.Status as HT import qualified Network.HTTP.Types.Status as HT
import qualified Data.Aeson as JSON import Network.Wai (Response, responseLBS)
import qualified Data.Text as T
import Data.Aeson ((.=))
import Data.String.Conversions (cs)
import Data.String.Utils(replace)
import Network.Wai(Response, responseLBS)
import Network.HTTP.Types.Header
type PgError = H.SessionError P.Postgres type PgError = H.SessionError P.Postgres
src/PostgREST/Functions.hs
+25 -22
View File
@@ -2,17 +2,20 @@
module PostgREST.Functions module PostgREST.Functions
where where
import PostgREST.Types
import Control.Error import Control.Error
import Data.List (find) import Data.List (find)
import Data.Tree import Data.Monoid
import Data.Text hiding (find, foldr, map, null, last, head) import Data.Text hiding (find, foldr, head, last, map, null)
import Data.Monoid import Data.Tree
import PostgREST.PgQuery (orderT, pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..), StatementT, PStmt) import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi,
import qualified Hasql as H orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
import qualified Hasql.Postgres as P pgFmtValue, whiteList)
import qualified Hasql.Backend as B import PostgREST.Types
import qualified Data.Vector as V (empty) --import qualified Hasql as H
--import qualified Hasql.Postgres as P
import qualified Data.Vector as V (empty)
import qualified Hasql.Backend as B
@@ -47,7 +50,7 @@ requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs
where where
-- it's ok not to check that the table exists here, mainTable will do the checking -- it's ok not to check that the table exists here, mainTable will do the checking
toDbSelectItem :: SelectItem -> Either Text DbSelectItem toDbSelectItem :: SelectItem -> Either Text DbSelectItem
toDbSelectItem (("*", Nothing), Nothing) = Right $ ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing) toDbSelectItem (("*", Nothing), Nothing) = Right ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing)
toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast
where where
col = findColumn allColumns schema tblName $ pack c col = findColumn allColumns schema tblName $ pack c
@@ -63,7 +66,7 @@ addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}
Nothing -> Node query{qRelation=Nothing} <$> updatedForest Nothing -> Node query{qRelation=Nothing} <$> updatedForest
(Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
where where
rel = note ("no relation between " <> (tableName table) <> " and " <> (tableName parentTable)) $ rel = note ("no relation between " <> tableName table <> " and " <> tableName parentTable) $
findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable) findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable)
addRel :: Query -> Relation -> Query addRel :: Query -> Relation -> Query
addRel q r = q{qRelation = Just r} addRel q r = q{qRelation = Just r}
@@ -85,7 +88,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) =
_ -> Left "unknow relation" _ -> Left "unknow relation"
where where
-- add parentTable and parentJoinConditions to the query -- add parentTable and parentJoinConditions to the query
updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ (qJoinTables query)}) <$> parentJoinConditions updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ qJoinTables query}) <$> parentJoinConditions
where where
parentJoinConditions = mapM (getJoinCondition.snd) parents parentJoinConditions = mapM (getJoinCondition.snd) parents
parentTables = map fst parents parentTables = map fst parents
@@ -101,7 +104,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) =
dbRequestToCountQuery :: DbRequest -> PStmt dbRequestToCountQuery :: DbRequest -> PStmt
dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) =
B.Stmt query V.empty True B.Stmt query V.empty True
where where
query = Data.Text.unwords [ query = Data.Text.unwords [
@@ -112,8 +115,8 @@ dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) =
emptyOnNull val x = if null x then "" else val emptyOnNull val x = if null x then "" else val
dbRequestToQuery :: DbRequest -> PStmt dbRequestToQuery :: DbRequest -> PStmt
dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation ord) forest) = dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) =
orderT (fromMaybe [] ord) $ query orderT (fromMaybe [] ord) query
-- case relation of -- case relation of
-- Nothing ->B.Stmt ("SELECT " -- Nothing ->B.Stmt ("SELECT "
-- <> "(" -- <> "("
@@ -129,11 +132,11 @@ dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation or
-- _ -> B.Stmt query V.empty True -- _ -> B.Stmt query V.empty True
where where
query = B.Stmt q V.empty True query = B.Stmt qStr V.empty True
q = Data.Text.unwords [ qStr = Data.Text.unwords [
("WITH " <> intercalate ", " withs) `emptyOnNull` withs, ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
"SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects),
"FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)),
("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions
] ]
emptyOnNull val x = if null x then "" else val emptyOnNull val x = if null x then "" else val
@@ -186,7 +189,7 @@ pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <>
pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*" pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*"
pgFmtJsonPath :: Maybe JsonPath -> Text pgFmtJsonPath :: Maybe JsonPath -> Text
pgFmtJsonPath (Just [x]) = "->>" <> (pgFmtLit $ pack x) pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit (pack x)
pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs ) pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs )
pgFmtJsonPath _ = "" pgFmtJsonPath _ = ""
@@ -199,4 +202,4 @@ selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPa
asJsonPath :: Maybe JsonPath -> Text asJsonPath :: Maybe JsonPath -> Text
asJsonPath Nothing = "" asJsonPath Nothing = ""
asJsonPath (Just xx) = " AS " <> (pack $ last xx) asJsonPath (Just xx) = " AS " <> pack (last xx)
src/PostgREST/Main.hs
+37 -31
View File
@@ -1,42 +1,48 @@
{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Paths_postgrest (version)
import Paths_postgrest (version)
-- added -- added
import PostgREST.PgStructure import PostgREST.PgStructure
import Data.Aeson --import Data.Aeson
import Data.List (find) --import Data.List (find)
import Data.Maybe (isJust) --import Data.Maybe (isJust)
import PostgREST.Types import PostgREST.Types
import Network.HTTP.Types.Status --import Network.HTTP.Types.Status
import Network.HTTP.Types.Header --import Network.HTTP.Types.Header
import Network.Wai -- (strictRequestBody, pathInfo, requestMethod, requestHeaders) import Network.Wai
import PostgREST.App import PostgREST.App
import PostgREST.Middleware import PostgREST.Error (errResponse)
import PostgREST.Error(errResponse) import PostgREST.Middleware
import Control.Monad (unless) import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.String.Conversions (cs) import Data.Functor.Identity
import Network.Wai.Handler.Warp hiding (Connection) import Data.List (intercalate)
import Network.Wai.Middleware.RequestLogger (logStdout) import Data.String.Conversions (cs)
import Data.List (intercalate) import Data.Text (Text)
import Data.Version (versionBranch) import Data.Version (versionBranch)
import Data.Functor.Identity import qualified Hasql as H
import Data.Text(Text) import qualified Hasql.Postgres as P
import qualified Hasql as H import Network.Wai.Handler.Warp hiding (Connection)
import qualified Hasql.Postgres as P import Network.Wai.Middleware.RequestLogger (logStdout)
import Options.Applicative hiding (columns) import Options.Applicative hiding (columns)
import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import System.IO (BufferMode (..),
hSetBuffering, stderr,
stdin, stdout)
import PostgREST.Config (AppConfig(..), argParser) import PostgREST.Config (AppConfig (..),
argParser)
isServerVersionSupported :: H.Session P.Postgres IO Bool
isServerVersionSupported = do isServerVersionSupported = do
Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|] Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
return $ read (cs row) >= 90200 return $ read (cs row) >= (90200::Integer)
main :: IO () main :: IO ()
main = do main = do
@@ -76,12 +82,12 @@ main = do
H.poolSettings (fromIntegral $ configPool conf) 30 H.poolSettings (fromIntegral $ configPool conf) 30
pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
resOrError <- H.session pool isServerVersionSupported supportedOrError <- H.session pool isServerVersionSupported
either (fail . show) either (fail . show)
(\supported -> (\supported ->
unless supported $ unless supported $
fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
) resOrError ) supportedOrError
-- read the structure of the database -- read the structure of the database
-- read the structure of the database -- read the structure of the database
@@ -96,7 +102,7 @@ main = do
colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations
let allColumns = either (fail . show) id colsRes let allColumns = either (fail . show) id colsRes
pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys pkRes <- H.session pool $ H.tx txParam allprimaryKeys
let allPrimaryKeys = either (fail . show) id pkRes let allPrimaryKeys = either (fail . show) id pkRes
-- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl
src/PostgREST/Middleware.hs
+26 -21
View File
@@ -3,32 +3,37 @@
module PostgREST.Middleware where module PostgREST.Middleware where
import Data.Maybe (fromMaybe, isNothing) import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid import Data.Monoid
import Data.Text import Data.Text
-- import Data.Pool(withResource, Pool) -- import Data.Pool(withResource, Pool)
import qualified Hasql as H import Data.String.Conversions (cs)
import qualified Hasql.Postgres as P import qualified Hasql as H
import Data.String.Conversions(cs) import qualified Hasql.Postgres as P
import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept) import Network.HTTP.Types (RequestHeaders)
import Network.HTTP.Types (RequestHeaders) import Network.HTTP.Types.Header (hAccept, hAuthorization,
import Network.HTTP.Types.Status (status400, status401, status301, status415) hLocation)
import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, import Network.HTTP.Types.Status (status301, status400, status401,
rawQueryString, isSecure, Request(..), Response) status415)
import Network.Wai.Middleware.Gzip (gzip, def) import Network.URI (URI (..), parseURI)
import Network.Wai.Middleware.Cors (cors) import Network.Wai (Application, Request (..),
import Network.Wai.Middleware.Static (staticPolicy, only) Response, isSecure, rawPathInfo,
import Network.URI (URI(..), parseURI) rawQueryString, requestHeaders,
responseLBS)
import Network.Wai.Middleware.Cors (cors)
import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.Config (AppConfig(..), corsPolicy) import Codec.Binary.Base64.String (decode)
import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) import PostgREST.App (contentTypeForAccept)
import PostgREST.App (contentTypeForAccept) import PostgREST.Auth (DbRole, LoginAttempt (..),
import Codec.Binary.Base64.String (decode) setRole, setUserId, signInRole,
import PostgREST.Auth (DbRole) signInWithJWT)
import PostgREST.Config (AppConfig (..), corsPolicy)
import Prelude import Prelude
authenticated :: forall s. AppConfig -> authenticated :: forall s. AppConfig ->
(DbRole -> Request -> H.Tx P.Postgres s Response) -> (DbRole -> Request -> H.Tx P.Postgres s Response) ->
src/PostgREST/Parsers.hs
+28 -60
View File
@@ -1,33 +1,18 @@
--{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} --{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-}
module PostgREST.Parsers module PostgREST.Parsers
-- ( parseGetRequest ( parseGetRequest
-- , pSelect )
-- , pField
-- , pRequestSelect
-- )
where where
import Text.ParserCombinators.Parsec hiding (many, (<|>))
--import Text.Parsec.Text
--import Text.Parsec hiding (many, (<|>))
--import Text.Parsec.Prim hiding (many, (<|>))
import Control.Applicative import Control.Applicative
--import Control.Monad import Control.Monad (join)
--import qualified Data.Text as T
import Data.Tree
import Network.Wai (Request, pathInfo, queryString)
import PostgREST.Types
--import qualified Data.ByteString.Char8 as C
--import Control.Monad
--import Data.Foldable (foldrM)
import Data.List (delete, find) import Data.List (delete, find)
import Data.Maybe import Data.Maybe
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import Control.Monad (join) import Data.Tree
import Network.Wai (Request, pathInfo, queryString)
--import qualified Data.ByteString.Char8 as C import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>))
--buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request
parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest :: Request -> Either ParseError ApiRequest
parseGetRequest httpRequest = parseGetRequest httpRequest =
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
@@ -38,7 +23,7 @@ parseGetRequest httpRequest =
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
orderStr = join $ lookup "order" qString orderStr = join $ lookup "order" qString
ord = traverse (parse pOrder ("failed to parse order ()")) orderStr ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr
selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
@@ -81,15 +66,12 @@ addFilter (path, flt) (Node rn forest) =
ws :: Parser String ws :: Parser String
ws = many (oneOf " \t") ws = many (oneOf " \t")
--lexeme :: Parser String -> Parser String lexeme :: Parser a -> Parser a
--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a
--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char
lexeme p = ws *> p <* ws lexeme p = ws *> p <* ws
pTreePath :: Parser (Path,Field) pTreePath :: Parser (Path,Field)
pTreePath = do pTreePath = do
p <- (pFieldName `sepBy1` pDelimiter) p <- pFieldName `sepBy1` pDelimiter
--f <- pField
jp <- optionMaybe ( string "->" >> pJsonPath) jp <- optionMaybe ( string "->" >> pJsonPath)
return (init p, (last p, jp)) return (init p, (last p, jp))
@@ -98,17 +80,8 @@ pFieldForest :: Parser [Tree SelectItem]
pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
pFieldTree :: Parser (Tree SelectItem) pFieldTree :: Parser (Tree SelectItem)
pFieldTree = pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')'))
try ( do <|> Node <$> pSelect <*> pure []
fld <- pSelect
char '('
subforest <- pFieldForest
char ')'
return (Node fld subforest)
)
<|> do
fld <- pSelect
return (Node fld [])
pStar :: Parser String pStar :: Parser String
pStar = string "*" *> pure "*" pStar = string "*" *> pure "*"
@@ -117,22 +90,18 @@ pFieldName :: Parser String
pFieldName = many1 (letter <|> digit <|> oneOf "_") pFieldName = many1 (letter <|> digit <|> oneOf "_")
<?> "field name (* or [a..z0..9_])" <?> "field name (* or [a..z0..9_])"
pJsonPathDelimiter :: Parser String
pJsonPathDelimiter = try (string "->>") <|> string "->"
pJsonPath :: Parser [String] pJsonPath :: Parser [String]
pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->") pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter
pField :: Parser Field pField :: Parser Field
pField = lexeme $ do pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJsonPath)
f <- pFieldName
jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath)
return (f, jp)
pSelect :: Parser SelectItem pSelect :: Parser SelectItem
pSelect = lexeme $ pSelect = lexeme $
try (do try ((,) <$> pField <*> optionMaybe (string "::" *> many letter))
n <- pField
v <- optionMaybe (string "::" >> many letter)
return (n, v)
)
<|> do <|> do
s <- pStar s <- pStar
return ((s, Nothing), Nothing) return ((s, Nothing), Nothing)
@@ -154,8 +123,8 @@ pOperator = try (string "lte") -- has to be before lt
<|> try (string "@@") <|> try (string "@@")
<?> "operator (eq, gt, ...)" <?> "operator (eq, gt, ...)"
pInt :: Parser Int -- pInt :: Parser Int
pInt = try (liftA read (many1 digit)) <?> "integer" -- pInt = try (liftA read (many1 digit)) <?> "integer"
--pValue :: Parser Value --pValue :: Parser Value
--pValue = (VInt <$> try (pInt <* eof)) --pValue = (VInt <$> try (pInt <* eof))
@@ -166,20 +135,19 @@ pValue = many anyChar
pDelimiter :: Parser Char pDelimiter :: Parser Char
pDelimiter = char '.' <?> "delimiter (.)" pDelimiter = char '.' <?> "delimiter (.)"
pOpValueExp :: Parser (Operator, FValue) pOperatiorWithNegation :: Parser Operator
pOpValueExp = do pOperatiorWithNegation = try ( (++) <$> string "not." <*> pOperator) <|> pOperator
o <- ( try ( liftA2 (++) (string "not.") pOperator) <|> pOperator )
pDelimiter
v <- pValue
return (o, v)
pOrder :: Parser ([OrderTerm]) pOpValueExp :: Parser (Operator, FValue)
pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue)
pOrder :: Parser [OrderTerm]
pOrder = lexeme pOrderTerm `sepBy` char ',' pOrder = lexeme pOrderTerm `sepBy` char ','
pOrderTerm :: Parser OrderTerm pOrderTerm :: Parser OrderTerm
pOrderTerm = do pOrderTerm = do
c <- pFieldName c <- pFieldName
pDelimiter _ <- pDelimiter
d <- string "asc" <|> string "desc" d <- string "asc" <|> string "desc"
nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String))))
return $ OrderTerm (cs c) (cs d) (cs <$> nls) return $ OrderTerm (cs c) (cs d) (cs <$> nls)
src/PostgREST/PgQuery.hs
+26 -22
View File
@@ -1,31 +1,35 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module PostgREST.PgQuery where module PostgREST.PgQuery where
import PostgREST.RangeQuery
import PostgREST.Types (OrderTerm(..))
import qualified Hasql as H
import qualified Hasql.Postgres as P
import qualified Hasql.Backend as B
import qualified Data.Text as T import qualified Hasql as H
import qualified Data.HashMap.Strict as H import qualified Hasql.Backend as B
import Text.Regex.TDFA ( (=~) ) import qualified Hasql.Postgres as P
import qualified Network.HTTP.Types.URI as Net import PostgREST.RangeQuery
import qualified Data.ByteString.Char8 as BS import PostgREST.Types (OrderTerm (..))
import Data.Monoid
import Data.Vector (empty)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Functor
import Control.Monad (join)
import Data.String.Conversions (cs)
import qualified Data.Aeson as JSON
import qualified Data.List as L
import qualified Data.Vector as V
import Data.Scientific (isInteger, formatScientific, FPFormat(..))
import Prelude import Control.Monad (join)
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS
import Data.Functor
import qualified Data.HashMap.Strict as H
import qualified Data.List as L
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import Data.Scientific (FPFormat (..), formatScientific,
isInteger)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import Data.Vector (empty)
import qualified Data.Vector as V
import qualified Network.HTTP.Types.URI as Net
import Text.Regex.TDFA ((=~))
import Prelude
type PStmt = H.Stmt P.Postgres type PStmt = H.Stmt P.Postgres
instance Monoid PStmt where instance Monoid PStmt where
src/PostgREST/PgStructure.hs
+23 -40
View File
@@ -1,24 +1,27 @@
{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, {-# LANGUAGE FlexibleContexts #-}
MultiParamTypeClasses, ScopedTypeVariables, {-# LANGUAGE MultiParamTypeClasses #-}
FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module PostgREST.PgStructure where module PostgREST.PgStructure where
import PostgREST.PgQuery (QualifiedIdentifier(..)) import Data.List (find)
import PostgREST.Types import Data.Text (Text, split)
import Data.Text (Text, unpack, split) import PostgREST.PgQuery ()
import Data.List (find) import PostgREST.Types
import Data.Aeson --import Data.Aeson
import Data.Functor.Identity import Data.Functor.Identity
import Data.String.Conversions (cs) --import Data.String.Conversions (cs)
import Data.Maybe (fromMaybe, isJust) import Control.Applicative
import Control.Applicative import Data.Maybe (fromMaybe, isJust)
import qualified Data.Map as Map --import qualified Data.Map as Map
import qualified Hasql as H import qualified Hasql as H
import qualified Hasql.Postgres as P import qualified Hasql.Postgres as P
import Prelude import Prelude
doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
@@ -53,28 +56,6 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
parseEnum str = fromMaybe [] $ split (==',') <$> str parseEnum str = fromMaybe [] $ split (==',') <$> str
instance ToJSON Column where
toJSON c = object [
"schema" .= colSchema c
, "name" .= colName c
, "position" .= colPosition c
, "nullable" .= colNullable c
, "type" .= colType c
, "updatable" .= colUpdatable c
, "maxLen" .= colMaxLen c
, "precision" .= colPrecision c
, "references".= colFK c
, "default" .= colDefault c
, "enum" .= colEnum c ]
instance ToJSON ForeignKey where
toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
instance ToJSON Table where
toJSON v = object [
"schema" .= tableSchema v
, "name" .= tableName v
, "insertable" .= tableInsertable v ]
------------ ------------
@@ -152,7 +133,7 @@ allrelations = do
return $ foldr (addFlippedRelation.relationFromRow) [] rels return $ foldr (addFlippedRelation.relationFromRow) [] rels
allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] allcolumns :: [Relation] -> H.Tx P.Postgres s [Column]
allcolumns relations = do allcolumns rels = do
cols <- H.listEx $ [H.stmt| cols <- H.listEx $ [H.stmt|
SELECT SELECT
info.table_schema AS schema, info.table_schema AS schema,
@@ -197,9 +178,11 @@ allcolumns relations = do
return $ map (addFK . columnFromRow) cols return $ map (addFK . columnFromRow) cols
where where
addFK col = col { colFK = relToFk <$> find (lookupFn col) relations } addFK col = col { colFK = relToFk <$> find (lookupFn col) rels }
lookupFn :: Column -> Relation -> Bool
lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) = lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) =
cs==rs && ct==rt && cn==rc && rty=="child" cs==rs && ct==rt && cn==rc && rty=="child"
lookupFn _ _ = False
relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c
allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
src/PostgREST/RangeQuery.hs
+11 -11
View File
@@ -6,22 +6,22 @@ module PostgREST.RangeQuery (
, NonnegRange , NonnegRange
) where ) where
import PostgREST.Types (OrderTerm(..))
import Control.Applicative
import Network.HTTP.Types.Header
import qualified Data.ByteString.Char8 as BS import Control.Applicative
import Network.HTTP.Types.Header
import PostgREST.Types ()
import Data.Ranged.Boundaries import qualified Data.ByteString.Char8 as BS
import Data.Ranged.Ranges import Data.Ranged.Boundaries
import Data.Ranged.Ranges
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import Text.Regex.TDFA ((=~)) import Text.Read (readMaybe)
import Text.Read (readMaybe) import Text.Regex.TDFA ((=~))
import Data.Maybe (fromMaybe, listToMaybe) import Data.Maybe (fromMaybe, listToMaybe)
import Prelude import Prelude
type NonnegRange = Range Int type NonnegRange = Range Int
src/PostgREST/Types.hs
+25
View File
@@ -2,6 +2,7 @@ module PostgREST.Types where
import Data.Text import Data.Text
import Data.Tree import Data.Tree
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Aeson
data DbStructure = DbStructure { data DbStructure = DbStructure {
tables :: [Table] tables :: [Table]
@@ -11,6 +12,7 @@ data DbStructure = DbStructure {
--, tablesAcl :: [(Text, Text, Text)] --, tablesAcl :: [(Text, Text, Text)]
} }
data Table = Table { data Table = Table {
tableSchema :: Text tableSchema :: Text
, tableName :: Text , tableName :: Text
@@ -92,3 +94,26 @@ data Query = Select {
, qOrder::Maybe [OrderTerm] , qOrder::Maybe [OrderTerm]
} deriving (Show) } deriving (Show)
type DbRequest = Tree Query type DbRequest = Tree Query
instance ToJSON Column where
toJSON c = object [
"schema" .= colSchema c
, "name" .= colName c
, "position" .= colPosition c
, "nullable" .= colNullable c
, "type" .= colType c
, "updatable" .= colUpdatable c
, "maxLen" .= colMaxLen c
, "precision" .= colPrecision c
, "references".= colFK c
, "default" .= colDefault c
, "enum" .= colEnum c ]
instance ToJSON ForeignKey where
toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
instance ToJSON Table where
toJSON v = object [
"schema" .= tableSchema v
, "name" .= tableName v
, "insertable" .= tableInsertable v ]