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