git.iko.soy/project-m36
on master help sign in
WIP add PersistUnique instance with functioning getBy
69c578cAgentM
Database/Persist/ProjectM36.hs+89−8
compare with master
unifiedsplit
@@ -16,11 +16,15 @@ import Control.Monad.Trans.Reader (ask, ReaderT)
16import Control.Exception (throw, throwIO)
16import Control.Exception (throw, throwIO)
17import qualified Data.Text as T
17import qualified Data.Text as T
18import ProjectM36.Atom
18import ProjectM36.Atom
19−import Data.Aeson (FromJSON(..), ToJSON(..), withText)
19+import Data.Aeson (FromJSON(..), ToJSON(..), withText, withObject, (.:))
20import qualified Data.HashSet as HS
20import qualified Data.HashSet as HS
21import qualified Data.Map as M
21import qualified Data.Map as M
22import Control.Monad (when)
22import Control.Monad (when)
23import Data.Maybe (isJust)
23import 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
24
28
25type ProjectM36Backend = C.Connection
29type ProjectM36Backend = C.Connection
26
30
@@ -216,6 +220,9 @@ dummyFromKey = Just . recordTypeFromKey
216recordTypeFromKey :: Key record -> record
220recordTypeFromKey :: Key record -> record
217recordTypeFromKey _ = error "dummyFromKey"
221recordTypeFromKey _ = error "dummyFromKey"
218
222
223+dummyFromUnique :: Unique v -> Maybe v
224+dummyFromUnique _ = Nothing
225+
219keyToUUID:: (PersistEntity record) => Key record -> U.UUID
226keyToUUID:: (PersistEntity record) => Key record -> U.UUID
220keyToUUID key = case keyToValues key of
227keyToUUID key = case keyToValues key of
221 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
228 ([PersistText uuidText]) -> case U.fromString (T.unpack uuidText) of
@@ -278,13 +285,6 @@ relVarNameFromRecord :: (PersistEntity record, PersistEntityBackend record ~ C.C
278 => record -> RelVarName
285 => record -> RelVarName
279relVarNameFromRecord = unDBName . entityDB . entityDef . Just
286relVarNameFromRecord = unDBName . entityDB . entityDef . Just
280
287
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−
288{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
288{- unfortunately copy-pasted from Database.Persist.Sql.Orphan.PersistStore -}
289updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
289updateFieldDef :: PersistEntity v => DP.Update v -> FieldDef
290updateFieldDef (DP.Update f _ _) = persistFieldDef f
290updateFieldDef (DP.Update f _ _) = persistFieldDef f
@@ -293,3 +293,84 @@ updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect Backend
293updatePersistValue :: DP.Update v -> PersistValue
293updatePersistValue :: DP.Update v -> PersistValue
294updatePersistValue (DP.Update _ v _) = toPersistValue v
294updatePersistValue (DP.Update _ v _) = toPersistValue v
295updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate"
295updatePersistValue (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
ProjectM36/Base.hs+1−1
@@ -127,7 +127,7 @@ instance Hash.Hashable Relation where
127
127
128instance Binary Relation
128instance Binary Relation
129
129
130−data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic)
130+data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show, Generic, Ord)
131data RelationSizeInfinite = RelationSizeInfinite
131data RelationSizeInfinite = RelationSizeInfinite
132
132
133type RelVarName = StringType
133type RelVarName = StringType
project-m36.cabal+7−1
@@ -7,7 +7,7 @@ Category: Relational Algebra
7Cabal-Version: >= 1.2
7Cabal-Version: >= 1.2
8
8
9Library
9Library
10− Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava ==0.4.*,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale,attoparsec, persistent,persistent-sqlite,persistent-template,aeson
10+ Build-Depends: base,mtl,containers,unordered-containers,parsec,hashable,haskeline,directory,uuid,cassava ==0.4.*,text,bytestring,deepseq,deepseq-generics,vector,parallel,monad-parallel,transformers,gnuplot,binary,filepath,directory,vector-binary-instances,unix,temporary,stm,time,hashable-time,old-locale,attoparsec, persistent,persistent-template,aeson,path-pieces
11--required for persistent db driver
11--required for persistent db driver
12 Exposed-Modules: ProjectM36.Error,
12 Exposed-Modules: ProjectM36.Error,
13 ProjectM36.Transaction,
13 ProjectM36.Transaction,
@@ -101,6 +101,12 @@ Test-Suite test-relation-export-csv
101 Build-Depends: base,HUnit,Cabal
101 Build-Depends: base,HUnit,Cabal
102 GHC-Options: -Wall
102 GHC-Options: -Wall
103
103
104+Test-Suite test-persistent-driver
105+ type: exitcode-stdio-1.0
106+ main-is: test/persistent-driver/test.hs
107+ Build-Depends: base,HUnit,Cabal,template-haskell
108+ GHC-Options: -Wall
109+
104benchmark bench
110benchmark bench
105 type: exitcode-stdio-1.0
111 type: exitcode-stdio-1.0
106 main-is: benchmark/Relation.hs
112 main-is: benchmark/Relation.hs
test/persistent-driver/test.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE EmptyDataDecls #-}
6+{-# LANGUAGE TypeSynonymInstances #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+import Test.HUnit
11+import Database.Persist.ProjectM36
12+import ProjectM36.Base --shouldn't be here
13+import ProjectM36.Attribute --useful functions should be exported through the Client interface
14+import ProjectM36.Client
15+import qualified ProjectM36.Client as C
16+import System.Exit
17+import Database.Persist
18+import Database.Persist.TH
19+import Language.Haskell.TH.Syntax
20+import Control.Monad.Reader
21+
22+let projectM36PersistSettings = mkPersistSettings (ConT ''ProjectM36Backend)
23+ in
24+ share [mkPersist projectM36PersistSettings] [persistLowerCase|
25+Person
26+ name String Eq
27+ age Int
28+ UniqueName name
29+ deriving Show
30+|]
31+
32+testList :: Test
33+testList = TestList [testBasicInProcessConnection]
34+
35+main :: IO ()
36+main = do
37+ tcounts <- runTestTT testList
38+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
39+
40+testBasicInProcessConnection :: Test
41+testBasicInProcessConnection = TestCase $ do
42+ let connSettings = InProcessConnectionInfo NoPersistence
43+ withProjectM36Conn connSettings $ runProjectM36Conn $ do
44+ conn <- ask
45+ _ <- liftIO $ C.executeDatabaseContextExpr conn (Define "person" (attributesFromList [Attribute "name" StringAtomType, Attribute "age" IntAtomType, Attribute "id" StringAtomType]))
46+ m <- insert $ Person "Michael" 26
47+ michael <- getBy $ UniqueName "Michael"
48+ liftIO $ putStrLn (show michael)
49+ liftIO $ assertBool "poop" False
50+ return ()
51+