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

Protolude completion in library and executable (#697)

Browse Source
This commit is contained in:
Diogo Biazus
2016-08-21 15:10:19 -07:00
committed by Joe Nelson
parent 298753d59e
commit 6f737056a2
13 changed files with 149 additions and 177 deletions
Download Patch File Download Diff File Expand all files Collapse all files
main/Main.hs
+1 -1
View File
@@ -47,7 +47,7 @@ main = do
port = configPort conf
proxy = configProxyUri conf
pgSettings = toS (configDatabase conf)
appSettings = setHost (fromString host)
appSettings = setHost ((fromString . toS) host)
. setPort port
. setServerName (toS $ "postgrest/" <> prettyVersion)
$ defaultSettings
postgrest.cabal
+1 -2
View File
@@ -54,7 +54,6 @@ executable postgrest
, regex-tdfa
, safe >= 0.3 && < 0.4
, scientific
, string-conversions
, text
, time
, transformers
@@ -101,7 +100,6 @@ library
, regex-tdfa
, safe
, scientific
, string-conversions
, text
, time
, unordered-containers
@@ -155,6 +153,7 @@ Test-Suite spec
Build-Depends: aeson
, async
, base
, protolude
, base64-string
, bytestring
, case-insensitive
src/PostgREST/ApiRequest.hs
+43 -43
View File
@@ -1,6 +1,6 @@
module PostgREST.ApiRequest where
import Prelude
import Protolude
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
@@ -8,17 +8,12 @@ import qualified Data.ByteString.Internal as BS (c2w)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Csv as CSV
import qualified Data.List as L
import Data.List (lookup, last)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.Maybe (fromMaybe, isJust, isNothing,
listToMaybe, fromJust)
import Data.Maybe (fromJust)
import Control.Arrow ((***))
import Control.Monad (join)
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import Text.Read (readMaybe)
import qualified Data.Vector as V
import Network.HTTP.Base (urlEncodeVars)
import Network.HTTP.Types.Header (hAuthorization, hContentType, Header)
@@ -43,21 +38,23 @@ data Action = ActionCreate | ActionRead
data Target = TargetIdent QualifiedIdentifier
| TargetProc QualifiedIdentifier
| TargetRoot
| TargetUnknown [T.Text]
| TargetUnknown [Text]
-- | How to return the inserted data
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
--
-- | Enumeration of currently supported response content types
data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
| CTAny | CTOther BS.ByteString deriving Eq
instance Show ContentType where
show CTApplicationJSON = "application/json"
show CTTextCSV = "text/csv"
show CTOpenAPI = "application/openapi+json"
show CTAny = "*/*"
show (CTOther ct) = cs ct
ctToHeader :: ContentType -> Header
ctToHeader ct = (hContentType, cs (show ct) <> "; charset=utf-8")
ctToHeader ct = (hContentType, toHeader ct <> "; charset=utf-8")
toHeader :: ContentType -> ByteString
toHeader CTApplicationJSON = "application/json"
toHeader CTTextCSV = "text/csv"
toHeader CTOpenAPI = "application/openapi+json"
toHeader CTAny = "*/*"
toHeader (CTOther ct) = ct
{-|
Describes what the user wants to do. This data type is a
@@ -70,7 +67,7 @@ data ApiRequest = ApiRequest {
-- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
iAction :: Action
-- | Requested range of rows within response
, iRange :: M.HashMap String NonnegRange
, iRange :: M.HashMap ByteString NonnegRange
-- | The target, be it calling a proc or accessing a table
, iTarget :: Target
-- | Content types the client will accept, [CTAny] if no Accept header
@@ -84,15 +81,15 @@ data ApiRequest = ApiRequest {
-- | Whether the client wants a result count (slower)
, iPreferCount :: Bool
-- | Filters on the result ("id", "eq.10")
, iFilters :: [(String, String)]
, iFilters :: [(Text, Text)]
-- | &select parameter used to shape the response
, iSelect :: String
, iSelect :: Text
-- | &order parameters for each level
, iOrder :: [(String,String)]
, iOrder :: [(Text, Text)]
-- | Alphabetized (canonical) request query string for response URLs
, iCanonicalQS :: String
, iCanonicalQS :: ByteString
-- | JSON Web Token
, iJWT :: T.Text
, iJWT :: Text
}
-- | Examines HTTP request and translates it into user intent.
@@ -123,23 +120,23 @@ userApiRequest schema req reqBody =
. fromMaybe "application/json"
$ lookupHeader "content-type" of
CTApplicationJSON ->
either (PayloadParseError . cs)
either (PayloadParseError . toS)
(\val -> case ensureUniform (pluralize val) of
Nothing -> PayloadParseError "All object keys must match"
Just json -> PayloadJSON json)
(JSON.eitherDecode reqBody)
CTTextCSV ->
either (PayloadParseError . cs)
either (PayloadParseError . toS)
(\val -> case ensureUniform (csvToJson val) of
Nothing -> PayloadParseError "All lines must have same number of fields"
Just json -> PayloadJSON json)
(CSV.decodeByName reqBody)
CTOther "application/x-www-form-urlencoded" ->
PayloadJSON . UniformObjects . V.singleton . M.fromList
. map (cs *** JSON.String . cs) . parseSimpleQuery
$ cs reqBody
. map (toS *** JSON.String . toS) . parseSimpleQuery
$ toS reqBody
ct ->
PayloadParseError $ "Content-Type not acceptable: " <> cs (show ct)
PayloadParseError $ "Content-Type not acceptable: " <> toHeader ct
relevantPayload = case action of
ActionCreate -> Just payload
ActionUpdate -> Just payload
@@ -150,19 +147,19 @@ userApiRequest schema req reqBody =
iAction = action
, iTarget = target
, iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $
M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
M.fromList [ (toS k, restrictRange (readBSMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
, iAccepts = fromMaybe [CTAny] $
map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferSingular = singular
, iPreferCount = not $ singular || hasPrefer "count=none"
, iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]
, iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
, iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
, iCanonicalQS = urlEncodeVars
, iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]
, iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
, iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
, iCanonicalQS = toS $ urlEncodeVars
. L.sortBy (comparing fst)
. map (join (***) cs)
. map (join (***) toS)
. parseSimpleQuery
$ rawQueryString req
, iJWT = tokenStr
@@ -173,31 +170,31 @@ userApiRequest schema req reqBody =
method = requestMethod req
isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
hdrs = requestHeaders req
qParams = [(cs k, cs <$> v)|(k,v) <- queryString req]
qParams = [(toS k, v)|(k,v) <- queryString req]
lookupHeader = flip lookup hdrs
hasPrefer :: T.Text -> Bool
hasPrefer :: Text -> Bool
hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
where
split :: BS.ByteString -> [T.Text]
split = map T.strip . T.split (==';') . cs
split :: BS.ByteString -> [Text]
split = map T.strip . T.split (==';') . toS
singular = hasPrefer "plurality=singular"
representation
| hasPrefer "return=representation" = Full
| hasPrefer "return=minimal" = None
| otherwise = HeadersOnly
auth = fromMaybe "" $ lookupHeader hAuthorization
tokenStr = case T.split (== ' ') (cs auth) of
tokenStr = case T.split (== ' ') (toS auth) of
("Bearer" : t : _) -> t
_ -> ""
endingIn:: [T.Text] -> T.Text -> Bool
endingIn:: [Text] -> Text -> Bool
endingIn xx key = lastWord `elem` xx
where lastWord = last $ T.split (=='.') key
headerRange = if singular && method == "GET" then singletonRange 0 else rangeRequested hdrs
urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $
readMaybe =<< join (lookup "offset" qParams)
readBSMaybe =<< join (lookup "offset" qParams)
urlRange = restrictRange
(readMaybe =<< join (lookup "limit" qParams))
(readBSMaybe =<< join (lookup "limit" qParams))
urlOffsetRange
{-|
@@ -227,7 +224,7 @@ decodeContentType ct =
"*/*" -> CTAny
ct' -> CTOther ct'
type CsvData = V.Vector (M.HashMap T.Text BL.ByteString)
type CsvData = V.Vector (M.HashMap Text BL.ByteString)
{-|
Converts CSV like
@@ -249,7 +246,7 @@ csvToJson (_, vals) =
M.map (\str ->
if str == "NULL"
then JSON.Null
else JSON.String $ cs str
else JSON.String $ toS str
)
-- | Convert {foo} to [{foo}], leave arrays unchanged
@@ -276,3 +273,6 @@ ensureUniform arr =
if (V.length objs == V.length arr) && areKeysUniform
then Just (UniformObjects objs)
else Nothing
readBSMaybe :: Read a => ByteString -> Maybe a
readBSMaybe = readMaybe . toS
src/PostgREST/App.hs
+10 -8
View File
@@ -12,7 +12,7 @@ import Data.IORef (IORef, readIORef)
import Data.List (delete, lookup)
import Data.Maybe (fromJust)
import Data.Ranged.Ranges (emptyRange)
import Data.Text (replace, strip, pack, isInfixOf, dropWhile, drop, intercalate)
import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate)
import Data.Tree
import qualified Hasql.Pool as P
@@ -41,7 +41,9 @@ import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
, Action(..), Target(..)
, PreferRepresentation (..)
, userApiRequest, mutuallyAgreeable
, ctToHeader)
, ctToHeader
, userApiRequest
, toHeader)
import PostgREST.Auth (tokenJWT, jwtClaims, containsRole)
import PostgREST.Config (AppConfig (..))
import PostgREST.DbStructure
@@ -117,7 +119,7 @@ app dbStructure conf apiRequest =
[ctToHeader contentType, contentRange,
("Content-Location",
"/" <> toS (qiName qi) <>
if Protolude.null canonical then "" else "?" <> toS canonical
if BS.null canonical then "" else "?" <> toS canonical
)
] (toS body)
@@ -219,7 +221,7 @@ app dbStructure conf apiRequest =
let host = configHost conf
port = toInteger $ configPort conf
proxy = pickProxy $ toS <$> configProxyUri conf
uri Nothing = ("http", pack host, port, "/")
uri Nothing = ("http", host, port, "/")
uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
uri' = uri proxy
encodeApi ti = encodeOpenAPI ti uri'
@@ -280,7 +282,7 @@ serves :: Monad m => [ContentType] -> [ContentType] ->
serves sProduces cAccepts resp =
case mutuallyAgreeable sProduces cAccepts of
Nothing -> do
let failed = intercalate ", " $ map show cAccepts
let failed = intercalate ", " $ map (toS . toHeader) cAccepts
return $ errResponse status415 $
"None of these Content-Types are available: " <> failed
Just ct -> resp ct
@@ -351,7 +353,7 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
flts
| action == ActionRead = iFilters apiRequest
| action == ActionInvoke = iFilters apiRequest
| otherwise = filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
| otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
orders :: Either ParseError [(Path, [OrderTerm])]
orders = mapM pRequestOrder $ iOrder apiRequest
ranges :: Either ParseError [(Path, NonnegRange)]
@@ -388,7 +390,7 @@ buildReadRequest maxRows allRels allProcs apiRequest =
readRequest :: Either ParseError ReadRequest
readRequest = addFiltersOrdersRanges apiRequest <*>
parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr)
where
selStr = iSelect apiRequest
rootName = if action == ActionRead
@@ -419,7 +421,7 @@ buildMutateRequest apiRequest = case action of
(TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined
filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
where mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
addFilterToNode :: Filter -> ReadRequest -> ReadRequest
addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f
src/PostgREST/Auth.hs
+3 -4
View File
@@ -26,7 +26,6 @@ import Data.Aeson.Types (parseMaybe, emptyObject, emptyArray)
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromJust)
import Data.String.Conversions (cs)
import Data.Time.Clock (NominalDiffTime)
import PostgREST.QueryBuilder (pgFmtIdent, pgFmtLit, unquoted)
import qualified Web.JWT as JWT
@@ -41,10 +40,10 @@ claimsToSQL :: M.HashMap Text Value -> [ByteString]
claimsToSQL claims = roleStmts <> varStmts
where
roleStmts = maybeToList $
(\r -> "set local role " <> r <> ";") . cs . valueToVariable <$> M.lookup "role" claims
(\r -> "set local role " <> r <> ";") . toS . valueToVariable <$> M.lookup "role" claims
varStmts = map setVar $ M.toList (M.delete "role" claims)
setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)
<> " = " <> cs (valueToVariable val) <> ";"
setVar (k, val) = "set local " <> toS (pgFmtIdent $ "postgrest.claims." <> k)
<> " = " <> toS (valueToVariable val) <> ";"
valueToVariable = pgFmtLit . unquoted
{-|
src/PostgREST/Config.hs
+17 -18
View File
@@ -22,25 +22,24 @@ module PostgREST.Config ( prettyVersion
import Control.Applicative
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import Data.List (intercalate)
import Data.String.Conversions (cs)
import Data.Text (strip)
import Data.List (lookup)
import Data.Text (strip, intercalate)
import Data.Version (versionBranch)
import Network.Wai
import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
import Options.Applicative
import Paths_postgrest (version)
import Prelude
import Protolude hiding (intercalate)
import Safe (readMay)
import Web.JWT (Secret, secret)
-- | Data type to store all command line options
data AppConfig = AppConfig {
configDatabase :: String
, configAnonRole :: String
, configProxyUri :: Maybe String
, configSchema :: String
, configHost :: String
configDatabase :: Text
, configAnonRole :: Text
, configProxyUri :: Maybe Text
, configSchema :: Text
, configHost :: Text
, configPort :: Int
, configJwtSecret :: Secret
, configPool :: Int
@@ -50,13 +49,13 @@ data AppConfig = AppConfig {
argParser :: Parser AppConfig
argParser = AppConfig
<$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL")
<*> strOption (long "anonymous" <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE")
<*> (optional . strOption) (long "proxy-uri" <> short 'x' <> help "proxy uri of the HTTP server" <> metavar "PROXY")
<*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault)
<*> strOption (long "host" <> short 'l' <> help "hostname or ip on which to run HTTP server" <> metavar "HOST" <> value "*4" <> showDefault)
<$> (toS <$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL"))
<*> (toS <$> strOption (long "anonymous" <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE"))
<*> (optional . map toS . strOption) (long "proxy-uri" <> short 'x' <> help "proxy uri of the HTTP server" <> metavar "PROXY")
<*> (toS <$> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault))
<*> (toS <$> strOption (long "host" <> short 'l' <> help "hostname or ip on which to run HTTP server" <> metavar "HOST" <> value "*4" <> showDefault))
<*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)
<*> (secret . cs <$>
<*> (secret . toS <$>
strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault))
<*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)
<*> (readMay <$> strOption (long "max-rows" <> short 'm' <> help "max rows in response" <> metavar "COUNT" <> value "infinity" <> showDefault))
@@ -82,11 +81,11 @@ corsPolicy req = case lookup "origin" headers of
where
headers = requestHeaders req
accHeaders = case lookup "access-control-request-headers" headers of
Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs
Nothing -> []
-- | User friendly version number
prettyVersion :: String
prettyVersion :: Text
prettyVersion = intercalate "." $ map show $ versionBranch version
-- | Function to read and parse options from the command line
@@ -97,7 +96,7 @@ readOptions = customExecParser parserPrefs opts
fullDesc
<> progDesc (
"PostgREST "
<> prettyVersion
<> toS prettyVersion
<> " / create a REST API to an existing Postgres database"
)
parserPrefs = prefs showHelpOnError
src/PostgREST/DbStructure.hs
+15 -17
View File
@@ -13,20 +13,17 @@ import qualified Hasql.Encoders as HE
import qualified Hasql.Query as H
import Control.Applicative
import Control.Monad (join, replicateM)
import Data.List (elemIndex, find, sort,
subsequences, transpose)
import Data.Maybe (fromJust, fromMaybe, isJust,
listToMaybe, mapMaybe)
import Data.List (elemIndex)
import Data.Maybe (fromJust)
import Data.Monoid
import Data.Text (Text, split)
import Data.Text (split)
import qualified Hasql.Session as H
import PostgREST.Types
import Text.InterpolatedString.Perl6 (q)
import Data.Int (Int32)
import GHC.Exts (groupWith)
import Prelude
import Protolude
import Unsafe (unsafeHead)
getDbStructure :: Schema -> H.Session DbStructure
getDbStructure schema = do
@@ -139,7 +136,9 @@ accessibleTables =
synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
synonymousColumns allSyns cols = synCols'
where
syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns
syns = case headMay cols of
Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns
Nothing -> []
synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols
synCols' = (filter sameTable . filter matchLength) synCols
matchLength cs = length cols == length cs
@@ -153,11 +152,10 @@ addForeignKeys rels = map addFk
fk col = join $ relToFk col <$> find (lookupFn col) rels
lookupFn :: Column -> Relation -> Bool
lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child
-- lookupFn _ _ = False
relToFk col Relation{relColumns=cols, relFColumns=colsF} = ForeignKey <$> colF
where
pos = elemIndex col cols
colF = (colsF !!) <$> pos
relToFk col Relation{relColumns=cols, relFColumns=colsF} = do
pos <- elemIndex col cols
colF <- atMay colsF pos
return $ ForeignKey colF
addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
addSynonymousRelations _ [] = []
@@ -165,7 +163,7 @@ addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynony
where
synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})
synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols
synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols
addParentRelations :: [Relation] -> [Relation]
addParentRelations [] = []
@@ -198,8 +196,8 @@ raiseRelations schema syns = map raiseRel
where
cols = relFColumns rel
table = relFTable rel
newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols)
newTable = (colTable . head) <$> newCols
newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols)
newTable = (colTable . unsafeHead) <$> newCols
synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]
synonymousPrimaryKeys _ [] = []
src/PostgREST/Middleware.hs
+1 -2
View File
@@ -5,7 +5,6 @@ module PostgREST.Middleware where
import Data.Aeson (Value (..))
import qualified Data.HashMap.Strict as M
import Data.String.Conversions (cs)
import qualified Hasql.Transaction as H
import Network.HTTP.Types.Status (status400)
@@ -33,7 +32,7 @@ runWithClaims conf eClaims app req =
H.sql . mconcat . claimsToSQL $ M.union claims (M.singleton "role" anon)
app req
where
anon = String . cs $ configAnonRole conf
anon = String . toS $ configAnonRole conf
clientErr = return . errResponse status400
defaultMiddle :: Application -> Application
src/PostgREST/OpenAPI.hs
+3 -3
View File
@@ -20,14 +20,14 @@ import Protolude hiding (concat, (&), Proxy, get, interca
import Data.Swagger
import PostgREST.ApiRequest (ContentType(..))
import PostgREST.ApiRequest (ContentType(..), toHeader)
import PostgREST.Config (prettyVersion)
import PostgREST.QueryBuilder (operators)
import PostgREST.Types (Table(..), Column(..),
Proxy(..))
makeMimeList :: [ContentType] -> MimeList
makeMimeList cs = MimeList $ map (fromString . show) cs
makeMimeList cs = MimeList $ map (fromString . toS . toHeader) cs
toSwaggerType :: Text -> SwaggerType t
toSwaggerType "text" = SwaggerString
@@ -230,7 +230,7 @@ postgrestSpec ti (s, h, p, b) = (mempty :: Swagger)
& basePath ?~ unpack b
& schemes ?~ [s']
& info .~ ((mempty :: Info)
& version .~ pack prettyVersion
& version .~ prettyVersion
& title .~ "PostgREST API"
& description ?~ "This is a dynamic API generated by PostgREST")
& host .~ h'
src/PostgREST/Parsers.hs
+26 -30
View File
@@ -1,13 +1,9 @@
module PostgREST.Parsers
-- ( parseGetRequest
-- )
where
module PostgREST.Parsers where
import Prelude
import Control.Applicative hiding ((<$>))
import Data.Monoid
import Data.String.Conversions (cs)
import Data.Text (Text, intercalate)
import Protolude hiding (try, intercalate)
import Control.Monad ((>>))
import Data.Text (intercalate)
import Data.List (init, last)
import Data.Tree
import PostgREST.QueryBuilder (operators)
import PostgREST.Types
@@ -29,31 +25,31 @@ pRequestSelect rootNodeName = do
newForest =
foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter)
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
where
treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
opVal = parse pOpValueExp ("failed to parse filter (" ++ toS v ++ ")") $ toS v
path = fst <$> treePath
fld = snd <$> treePath
op = fst <$> opVal
val = snd <$> opVal
pRequestOrder :: (String, String) -> Either ParseError (Path, [OrderTerm])
pRequestOrder (k, v) = (,) <$> path <*> ord
pRequestOrder :: (Text, Text) -> Either ParseError (Path, [OrderTerm])
pRequestOrder (k, v) = (,) <$> path <*> ord'
where
treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
path = fst <$> treePath
ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v
ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange)
pRequestRange :: (ByteString, NonnegRange) -> Either ParseError (Path, NonnegRange)
pRequestRange (k, v) = (,) <$> path <*> pure v
where
treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
path = fst <$> treePath
ws :: Parser Text
ws = cs <$> many (oneOf " \t")
ws = toS <$> many (oneOf " \t")
lexeme :: Parser a -> Parser a
lexeme p = ws *> p <* ws
@@ -72,13 +68,13 @@ pFieldTree = try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFiel
<|> Node <$> pSelect <*> pure []
pStar :: Parser Text
pStar = cs <$> (string "*" *> pure ("*"::String))
pStar = toS <$> (string "*" *> pure ("*"::ByteString))
pFieldName :: Parser Text
pFieldName = do
matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"
return $ intercalate "-" $ map cs matches
return $ intercalate "-" $ map toS matches
where
isDash :: GenParser Char st ()
isDash = try ( char '-' >> notFollowedBy (char '>') )
@@ -87,10 +83,10 @@ pFieldName = do
pJsonPathStep :: Parser Text
pJsonPathStep = cs <$> try (string "->" *> pFieldName)
pJsonPathStep = toS <$> try (string "->" *> pFieldName)
pJsonPath :: Parser [Text]
pJsonPath = (++) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
pField :: Parser Field
pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
@@ -111,25 +107,25 @@ pSelect = lexeme $
do
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
fld <- pField
cast <- optionMaybe (string "::" *> many letter)
return (fld, cs <$> cast, alias)
cast' <- optionMaybe (string "::" *> many letter)
return (fld, toS <$> cast', alias)
)
<|> do
s <- pStar
return ((s, Nothing), Nothing, Nothing)
pOperator :: Parser Operator
pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators
pOperator = toS <$> (pOp <?> "operator (eq, gt, ...)")
where pOp = foldl (<|>) empty $ map (try . string . toS . fst) operators
pValue :: Parser FValue
pValue = VText <$> (cs <$> many anyChar)
pValue = VText <$> (toS <$> many anyChar)
pDelimiter :: Parser Char
pDelimiter = char '.' <?> "delimiter (.)"
pOperatiorWithNegation :: Parser Operator
pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*> pOperator) <|> pOperator
pOperatiorWithNegation = try ( (<>) <$> ( toS <$> string "not." ) <*> pOperator) <|> pOperator
pOpValueExp :: Parser (Operator, FValue)
pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue)
@@ -150,4 +146,4 @@ pOrderTerm =
))
return $ OrderTerm c d nls
)
<|> OrderTerm <$> (cs <$> pFieldName) <*> pure OrderAsc <*> pure Nothing
<|> OrderTerm <$> (toS <$> pFieldName) <*> pure OrderAsc <*> pure Nothing
src/PostgREST/QueryBuilder.hs
+21 -25
View File
@@ -33,20 +33,14 @@ import qualified Hasql.Encoders as HE
import qualified Hasql.Decoders as HD
import qualified Data.Aeson as JSON
import Data.Int (Int64)
import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange)
import Control.Error (note, fromMaybe)
import Control.Error (note)
import Data.Functor.Contravariant (contramap)
import qualified Data.HashMap.Strict as HM
import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split)
import Data.Text (intercalate, unwords, replace, isInfixOf, toLower, split)
import qualified Data.Text as T (map, takeWhile, null)
import qualified Data.Text.Encoding as T
import Data.String.Conversions (cs)
import Control.Applicative ((<|>))
import Control.Monad (replicateM)
import Data.Tree (Tree(..))
import qualified Data.Vector as V
import PostgREST.Types
@@ -58,7 +52,7 @@ import Data.Scientific ( FPFormat (..)
, formatScientific
, isInteger
)
import Prelude hiding (unwords)
import Protolude hiding (from, intercalate, ord, cast)
import PostgREST.ApiRequest (PreferRepresentation (..))
{-| The generic query result format used by API responses. The location header
@@ -183,8 +177,8 @@ addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _
findRelationByTable s t1 t2 =
find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t1 == tableName (relTable r) && t2 == tableName (relFTable r)) allRelations
findRelationByColumn s t c =
find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t == tableName (relFTable r) && length (relFColumns r) == 1 && c `colMatches` (colName . head . relFColumns) r) allRelations
where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString)
find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t == tableName (relFTable r) && length (relFColumns r) == 1 && c `colMatches` fromMaybe "" (colName <$> (head . relFColumns) r)) allRelations
where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)
addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
@@ -212,8 +206,8 @@ callProc qi params selectQuery countQuery _ countTotal isSingle =
SELECT
{countResultF} AS total_result_set,
pg_catalog.count(t) AS page_total,
case
when pg_catalog.count(1) > 1 then
case
when pg_catalog.count(1) > 1 then
{bodyF}
else
coalesce(((array_agg(row_to_json(t)))[1]->{_procName})::character varying, {bodyF})
@@ -257,7 +251,7 @@ operators = [
]
pgFmtIdent :: SqlFragment -> SqlFragment
pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ cs x) <> "\""
pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
pgFmtLit :: SqlFragment -> SqlFragment
pgFmtLit x =
@@ -312,9 +306,9 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions
clause = intercalate "," (map queryTerm ts)
queryTerm :: OrderTerm -> Text
queryTerm t = " "
<> cs (pgFmtColumn qi $ otTerm t) <> " "
<> (cs.show) (otDirection t) <> " "
<> maybe "" (cs.show) (otNullOrder t) <> " "
<> toS (pgFmtColumn qi $ otTerm t) <> " "
<> show (otDirection t) <> " "
<> maybe "" show (otNullOrder t) <> " "
(joins, selects) = foldr getQueryParts ([],[]) forest
getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
@@ -386,9 +380,9 @@ sourceCTEName = "pg_source"
unquoted :: JSON.Value -> Text
unquoted (JSON.String t) = t
unquoted (JSON.Number n) =
cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
unquoted (JSON.Bool b) = cs . show $ b
unquoted v = cs $ JSON.encode v
toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
unquoted (JSON.Bool b) = show b
unquoted v = toS $ JSON.encode v
-- private functions
asCsvF :: SqlFragment
@@ -428,8 +422,8 @@ limitF r = if r == allRange
then ""
else "LIMIT " <> limit <> " OFFSET " <> offset
where
limit = maybe "ALL" (cs . show) $ rangeLimit r
offset = cs . show $ rangeOffset r
limit = maybe "ALL" show $ rangeLimit r
offset = show $ rangeOffset r
fromQi :: QualifiedIdentifier -> SqlFragment
fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
@@ -463,7 +457,7 @@ insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v
whiteList :: Text -> SqlFragment
whiteList val = fromMaybe
(cs (pgFmtLit val) <> "::unknown ")
(toS (pgFmtLit val) <> "::unknown ")
(find ((==) . toLower $ val) ["null","true","false"])
pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
@@ -484,7 +478,7 @@ pgFmtCondition table (Filter (col,jp) ops val) =
where
headPredicate:rest = split (=='.') ops
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
opCode = hasNot (head rest) headPredicate
opCode = hasNot (headDef "eq" rest) headPredicate
notOp = hasNot headPredicate ""
sqlCol = case val of
VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
@@ -524,7 +518,9 @@ pgFmtJsonPath _ = ""
pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment
pgFmtAs Nothing Nothing = ""
pgFmtAs (Just xx) Nothing = " AS " <> pgFmtIdent (last xx)
pgFmtAs (Just xx) Nothing = case lastMay xx of
Just alias -> " AS " <> pgFmtIdent alias
Nothing -> ""
pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias
trimNullChars :: Text -> Text
test/SpecHelper.hs
+3 -1
View File
@@ -22,6 +22,8 @@ import Data.Maybe (fromJust)
import Data.Aeson (decode)
import qualified Data.JsonSchema.Draft4 as D4
import Data.Text
validateOpenApiResponse :: [Header] -> WaiSession ()
validateOpenApiResponse headers = do
r <- request methodGet "/" headers ""
@@ -45,7 +47,7 @@ validateOpenApiResponse headers = do
in
D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right ()
testDbConn :: String
testDbConn :: Text
testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"
testCfg :: AppConfig
test/TestTypes.hs
+5 -23
View File
@@ -1,23 +1,18 @@
module TestTypes (
IncPK(..)
, CompoundPK(..)
-- , incFromList
-- , compoundFromList
) where
import qualified Data.Aeson as JSON
import Data.Aeson ((.:))
-- import Data.Maybe (fromJust)
import Control.Applicative
import Control.Monad (mzero)
import Prelude
import Protolude
data IncPK = IncPK {
incId :: Int
, incNullableStr :: Maybe String
, incStr :: String
, incInsert :: String
, incNullableStr :: Maybe Text
, incStr :: Text
, incInsert :: Text
} deriving (Eq, Show)
instance JSON.FromJSON IncPK where
@@ -28,16 +23,9 @@ instance JSON.FromJSON IncPK where
r .: "inserted_at"
parseJSON _ = mzero
-- incFromList :: [(String, SqlValue)] -> IncPK
-- incFromList row = IncPK
-- (fromSql . fromJust $ lookup "id" row)
-- (fromSql . fromJust $ lookup "nullable_string" row)
-- (fromSql . fromJust $ lookup "non_nullable_string" row)
-- (fromSql . fromJust $ lookup "inserted_at" row)
data CompoundPK = CompoundPK {
compoundK1 :: Int
, compoundK2 :: String
, compoundK2 :: Text
, compoundExtra :: Maybe Int
} deriving (Eq, Show)
@@ -47,9 +35,3 @@ instance JSON.FromJSON CompoundPK where
r .: "k2" <*>
r .: "extra"
parseJSON _ = mzero
-- compoundFromList :: [(String, SqlValue)] -> CompoundPK
-- compoundFromList row = CompoundPK
-- (fromSql . fromJust $ lookup "k1" row)
-- (fromSql . fromJust $ lookup "k2" row)
-- (fromSql . fromJust $ lookup "extra" row)