From c42832f1c53451c9e234c3865a03b8729d3804dc Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 25 Sep 2015 11:51:37 +0300 Subject: [PATCH] code cleanup --- src/PostgREST/App.hs | 33 ++++++++------ src/PostgREST/Auth.hs | 39 ++++++++-------- src/PostgREST/Config.hs | 39 ++++++++-------- src/PostgREST/Error.hs | 22 +++++---- src/PostgREST/Functions.hs | 47 ++++++++++--------- src/PostgREST/Main.hs | 68 +++++++++++++++------------- src/PostgREST/Middleware.hs | 47 ++++++++++--------- src/PostgREST/Parsers.hs | 88 ++++++++++++------------------------ src/PostgREST/PgQuery.hs | 48 +++++++++++--------- src/PostgREST/PgStructure.hs | 63 ++++++++++---------------- src/PostgREST/RangeQuery.hs | 22 ++++----- src/PostgREST/Types.hs | 25 ++++++++++ 12 files changed, 272 insertions(+), 269 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index dc160fe54..932b5bc94 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,11 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} -module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept --- added +module PostgREST.App ( + app +, sqlError +, isSqlError +, contentTypeForAccept , jsonH , requestedSchema , TableOptions(..) ) where + import Control.Monad (join) import Control.Arrow ((***), second) import Control.Applicative @@ -53,7 +57,7 @@ import PostgREST.Functions import Prelude 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 -- ([], _) -> do -- body <- encode <$> tables (cs schema) @@ -67,11 +71,11 @@ app dbstructure conf reqBody role req = -- $ encode (TableOptions cols pkey) ([], _) -> 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 ([table], "OPTIONS") -> do - let qt = Table schema table + --let qt = Table schema table let cols = filter (filterCol schema table) allColumns let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys let body = encode (TableOptions cols pkeys) @@ -218,13 +222,13 @@ app dbstructure conf reqBody role req = Right toBeInserted -> do rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --primaryKeys <- primaryKeyColumns qt + pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --pKeys <- primaryKeyColumns qt let responses = flip map inserted $ \obj -> do let primaries = - if Prelude.null primaryKeys + if Prelude.null pKeys then obj - else M.filterWithKey (const . (`elem` primaryKeys)) obj + else M.filterWithKey (const . (`elem` pKeys)) obj let params = urlEncodeVars $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t))) $ sortBy (comparing fst) $ M.toList primaries @@ -253,10 +257,10 @@ app dbstructure conf reqBody role req = ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do let qt = qualify table - primaryKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys - --primaryKeys <- primaryKeyColumns qt + pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys + --pKeys <- primaryKeyColumns qt let specifiedKeys = map (cs . fst) qq - if S.fromList primaryKeys /= S.fromList specifiedKeys + if S.fromList pKeys /= S.fromList specifiedKeys then return $ responseLBS status405 [] "You must speficy all and only primary keys as params" else do @@ -317,8 +321,9 @@ app dbstructure conf reqBody role req = allColumns = columns dbstructure allPrimaryKeys = primaryKeys dbstructure --allTablesAcl = tablesAcl dbstructure - filterCol schema table (Column{colSchema=s, colTable=t}) = s==schema && table==t - filterPk schema table (PrimaryKey{pkSchema=s, pkTable=t}) = s==schema && table==t + filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t + filterCol _ _ _ = False + filterPk sc table (PrimaryKey{pkSchema=s, pkTable=t}) = s==sc && table==t filterTableAcl :: Text -> Table -> Bool filterTableAcl r (Table{tableAcl=a}) = r `elem` a diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 0dfe553e0..9cd8cf779 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module PostgREST.Auth where -import Data.Aeson -import Control.Monad (mzero) -import Control.Applicative -import Crypto.BCrypt -import Data.Text -import Data.Monoid -import Data.Map -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import qualified Web.JWT as JWT -import Data.String.Conversions (cs) -import PostgREST.PgQuery (pgFmtLit) +import Control.Applicative +import Control.Monad (mzero) +import Crypto.BCrypt +import Data.Aeson +import Data.Map +import Data.Monoid +import Data.String.Conversions (cs) +import Data.Text +import qualified Data.Vector as V +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +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 { - userId :: String + userId :: String , userPass :: String , userRole :: String } deriving (Show) diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 1de7da33b..30d6d2a5d 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,27 +1,28 @@ module PostgREST.Config where -import Network.Wai -import Control.Applicative -import Data.Text (strip) -import qualified Data.CaseInsensitive as CI -import qualified Data.ByteString.Char8 as BS -import Data.String.Conversions (cs) -import Options.Applicative hiding (columns) -import Network.Wai.Middleware.Cors (CorsResourcePolicy(..)) -import Prelude + +import Control.Applicative +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.String.Conversions (cs) +import Data.Text (strip) +import Network.Wai +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) +import Options.Applicative hiding (columns) +import Prelude data AppConfig = AppConfig { - configDbName :: String - , configDbPort :: Int - , configDbUser :: String - , configDbPass :: String - , configDbHost :: String + configDbName :: String + , configDbPort :: Int + , configDbUser :: String + , configDbPass :: String + , configDbHost :: String - , configPort :: Int - , configAnonRole :: String - , configSecure :: Bool - , configPool :: Int - , configV1Schema :: String + , configPort :: Int + , configAnonRole :: String + , configSecure :: Bool + , configPool :: Int + , configV1Schema :: String , configJwtSecret :: String } diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 176b5a327..9b162c53a 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -1,18 +1,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} 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 Data.Aeson as JSON -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 +import Network.Wai (Response, responseLBS) type PgError = H.SessionError P.Postgres diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index ee5320242..c4b972e4c 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -2,17 +2,20 @@ module PostgREST.Functions where -import PostgREST.Types + import Control.Error -import Data.List (find) -import Data.Tree -import Data.Text hiding (find, foldr, map, null, last, head) -import Data.Monoid -import PostgREST.PgQuery (orderT, pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..), StatementT, PStmt) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import qualified Hasql.Backend as B -import qualified Data.Vector as V (empty) +import Data.List (find) +import Data.Monoid +import Data.Text hiding (find, foldr, head, last, map, null) +import Data.Tree +import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi, + orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, + pgFmtValue, whiteList) +import PostgREST.Types +--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 -- it's ok not to check that the table exists here, mainTable will do the checking 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 where 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 (Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest 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) addRel :: Query -> Relation -> Query addRel q r = q{qRelation = Just r} @@ -85,7 +88,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = _ -> Left "unknow relation" where -- 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 parentJoinConditions = mapM (getJoinCondition.snd) parents parentTables = map fst parents @@ -101,7 +104,7 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = dbRequestToCountQuery :: DbRequest -> PStmt -dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = +dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) _) = B.Stmt query V.empty True where query = Data.Text.unwords [ @@ -112,8 +115,8 @@ dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = emptyOnNull val x = if null x then "" else val dbRequestToQuery :: DbRequest -> PStmt -dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation ord) forest) = - orderT (fromMaybe [] ord) $ query +dbRequestToQuery (Node (Select mainTable colSelects tbls conditions _ ord) forest) = + orderT (fromMaybe [] ord) query -- case relation of -- Nothing ->B.Stmt ("SELECT " -- <> "(" @@ -129,11 +132,11 @@ dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation or -- _ -> B.Stmt query V.empty True where - query = B.Stmt q V.empty True - q = Data.Text.unwords [ + query = B.Stmt qStr V.empty True + qStr = Data.Text.unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), - "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), + "SELECT ", intercalate ", " (map selectItemToStr colSelects ++ selects), + "FROM ", intercalate ", " (map pgFmtTable (mainTable:tbls)), ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions ] 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 <> ".*" 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 _ = "" @@ -199,4 +202,4 @@ selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPa asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" -asJsonPath (Just xx) = " AS " <> (pack $ last xx) +asJsonPath (Just xx) = " AS " <> pack (last xx) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 1921d3dc9..7af30e22e 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,42 +1,48 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Paths_postgrest (version) + +import Paths_postgrest (version) -- added -import PostgREST.PgStructure -import Data.Aeson -import Data.List (find) -import Data.Maybe (isJust) -import PostgREST.Types -import Network.HTTP.Types.Status -import Network.HTTP.Types.Header -import Network.Wai -- (strictRequestBody, pathInfo, requestMethod, requestHeaders) +import PostgREST.PgStructure +--import Data.Aeson +--import Data.List (find) +--import Data.Maybe (isJust) +import PostgREST.Types +--import Network.HTTP.Types.Status +--import Network.HTTP.Types.Header +import Network.Wai -import PostgREST.App -import PostgREST.Middleware -import PostgREST.Error(errResponse) +import PostgREST.App +import PostgREST.Error (errResponse) +import PostgREST.Middleware -import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) -import Data.String.Conversions (cs) -import Network.Wai.Handler.Warp hiding (Connection) -import Network.Wai.Middleware.RequestLogger (logStdout) -import Data.List (intercalate) -import Data.Version (versionBranch) -import Data.Functor.Identity -import Data.Text(Text) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import Options.Applicative hiding (columns) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Data.Functor.Identity +import Data.List (intercalate) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Version (versionBranch) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import Network.Wai.Handler.Warp hiding (Connection) +import Network.Wai.Middleware.RequestLogger (logStdout) +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 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 = do @@ -76,12 +82,12 @@ main = do H.poolSettings (fromIntegral $ configPool conf) 30 pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings - resOrError <- H.session pool isServerVersionSupported + supportedOrError <- H.session pool isServerVersionSupported either (fail . show) (\supported -> unless supported $ 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 @@ -96,7 +102,7 @@ main = do colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations 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 -- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index e29fabda2..47ae96389 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,32 +3,37 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid -import Data.Text +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid +import Data.Text -- import Data.Pool(withResource, Pool) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import Data.String.Conversions(cs) +import Data.String.Conversions (cs) +import qualified Hasql as H +import qualified Hasql.Postgres as P -import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept) -import Network.HTTP.Types (RequestHeaders) -import Network.HTTP.Types.Status (status400, status401, status301, status415) -import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo, - rawQueryString, isSecure, Request(..), Response) -import Network.Wai.Middleware.Gzip (gzip, def) -import Network.Wai.Middleware.Cors (cors) -import Network.Wai.Middleware.Static (staticPolicy, only) -import Network.URI (URI(..), parseURI) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Header (hAccept, hAuthorization, + hLocation) +import Network.HTTP.Types.Status (status301, status400, status401, + status415) +import Network.URI (URI (..), parseURI) +import Network.Wai (Application, Request (..), + Response, isSecure, rawPathInfo, + 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 PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, setUserId) -import PostgREST.App (contentTypeForAccept) -import Codec.Binary.Base64.String (decode) -import PostgREST.Auth (DbRole) +import Codec.Binary.Base64.String (decode) +import PostgREST.App (contentTypeForAccept) +import PostgREST.Auth (DbRole, LoginAttempt (..), + setRole, setUserId, signInRole, + signInWithJWT) +import PostgREST.Config (AppConfig (..), corsPolicy) -import Prelude +import Prelude authenticated :: forall s. AppConfig -> (DbRole -> Request -> H.Tx P.Postgres s Response) -> diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 03b476222..889fb2920 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,33 +1,18 @@ --{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-} module PostgREST.Parsers --- ( parseGetRequest --- , pSelect --- , pField --- , pRequestSelect --- ) - +( parseGetRequest +) 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.Monad ---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 Control.Monad (join) import Data.List (delete, find) import Data.Maybe import Data.String.Conversions (cs) -import Control.Monad (join) - ---import qualified Data.ByteString.Char8 as C - ---buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request +import Data.Tree +import Network.Wai (Request, pathInfo, queryString) +import PostgREST.Types +import Text.ParserCombinators.Parsec hiding (many, (<|>)) parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts @@ -38,7 +23,7 @@ parseGetRequest httpRequest = rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] 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 * 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 = many (oneOf " \t") ---lexeme :: Parser String -> Parser String ---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 :: Parser a -> Parser a lexeme p = ws *> p <* ws pTreePath :: Parser (Path,Field) pTreePath = do - p <- (pFieldName `sepBy1` pDelimiter) - --f <- pField + p <- pFieldName `sepBy1` pDelimiter jp <- optionMaybe ( string "->" >> pJsonPath) return (init p, (last p, jp)) @@ -98,17 +80,8 @@ pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) -pFieldTree = - try ( do - fld <- pSelect - char '(' - subforest <- pFieldForest - char ')' - return (Node fld subforest) - ) - <|> do - fld <- pSelect - return (Node fld []) +pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) + <|> Node <$> pSelect <*> pure [] pStar :: Parser String pStar = string "*" *> pure "*" @@ -117,22 +90,18 @@ pFieldName :: Parser String pFieldName = many1 (letter <|> digit <|> oneOf "_") "field name (* or [a..z0..9_])" +pJsonPathDelimiter :: Parser String +pJsonPathDelimiter = try (string "->>") <|> string "->" + pJsonPath :: Parser [String] -pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->") +pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter pField :: Parser Field -pField = lexeme $ do - f <- pFieldName - jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath) - return (f, jp) +pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *> pJsonPath) pSelect :: Parser SelectItem pSelect = lexeme $ - try (do - n <- pField - v <- optionMaybe (string "::" >> many letter) - return (n, v) - ) + try ((,) <$> pField <*> optionMaybe (string "::" *> many letter)) <|> do s <- pStar return ((s, Nothing), Nothing) @@ -154,8 +123,8 @@ pOperator = try (string "lte") -- has to be before lt <|> try (string "@@") "operator (eq, gt, ...)" -pInt :: Parser Int -pInt = try (liftA read (many1 digit)) "integer" +-- pInt :: Parser Int +-- pInt = try (liftA read (many1 digit)) "integer" --pValue :: Parser Value --pValue = (VInt <$> try (pInt <* eof)) @@ -166,20 +135,19 @@ pValue = many anyChar pDelimiter :: Parser Char pDelimiter = char '.' "delimiter (.)" -pOpValueExp :: Parser (Operator, FValue) -pOpValueExp = do - o <- ( try ( liftA2 (++) (string "not.") pOperator) <|> pOperator ) - pDelimiter - v <- pValue - return (o, v) +pOperatiorWithNegation :: Parser Operator +pOperatiorWithNegation = try ( (++) <$> string "not." <*> pOperator) <|> pOperator -pOrder :: Parser ([OrderTerm]) +pOpValueExp :: Parser (Operator, FValue) +pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue) + +pOrder :: Parser [OrderTerm] pOrder = lexeme pOrderTerm `sepBy` char ',' pOrderTerm :: Parser OrderTerm pOrderTerm = do c <- pFieldName - pDelimiter + _ <- pDelimiter d <- string "asc" <|> string "desc" 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) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index dcbccf626..b2182e20e 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -1,31 +1,35 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} 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 Data.HashMap.Strict as H -import Text.Regex.TDFA ( (=~) ) -import qualified Network.HTTP.Types.URI as Net -import qualified Data.ByteString.Char8 as BS -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 qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P +import PostgREST.RangeQuery +import PostgREST.Types (OrderTerm (..)) -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 instance Monoid PStmt where diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index 33fe3c633..9cd82e449 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -1,24 +1,27 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, - MultiParamTypeClasses, ScopedTypeVariables, - FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module PostgREST.PgStructure where -import PostgREST.PgQuery (QualifiedIdentifier(..)) -import PostgREST.Types -import Data.Text (Text, unpack, split) -import Data.List (find) -import Data.Aeson -import Data.Functor.Identity -import Data.String.Conversions (cs) -import Data.Maybe (fromMaybe, isJust) -import Control.Applicative +import Data.List (find) +import Data.Text (Text, split) +import PostgREST.PgQuery () +import PostgREST.Types +--import Data.Aeson +import Data.Functor.Identity +--import Data.String.Conversions (cs) +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.Postgres as P +import qualified Hasql as H +import qualified Hasql.Postgres as P -import Prelude +import Prelude 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 -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 allcolumns :: [Relation] -> H.Tx P.Postgres s [Column] -allcolumns relations = do +allcolumns rels = do cols <- H.listEx $ [H.stmt| SELECT info.table_schema AS schema, @@ -197,9 +178,11 @@ allcolumns relations = do return $ map (addFK . columnFromRow) cols 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}) = cs==rs && ct==rt && cn==rc && rty=="child" + lookupFn _ _ = False relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey] diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index d28e2574c..ff9997378 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,22 +6,22 @@ module PostgREST.RangeQuery ( , NonnegRange ) 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 Data.Ranged.Ranges +import qualified Data.ByteString.Char8 as BS +import Data.Ranged.Boundaries +import Data.Ranged.Ranges -import Data.String.Conversions (cs) -import Text.Regex.TDFA ((=~)) -import Text.Read (readMaybe) +import Data.String.Conversions (cs) +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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 2144a0689..3321b0e68 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,6 +2,7 @@ module PostgREST.Types where import Data.Text import Data.Tree import qualified Data.ByteString.Char8 as BS +import Data.Aeson data DbStructure = DbStructure { tables :: [Table] @@ -11,6 +12,7 @@ data DbStructure = DbStructure { --, tablesAcl :: [(Text, Text, Text)] } + data Table = Table { tableSchema :: Text , tableName :: Text @@ -92,3 +94,26 @@ data Query = Select { , qOrder::Maybe [OrderTerm] } deriving (Show) 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 ]