79224b6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP all fundamental PersistStore functions implemented and compiling

79224b6AgentM11 years ago

Database/Persist/ProjectM36.hs+95−27

@@ -1,7 +1,8 @@

1{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, FlexibleContexts #-}

2{-# OPTIONS_GHC -fno-warn-orphans #-}

3module Database.Persist.ProjectM36 where

4−import Database.Persist

4+import Database.Persist hiding (Assign, Update)

5+import qualified Database.Persist as DP

5import ProjectM36.Base

6import ProjectM36.Base

6import ProjectM36.Tuple

7import ProjectM36.Tuple

7import qualified ProjectM36.Client as C

8import qualified ProjectM36.Client as C

@@ -17,9 +18,12 @@ import qualified Data.Text as T

17import ProjectM36.Atom

18import ProjectM36.Atom

18import Data.Aeson (FromJSON(..), ToJSON(..), withText)

19import Data.Aeson (FromJSON(..), ToJSON(..), withText)

19import qualified Data.HashSet as HS

20import qualified Data.HashSet as HS

21+import qualified Data.Map as M

22+import Control.Monad (when)

23+import Data.Maybe (isJust)

21type ProjectM36Backend = C.Connection

25type ProjectM36Backend = C.Connection

22−

26+

23--convert a PersistEntity to a RelationTuple

27--convert a PersistEntity to a RelationTuple

24recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)

28recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)

25 => Maybe U.UUID -> record -> Either RelationalError RelationTuple

29 => Maybe U.UUID -> record -> Either RelationalError RelationTuple

@@ -102,7 +106,7 @@ insertNewRecords :: (Trans.MonadIO m,

102 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]

106 [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]

103insertNewRecords uuids records = do

107insertNewRecords uuids records = do

104 let recordsZip = zip (map Just uuids) records

108 let recordsZip = zip (map Just uuids) records

105− insertExpr = Insert (relVarName $ head records)

109+ insertExpr = Insert (relVarNameFromRecord $ head records)

106 case recordsAsRelation recordsZip of

110 case recordsAsRelation recordsZip of

107 Left err -> throw $ PersistError (T.pack $ show err)

111 Left err -> throw $ PersistError (T.pack $ show err)

108 Right rel -> do

112 Right rel -> do

@@ -116,24 +120,18 @@ lookupByKey :: forall record m.

116 PersistEntityBackend record ~ C.Connection)

120 PersistEntityBackend record ~ C.Connection)

117 => Key record -> ReaderT C.Connection m (Maybe (Entity record))

121 => Key record -> ReaderT C.Connection m (Maybe (Entity record))

118lookupByKey key = do

122lookupByKey key = do

119− case fromPersistValue $ head $ keyToValues key of

123+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

120− Left err -> Trans.liftIO $ throwIO $ PersistError "key uuid extraction failure"

121− Right matchUUID -> do

122− let matchUUIDText = T.pack $ U.toString matchUUID

123− entityInfo = entityDefFromKey key

124− keyAttributeName = unDBName (fieldDB $ entityId entityInfo)

125− relVarName = unDBName $ entityDB entityInfo

126− restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))

127− query = Restrict restrictionPredicate (RelationVariable relVarName)

124+ let query = Restrict restrictionPredicate (RelationVariable relVarName)

128− conn <- ask

125+ conn <- ask

129− resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query

126+ resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query

130− case resultRel of

127+ case resultRel of

131− Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"

128+ Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"

132− Right resultRel' -> case singletonTuple resultRel' of

129+ Right resultRel' -> case singletonTuple resultRel' of

133− Nothing -> return Nothing --no match on key

130+ Nothing -> return Nothing --no match on key

134− Just tuple -> do

131+ Just tuple -> do

132+ let entityInfo = entityDefFromKey key

135− entity <- fromPersistValuesThrow entityInfo tuple --correct, one match

133+ entity <- fromPersistValuesThrow entityInfo tuple --correct, one match

136− return $ Just entity

134+ return $ Just entity

137

135

