{-# LANGUAGE ScopedTypeVariables #-}

module Database.Persist.Sql.Util
    ( parseEntityValues
    , keyAndEntityColumnNames
    , entityColumnCount
    , isIdField
    , hasNaturalKey
    , hasCompositePrimaryKey
    , dbIdColumns
    , dbIdColumnsEsc
    , dbColumns
    , updateFieldDef
    , updatePersistValue
    , mkUpdateText
    , mkUpdateText'
    , commaSeparated
    , parenWrapped
    , mkInsertValues
    , mkInsertPlaceholders
    , parseExistsResult
    ) where

import Data.ByteString.Char8 (readInteger)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Maybe as Maybe
import Data.Text (Text, pack)
import qualified Data.Text as T

import Database.Persist
       ( Entity(Entity)
       , EntityDef
       , EntityField
       , FieldDef(..)
       , FieldNameDB
       , FieldNameHS(FieldNameHS)
       , PersistEntity(..)
       , PersistUpdate(..)
       , PersistValue(..)
       , Update(..)
       , compositeFields
       , entityPrimary
       , fieldDB
       , fieldHaskell
       , fromPersistValues
       , getEntityFields
       , getEntityKeyFields
       , keyAndEntityFields
       , keyFromValues
       , persistFieldDef
       , toPersistValue
       )

import Database.Persist.SqlBackend.Internal (SqlBackend(..))

keyAndEntityColumnNames :: EntityDef -> SqlBackend -> NonEmpty Text
keyAndEntityColumnNames :: EntityDef -> SqlBackend -> NonEmpty Text
keyAndEntityColumnNames EntityDef
ent SqlBackend
conn =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) (EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent)

entityColumnCount :: EntityDef -> Int
entityColumnCount :: EntityDef -> Int
entityColumnCount EntityDef
e = forall (t :: * -> *) a. Foldable t => t a -> Int
length (EntityDef -> [FieldDef]
getEntityFields EntityDef
e)
                    forall a. Num a => a -> a -> a
+ if EntityDef -> Bool
hasNaturalKey EntityDef
e then Int
0 else Int
1

-- | Returns 'True' if the entity has a natural key defined with the
-- Primary keyword.
--
-- A natural key is a key that is inherent to the record, and is part of
-- the actual Haskell record. The opposite of a natural key is a "surrogate
-- key", which is not part of the normal domain object. Automatically
-- generated ID columns are the most common surrogate ID, while an email
-- address is a common natural key.
--
-- @
-- User
--     email String
--     name String
--     Primary email
--
-- Person
--     Id   UUID
--     name String
--
-- Follower
--     name String
-- @
--
-- Given these entity definitions, @User@ would return 'True', because the
-- @Primary@ keyword sets the @email@ column to be the primary key. The
-- generated Haskell type would look like this:
--
-- @
-- data User = User
--     { userEmail :: String
--     , userName :: String
--     }
-- @
--
-- @Person@ would be false. While the @Id@ syntax allows you to define
-- a custom ID type for an entity, the @Id@ column is a surrogate key.
--
-- The same is true for @Follower@. The automatically generated
-- autoincremented integer primary key is a surrogate key.
--
-- There's nothing preventing you from defining a @Primary@ definition that
-- refers to a surrogate key. This is totally fine.
--
-- @since 2.11.0
hasNaturalKey :: EntityDef -> Bool
hasNaturalKey :: EntityDef -> Bool
hasNaturalKey =
    forall a. Maybe a -> Bool
Maybe.isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> Maybe CompositeDef
entityPrimary

-- | Returns 'True' if the provided entity has a custom composite primary
-- key. Composite keys have multiple fields in them.
--
-- @
-- User
--     email String
--     name String
--     Primary userId
--
-- Profile
--     personId PersonId
--     email    String
--     Primary personId email
--
-- Person
--     Id   UUID
--     name String
--
-- Follower
--     name String
-- @
--
-- Given these entity definitions, only @Profile@ would return 'True',
-- because it is the only entity with multiple columns in the primary key.
-- @User@ has a single column natural key. @Person@ has a custom single
-- column surrogate key defined with @Id@. And @Follower@ has a default
-- single column surrogate key.
--
-- @since 2.11.0
hasCompositePrimaryKey :: EntityDef -> Bool
hasCompositePrimaryKey :: EntityDef -> Bool
hasCompositePrimaryKey EntityDef
ed =
    case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
ed of
        Just CompositeDef
cdef ->
            case CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
cdef of
                (FieldDef
_ :| FieldDef
_ : [FieldDef]
_) ->
                    Bool
True
                NonEmpty FieldDef
_ ->
                    Bool
False
        Maybe CompositeDef
Nothing ->
            Bool
False

dbIdColumns :: SqlBackend -> EntityDef -> NonEmpty Text
dbIdColumns :: SqlBackend -> EntityDef -> NonEmpty Text
dbIdColumns SqlBackend
conn = (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
dbIdColumnsEsc (SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn)

dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text
dbIdColumnsEsc FieldNameDB -> Text
esc EntityDef
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameDB -> Text
esc forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) forall a b. (a -> b) -> a -> b
$ EntityDef -> NonEmpty FieldDef
getEntityKeyFields EntityDef
t

