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

Protolude second movement (#677)

Browse Source 
* Replace Prelude import for Protolude in middleware

* Remove qualifier from Text type

* Replace Prelude for Protolude, replace 'cs' for 'toS' calls, also change some name bindings

* Replace Prelude in main for Protolude. Replace error calls for panic calls. Also replace cs for toS

* Replace Prelude for Protolude

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