From 6f737056a2a73698badffc9ca450c019100a7531 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 21 Aug 2016 18:10:19 -0400 Subject: [PATCH] Protolude completion in library and executable (#697) --- main/Main.hs | 2 +- postgrest.cabal | 3 +- src/PostgREST/ApiRequest.hs | 86 +++++++++++++++++------------------ src/PostgREST/App.hs | 18 ++++---- src/PostgREST/Auth.hs | 7 ++- src/PostgREST/Config.hs | 35 +++++++------- src/PostgREST/DbStructure.hs | 32 ++++++------- src/PostgREST/Middleware.hs | 3 +- src/PostgREST/OpenAPI.hs | 6 +-- src/PostgREST/Parsers.hs | 56 +++++++++++------------ src/PostgREST/QueryBuilder.hs | 46 +++++++++---------- test/SpecHelper.hs | 4 +- test/TestTypes.hs | 28 ++---------- 13 files changed, 149 insertions(+), 177 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index f8d8b1968..32a52de5b 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/postgrest.cabal b/postgrest.cabal index f427820e0..697762dbe 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index f8d34210e..d8b1ee155 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index ed0cf366b..c23c0c077 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 18f5c2be6..e203cebb5 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -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 {-| diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index d07c1a36d..ca6551ead 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -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 diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 84e99cbf5..419de824f 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -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 _ [] = [] diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 78e0595a6..2f3798de0 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index c3d75ccd2..3803dd8b3 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -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' diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 1de0dd9de..dd556fd25 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 1b40ca893..736c4e17a 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 1c6bc23df..5043947a9 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 142a4329b..c6e99aa15 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -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)