dbColumns :: SqlBackend -> EntityDef -> NonEmpty Text
dbColumns :: SqlBackend -> EntityDef -> NonEmpty Text
dbColumns SqlBackend
conn =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> Text
escapeColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> NonEmpty FieldDef
keyAndEntityFields
  where
    escapeColumn :: FieldDef -> Text
escapeColumn = SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB

parseEntityValues :: PersistEntity record
                  => EntityDef -> [PersistValue] -> Either Text (Entity record)
parseEntityValues :: forall record.
PersistEntity record =>
EntityDef -> [PersistValue] -> Either Text (Entity record)
parseEntityValues EntityDef
t [PersistValue]
vals =
    case EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
t of
      Just CompositeDef
pdef ->
            let pks :: NonEmpty FieldNameHS
pks = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameHS
fieldHaskell forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
                keyvals :: [PersistValue]
keyvals = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty FieldNameHS
pks) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                        forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldNameHS
fieldHaskell forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields EntityDef
t) [PersistValue]
vals
            in forall {record}.
PersistEntity record =>
[PersistValue] -> [PersistValue] -> Either Text (Entity record)
fromPersistValuesComposite' [PersistValue]
keyvals [PersistValue]
vals
      Maybe CompositeDef
Nothing -> forall {record}.
PersistEntity record =>
[PersistValue] -> Either Text (Entity record)
fromPersistValues' [PersistValue]
vals
  where
    fromPersistValues' :: [PersistValue] -> Either Text (Entity record)
fromPersistValues' (PersistValue
kpv:[PersistValue]
xs) = -- oracle returns Double
        case forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues [PersistValue]
xs of
            Left Text
e -> forall a b. a -> Either a b
Left Text
e
            Right record
xs' ->
                case forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
kpv] of
                    Left Text
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"fromPersistValues': keyFromValues failed on " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PersistValue
kpv
                    Right Key record
k -> forall a b. b -> Either a b
Right (forall record. Key record -> record -> Entity record
Entity Key record
k record
xs')


    fromPersistValues' [PersistValue]
xs = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char]
"error in fromPersistValues' xs=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
xs)

    fromPersistValuesComposite' :: [PersistValue] -> [PersistValue] -> Either Text (Entity record)
fromPersistValuesComposite' [PersistValue]
keyvals [PersistValue]
xs =
        case forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues [PersistValue]
xs of
            Left Text
e -> forall a b. a -> Either a b
Left Text
e
            Right record
xs' -> case forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue]
keyvals of
                Left Text
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"fromPersistValuesComposite': keyFromValues failed with error: "
                    forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
                Right Key record
