From 33532cfbb6301e060bb50aece06cc73c359536a4 Mon Sep 17 00:00:00 2001 From: Robert Date: Sun, 9 Jun 2019 03:52:48 +0200 Subject: [PATCH] Fix hlint warnings for hlint v2.1.20 (#1320) * Apply some hlint suggestions. * Simplify config parser (to avoid hlint error) * Reorganize for clarity (and fix hlint error) * Remove redundant language extension * Reformat slice more conventionally to avoid hlint bug * Refactor for clarity (and to avoid hlint error) * Simplify (and avoid hlint error) * Fix hlint complaint --- main/Main.hs | 4 ++-- src/PostgREST/ApiRequest.hs | 2 +- src/PostgREST/Config.hs | 26 ++++++++++++++++---------- src/PostgREST/DbStructure.hs | 31 ++++++++++++++++++++----------- src/PostgREST/Error.hs | 3 +-- src/PostgREST/OpenAPI.hs | 2 +- src/PostgREST/Parsers.hs | 8 +++++--- src/PostgREST/Types.hs | 21 +++++++++++---------- test/Main.hs | 2 +- 9 files changed, 58 insertions(+), 41 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index f697b602c..b5b4f67b7 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -135,8 +135,8 @@ connectionStatus pool = shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool shouldRetry rs isConnSucc = do - delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000 - itShould <- pure $ NotConnected == isConnSucc + let delay = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000 + itShould = NotConnected == isConnSucc when itShould $ putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..." return itShould diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index a7c52a702..35b13c158 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -137,7 +137,7 @@ userApiRequest schema req reqBody , iColumns = columns , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] , iCanonicalQS = toS $ urlEncodeVars - . L.sortBy (comparing fst) + . L.sortOn fst . map (join (***) toS . second (fromMaybe BS.empty)) $ queryStringWPlus , iJWT = tokenStr diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index aa6255c3e..21768a28c 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -146,18 +146,18 @@ readOptions = do AppConfig <$> reqString "db-uri" <*> reqString "db-anon-role" - <*> (mfilter (/= "") <$> optString "server-proxy-uri") + <*> optString "server-proxy-uri" <*> reqString "db-schema" - <*> (fromMaybe "!4" . mfilter (/= "") <$> optString "server-host") - <*> (fromMaybe 3000 . join . fmap coerceInt <$> optValue "server-port") + <*> (fromMaybe "!4" <$> optString "server-host") + <*> (fromMaybe 3000 <$> optInt "server-port") <*> optString "server-unix-socket" - <*> (fmap encodeUtf8 . mfilter (/= "") <$> optString "jwt-secret") - <*> (fromMaybe False . join . fmap coerceBool <$> optValue "secret-is-base64") + <*> (fmap encodeUtf8 <$> optString "jwt-secret") + <*> (fromMaybe False <$> optBool "secret-is-base64") <*> parseJwtAudience "jwt-aud" - <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool") - <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool-timeout") - <*> (join . fmap coerceInt <$> optValue "max-rows") - <*> (mfilter (/= "") <$> optString "pre-request") + <*> (fromMaybe 10 <$> optInt "db-pool") + <*> (fromMaybe 10 <$> optInt "db-pool-timeout") + <*> optInt "max-rows" + <*> optString "pre-request" <*> pure False <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value) <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key") @@ -176,11 +176,17 @@ readOptions = do reqString k = C.required k C.string optString :: C.Key -> C.Parser C.Config (Maybe Text) - optString k = C.optional k C.string + optString k = mfilter (/= "") <$> C.optional k C.string optValue :: C.Key -> C.Parser C.Config (Maybe C.Value) optValue k = C.optional k C.value + optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i) + optInt k = join <$> C.optional k (coerceInt <$> C.value) + + optBool :: C.Key -> C.Parser C.Config (Maybe Bool) + optBool k = join <$> C.optional k (coerceBool <$> C.value) + coerceText :: C.Value -> Text coerceText (C.String s) = s coerceText v = show v diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 5636b7a8a..eb6df3e6e 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -240,7 +240,7 @@ addForeignKeys :: [Relation] -> [Column] -> [Column] addForeignKeys rels = map addFk where addFk col = col { colFK = fk col } - fk col = join $ relToFk col <$> find (lookupFn col) rels + fk col = find (lookupFn col) rels >>= relToFk col lookupFn :: Column -> Relation -> Bool lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child relToFk col Relation{relColumns=cols, relFColumns=colsF} = do @@ -295,19 +295,28 @@ addViewChildRelations allSyns = concatMap (\rel -> -- Relation is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query. -- So we need to change the order of the synonyms to match the relColumns -- This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns - syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns in + syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns - -- View Table Child Relations - [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) relFTable relFColumns Child Nothing Nothing Nothing - | syns <- colsSyns, syns `allSynsOf` relColumns] ++ + viewTableChild = + [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) + relFTable relFColumns + Child Nothing Nothing Nothing + | syns <- colsSyns, syns `allSynsOf` relColumns ] - -- Table View Child Relations - [Relation relTable relColumns (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing - | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] ++ + tableViewChild = + [ Relation relTable relColumns + (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) + Child Nothing Nothing Nothing + | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] - -- View View Child Relations - [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing - | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns] + viewViewChild = + [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) + (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) + Child Nothing Nothing Nothing + | syns <- colsSyns, syns `allSynsOf` relColumns + , fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] + + in viewTableChild ++ tableViewChild ++ viewViewChild _ -> []) diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 42a82aac8..a2c8d0059 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -3,8 +3,7 @@ Module : PostgREST.Error Description : PostgREST error HTTP responses -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module PostgREST.Error ( errorResponseFor diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index c1df03804..55ecb0866 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -349,7 +349,7 @@ isUriValid:: URI -> Bool isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] fAnd :: [a -> Bool] -> a -> Bool -fAnd fs x = all ($x) fs +fAnd fs x = all ($ x) fs isSchemeValid :: URI -> Bool isSchemeValid URI {uriScheme = s} diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 81857b467..342a3fe95 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -56,9 +56,11 @@ pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree where path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k embedPath = fst <$> path - op = snd <$> path - -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" - logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v) + logicTree = do + op <- snd <$> path + -- Concat op and v to make pLogicTree argument regular, + -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" + parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName)) pRequestColumns colStr = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 5eed8c662..a7e8cea04 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -91,20 +91,21 @@ instance Ord ProcDescription where | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2) {-| - Search a pg procedure by its parameters, since a function can be overloaded the name is not enough to find it. + Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it. An overloaded function can have a different volatility or even a different return type. -} findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription findProc qi payloadKeys paramsAsSingleObject allProcs = - let procs = M.lookup (qiName qi) allProcs in - -- Handle overloaded functions case - join $ (case length <$> procs of - Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription - _ -> find (\x -> - if paramsAsSingleObject - then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err - else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x)) - ) <$> procs + case M.lookup (qiName qi) allProcs of + Nothing -> Nothing + Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription + Just procs -> find matches procs -- Handle overloaded functions case + where + matches proc = + if paramsAsSingleObject + -- if the arg is not of json type let the db give the err + then length (pdArgs proc) == 1 + else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc) {-| Search the procedure parameters by matching them with the specified keys. diff --git a/test/Main.hs b/test/Main.hs index b1c029c1b..7c0da1872 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -55,7 +55,7 @@ main = do ver <- getPgVersion HT.transaction HT.ReadCommitted HT.Read $ getDbStructure "test" ver - dbStructure <- pure $ either (panic.show) id result + let dbStructure = either (panic.show) id result getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }