Controller.hs

{-# LANGUAGE UndecidableInstances #-}
module IHP.DataSync.REST.Controller where

import IHP.ControllerPrelude hiding (OrderByClause)
import IHP.DataSync.REST.Types
import Data.Aeson
import qualified Database.PostgreSQL.Simple.ToField as PG
import qualified Database.PostgreSQL.Simple.Types as PG
import qualified Database.PostgreSQL.Simple as PG
import qualified Data.Vector as Vector
import qualified Data.ByteString.Char8 as ByteString
import qualified Control.Exception.Safe as Exception
import IHP.DataSync.RowLevelSecurity
import IHP.DataSync.DynamicQuery
import IHP.DataSync.Types
import Network.HTTP.Types (status400)
import IHP.DataSync.DynamicQueryCompiler
import qualified Data.Text as Text
import qualified Data.Scientific as Scientific

import qualified Data.ByteString.Builder as ByteString
import qualified Data.Aeson.Encoding.Internal as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import qualified Data.Aeson.Key as Aeson


instance (
    PG.ToField (PrimaryKey (GetTableName CurrentUserRecord))
    , Show (PrimaryKey (GetTableName CurrentUserRecord))
    , HasNewSessionUrl CurrentUserRecord
    , Typeable CurrentUserRecord
    , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
    ) => Controller ApiController where
    action CreateRecordAction { table } = do
        ensureRLSEnabled table

        let payload = requestBodyJSON

        case payload of
            Object hashMap -> do
                let query = "INSERT INTO ? ? VALUES ? RETURNING *"
                let columns = hashMap
                        |> Aeson.keys
                        |> map (fieldNameToColumnName . Aeson.toText)

                let values = hashMap
                        |> Aeson.elems
                        |> map aesonValueToPostgresValue

                let params = (PG.Identifier table, PG.In (map PG.Identifier columns), PG.In values)

                result :: Either EnhancedSqlError [[Field]] <- Exception.try do
                    sqlQueryWithRLS query params

                case result of
                    Left error -> renderErrorJson error
                    Right result -> renderJson result

            Array objects -> do
                let query = "INSERT INTO ? ? ? RETURNING *"
                let columns = objects
                        |> Vector.toList
                        |> head
                        |> \case
                            Just value -> value
                            Nothing -> error "Atleast one record is required"
                        |> \case
                            Object hashMap -> hashMap
                            otherwise -> error "Expected object"
                        |> Aeson.keys
                        |> map (fieldNameToColumnName . Aeson.toText)

                let values = objects
                        |> Vector.toList
                        |> map (\object ->
                                object
                                |> \case
                                    Object hashMap -> hashMap
                                    otherwise -> error "Expected object"
                                |> Aeson.elems
                                |> map aesonValueToPostgresValue
                            )


                let params = (PG.Identifier table, PG.In (map PG.Identifier columns), PG.Values [] values)

                result :: [[Field]] <- sqlQueryWithRLS query params
                renderJson result



    action UpdateRecordAction { table, id } = do
        ensureRLSEnabled table

        let payload = requestBodyJSON
                |> \case
                    Object hashMap -> hashMap

        let columns = payload
                |> Aeson.keys
                |> map (fieldNameToColumnName . Aeson.toText)
                |> map PG.Identifier

        let values = payload
                |> Aeson.elems
                |> map aesonValueToPostgresValue

        let keyValues = zip columns values

        let setCalls = keyValues
                |> map (\_ -> "? = ?")
                |> ByteString.intercalate ", "
        let query = "UPDATE ? SET " <> setCalls <> " WHERE id = ? RETURNING *"

        let params = [PG.toField (PG.Identifier table)]
                <> (join (map (\(key, value) -> [PG.toField key, value]) keyValues))
                <> [PG.toField id]

        result :: [[Field]] <- sqlQueryWithRLS (PG.Query query) params

        renderJson (head result)

    -- DELETE /api/:table/:id
    action DeleteRecordAction { table, id } = do
        ensureRLSEnabled table

        sqlExecWithRLS "DELETE FROM ? WHERE id = ?" (PG.Identifier table, id)

        renderJson True

    -- GET /api/:table/:id
    action ShowRecordAction { table, id } = do
        ensureRLSEnabled table

        result :: [[Field]] <- sqlQueryWithRLS "SELECT * FROM ? WHERE id = ?" (PG.Identifier table, id)

        renderJson (head result)

    -- GET /api/:table
    -- GET /api/:table?orderBy=createdAt
    -- GET /api/:table?fields=id,title
    action ListRecordsAction { table } = do
        ensureRLSEnabled table

        let (theQuery, theParams) = compileQuery (buildDynamicQueryFromRequest table)
        result :: [[Field]] <- sqlQueryWithRLS theQuery theParams

        renderJson result

buildDynamicQueryFromRequest table = DynamicSQLQuery
    { table
    , selectedColumns = paramOrDefault SelectAll "fields"
    , whereCondition = Nothing
    , orderByClause = paramList "orderBy"
    , distinctOnColumn = paramOrNothing "distinctOnColumn"
    , limit = paramOrNothing "limit"
    , offset = paramOrNothing "offset"
    }

instance ParamReader SelectedColumns where
    readParameter byteString = pure $
        byteString
            |> cs
            |> Text.split (\char -> char == ',')
            |> SelectSpecific

instance ParamReader OrderByClause where
    readParameter byteString = case ByteString.split ',' byteString of
            [orderByColumn, order] -> do
                orderByDirection <- parseOrder order
                pure OrderByClause { orderByColumn, orderByDirection }
            [orderByColumn] -> pure OrderByClause { orderByColumn, orderByDirection = Asc }
        where
            parseOrder "asc" = Right Asc
            parseOrder "desc" = Right Desc
            parseOrder otherwise = Left ("Invalid order " <> cs otherwise)

instance ToJSON PG.SqlError where
    toJSON PG.SqlError { sqlState, sqlErrorMsg, sqlErrorDetail, sqlErrorHint } = object
                [ "state" .= ((cs sqlState) :: Text)
                , "errorMsg" .= ((cs sqlErrorMsg) :: Text)
                , "errorDetail" .= ((cs sqlErrorDetail) :: Text)
                , "errorHint" .= ((cs sqlErrorHint) :: Text)
                ]
        where
            fieldValueToJSON (IntValue value) = toJSON value
            fieldValueToJSON (TextValue value) = toJSON value
            fieldValueToJSON (BoolValue value) = toJSON value
            fieldValueToJSON (UUIDValue value) = toJSON value
            fieldValueToJSON (DateTimeValue value) = toJSON value

instance ToJSON EnhancedSqlError where
    toJSON EnhancedSqlError { sqlError } = toJSON sqlError

renderErrorJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ()
renderErrorJson json = renderJsonWithStatusCode status400 json
{-# INLINABLE renderErrorJson #-}

aesonValueToPostgresValue :: Value -> PG.Action
aesonValueToPostgresValue (String text) = PG.toField text
aesonValueToPostgresValue (Bool value) = PG.toField value
aesonValueToPostgresValue (Number value) = case Scientific.floatingOrInteger value of -- Hacky, we should make this function "Schema.sql"-aware in the future
    Left (floating :: Double) -> PG.toField floating
    Right (integer :: Integer) -> PG.toField integer
aesonValueToPostgresValue Data.Aeson.Null = PG.toField PG.Null
aesonValueToPostgresValue (Data.Aeson.Array values) = PG.toField (PG.PGArray (map aesonValueToPostgresValue (Vector.toList values)))
aesonValueToPostgresValue object@(Object values) =
    let
        tryDecodeAsPoint :: Maybe Point
        tryDecodeAsPoint = do
                xValue <- Aeson.lookup "x" values
                yValue <- Aeson.lookup "y" values
                x <- case xValue of
                        Number number -> pure (Scientific.toRealFloat number)
                        otherwise -> Nothing
                y <- case yValue of
                        Number number -> pure (Scientific.toRealFloat number)
                        otherwise -> Nothing
                pure Point { x, y }
    in
        -- This is really hacky and is mostly duck typing. We should refactor this in the future to
        -- become more type aware by passing the DDL of the table to 'aesonValueToPostgresValue'.
        if Aeson.size values == 2
            then fromMaybe (PG.toField $ toJSON object) (PG.toField <$> tryDecodeAsPoint)
            else PG.toField (toJSON object)


instance ToJSON GraphQLResult where
    toJSON GraphQLResult { requestId, graphQLResult } = object [ "tag" .= ("GraphQLResult" :: Text), "requestId" .= requestId, "graphQLResult" .= ("" :: Text) ]
    toEncoding GraphQLResult { requestId, graphQLResult } = Aeson.econcat
        [ Aeson.unsafeToEncoding "{\"tag\":\"GraphQLResult\",\"requestId\":"
        , Aeson.int requestId
        , Aeson.unsafeToEncoding ",\"graphQLResult\":"
        , toEncoding graphQLResult
        , Aeson.unsafeToEncoding "}"
        ]
instance ToJSON UndecodedJSON where
    toJSON (UndecodedJSON _) = error "Not implemented"
    toEncoding (UndecodedJSON json) = Aeson.unsafeToEncoding (ByteString.byteString json)