key -> forall a b. b -> Either a b
Right (forall record. Key record -> record -> Entity record
Entity Key record
key record
xs')


isIdField
    :: forall record typ. (PersistEntity record)
    => EntityField record typ
    -> Bool
isIdField :: forall record typ.
PersistEntity record =>
EntityField record typ -> Bool
isIdField EntityField record typ
f = FieldDef -> FieldNameHS
fieldHaskell (forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
f) forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id"

-- | Gets the 'FieldDef' for an 'Update'.
updateFieldDef :: PersistEntity v => Update v -> FieldDef
updateFieldDef :: forall v. PersistEntity v => Update v -> FieldDef
updateFieldDef (Update EntityField v typ
f typ
_ PersistUpdate
_) = forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField v typ
f
updateFieldDef BackendUpdate {} = forall a. HasCallStack => [Char] -> a
error [Char]
"updateFieldDef: did not expect BackendUpdate"

updatePersistValue :: Update v -> PersistValue
updatePersistValue :: forall v. Update v -> PersistValue
updatePersistValue (Update EntityField v typ
_ typ
v PersistUpdate
_) = forall a. PersistField a => a -> PersistValue
toPersistValue typ
v
updatePersistValue (BackendUpdate{}) =
    forall a. HasCallStack => [Char] -> a
error [Char]
"updatePersistValue: did not expect BackendUpdate"

commaSeparated :: [Text] -> Text
commaSeparated :: [Text] -> Text
commaSeparated = Text -> [Text] -> Text
T.intercalate Text
", "

mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text
mkUpdateText :: forall record.
PersistEntity record =>
SqlBackend -> Update record -> Text
mkUpdateText SqlBackend
conn = forall record.
PersistEntity record =>
(FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' (SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn) forall a. a -> a
id

-- TODO: incorporate the table names into a sum type
mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' :: forall record.
PersistEntity record =>
(FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' FieldNameDB -> Text
escapeName Text -> Text
refColumn Update record
x =
  case forall record. Update record -> PersistUpdate
updateUpdate Update record
x of
    PersistUpdate
Assign -> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"=?"
    PersistUpdate
Add -> [Text] -> Text
T.concat [Text
n, Text
"=", Text -> Text
refColumn Text
n, Text
"+?"]
    PersistUpdate
Subtract -> [Text] -> Text
T.concat [Text
n, Text
"=", Text -> Text
refColumn Text
n, Text
"-?"]
    PersistUpdate
Multiply -> [Text] -> Text
T.concat [Text
n, Text
"=", Text -> Text
refColumn Text
n, Text
"*?"]
    PersistUpdate
Divide -> [Text] -> Text
T.concat [Text
n, Text
"=", Text -> Text
refColumn Text
n, Text
"/?"]
    BackendSpecificUpdate Text
up ->
      forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"mkUpdateText: BackendSpecificUpdate " forall a. Semigroup a => a -> a -> a
<> Text
up forall a. Semigroup a => a -> a -> a
<> Text
" not supported"
  where
    n :: Text
n = FieldNameDB -> Text
escapeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. PersistEntity v => Update v -> FieldDef
updateFieldDef forall a b. (a -> b) -> a -> b
$ Update record
x

parenWrapped :: Text -> Text
parenWrapped :: Text -> Text
parenWrapped Text
t = [Text] -> Text
T.concat [Text
"(", Text
t, Text
")"]

-- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely
-- with the function 'mkInsertPlaceholders'.
--
-- Does not include generated columns.
--
-- @since 2.11.0.0
mkInsertValues
    :: PersistEntity rec
    => rec
    -> [PersistValue]
mkInsertValues :: forall rec. PersistEntity rec => rec -> [PersistValue]
mkInsertValues rec
entity =
    forall a. [Maybe a] -> [a]
Maybe.catMaybes
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. FieldDef -> a -> Maybe a
redactGeneratedCol (EntityDef -> [FieldDef]
getEntityFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just rec
entity)
        forall a b. (a -> b) -> a -> b
$ forall rec. PersistEntity rec => rec -> [PersistValue]
toPersistFields rec
entity
  where
    redactGeneratedCol :: FieldDef -> a -> Maybe a
redactGeneratedCol FieldDef
fd a
pv = case FieldDef -> Maybe Text
fieldGenerated FieldDef
fd of
        Maybe Text
Nothing ->
            forall a. a -> Maybe a
Just a
pv
        Just Text
_ ->
            forall a. Maybe a
Nothing

-- | Returns a list of escaped field names and @"?"@ placeholder values for
-- performing inserts. This does not include generated columns.
--
-- Does not include generated columns.
--
-- @since 2.11.0.0
mkInsertPlaceholders
    :: EntityDef
    -> (FieldNameDB -> Text)
    -- ^ An `escape` function
    -> [(Text, Text)]
mkInsertPlaceholders :: EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
mkInsertPlaceholders EntityDef
ed FieldNameDB -> Text
escape =
    forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe FieldDef -> Maybe (Text, Text)
redactGeneratedCol (EntityDef -> [FieldDef]
getEntityFields EntityDef
ed)
  where
    redactGeneratedCol :: FieldDef -> Maybe (Text, Text)
redactGeneratedCol FieldDef
fd = case FieldDef -> Maybe Text
fieldGenerated FieldDef
fd of
        Maybe Text
Nothing ->
            forall a. a -> Maybe a
Just (FieldNameDB -> Text
escape (FieldDef -> FieldNameDB
fieldDB FieldDef
fd), Text
"?")
        Just Text
_ ->
            forall a. Maybe a
Nothing

parseExistsResult :: Maybe [PersistValue] -> Text -> String -> Bool
parseExistsResult :: Maybe [PersistValue] -> Text -> [Char] -> Bool
parseExistsResult Maybe [PersistValue]
mm Text
sql [Char]
errloc =
    case Maybe [PersistValue]
mm of
        Just [PersistBool Bool
b]  -> Bool
b -- Postgres
        Just [PersistInt64 Int64
i] -> Int64
i forall a. Ord a => a -> a -> Bool
> Int64
0 -- MySQL, SQLite
        Just [PersistDouble Double
i] -> (forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
i :: Int64) forall a. Ord a => a -> a -> Bool
> Int64
0 -- gb oracle
        Just [PersistByteString ByteString
i] -> case ByteString -> Maybe (Integer, ByteString)
readInteger ByteString
i of -- gb mssql
                                        Just (Integer
ret,ByteString
"") -> Integer
ret forall a. Ord a => a -> a -> Bool
> Integer
0
                                        Maybe (Integer, ByteString)
xs -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"invalid number i["forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show ByteString
iforall a. [a] -> [a] -> [a]
++[Char]
"] xs[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Maybe (Integer, ByteString)
xs forall a. [a] -> [a] -> [a]
++ [Char]
"]"
        Just [PersistValue]
xs -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errloc forall a. [a] -> [a] -> [a]
++ [Char]
": Expected a boolean, int, double, or bytestring; got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [PersistValue]
xs forall a. [a] -> [a] -> [a]
++ [Char]
" for query: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
sql
        Maybe [PersistValue]
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
errloc forall a. [a] -> [a] -> [a]
++ [Char]
": Expected a boolean, int, double, or bytestring; got: Nothing for query: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
sql