@@ -16,11 +16,15 @@ import Control.Monad.Trans.Reader (ask, ReaderT)
1616import Control.Exception (throw, throwIO)
1717import qualified Data.Text as T
1818import ProjectM36.Atom
19−import Data.Aeson (FromJSON(..), ToJSON(..), withText)
19+import Data.Aeson (FromJSON(..), ToJSON(..), withText, withObject, (.:))
2020import qualified Data.HashSet as HS
2121import qualified Data.Map as M
2222import Control.Monad (when)
2323import Data.Maybe (isJust)
24+import Data.Aeson.Types (modifyFailure)
25+import Control.Monad.Reader (runReaderT)
26+import Web.PathPieces (PathPiece (..))
27+import qualified Database.Persist.Sql as Sql
2428
2529type ProjectM36Backend = C.Connection
2630
@@ -216,6 +220,9 @@ dummyFromKey = Just . recordTypeFromKey
216220recordTypeFromKey :: Key record -> record
217221recordTypeFromKey _ = error "dummyFromKey"
218222
223+dummyFromUnique :: Unique v -> Maybe v
224+dummyFromUnique _ = Nothing
225+
219226keyToUUID:: (PersistEntity record) => Key record -> U.UUID
220227keyToUUID key = case keyToValues key of
221228 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
@@ -278,13 +285,6 @@ relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.C
278285 => record -> RelVarName
279286relVarNameFromRecord = unDBName . entityDB . entityDef . Just
280287
281−instance PersistField U.UUID where
282− toPersistValue val = PersistText $ T.pack (U.toString val)
283− fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
284− Nothing -> Left "uuid text read failure"
285− Just uuid -> Right uuid
286− fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
287−
288288{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
289289updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
290290updateFieldDef (DP.Update f _ _) = persistFieldDef f
@@ -293,3 +293,84 @@ updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect Backend
293293updatePersistValue :: DP.Update v -> PersistValue
294294updatePersistValue (DP.Update _ v _) = toPersistValue v
295295updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"
296+
297+instance PersistField U.UUID where
298+ toPersistValue val = PersistText $ T.pack (U.toString val)
299+ fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
300+ Nothing -> Left "uuid text read failure"
301+ Just uuid -> Right uuid
302+ fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
303+
304+instance FromJSON C.ConnectionInfo where
305+ parseJSON v = modifyFailure ("Persistent: error loading ProjectM36 conf: " ++) $
306+ flip (withObject "ProjectM36Conf") v $ \o -> do
307+ ctype <- parseJSON =<< ( o .: "connectionType")
308+ return ctype
309+
310+instance PersistConfig C.ConnectionInfo where
311+ type PersistConfigBackend C.ConnectionInfo = ReaderT C.Connection
312+ type PersistConfigPool C.ConnectionInfo = C.Connection
313+
314+ loadConfig = parseJSON
315+ applyEnv = return -- no environment variables are used
316+ createPoolConfig conf = do
317+ connErr <- C.connectProjectM36 conf
318+ case connErr of
319+ Left err -> throwIO $ PersistError "Failed to create connection"
320+ Right conn -> return conn
321+ --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a
322+ runPool _ r = runReaderT r
323+
324+withProjectM36Conn :: (Monad m, Trans.MonadIO m) => C.ConnectionInfo -> (C.Connection -> m a) -> m a
325+withProjectM36Conn conf connReader = do
326+ conn <- Trans.liftIO $ createPoolConfig conf
327+ connReader conn
328+
329+runProjectM36Conn :: (Trans.MonadIO m) => ReaderT C.Connection m a -> C.Connection -> m a
330+runProjectM36Conn m1 conn = runReaderT m1 conn
331+
332+instance PathPiece (BackendKey ProjectM36Backend) where
333+ toPathPiece (ProjectM36Key uuid) = U.toText uuid
334+ fromPathPiece txt = do
335+ uuid <- U.fromText txt
336+ return $ ProjectM36Key uuid
337+
338+instance Sql.PersistFieldSql U.UUID where
339+ sqlType _ = Sql.SqlOther "doesn't make much sense for ProjectM36"
340+
341+instance Sql.PersistFieldSql (BackendKey C.Connection) where
342+ sqlType _ = Sql.SqlOther "doesn't make much sense for ProjectM36"
343+
344+persistUniqueToRestrictionPredicate :: PersistEntity record => Unique record -> Either RelationalError RestrictionPredicateExpr
345+persistUniqueToRestrictionPredicate unique = do
346+ atoms <- mapM (\v -> maybe (Left $ AtomTypeNotSupported "") Right $ persistValueAtom v) $ persistUniqueToValues unique
347+ let attrNames = map (unDBName . snd) $ persistUniqueToFieldNames unique
348+ andify [] = TruePredicate
349+ andify ((attrName, atom):xs) = AndPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom)) $ andify xs
350+ return $ andify (zip attrNames atoms)
351+
352+instance PersistUnique C.Connection where
353+ getBy unique = do
354+ conn <- ask
355+ let predicate = persistUniqueToRestrictionPredicate unique
356+ relVarName = unDBName $ entityDB entDef
357+ entDef = entityDef $ dummyFromUnique unique
358+ throwRelErr err = Trans.liftIO $ throwIO (PersistError (T.pack $ show err))
359+ case predicate of
360+ Left err -> throwRelErr err
361+ Right predicate' -> do
362+ let restrictExpr = Restrict predicate' (RelationVariable relVarName)
363+ singletonRel <- Trans.liftIO $ C.executeRelationalExpr conn restrictExpr
364+ case singletonRel of
365+ Left err -> throwRelErr err
366+ Right singletonRel' -> do
367+ if cardinality singletonRel' == Countable 0 then
368+ return Nothing
369+ else if cardinality singletonRel' > Countable 1 then
370+ Trans.liftIO $ throwIO (PersistError "getBy returned more than one tuple")
371+ else -- exactly one tuple
372+ case singletonTuple singletonRel' of
373+ Nothing -> Trans.liftIO $ throwIO (PersistMarshalError "singletonTuple failure")
374+ Just tuple -> do
375+ newEnt <- Trans.liftIO $ fromPersistValuesThrow entDef tuple
376+ return $ Just newEnt