138fromPersistValuesThrow :: (Trans.MonadIO m,

136fromPersistValuesThrow :: (Trans.MonadIO m,

139 PersistEntity record,

137 PersistEntity record,

@@ -151,6 +149,63 @@ fromPersistValuesThrow entDef tuple = do

151 Right key -> case body of

149 Right key -> case body of

152 Left err -> Trans.liftIO $ throwIO $ PersistError err

150 Left err -> Trans.liftIO $ throwIO $ PersistError err

153 Right body' -> return $ Entity key body'

151 Right body' -> return $ Entity key body'

152+

153+commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)

154+commonKeyQueryProperties key = do

155+ let matchUUID = keyToUUID key

156+ keyAttributeName = unDBName (fieldDB $ entityId entityInfo)

157+ relVarName = unDBName $ entityDB entityInfo

158+ matchUUIDText = T.pack $ U.toString matchUUID

159+ entityInfo = entityDefFromKey key

160+ restrictionPredicate = AttributeEqualityPredicate keyAttributeName (NakedAtomExpr (StringAtom matchUUIDText))

161+ return (relVarName, restrictionPredicate)

162+

163+deleteByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (Bool)

164+deleteByKey key = do

165+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

166+ let query = Delete relVarName restrictionPredicate

167+ conn <- ask

168+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query

169+ return $ isJust maybeErr

170+

171+--convert persistent update list to ProjectM36 Update map

172+updatesToUpdateMap :: (Trans.MonadIO m,

173+ PersistEntityBackend val ~ C.Connection,

174+ PersistEntity val) =>

175+ [DP.Update val] -> ReaderT C.Connection m (M.Map AttributeName Atom)

176+updatesToUpdateMap updates = do

177+ let convertMap upd = case updateUpdate upd of

178+ DP.Assign -> let attrName = unDBName $ fieldDB $ updateFieldDef upd

179+ newAttrValue = persistValueAtom (updatePersistValue upd) in

180+ case newAttrValue of

181+ Nothing -> Trans.liftIO $ throwIO $ PersistError "atom conversion failed"

182+ Just newAttrValue' -> return (attrName, newAttrValue')

183+ _ -> Trans.liftIO $ throwIO $ PersistError "update type not supported"

184+ updateAtomList <- mapM convertMap updates

185+ return $ M.fromList updateAtomList

186+

187+updateByKey :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> [DP.Update val] -> ReaderT C.Connection m ()

188+updateByKey key updates = do

189+ (relVarName, restrictionPredicate) <- commonKeyQueryProperties key

190+ updateMap <- updatesToUpdateMap updates

191+ let query = Update relVarName updateMap restrictionPredicate

192+ conn <- ask

193+ maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query

194+ case maybeErr of

195+ Just err -> Trans.liftIO $ throwIO $ PersistError "executeDatabaseExpr error"

196+ Nothing -> return ()

197+

198+--set the truth unconditionally

199+repsertByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()

200+repsertByKey key val = do

201+ _ <- delete key

202+ insertKey key val

203+

204+replaceByKey :: (Trans.MonadIO m, C.Connection ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT C.Connection m ()

205+replaceByKey key val = do

206+ deletionSuccess <- deleteByKey key

207+ when (not deletionSuccess) (Trans.liftIO $ throwIO $ PersistError "entity missing during replace")

208+ insertKey key val

154

209

155entityDefFromKey :: PersistEntity record => Key record -> EntityDef

210entityDefFromKey :: PersistEntity record => Key record -> EntityDef

156entityDefFromKey = entityDef . Just . recordTypeFromKey

211entityDefFromKey = entityDef . Just . recordTypeFromKey

@@ -195,10 +250,15 @@ instance PersistStore C.Connection where

195 Nothing -> return Nothing

250 Nothing -> return Nothing

196 Just (Entity _ val) -> return $ Just val

251 Just (Entity _ val) -> return $ Just val

197

252

198− repsert = undefined

253+ repsert = repsertByKey

199− delete = undefined

254+ --delete followed by insert "set the record as the truth

255+

256+ delete key = deleteByKey key >> return ()

257+

200− replace = undefined

258+ replace = replaceByKey

201− update = undefined

259+

260+ --update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) => Key val -> [Update val] -> ReaderT backend m ()

261+ update = updateByKey

202

262

203instance FromJSON (BackendKey C.Connection) where

263instance FromJSON (BackendKey C.Connection) where

204 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))

264 parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))

@@ -214,9 +274,9 @@ executeDatabaseContextExpr conn expr = do

214 Nothing -> return ()

274 Nothing -> return ()

215 Just err -> throwIO (PersistError $ T.pack (show err))

275 Just err -> throwIO (PersistError $ T.pack (show err))

216

276

217−relVarName :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)

277+relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)

218 => record -> RelVarName

278 => record -> RelVarName

219−relVarName = unDBName . entityDB . entityDef . Just

279+relVarNameFromRecord = unDBName . entityDB . entityDef . Just

220

280

221instance PersistField U.UUID where

281instance PersistField U.UUID where

222 toPersistValue val = PersistText $ T.pack (U.toString val)

282 toPersistValue val = PersistText $ T.pack (U.toString val)

@@ -225,3 +285,11 @@ instance PersistField U.UUID where

225 Just uuid -> Right uuid

285 Just uuid -> Right uuid

226 fromPersistValue _ = Left $ T.pack "expected PersistObjectId"

286 fromPersistValue _ = Left $ T.pack "expected PersistObjectId"

227

287

288+{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}

289+updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef

290+updateFieldDef (DP.Update f _ _) = persistFieldDef f

291+updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate"

292+

293+updatePersistValue :: DP.Update v -> PersistValue

294+updatePersistValue (DP.Update _ v _) = toPersistValue v

295+updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"