diff --git a/postgrest.cabal b/postgrest.cabal index c0b2b81ac..e76a2e824 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -72,6 +72,7 @@ executable postgrest , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types library @@ -135,6 +136,7 @@ library , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types hs-source-dirs: src @@ -165,6 +167,7 @@ Test-Suite spec , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types , Spec , SpecHelper diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs new file mode 100644 index 000000000..58036c144 --- /dev/null +++ b/src/PostgREST/RequestIntent.hs @@ -0,0 +1,104 @@ +module PostgREST.RequestIntent where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.List (find) +import Data.Maybe (fromMaybe, isJust, isNothing, + listToMaybe) +import Network.Wai (Request (..)) +import Network.Wai.Parse (parseHttpAccept) +import PostgREST.RangeQuery (NonnegRange, rangeRequested) +import PostgREST.Types (QualifiedIdentifier (..), Schema) + +type RequestBody = BL.ByteString + +-- | Types of things a user wants to do to tables/views/procs +data Action = ActionCreate | ActionRead + | ActionUpdate | ActionDelete + | ActionInfo | ActionInvoke +-- | The target db object of a user action +data Target = TargetIdent QualifiedIdentifier + | TargetRoot +-- | Enumeration of currently supported content types for +-- route responses and upload payloads +data ContentType = ApplicationJSON | TextCSV +-- | When Hasql supports the COPY command then we can +-- have a special payload just for CSV, but until +-- then CSV is converted to a JSON array +data Payload = PayloadJSON JSON.Array + +-- | Describes what the user wants to do. This data type is a +-- translation of the raw elements of an HTTP request into domain +-- specific language. There is no guarantee that the intent is +-- sensible, it is up to a later stage of processing to determine +-- if it is an action we are able to perform. +data Intent = Intent { + -- | Set to Nothing for unknown HTTP verbs + iAction :: Maybe Action + -- | Set to Nothing for malformed range + , iRange :: Maybe NonnegRange + -- | Set to Nothing for strangely nested urls + , iTarget :: Maybe Target + -- | The content type the client most desires (or JSON if undecided) + , iAccepts :: Either BS.ByteString ContentType + -- | {foo} becomes [{foo}] and CSV is converted to JSON + , iPayload :: Maybe Payload + -- | Taken from JSON Web Token + , iTrustedClaims :: Maybe JSON.Object + -- | If client wants created items echoed back + , iPreferRepresentation :: Bool + -- | If client wants first row as raw object + , iPreferSingular :: Bool + } + +-- | Examines HTTP request and translates it into user intent. +userIntent :: Schema -> Request -> RequestBody -> Intent +userIntent schema req _ = + let action = case requestMethod req of + "GET" -> Just ActionRead + "POST" -> Just $ if isTargetingProc + then ActionInvoke + else ActionCreate + "PATCH" -> Just ActionUpdate + "DELETE" -> Just ActionDelete + "OPTIONS" -> Just ActionInfo + _ -> Nothing + target = case path of + [] -> Just TargetRoot + [table] -> Just $ TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> Just $ TargetIdent + $ QualifiedIdentifier schema proc + _ -> Nothing in + + Intent action + (rangeRequested hdrs) + target + (pickContentType $ lookupHeader "accept") + Nothing -- TODO: calculate payload + Nothing -- TODO: decode jwt + (hasPrefer "return=representation") + (hasPrefer "plurality=singular") + + where + path = pathInfo req + isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path + hdrs = requestHeaders req + lookupHeader = flip lookup hdrs + hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs + +-- | Chooses a payload from the items in an accept header. +-- When possible it picks JSON. +pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType +pickContentType accept + | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON + | has ctCsv = Right TextCSV + | otherwise = Left acceptH + where + ctAll = "*/*" + ctCsv = "text/csv" + ctJson = "application/json" + Just acceptH = accept + findInAccept = flip find $ parseHttpAccept acceptH + has = isJust . findInAccept . BS.isPrefixOf