diff --git a/main/Main.hs b/main/Main.hs index 34fc543e0..f8d8b1968 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -2,7 +2,7 @@ module Main where -import Prelude +import Protolude import PostgREST.App import PostgREST.Config (AppConfig (..), minimumPgVersion, @@ -11,10 +11,8 @@ import PostgREST.Config (AppConfig (..), import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.DbStructure -import Control.Monad -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) import Data.String (IsString (..)) +import Data.Function (id) import qualified Hasql.Query as H import qualified Hasql.Session as H import qualified Hasql.Decoders as HD @@ -22,25 +20,21 @@ import qualified Hasql.Encoders as HE import qualified Hasql.Pool as P import Network.Wai.Handler.Warp import System.IO (BufferMode (..), - hSetBuffering, stderr, - stdin, stdout) + hSetBuffering) import Web.JWT (secret) import Data.IORef #ifndef mingw32_HOST_OS -import Control.Monad.IO.Class (liftIO) import System.Posix.Signals -import Control.Concurrent (myThreadId) -import Control.Exception.Base (throwTo, AsyncException(..)) #endif isServerVersionSupported :: H.Session Bool isServerVersionSupported = do ver <- H.query () pgVersion - return $ read (cs ver) >= minimumPgVersion + return $ toInteger ver >= minimumPgVersion where pgVersion = H.statement "SHOW server_version_num" - HE.unit (HD.singleRow $ HD.value HD.text) True + HE.unit (HD.singleRow $ HD.value HD.int4) True main :: IO () main = do @@ -52,30 +46,29 @@ main = do let host = configHost conf port = configPort conf proxy = configProxyUri conf - pgSettings = cs (configDatabase conf) + pgSettings = toS (configDatabase conf) appSettings = setHost (fromString host) . setPort port - . setServerName (cs $ "postgrest/" <> prettyVersion) + . setServerName (toS $ "postgrest/" <> prettyVersion) $ defaultSettings - when (isMalformedProxyUri proxy) $ error + when (isMalformedProxyUri $ toS <$> proxy) $ panic "Malformed proxy uri, a correct example: https://example.com:8443/basePath" unless (secret "secret" /= configJwtSecret conf) $ - putStrLn "WARNING, running in insecure mode, JWT secret is the default value" - Prelude.putStrLn $ "Listening on port " ++ - (show $ configPort conf :: String) + putStrLn ("WARNING, running in insecure mode, JWT secret is the default value" :: Text) + putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) pool <- P.acquire (configPool conf, 10, pgSettings) result <- P.use pool $ do supported <- isServerVersionSupported - unless supported $ error ( + unless supported $ panic ( "Cannot run in this PostgreSQL version, PostgREST needs at least " <> show minimumPgVersion) - getDbStructure (cs $ configSchema conf) + getDbStructure (toS $ configSchema conf) - refDbStructure <- newIORef $ either (error.show) id result + refDbStructure <- newIORef $ either (panic . show) id result #ifndef mingw32_HOST_OS tid <- myThreadId @@ -87,7 +80,7 @@ main = do void $ installHandler sigHUP ( Catch . void . P.use pool $ do - s <- getDbStructure (cs $ configSchema conf) + s <- getDbStructure (toS $ configSchema conf) liftIO $ atomicWriteIORef refDbStructure s ) Nothing #endif diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index cc52db42c..de484d6bc 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -7,14 +7,12 @@ module PostgREST.App ( ) where import Control.Applicative -import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as BS import Data.IORef (IORef, readIORef) -import Data.List (find, delete) -import Data.Maybe (fromMaybe, fromJust, mapMaybe) +import Data.List (delete, lookup) +import Data.Maybe (fromJust) import Data.Ranged.Ranges (emptyRange) -import Data.String.Conversions (cs) -import Data.Text (Text, replace, strip, pack, isInfixOf, dropWhile, drop) +import Data.Text (replace, strip, pack, isInfixOf, dropWhile, drop) import Data.Tree import qualified Hasql.Pool as P @@ -62,8 +60,9 @@ import PostgREST.QueryBuilder ( callProc import PostgREST.Types import PostgREST.OpenAPI -import Prelude hiding (dropWhile, drop) - +import Data.Foldable (foldr1) +import Data.Function (id) +import Protolude hiding (dropWhile, drop, Proxy) postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application postgrest conf refDbStructure pool = @@ -74,7 +73,7 @@ postgrest conf refDbStructure pool = body <- strictRequestBody req dbStructure <- readIORef refDbStructure - let schema = cs $ configSchema conf + let schema = toS $ configSchema conf apiRequest = userApiRequest schema req body eClaims = jwtClaims (configJwtSecret conf) (iJWT apiRequest) time authed = containsRole eClaims @@ -95,13 +94,13 @@ app dbStructure conf apiRequest = let -- TODO: blow up for Left values (there is a middleware that checks the headers) contentType = either (const ApplicationJSON) id (iAccepts apiRequest) - contentTypeH = (hContentType, cs $ show contentType) in + contentTypeH = (hContentType, show contentType) in case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of (ActionRead, TargetIdent qi, Nothing) -> case readSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e + Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (q, cq) -> do let singular = iPreferSingular apiRequest stm = createReadStatement q cq singular @@ -112,22 +111,22 @@ app dbStructure conf apiRequest = if singular then return $ if queryTotal <= 0 then responseLBS status404 [] "" - else responseLBS status200 [contentTypeH] (cs body) + else responseLBS status200 [contentTypeH] (toS body) else do let (status, contentRange) = rangeHeader queryTotal tableTotal canonical = iCanonicalQS apiRequest return $ responseLBS status [contentTypeH, contentRange, ("Content-Location", - "/" <> cs (qiName qi) <> - if Prelude.null canonical then "" else "?" <> cs canonical + "/" <> toS (qiName qi) <> + if Protolude.null canonical then "" else "?" <> toS canonical ) - ] (cs body) + ] (toS body) (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e + Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (sq,mq) -> do let isSingle = (==1) $ V.length rows let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? @@ -136,15 +135,15 @@ app dbStructure conf apiRequest = let (_, _, fs, body) = extractQueryResult row header = if null fs then [] - else [(hLocation, "/" <> cs table <> renderLocationFields fs)] + else [(hLocation, "/" <> toS table <> renderLocationFields fs)] return $ if iPreferRepresentation apiRequest == Full - then responseLBS status201 (contentTypeH : header) (cs body) + then responseLBS status201 (contentTypeH : header) (toS body) else responseLBS status201 header "" (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e + Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (sq,mq) -> do let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload row <- H.query uniform stm @@ -154,12 +153,12 @@ app dbStructure conf apiRequest = | iPreferRepresentation apiRequest == Full -> status200 | otherwise -> status204 return $ if iPreferRepresentation apiRequest == Full - then responseLBS s [contentTypeH, r] (cs body) + then responseLBS s [contentTypeH, r] (toS body) else responseLBS s [r] "" (ActionDelete, TargetIdent qi, Nothing) -> case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e + Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (sq,mq) -> do let emptyUniform = UniformObjects V.empty fakeload = PayloadJSON emptyUniform @@ -170,7 +169,7 @@ app dbStructure conf apiRequest = return $ if queryTotal == 0 then notFound else if iPreferRepresentation apiRequest == Full - then responseLBS status200 [contentTypeH, r] (cs body) + then responseLBS status200 [contentTypeH, r] (toS body) else responseLBS status204 [r] "" (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> @@ -182,7 +181,7 @@ app dbStructure conf apiRequest = pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys body = encode (TableOptions cols pkeys) acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in - return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body + return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ toS body (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> do @@ -192,7 +191,7 @@ app dbStructure conf apiRequest = returnType = lookup (qiName qi) $ dbProcs dbStructure returnsJWT = fromMaybe False $ isInfixOf "jwt_claims" <$> returnType case readSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ cs e + Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (q,cq) -> respondToRange $ do row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular) let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row @@ -200,27 +199,27 @@ app dbStructure conf apiRequest = in return $ responseLBS status [jsonH, contentRange] (if returnsJWT - then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" - else cs $ encode body) + then "{\"token\":\"" <> toS (tokenJWT jwtSecret body) <> "\"}" + else toS $ encode body) (ActionRead, TargetRoot, Nothing) -> do let encodeApi ti = encodeOpenAPI ti uri' host = configHost conf port = toInteger $ configPort conf - proxy = pickProxy $ configProxyUri conf + proxy = pickProxy $ toS <$> configProxyUri conf uri Nothing = ("http", pack host, port, "/") uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) uri' = uri proxy encodeFn = if contentType == OpenAPI then encodeApi . toTableInfo else encode header = if contentType == OpenAPI then openapiH else jsonH body <- encodeFn <$> H.query schema accessibleTables - return $ responseLBS status200 [header] $ cs body + return $ responseLBS status200 [header] $ toS body (ActionInappropriate, _, _) -> return $ responseLBS status405 [] "" (_, _, Just (PayloadParseError e)) -> return $ responseLBS status400 [jsonH] $ - cs (formatGeneralError "Cannot parse request payload" (cs e)) + toS (formatGeneralError "Cannot parse request payload" (toS e)) (_, TargetUnknown _, _) -> return notFound @@ -242,7 +241,7 @@ app dbStructure conf apiRequest = filterCol _ _ _ = False allPrKeys = dbPrimaryKeys dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - schema = cs $ configSchema conf + schema = toS $ configSchema conf shouldCount = iPreferCount apiRequest topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (dbProcs dbStructure) apiRequest @@ -255,10 +254,10 @@ app dbStructure conf apiRequest = respondToRange response = if topLevelRange == emptyRange then return $ errResponse status416 "HTTP Range error" else response - rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange - to = frm + toInteger queryTotal - 1 - contentRange = contentRangeH frm to (toInteger <$> tableTotal) - status = rangeStatus frm to (toInteger <$> tableTotal) + rangeHeader queryTotal tableTotal = let lower = rangeOffset topLevelRange + upper = lower + toInteger queryTotal - 1 + contentRange = contentRangeH lower upper (toInteger <$> tableTotal) + status = rangeStatus lower upper (toInteger <$> tableTotal) in (status, contentRange) splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) @@ -271,22 +270,22 @@ renderLocationFields fields = rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200 -rangeStatus frm to (Just total) - | frm > total = status416 - | (1 + to - frm) < total = status206 +rangeStatus lower upper (Just total) + | lower > total = status416 + | (1 + upper - lower) < total = status206 | otherwise = status200 contentRangeH :: Integer -> Integer -> Maybe Integer -> Header -contentRangeH frm to total = - ("Content-Range", cs headerValue) +contentRangeH lower upper total = + ("Content-Range", headerValue) where headerValue = rangeString <> "/" <> totalString rangeString - | totalNotZero && fromInRange = show frm <> "-" <> cs (show to) + | totalNotZero && fromInRange = show lower <> "-" <> show upper | otherwise = "*" totalString = fromMaybe "*" (show <$> total) totalNotZero = fromMaybe True ((/=) 0 <$> total) - fromInRange = frm <= to + fromInRange = lower <= upper jsonH :: Header jsonH = (hContentType, "application/json; charset=utf-8") @@ -301,12 +300,12 @@ formatRelationError = formatGeneralError formatParserError :: ParseError -> Text formatParserError e = formatGeneralError message details where - message = cs $ show (errorPos e) - details = strip $ replace "\n" " " $ cs + message = show $ errorPos e + details = strip $ replace "\n" " " $ toS $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) formatGeneralError :: Text -> Text -> Text -formatGeneralError message details = cs $ encode $ object [ +formatGeneralError message details = toS $ encode $ object [ "message" .= message, "details" .= details] diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 92ae84fa4..a93c11802 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -29,21 +29,21 @@ pgErrResponse authed e = instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [ - "code" .= ("" :: T.Text), - "message" .= ("Connection error" :: T.Text), - "details" .= (toS $ fromMaybe "" e :: T.Text)] + "code" .= ("" :: Text), + "message" .= ("Connection error" :: Text), + "details" .= (toS $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error instance JSON.ToJSON H.Error where toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [ - "code" .= (toS c::T.Text), - "message" .= (toS m::T.Text), - "details" .= (fmap toS d::Maybe T.Text), - "hint" .= (fmap toS h::Maybe T.Text)] + "code" .= (toS c::Text), + "message" .= (toS m::Text), + "details" .= (fmap toS d::Maybe Text), + "hint" .= (fmap toS h::Maybe Text)] toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [ - "message" .= (m::T.Text)] + "message" .= (m::Text)] toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [ - "message" .= ("Row error: end of input"::T.Text), + "message" .= ("Row error: end of input"::Text), "details" .= ("Attempt to parse more columns than there are in the result"::Text), "details" .= (("Row number " <> show i)::Text)] @@ -60,7 +60,7 @@ instance JSON.ToJSON H.Error where "details" .= i] toJSON (H.ClientError d) = JSON.object [ "message" .= ("Database client error"::Text), - "details" .= (fmap toS d::Maybe T.Text)] + "details" .= (fmap toS d::Maybe Text)] httpStatus :: Bool -> P.UsageError -> HT.Status httpStatus _ (P.ConnectionError _) = HT.status500 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 6682fdb35..be05a601d 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -6,8 +6,6 @@ module PostgREST.Middleware where import Data.Aeson (Value (..)) import qualified Data.HashMap.Strict as M import Data.String.Conversions (cs) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Text import qualified Hasql.Transaction as H import Network.HTTP.Types.Header (hAccept) @@ -22,8 +20,10 @@ import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), import PostgREST.Auth (claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) +import Data.Text +import Data.List (lookup) -import Prelude hiding (concat, null) +import Protolude hiding (concat, null) runWithClaims :: AppConfig -> Either Text (M.HashMap Text Value) -> (ApiRequest -> H.Transaction Response) -> diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index cd7136a78..acf191f1a 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -8,16 +8,15 @@ module PostgREST.OpenAPI ( import Control.Lens import Data.Aeson (decode, encode) -import Data.ByteString.Lazy (ByteString) import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) -import Data.Maybe (isJust, isNothing, fromJust) +import Data.Maybe (fromJust) import Data.String (IsString (..)) -import Data.Text (Text, unpack, pack, concat, intercalate, init, tail, toLower) +import Data.Text (unpack, pack, concat, intercalate, init, tail, toLower) import qualified Data.Set as Set import Network.URI (parseURI, isAbsoluteURI, URI (..), URIAuth (..)) -import Prelude hiding (concat, init, tail) +import Protolude hiding (concat, (&), Proxy, get, intercalate) import Data.Swagger @@ -244,7 +243,7 @@ postgrestSpec ti (s, h, p, b) = (mempty :: Swagger) s' = if s == "http" then Http else Https h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p)) -encodeOpenAPI :: [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> ByteString +encodeOpenAPI :: [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString encodeOpenAPI ti uri = encode $ postgrestSpec ti uri {-| @@ -256,16 +255,16 @@ encodeOpenAPI ti uri = encode $ postgrestSpec ti uri http://postgrest.com/openapi.json https://postgrest.com:8080/openapi.json -} -isMalformedProxyUri :: Maybe String -> Bool +isMalformedProxyUri :: Maybe Text -> Bool isMalformedProxyUri Nothing = False isMalformedProxyUri (Just uri) - | isAbsoluteURI uri = not $ isUriValid $ toURI uri + | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri | otherwise = True -toURI :: String -> URI -toURI uri = fromJust $ parseURI uri +toURI :: Text -> URI +toURI uri = fromJust $ parseURI (toS uri) -pickProxy :: Maybe String -> Maybe Proxy +pickProxy :: Maybe Text -> Maybe Proxy pickProxy proxy | isNothing proxy = Nothing -- should never happen @@ -287,11 +286,12 @@ pickProxy proxy authority = fromJust $ uriAuthority uri host' = pack $ uriRegName authority port' = uriPort authority + readPort = fromMaybe 80 . readMaybe port'' :: Integer port'' = case (port', scheme) of ("", "http") -> 80 ("", "https") -> 443 - _ -> read $ unpack $ tail $ pack port' + _ -> readPort $ unpack $ tail $ pack port' isUriValid:: URI -> Bool isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] @@ -325,6 +325,7 @@ isHostValid _ = True isPortValid :: URIAuth -> Bool isPortValid URIAuth {uriPort = ""} = True isPortValid URIAuth {uriPort = (':':p)} = - let i :: Integer = read p in - i > 0 && i < 65536 + case readMaybe p of + Just i -> i > (0 :: Integer) && i < 65536 + Nothing -> False isPortValid _ = False diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index f14fb04a2..ef85e8da1 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -17,13 +17,11 @@ import qualified Data.ByteString.Char8 as BS import Data.Ranged.Boundaries import Data.Ranged.Ranges -import Data.String.Conversions (cs) -import Text.Read (readMaybe) import Text.Regex.TDFA ((=~)) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.List (lookup) -import Prelude +import Protolude type NonnegRange = Range Integer @@ -33,9 +31,9 @@ rangeParse range = do case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of Just parsedRange -> - let [_, from, to] = readMaybe . cs <$> parsedRange - lower = fromMaybe emptyRange (rangeGeq <$> from) - upper = fromMaybe allRange (rangeLeq <$> to) in + let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange + lower = fromMaybe emptyRange (rangeGeq <$> mLower) + upper = fromMaybe allRange (rangeLeq <$> mUpper) in rangeIntersection lower upper Nothing -> allRange @@ -52,14 +50,14 @@ restrictRange (Just limit) r = rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range = case [rangeLower range, rangeUpper range] of - [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) + [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower) _ -> Nothing rangeOffset :: NonnegRange -> Integer rangeOffset range = case rangeLower range of - BoundaryBelow from -> from - _ -> error "range without lower bound" -- should never happen + BoundaryBelow lower -> lower + _ -> panic "range without lower bound" -- should never happen rangeGeq :: Integer -> NonnegRange rangeGeq n =