@@ -0,0 +1,103 @@
1+-- a simple example of a blog schema
2+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
3+
4+import ProjectM36.Client
5+import ProjectM36.Relation
6+import ProjectM36.Tupleable
7+
8+import Data.Either
9+import GHC.Generics
10+import Data.Binary
11+import qualified Data.Text as T
12+import Data.Time.Clock
13+import Data.Time.Calendar
14+import Control.DeepSeq
15+
16+--define your data types
17+data Blog = Blog {
18+ title :: T.Text,
19+ stamp :: UTCTime,
20+ category :: Category --note that this type is an algebraic data type
21+ }
22+ deriving (Generic, Show) --derive Generic so that Tupleable can use default instances
23+
24+--instantiate default Tupleable instances
25+instance Tupleable Blog
26+
27+data Comment = Comment {
28+ blogTitle :: T.Text,
29+ commentTime :: UTCTime,
30+ contents :: T.Text
31+ } deriving (Generic, Show)
32+
33+instance Tupleable Comment
34+
35+data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases
36+ deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value
37+
38+-- add some short-hand error handling- your application should have proper handling
39+handleIOError :: Show e => IO (Either e a) -> IO a
40+handleIOError m = do
41+ v <- m
42+ handleError v
43+
44+handleError :: Show e => Either e a -> IO a
45+handleError eErr = case eErr of
46+ Left err -> print err >> error "Died due to errors."
47+ Right v -> pure v
48+
49+handleIOErrors :: Show e => IO [Either e a] -> IO [a]
50+handleIOErrors m = do
51+ eErrs <- m
52+ case lefts eErrs of
53+ [] -> pure (rights eErrs)
54+ err:_ -> handleError (Left err)
55+
56+main :: IO ()
57+main = do
58+ --connect to the database
59+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
60+ conn <- handleIOError $ connectProjectM36 connInfo
61+
62+ sessionId <- handleIOError $ createSessionAtHead conn "master"
63+
64+ createSchema sessionId conn
65+ insertSampleData sessionId conn
66+ executeSampleQueries sessionId conn
67+
68+--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them
69+createSchema :: SessionId -> Connection -> IO ()
70+createSchema sessionId conn = do
71+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [
72+ toAddTypeExpr (undefined :: Category),
73+ toDefineExpr (undefined :: Blog) "blog",
74+ toDefineExpr (undefined :: Comment) "comment",
75+ databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ]
76+ pure ()
77+
78+--create some sample values and insert them into the database's relation variables
79+insertSampleData :: SessionId -> Connection -> IO ()
80+insertSampleData sessionId conn = do
81+ let blogs = [Blog { title = "Eat More Tofu",
82+ stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),
83+ category = Food },
84+ Blog { title = "Cat Falls Off Table",
85+ stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),
86+ category = Cats }
87+ ]
88+ comments = [Comment { blogTitle = "Cat Falls Off Table",
89+ commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000),
90+ contents = "more cats please" }]
91+ insertBlogsExpr <- handleError $ toInsertExpr blogs "blog"
92+ handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr
93+
94+ insertCommentsExpr <- handleError $ toInsertExpr comments "comment"
95+ handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr
96+
97+--issue a query and marshal the data back to the original data value
98+executeSampleQueries :: SessionId -> Connection -> IO ()
99+executeSampleQueries sessionId conn = do
100+ commentsRelation <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "comment" ())
101+
102+ comments <- toList commentsRelation >>= mapM (handleError . fromTuple) :: IO [Comment]
103+ print comments