module Database.Persist.Sql.Orphan.PersistStore (defaultIdName, sqlIdName, withRawQuery, BackendKey(..)) where
import Database.Persist
import Database.Persist.Sql.Types
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Class (IsSqlKey (..))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
import Data.Text (Text, unpack)
import Data.Monoid (mappend, (<>))
import Control.Monad.IO.Class
import Data.ByteString.Char8 (readInteger)
import Data.Maybe (isJust)
import Data.List (find)
import Control.Monad.Trans.Reader (ReaderT, ask)
import Data.Acquire (with)
import Data.Int (Int64)
import Web.PathPieces (PathPiece)
import Database.Persist.Sql.Class (PersistFieldSql, defaultIdName, sqlIdName)
import qualified Data.Aeson as A
import Control.Exception.Lifted (throwIO)
withRawQuery :: MonadIO m
=> Text
-> [PersistValue]
-> C.Sink [PersistValue] IO a
-> ReaderT Connection m a
withRawQuery sql vals sink = do
srcRes <- rawQueryRes sql vals
liftIO $ with srcRes (C.$$ sink)
instance IsSqlKey (BackendKey SqlBackend) where
toSqlKey = SqlBackendKey
fromSqlKey = unSqlBackendKey
instance PersistStore Connection where
newtype BackendKey Connection = SqlBackendKey { unSqlBackendKey :: Int64 }
deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, Real, Enum, Bounded, A.ToJSON, A.FromJSON)
update _ [] = return ()
update k upds = do
conn <- ask
let go'' n Assign = n <> "=?"
go'' n Add = T.concat [n, "=", n, "+?"]
go'' n Subtract = T.concat [n, "=", n, "-?"]
go'' n Multiply = T.concat [n, "=", n, "*?"]
go'' n Divide = T.concat [n, "=", n, "/?"]
let go' (x, pu) = go'' (connEscapeName conn x) pu
let wher = case entityPrimary t of
Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef
Nothing -> connEscapeName conn (sqlIdName t) <> "=?"
let sql = T.concat
[ "UPDATE "
, connEscapeName conn $ entityDB t
, " SET "
, T.intercalate "," $ map (go' . go) upds
, " WHERE "
, wher
]
rawExecute sql $
map updatePersistValue upds `mappend` keyToValues k
where
t = entityDef $ dummyFromKey k
go x = (fieldDB $ updateFieldDef x, updateUpdate x)
insert val = do
conn <- ask
let esql = connInsertSql conn t vals
key <-
case esql of
ISRSingle sql -> withRawQuery sql vals $ do
x <- CL.head
case x of
Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of
Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err
Right k -> return k
Nothing -> error $ "SQL insert did not return a result giving the generated ID"
Just vals' -> case keyFromValues vals' of
Left _ -> error $ "Invalid result from a SQL insert, got: " ++ show vals'
Right k -> return k
ISRInsertGet sql1 sql2 -> do
rawExecute sql1 vals
withRawQuery sql2 [] $ do
mm <- CL.head
let m = maybe
(Left $ "No results from ISRInsertGet: " `mappend` tshow (sql1, sql2))
Right mm
let convert x =
case x of
[PersistByteString i] -> case readInteger i of
Just (ret,"") -> [PersistInt64 $ fromIntegral ret]
_ -> x
_ -> x
onLeft Left{} x = x
onLeft x _ = x
case m >>= (\x -> keyFromValues x `onLeft` keyFromValues (convert x)) of
Right k -> return k
Left err -> throw $ "ISRInsertGet: keyFromValues failed: " `mappend` err
ISRManyKeys sql fs -> do
rawExecute sql vals
case entityPrimary t of
Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql
Just pdef ->
let pks = map fieldHaskell $ compositeFields pdef
keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs
in case keyFromValues keyvals of
Right k -> return k
Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e
return key
where
tshow :: Show a => a -> Text
tshow = T.pack . show
throw = liftIO . throwIO . userError . T.unpack
t = entityDef $ Just val
vals = map toPersistValue $ toPersistFields val
insertMany_ [] = return ()
insertMany_ vals = do
conn <- ask
let sql = T.concat
[ "INSERT INTO "
, connEscapeName conn (entityDB t)
, "("
, T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t
, ") VALUES ("
, T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t)
, ")"
]
if connRDBMS conn == "sqlite"
then mapM_ insert vals
else rawExecute sql (concat valss)
where
t = entityDef vals
valss = map (map toPersistValue . toPersistFields) vals
replace k val = do
conn <- ask
let t = entityDef $ Just val
let sql = T.concat
[ "UPDATE "
, connEscapeName conn (entityDB t)
, " SET "
, T.intercalate "," (map (go conn . fieldDB) $ entityFields t)
, " WHERE "
, connEscapeName conn $ sqlIdName t
, "=?"
]
vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k
rawExecute sql vals
where
go conn x = connEscapeName conn x `T.append` "=?"
insertKey = insrepHelper "INSERT"
repsert key value = do
mExisting <- get key
case mExisting of
Nothing -> insertKey key value
Just _ -> replace key value
get k = do
conn <- ask
let t = entityDef $ dummyFromKey k
let cols = T.intercalate ","
$ map (connEscapeName conn . fieldDB) $ entityFields t
noColumns :: Bool
noColumns = null $ entityFields t
let wher = case entityPrimary t of
Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef
Nothing -> connEscapeName conn (sqlIdName t) <> "=?"
let sql = T.concat
[ "SELECT "
, if noColumns then "*" else cols
, " FROM "
, connEscapeName conn $ entityDB t
, " WHERE "
, wher
]
withRawQuery sql (keyToValues k) $ do
res <- CL.head
case res of
Nothing -> return Nothing
Just vals ->
case fromPersistValues $ if noColumns then [] else vals of
Left e -> error $ "get " ++ show k ++ ": " ++ unpack e
Right v -> return $ Just v
delete k = do
conn <- ask
rawExecute (sql conn) (keyToValues k)
where
t = entityDef $ dummyFromKey k
wher conn =
case entityPrimary t of
Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef
Nothing -> connEscapeName conn (sqlIdName t) <> "=?"
sql conn = T.concat
[ "DELETE FROM "
, connEscapeName conn $ entityDB t
, " WHERE "
, wher conn
]
dummyFromKey :: Key v -> Maybe v
dummyFromKey _ = Nothing
insrepHelper :: (MonadIO m, PersistEntity val)
=> Text
-> Key val
-> val
-> ReaderT Connection m ()
insrepHelper command k val = do
conn <- ask
rawExecute (sql conn) vals
where
t = entityDef $ Just val
sql conn = T.concat
[ command
, " INTO "
, connEscapeName conn (entityDB t)
, "("
, T.intercalate ","
$ map (connEscapeName conn)
$ sqlIdName t : map fieldDB (entityFields t)
, ") VALUES("
, T.intercalate "," ("?" : map (const "?") (entityFields t))
, ")"
]
vals = keyToValues k ++ map toPersistValue (toPersistFields val)
updateFieldDef :: PersistEntity v => Update v -> FieldDef
updateFieldDef (Update f _ _) = persistFieldDef f
updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"
updatePersistValue :: Update v -> PersistValue
updatePersistValue (Update _ v _) = toPersistValue v
updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"