@@ -0,0 +1,227 @@
1+{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleInstances, FlexibleContexts #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module Database.Persist.ProjectM36 where
4+import Database.Persist
5+import ProjectM36.Base
6+import ProjectM36.Tuple
7+import qualified ProjectM36.Client as C
8+import qualified Data.UUID as U
9+import Data.UUID.V4 (nextRandom)
10+import qualified Data.Vector as V
11+import ProjectM36.Error
12+import ProjectM36.Relation
13+import qualified Control.Monad.IO.Class as Trans
14+import Control.Monad.Trans.Reader (ask, ReaderT)
15+import Control.Exception (throw, throwIO)
16+import qualified Data.Text as T
17+import ProjectM36.Atom
18+import Data.Aeson (FromJSON(..), ToJSON(..), withText)
19+import qualified Data.HashSet as HS
20+
21+type ProjectM36Backend = C.Connection
22+
23+--convert a PersistEntity to a RelationTuple
24+recordAsTuple :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
25+ => Maybe U.UUID -> record -> Either RelationalError RelationTuple
26+recordAsTuple uuid record = do -- if the uuid is passed in, set the idDBName attribute
27+ let entInfo = zip entFields entValues
28+ entFields = embeddedFields $ toEmbedEntityDef (entityDef $ Just record)
29+ entValues = map toPersistValue $ toPersistFields record
30+ attrVec <- recordAttributes entInfo record
31+ atomVec <- recordAsAtoms uuid attrVec record
32+ return $ RelationTuple attrVec atomVec
33+
34+recordAttributes :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
35+ => [(EmbedFieldDef, PersistValue)] -> record -> Either RelationalError Attributes
36+recordAttributes entInfo record = do
37+ let convertAttr = uncurry fieldDefAsAttribute
38+ idDBName = unDBName $ fieldDB $ entityId (entityDef $ Just record)
39+ attrList <- mapM convertAttr entInfo
40+ return $ V.fromList ([Attribute idDBName StringAtomType] ++ attrList)
41+
42+fieldDefAsAttribute :: EmbedFieldDef -> PersistValue -> Either RelationalError Attribute
43+fieldDefAsAttribute fieldDef pVal = case persistValueAtomType pVal of
44+ Nothing -> Left $ AtomTypeNotSupported attrName
45+ Just fType -> Right $ Attribute attrName fType
46+ where
47+ attrName = unDBName $ emFieldDB fieldDef
48+
49+persistValueAtomType :: PersistValue -> Maybe AtomType
50+persistValueAtomType val = do
51+ atom <- persistValueAtom val
52+ return $ atomTypeForAtom atom
53+
54+persistValueAtom :: PersistValue -> Maybe Atom
55+persistValueAtom val = case val of
56+ PersistText v -> return $ StringAtom v
57+ PersistInt64 v -> return $ IntAtom (fromIntegral v)
58+ PersistBool v -> return $ BoolAtom v
59+ PersistDay v -> return $ DateAtom v
60+ _ -> Nothing
61+
62+atomAsPersistValue :: Atom -> PersistValue
63+atomAsPersistValue a = case a of
64+ StringAtom v -> PersistText v
65+ IntAtom v -> PersistInt64 (fromIntegral v)
66+ BoolAtom v -> PersistBool v
67+ DateAtom v -> PersistDay v
68+ _ -> error "missing conversion"
69+
70+recordAsAtoms :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection)
71+ => Maybe U.UUID -> Attributes -> record -> Either RelationalError (V.Vector Atom)
72+recordAsAtoms freshUUID _ record = do
73+ let pValues = map toPersistValue $ toPersistFields record
74+ valAtom val = case persistValueAtom val of
75+ Nothing -> Left $ AtomTypeNotSupported ""
76+ Just atom -> Right atom
77+ atoms <- mapM valAtom pValues
78+ return $ V.fromList $ case freshUUID of
79+ Nothing -> atoms
80+ Just uuid -> [StringAtom $ T.pack (U.toString uuid)] ++ atoms
81+
82+--used by insert operations
83+recordsAsRelation :: forall record. (PersistEntity record, PersistEntityBackend record ~ C.Connection) =>
84+ [(Maybe U.UUID, record)] -> Either RelationalError Relation
85+recordsAsRelation [] = Left EmptyTuplesError
86+recordsAsRelation recordZips = do
87+ tupleList <- mapM (uncurry recordAsTuple) recordZips
88+ let oneTuple = head tupleList
89+ mkRelation (tupleAttributes oneTuple) (HS.fromList tupleList)
90+
91+keyFromValuesOrDie :: (Trans.MonadIO m,
92+ PersistEntity record,
93+ PersistEntityBackend record ~ C.Connection
94+ ) => [PersistValue] -> m (Key record)
95+keyFromValuesOrDie val = case keyFromValues val of
96+ Right k -> return k
97+ Left _ -> Trans.liftIO $ throwIO $ PersistError "key pooped"
98+
99+insertNewRecords :: (Trans.MonadIO m,
100+ PersistEntity record,
101+ PersistEntityBackend record ~ C.Connection) =>
102+ [U.UUID] -> [record] -> ReaderT C.Connection m [Key record]
103+insertNewRecords uuids records = do
104+ let recordsZip = zip (map Just uuids) records
105+ insertExpr = Insert (relVarName $ head records)
106+ case recordsAsRelation recordsZip of
107+ Left err -> throw $ PersistError (T.pack $ show err)
108+ Right rel -> do
109+ conn <- ask
110+ Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))
111+ mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids
112+
113+lookupByKey :: forall record m.
114+ (Trans.MonadIO m,
115+ PersistEntity record,
116+ PersistEntityBackend record ~ C.Connection)
117+ => Key record -> ReaderT C.Connection m (Maybe (Entity record))
118+lookupByKey key = do
119+ case fromPersistValue $ head $ keyToValues key of
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)
128+ conn <- ask
129+ resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query
130+ case resultRel of
131+ Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"
132+ Right resultRel' -> case singletonTuple resultRel' of
133+ Nothing -> return Nothing --no match on key
134+ Just tuple -> do
135+ entity <- fromPersistValuesThrow entityInfo tuple --correct, one match
136+ return $ Just entity
137+
138+fromPersistValuesThrow :: (Trans.MonadIO m,
139+ PersistEntity record,
140+ PersistEntityBackend record ~ C.Connection) => EntityDef -> RelationTuple -> m (Entity record)
141+fromPersistValuesThrow entDef tuple = do
142+ let body = fromPersistValues $ map getValue (entityFields entDef)
143+ getValue field = case atomForAttributeName (unDBName (fieldDB field)) tuple of
144+ Right atom -> atomAsPersistValue atom
145+ Left err -> throw $ PersistError "missing field"
146+ keyAtom = atomForAttributeName (unDBName (fieldDB (entityId entDef))) tuple
147+ case keyAtom of
148+ Left err -> Trans.liftIO $ throwIO $ PersistError "missing key atom"
149+ Right keyAtom' -> case keyFromValues [atomAsPersistValue keyAtom'] of
150+ Left err -> throw $ PersistError "key failure"
151+ Right key -> case body of
152+ Left err -> Trans.liftIO $ throwIO $ PersistError err
153+ Right body' -> return $ Entity key body'
154+
155+entityDefFromKey :: PersistEntity record => Key record -> EntityDef
156+entityDefFromKey = entityDef . Just . recordTypeFromKey
157+
158+dummyFromKey :: Key record -> Maybe record
159+dummyFromKey = Just . recordTypeFromKey
160+
161+recordTypeFromKey :: Key record -> record
162+recordTypeFromKey _ = error "dummyFromKey"
163+
164+keyToUUID:: (PersistEntity record) => Key record -> U.UUID
165+keyToUUID key = case keyToValues key of
166+ ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
167+ Nothing -> error "error reading uuid from text in key construction"
168+ Just uuid -> uuid
169+ _ -> error "unexpected persist value in key construction"
170+
171+instance PersistStore C.Connection where
172+ newtype BackendKey C.Connection = ProjectM36Key { unPM36Key :: U.UUID }
173+ deriving (Show, Read, Eq, Ord, PersistField)
174+
175+ insertMany [] = return []
176+ insertMany records = do
177+ freshUUIDs <- Trans.liftIO $ mapM (\_-> nextRandom) records
178+ insertNewRecords freshUUIDs records
179+
180+ insert record = do
181+ keys <- insertMany [record]
182+ return $ head keys
183+
184+ --insertEntityMany [] = return []
185+ --insertKey :: (Trans.MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> ReaderT backend m ()
186+ insertKey key record = do
187+ let uuid = keyToUUID key
188+ _ <- insertNewRecords [uuid] [record]
189+ return ()
190+
191+ --get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Key val -> ReaderT backend m (Maybe val)
192+ get key = do
193+ ent <- lookupByKey key
194+ case ent of
195+ Nothing -> return Nothing
196+ Just (Entity _ val) -> return $ Just val
197+
198+ repsert = undefined
199+ delete = undefined
200+ replace = undefined
201+ update = undefined
202+
203+instance FromJSON (BackendKey C.Connection) where
204+ parseJSON = withText "ProjectM36Key" $ \t -> maybe (fail "Invalid UUID") (return . ProjectM36Key) (U.fromString (T.unpack t))
205+
206+instance ToJSON (BackendKey C.Connection) where
207+ toJSON (ProjectM36Key uuid) = toJSON $ U.toString uuid
208+
209+--wrapped version which throws exceptions
210+executeDatabaseContextExpr :: C.Connection -> DatabaseExpr -> IO ()
211+executeDatabaseContextExpr conn expr = do
212+ res <- C.executeDatabaseContextExpr conn expr
213+ case res of
214+ Nothing -> return ()
215+ Just err -> throwIO (PersistError $ T.pack (show err))
216+
217+relVarName :: (PersistEntity record, PersistEntityBackend record ~ C.Connection)
218+ => record -> RelVarName
219+relVarName = unDBName . entityDB . entityDef . Just
220+
221+instance PersistField U.UUID where
222+ toPersistValue val = PersistText $ T.pack (U.toString val)
223+ fromPersistValue (PersistText uuidText) = case U.fromString $ T.unpack uuidText of
224+ Nothing -> Left "uuid text read failure"
225+ Just uuid -> Right uuid
226+ fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
227+