refactor: Remove Protolude.Conv from App
This commit is contained in:
+14
-15
@@ -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 =
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user