refactor: Remove Protolude.Conv from App

This commit is contained in:
monacoremo
2021-11-12 20:25:22 +01:00
committed by Remo
parent abb6167caa
commit 4104f5fb75
4 changed files with 23 additions and 22 deletions
+14 -15
View File
@@ -85,8 +85,7 @@ import PostgREST.Workers (connectionWorker, listener)
import qualified PostgREST.ContentType as ContentType import qualified PostgREST.ContentType as ContentType
import qualified PostgREST.DbStructure.Proc as Proc import qualified PostgREST.DbStructure.Proc as Proc
import Protolude hiding (Handler, toS) import Protolude hiding (Handler)
import Protolude.Conv (toS)
data RequestContext = RequestContext data RequestContext = RequestContext
@@ -134,7 +133,7 @@ serverSettings AppConfig{..} =
defaultSettings defaultSettings
& setHost (fromString $ toS configServerHost) & setHost (fromString $ toS configServerHost)
& setPort configServerPort & setPort configServerPort
& setServerName (toS $ "postgrest/" <> prettyVersion) & setServerName ("postgrest/" <> prettyVersion)
-- | PostgREST application -- | PostgREST application
postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
@@ -191,7 +190,7 @@ postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do
ApiRequest.userApiRequest conf dbStructure req body ApiRequest.userApiRequest conf dbStructure req body
-- The JWT must be checked before touching the db -- The JWT must be checked before touching the db
jwtClaims <- Auth.jwtClaims conf (toS iJWT) time jwtClaims <- Auth.jwtClaims conf (toUtf8Lazy iJWT) time
let let
handleReq apiReq = handleReq apiReq =
@@ -271,14 +270,14 @@ handleRead headersOnly identifier context@RequestContext{..} = do
[ contentRange [ contentRange
, ( "Content-Location" , ( "Content-Location"
, "/" , "/"
<> toS (qiName identifier) <> toUtf8 (qiName identifier)
<> if BS.null iCanonicalQS then mempty else "?" <> toS iCanonicalQS <> if BS.null iCanonicalQS then mempty else "?" <> iCanonicalQS
) )
] ]
++ contentTypeHeaders context ++ contentTypeHeaders context
failNotSingular iAcceptContentType queryTotal . response status headers $ failNotSingular iAcceptContentType queryTotal . response status headers $
if headersOnly then mempty else toS body if headersOnly then mempty else LBS.fromStrict body
readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64) readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)
readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery = readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery =
@@ -315,7 +314,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
Just Just
( HTTP.hLocation ( HTTP.hLocation
, "/" , "/"
<> toS qiName <> toUtf8 qiName
<> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields) <> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields)
) )
, Just . RangeQuery.contentRangeH 1 0 $ , Just . RangeQuery.contentRangeH 1 0 $
@@ -328,7 +327,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
failNotSingular iAcceptContentType resQueryTotal $ failNotSingular iAcceptContentType resQueryTotal $
if iPreferRepresentation == Full then if iPreferRepresentation == Full then
response HTTP.status201 (headers ++ contentTypeHeaders context) (toS resBody) response HTTP.status201 (headers ++ contentTypeHeaders context) (LBS.fromStrict resBody)
else else
response HTTP.status201 headers mempty response HTTP.status201 headers mempty
@@ -350,7 +349,7 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
failNotSingular iAcceptContentType resQueryTotal $ failNotSingular iAcceptContentType resQueryTotal $
if fullRepr then if fullRepr then
response status (contentTypeHeaders context ++ [contentRangeHeader]) (toS resBody) response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict resBody)
else else
response status [contentRangeHeader] mempty response status [contentRangeHeader] mempty
@@ -374,7 +373,7 @@ handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
return $ return $
if iPreferRepresentation == Full then if iPreferRepresentation == Full then
response HTTP.status200 (contentTypeHeaders context) (toS resBody) response HTTP.status200 (contentTypeHeaders context) (LBS.fromStrict resBody)
else else
response HTTP.status204 (contentTypeHeaders context) mempty response HTTP.status204 (contentTypeHeaders context) mempty
@@ -392,7 +391,7 @@ handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do
if iPreferRepresentation == Full then if iPreferRepresentation == Full then
response HTTP.status200 response HTTP.status200
(contentTypeHeaders context ++ [contentRangeHeader]) (contentTypeHeaders context ++ [contentRangeHeader])
(toS resBody) (LBS.fromStrict resBody)
else else
response HTTP.status204 [contentRangeHeader] mempty response HTTP.status204 [contentRangeHeader] mempty
@@ -460,7 +459,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
failNotSingular iAcceptContentType queryTotal $ failNotSingular iAcceptContentType queryTotal $
response status response status
(contentTypeHeaders context ++ [contentRange]) (contentTypeHeaders context ++ [contentRange])
(if invMethod == InvHead then mempty else toS body) (if invMethod == InvHead then mempty else LBS.fromStrict body)
handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do
@@ -482,7 +481,7 @@ handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure
return $ return $
Wai.responseLBS HTTP.status200 Wai.responseLBS HTTP.status200
(ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest)) (ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
(if headersOnly then mempty else toS body) (if headersOnly then mempty else body)
txMode :: ApiRequest -> SQL.Mode txMode :: ApiRequest -> SQL.Mode
txMode ApiRequest{..} = txMode ApiRequest{..} =
@@ -606,7 +605,7 @@ rawContentTypes AppConfig{..} =
profileHeader :: ApiRequest -> Maybe HTTP.Header profileHeader :: ApiRequest -> Maybe HTTP.Header
profileHeader ApiRequest{..} = profileHeader ApiRequest{..} =
(,) "Content-Profile" <$> (toS <$> iProfile) (,) "Content-Profile" <$> (toUtf8 <$> iProfile)
splitKeyValue :: ByteString -> (ByteString, ByteString) splitKeyValue :: ByteString -> (ByteString, ByteString)
splitKeyValue kv = splitKeyValue kv =
+2 -2
View File
@@ -30,8 +30,8 @@ import qualified Crypto.JOSE.Types as JOSE
import qualified Crypto.JWT as JWT import qualified Crypto.JWT as JWT
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Configurator as C import qualified Data.Configurator as C
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
@@ -59,7 +59,7 @@ import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, dumpQi,
toQi) toQi)
import PostgREST.Request.Types (JoinType (..)) import PostgREST.Request.Types (JoinType (..))
import Protolude hiding (Proxy, toList) import Protolude hiding (Proxy, toList)
data AppConfig = AppConfig data AppConfig = AppConfig
+2 -1
View File
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import qualified Data.HashSet.InsOrd as Set import qualified Data.HashSet.InsOrd as Set
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
@@ -324,7 +325,7 @@ postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
& basePath ?~ T.unpack b & basePath ?~ T.unpack b
& schemes ?~ [s'] & schemes ?~ [s']
& info .~ ((mempty :: Info) & info .~ ((mempty :: Info)
& version .~ prettyVersion & version .~ T.decodeUtf8 prettyVersion
& title .~ "PostgREST API" & title .~ "PostgREST API"
& description ?~ d) & description ?~ d)
& externalDocs ?~ ((mempty :: ExternalDocs) & externalDocs ?~ ((mempty :: ExternalDocs)
+5 -4
View File
@@ -4,7 +4,8 @@ module PostgREST.Version
, prettyVersion , prettyVersion
) where ) where
import qualified Data.Text as T import qualified Data.ByteString as BS
import qualified Data.Text as T
import Data.Version (showVersion, versionBranch) import Data.Version (showVersion, versionBranch)
import Development.GitRev (gitHash) import Development.GitRev (gitHash)
@@ -16,15 +17,15 @@ import Protolude
-- | User friendly version number such as '1.1.1'. -- | User friendly version number such as '1.1.1'.
-- Pre-release versions are tagged as such, e.g., '1.1.1.1 (pre-release)'. -- Pre-release versions are tagged as such, e.g., '1.1.1.1 (pre-release)'.
-- If a git hash is available, it's added to the version, e.g., '1.1.1 (abcdef0)'. -- If a git hash is available, it's added to the version, e.g., '1.1.1 (abcdef0)'.
prettyVersion :: Text prettyVersion :: ByteString
prettyVersion = prettyVersion =
T.pack (showVersion version) <> preRelease <> gitRev toUtf8 (showVersion version) <> preRelease <> gitRev
where where
gitRev = gitRev =
if $(gitHash) == ("UNKNOWN" :: Text) then if $(gitHash) == ("UNKNOWN" :: Text) then
mempty mempty
else else
" (" <> T.take 7 $(gitHash) <> ")" " (" <> BS.take 7 $(gitHash) <> ")"
preRelease = if isPreRelease then " (pre-release)" else mempty preRelease = if isPreRelease then " (pre-release)" else mempty