{-# LANGUAGE ScopedTypeVariables #-}
module Database.Persist.Sql.Util
( parseEntityValues
, keyAndEntityColumnNames
, entityColumnCount
, isIdField
, hasNaturalKey
, hasCompositePrimaryKey
, dbIdColumns
, dbIdColumnsEsc
, dbColumns
, updateFieldDef
, updatePersistValue
, mkUpdateText
, mkUpdateText'
, commaSeparated
, parenWrapped
, mkInsertValues
, mkInsertPlaceholders
) where
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 =
(FieldDef -> Text) -> NonEmpty FieldDef -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
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 = [FieldDef] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (EntityDef -> [FieldDef]
getEntityFields EntityDef
e)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if EntityDef -> Bool
hasNaturalKey EntityDef
e then Int
0 else Int
1
hasNaturalKey :: EntityDef -> Bool
hasNaturalKey :: EntityDef -> Bool
hasNaturalKey =
Maybe CompositeDef -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe CompositeDef -> Bool)
-> (EntityDef -> Maybe CompositeDef) -> EntityDef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> Maybe CompositeDef
entityPrimary
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 = (FieldDef -> Text) -> NonEmpty FieldDef -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldNameDB -> Text
esc (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB) (NonEmpty FieldDef -> NonEmpty Text)
-> NonEmpty FieldDef -> NonEmpty Text
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 =
(FieldDef -> Text) -> NonEmpty FieldDef -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> Text
escapeColumn (NonEmpty FieldDef -> NonEmpty Text)
-> (EntityDef -> NonEmpty FieldDef) -> EntityDef -> NonEmpty Text
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 (FieldNameDB -> Text)
-> (FieldDef -> FieldNameDB) -> FieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB
parseEntityValues :: PersistEntity record
=> EntityDef -> [PersistValue] -> Either Text (Entity record)
parseEntityValues :: 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 = (FieldDef -> FieldNameHS)
-> NonEmpty FieldDef -> NonEmpty FieldNameHS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldDef -> FieldNameHS
fieldHaskell (NonEmpty FieldDef -> NonEmpty FieldNameHS)
-> NonEmpty FieldDef -> NonEmpty FieldNameHS
forall a b. (a -> b) -> a -> b
$ CompositeDef -> NonEmpty FieldDef
compositeFields CompositeDef
pdef
keyvals :: [PersistValue]
keyvals = ((FieldNameHS, PersistValue) -> PersistValue)
-> [(FieldNameHS, PersistValue)] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameHS, PersistValue) -> PersistValue
forall a b. (a, b) -> b
snd ([(FieldNameHS, PersistValue)] -> [PersistValue])
-> ([(FieldNameHS, PersistValue)] -> [(FieldNameHS, PersistValue)])
-> [(FieldNameHS, PersistValue)]
-> [PersistValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldNameHS, PersistValue) -> Bool)
-> [(FieldNameHS, PersistValue)] -> [(FieldNameHS, PersistValue)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldNameHS -> NonEmpty FieldNameHS -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty FieldNameHS
pks) (FieldNameHS -> Bool)
-> ((FieldNameHS, PersistValue) -> FieldNameHS)
-> (FieldNameHS, PersistValue)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, PersistValue) -> FieldNameHS
forall a b. (a, b) -> a
fst)
([(FieldNameHS, PersistValue)] -> [PersistValue])
-> [(FieldNameHS, PersistValue)] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ [FieldNameHS] -> [PersistValue] -> [(FieldNameHS, PersistValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FieldDef -> FieldNameHS) -> [FieldDef] -> [FieldNameHS]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldNameHS
fieldHaskell ([FieldDef] -> [FieldNameHS]) -> [FieldDef] -> [FieldNameHS]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields EntityDef
t) [PersistValue]
vals
in [PersistValue] -> [PersistValue] -> Either Text (Entity record)
forall record.
PersistEntity record =>
[PersistValue] -> [PersistValue] -> Either Text (Entity record)
fromPersistValuesComposite' [PersistValue]
keyvals [PersistValue]
vals
Maybe CompositeDef
Nothing -> [PersistValue] -> Either Text (Entity record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Entity record)
fromPersistValues' [PersistValue]
vals
where
fromPersistValues' :: [PersistValue] -> Either Text (Entity record)
fromPersistValues' (PersistValue
kpv:[PersistValue]
xs) =
case [PersistValue] -> Either Text record
forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues [PersistValue]
xs of
Left Text
e -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left Text
e
Right record
xs' ->
case [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
kpv] of
Left Text
_ -> [Char] -> Either Text (Entity record)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either Text (Entity record))
-> [Char] -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ [Char]
"fromPersistValues': keyFromValues failed on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PersistValue -> [Char]
forall a. Show a => a -> [Char]
show PersistValue
kpv
Right Key record
k -> Entity record -> Either Text (Entity record)
forall a b. b -> Either a b
Right (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
xs')
fromPersistValues' [PersistValue]
xs = Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char]
"error in fromPersistValues' xs=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [PersistValue] -> [Char]
forall a. Show a => a -> [Char]
show [PersistValue]
xs)
fromPersistValuesComposite' :: [PersistValue] -> [PersistValue] -> Either Text (Entity record)
fromPersistValuesComposite' [PersistValue]
keyvals [PersistValue]
xs =
case [PersistValue] -> Either Text record
forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues [PersistValue]
xs of
Left Text
e -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left Text
e
Right record
xs' -> case [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue]
keyvals of
Left Text
err -> [Char] -> Either Text (Entity record)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Either Text (Entity record))
-> [Char] -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ [Char]
"fromPersistValuesComposite': keyFromValues failed with error: "
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
Right Key record
key -> Entity record -> Either Text (Entity record)
forall a b. b -> Either a b
Right (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
key record
xs')
isIdField
:: forall record typ. (PersistEntity record)
=> EntityField record typ
-> Bool
isIdField :: EntityField record typ -> Bool
isIdField EntityField record typ
f = FieldDef -> FieldNameHS
fieldHaskell (EntityField record typ -> FieldDef
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
f) FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id"
updateFieldDef :: PersistEntity v => Update v -> FieldDef
updateFieldDef :: Update v -> FieldDef
updateFieldDef (Update EntityField v typ
f typ
_ PersistUpdate
_) = EntityField v typ -> FieldDef
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField v typ
f
updateFieldDef BackendUpdate {} = [Char] -> FieldDef
forall a. HasCallStack => [Char] -> a
error [Char]
"updateFieldDef: did not expect BackendUpdate"
updatePersistValue :: Update v -> PersistValue
updatePersistValue :: Update v -> PersistValue
updatePersistValue (Update EntityField v typ
_ typ
v PersistUpdate
_) = typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue typ
v
updatePersistValue (BackendUpdate{}) =
[Char] -> PersistValue
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 :: SqlBackend -> Update record -> Text
mkUpdateText SqlBackend
conn = (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
forall record.
PersistEntity record =>
(FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' (SqlBackend -> FieldNameDB -> Text
connEscapeFieldName SqlBackend
conn) Text -> Text
forall a. a -> a
id
mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' :: (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text
mkUpdateText' FieldNameDB -> Text
escapeName Text -> Text
refColumn Update record
x =
case Update record -> PersistUpdate
forall record. Update record -> PersistUpdate
updateUpdate Update record
x of
PersistUpdate
Assign -> Text
n Text -> Text -> Text
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 ->
[Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> (Text -> [Char]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"mkUpdateText: BackendSpecificUpdate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
up Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not supported"
where
n :: Text
n = FieldNameDB -> Text
escapeName (FieldNameDB -> Text)
-> (Update record -> FieldNameDB) -> Update record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDef -> FieldNameDB
fieldDB (FieldDef -> FieldNameDB)
-> (Update record -> FieldDef) -> Update record -> FieldNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Update record -> FieldDef
forall v. PersistEntity v => Update v -> FieldDef
updateFieldDef (Update record -> Text) -> Update record -> Text
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
")"]
mkInsertValues
:: PersistEntity rec
=> rec
-> [PersistValue]
mkInsertValues :: rec -> [PersistValue]
mkInsertValues rec
entity =
[Maybe PersistValue] -> [PersistValue]
forall a. [Maybe a] -> [a]
Maybe.catMaybes
([Maybe PersistValue] -> [PersistValue])
-> ([SomePersistField] -> [Maybe PersistValue])
-> [SomePersistField]
-> [PersistValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDef -> PersistValue -> Maybe PersistValue)
-> [FieldDef] -> [PersistValue] -> [Maybe PersistValue]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FieldDef -> PersistValue -> Maybe PersistValue
forall a. FieldDef -> a -> Maybe a
redactGeneratedCol (EntityDef -> [FieldDef]
getEntityFields (EntityDef -> [FieldDef])
-> (Maybe rec -> EntityDef) -> Maybe rec -> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe rec -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe rec -> [FieldDef]) -> Maybe rec -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ rec -> Maybe rec
forall a. a -> Maybe a
Just rec
entity)
([PersistValue] -> [Maybe PersistValue])
-> ([SomePersistField] -> [PersistValue])
-> [SomePersistField]
-> [Maybe PersistValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue
([SomePersistField] -> [PersistValue])
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ rec -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
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 ->
a -> Maybe a
forall a. a -> Maybe a
Just a
pv
Just Text
_ ->
Maybe a
forall a. Maybe a
Nothing
mkInsertPlaceholders
:: EntityDef
-> (FieldNameDB -> Text)
-> [(Text, Text)]
mkInsertPlaceholders :: EntityDef -> (FieldNameDB -> Text) -> [(Text, Text)]
mkInsertPlaceholders EntityDef
ed FieldNameDB -> Text
escape =
(FieldDef -> Maybe (Text, Text)) -> [FieldDef] -> [(Text, Text)]
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 ->
(Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (FieldNameDB -> Text
escape (FieldDef -> FieldNameDB
fieldDB FieldDef
fd), Text
"?")
Just Text
_ ->
Maybe (Text, Text)
forall a. Maybe a
Nothing