@@ -0,0 +1,478 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+{-# LANGUAGE DeriveAnyClass #-}
6+
7+{-# LANGUAGE DerivingVia #-}
8+
9+
10+import Codec.Winery (Serialise, WineryVariant(WineryVariant))
11+import Control.DeepSeq (NFData)
12+import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON))
13+import Data.Data (Proxy(Proxy))
14+import Data.Either (lefts, rights)
15+import Data.Functor (($>))
16+import Data.Text as T (Text)
17+import qualified Data.Text.Lazy as TL (pack)
18+import GHC.Generics (Generic)
19+import qualified ProjectM36.Base as Base
20+import ProjectM36.Client
21+ ( AtomExprBase(NakedAtomExpr)
22+ , Atomable(toAddTypeExpr, toAtom)
23+ , AttributeName
24+ , Connection
25+ , ConnectionInfo(InProcessConnectionInfo)
26+ , DatabaseContextExpr
27+ , DatabaseContextExprBase(Delete)
28+ , PersistenceStrategy(NoPersistence)
29+ , RelationalError
30+ , RelationalExprBase(RelationVariable, Restrict)
31+ , RestrictionPredicateExprBase(AttributeEqualityPredicate)
32+ , SessionId
33+ , close
34+ , commit
35+ , connectProjectM36
36+ , createSessionAtHead
37+ , databaseContextExprForUniqueKey
38+ , defaultHeadName
39+ , emptyNotificationCallback
40+ , executeDatabaseContextExpr
41+ , executeRelationalExpr
42+ , withTransaction
43+ )
44+import qualified ProjectM36.Relation as Relation
45+import ProjectM36.Tupleable
46+ ( Tupleable(fromTuple)
47+ , toDefineExpr
48+ , toDeleteExpr
49+ , toInsertExpr
50+ , toUpdateExpr
51+ )
52+import qualified System.Random as R
53+
54+
55+import Control.Monad.IO.Class (MonadIO(liftIO))
56+import qualified Web.Scotty as S
57+
58+-- | This is an example showcasing the updating of data
59+-- with the help of plants. \\
60+-- This is a very simple example and of course not how
61+-- plants grow in nature. \\
62+-- The main goal of this example is to showcas the updating
63+-- of data and the different options of persistance.
64+
65+
66+
67+-- | Here is a python script for pretty printing the output \
68+-- if you include the acii:
69+{-|
70+#!/usr/bin/python3
71+# this can be replaced with the path to your python executable
72+# this is a vary hacky script just for visualisation of the json response
73+import json
74+import sys
75+import re
76+
77+for line in sys.stdin:
78+ parsed = json.loads(line)
79+ jstr = json.dumps(parsed, indent=4, sort_keys=True)
80+ leng = len(re.findall(r"((?: )*\"stage\": \")", jstr)[0])
81+ l = jstr.encode('utf-8').decode('unicode_escape')
82+ ls = l.split("\n")
83+ res = ""
84+ for i in ls:
85+ if not re.match(r"(?: )*(?:{|\"\w|}|\[|\])", i):
86+ spaces = leng
87+ if re.match(r"(?: )*\",$", i):
88+ spaces -= 1
89+ i = " " * spaces + i
90+ res += i + "\n"
91+ print(res)
92+-}
93+-- Either you make it executable with chmod +x scriptfilename or you \
94+-- execute it with python3 scriptfilename. \
95+-- Either way you then can use it to prettyprint when making a request. \
96+-- You can just pipe the putput form culr for eamxple into this command:
97+--
98+-- curl -X POST -H 'Accept: application/json' localhost:8001/plant/water/angu | python3 scriptfilename
99+
100+
101+data Stage = Seed | Sprout | Seedling | Adult | Dead
102+ deriving (Show, Eq, Ord, Generic, NFData, Atomable)
103+ deriving Serialise via WineryVariant Stage
104+
105+
106+instance ToJSON Stage where -- The where can be removed and the implementation commented out
107+ -- if the ascii values are not wanted
108+ toJSON s = toJSON $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s
109+
110+ toEncoding s = toEncoding $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s
111+
112+instance FromJSON Stage
113+
114+instance S.Parsable Stage where
115+ parseParam t
116+ | t == "seed" || t == "Seed" = Right Seed
117+ | t == "sprout" || t == "Sprout" = Right Sprout
118+ | t == "seedling" || t == "Seedling" = Right Seedling
119+ | t == "adult" || t == "Adult" = Right Adult
120+ | t == "dead" || t == "Dead" = Right Dead
121+ | otherwise = Left t
122+
123+
124+-- Just for ToJSON for ilustration of stage
125+type ASCIIStage = String
126+
127+seedStr :: ASCIIStage
128+seedStr = "<>\n\
129+ \'''\n"
130+sproutStr :: ASCIIStage
131+sproutStr = " ..\n\
132+ \<|>\n\
133+ \''''\n"
134+seedlingStr :: ASCIIStage
135+seedlingStr = " `\\⁄o \n\
136+ \ v|/\n\
137+ \'´;'''\n"
138+adultStr :: ASCIIStage
139+adultStr = "*~(#)~\n\
140+ \ \\,Y,e\n\
141+ \ \\|/\n\
142+ \''+'\\''\n"
143+deadStr :: ASCIIStage
144+deadStr = " ,__:<\n\
145+ \'/'''''\n"
146+
147+-- Just used for ToJSON illustration of stages
148+stagetoAscii :: Stage -> ASCIIStage
149+stagetoAscii Seed = seedStr
150+stagetoAscii Sprout = sproutStr
151+stagetoAscii Seedling = seedlingStr
152+stagetoAscii Adult = adultStr
153+stagetoAscii Dead = deadStr
154+
155+-- used for update stage
156+next :: Stage -> Stage
157+next Seed = Sprout
158+next Sprout = Seedling
159+next Seedling = Adult
160+next s = s
161+
162+data Plant = Plant { name :: Text, species :: Text, stage :: Stage, waterings:: Integer } deriving (Show, Generic)
163+instance Tupleable Plant
164+instance ToJSON Plant
165+instance FromJSON Plant
166+
167+
168+main :: IO ()
169+main = do
170+ putStrLn "Connecting to plant farm"
171+ c <- dbConnection
172+ _ <- createSchema c
173+ putStrLn "Planting some plants"
174+ _ <- insertSampleData c
175+ let port = 8001
176+ putStrLn $ "Started Plant farm at " <> show port
177+ S.scotty port $ do
178+
179+ -- retive a plant by name
180+ S.get "/plant/:name" $ do
181+ n <- S.param "name"
182+ e <- liftIO $ getPlant c n
183+ p <- handleWebError e
184+ S.json p
185+
186+
187+ -- save a plant providing it as json data
188+ S.post "/plant" $ do
189+ pl <- S.jsonData :: S.ActionM Plant
190+ e <- liftIO $ savePlant c [pl]
191+ p <- handleWebError e
192+ S.json p
193+
194+ -- updating a plant providing it as json data
195+ S.put "/plant" $ do
196+ pl <- S.jsonData :: S.ActionM Plant
197+ e <- liftIO $ updatePlantFst c pl
198+ p <- handleWebError e
199+ S.json p
200+
201+ -- watering the plant having the provided name.
202+ -- This will water the plant and migth let it progress to the next stage. It might also die.
203+ S.post "/plant/water/:name" $ do
204+ n <- S.param "name"
205+ e <- liftIO $ waterPlant c n
206+ p <- handleWebError e
207+ S.json p
208+
209+ -- retriving all the plants as json data
210+ S.get "/plants" $ do
211+ e <- liftIO $ getAllPlants c
212+ ps <- handleWebErrors e
213+ S.json ps
214+
215+ -- saving many plants at the same time
216+ S.post "/plants" $ do
217+ pl <- S.jsonData :: S.ActionM [Plant]
218+ e <- liftIO $ savePlant c pl
219+ p <- handleWebError e
220+ S.json p
221+
222+ -- deleting all plants at a speciffic stage
223+ S.delete "/plants?stage=:stage" $ do
224+ s <- S.param "stage"
225+ e <- liftIO $ deletePlantsByStage c s
226+ p <- handleWebError e
227+ S.json p
228+
229+ -- deleting all plants at a speciffic stage
230+ S.delete "/plants" $ do
231+ s <- S.param "name"
232+ e <- liftIO $ deletePlantByName c s
233+ p <- handleWebError e
234+ S.json p
235+
236+ -- deleting all dead plants
237+ S.delete "/plants/clear" $ do
238+ e <- liftIO $ clearDeadPlants c
239+ ps <- handleWebErrors e
240+ S.json ps
241+
242+handleWebError :: Either Err b -> S.ActionM b
243+handleWebError (Left e) = S.raise (TL.pack $ "An error Orrcured:\n" <> show e)
244+handleWebError (Right v) = pure v
245+
246+handleWebErrors :: [Either Err b] -> S.ActionM [b]
247+handleWebErrors e = do
248+ case lefts e of
249+ [] -> pure (rights e)
250+ l -> S.raise (TL.pack $ "Errors Orrcured:\n" <> concatMap ((<>"\n") . show)l)
251+
252+
253+-- | watering a plant and therby possibly updating its stage
254+waterPlant :: DBConnection -> Text -> IO (Either Err Plant)
255+waterPlant db n = do
256+ p <- getPlant db n
257+ case p of
258+ Left e -> pure $ Left e
259+ Right v -> updateStage db $ v { waterings = waterings v + 1 }
260+
261+-- | used by 'waterPlant' updates the stage depending on random numbers
262+updateStage :: DBConnection -> Plant -> IO (Either Err Plant)
263+updateStage db p@(Plant _ _ Dead _ ) = do
264+ tmp <- updatePlantFst db p
265+ case tmp of
266+ Left e -> pure $ Left e
267+ Right _ -> pure $ Right p
268+updateStage db p = do
269+ res <- calculateStage p
270+ tmp <- updatePlantFst db res
271+ case tmp of
272+ Left e -> pure $ Left e
273+ Right _ -> pure $ Right res
274+ where calculateStage p = do
275+ r1 <- R.randomRIO (1, 10) :: IO Integer
276+ let np = if r1 < waterings p then p { stage = next $ stage p, waterings = 0 } else p
277+ r2 <- R.randomRIO (1, 20)
278+ pure $ if r2 < waterings np then np { stage = Dead, waterings = 0 } else np
279+
280+-- | deletes all plants with Stage = Dead
281+clearDeadPlants :: DBConnection -> IO [Either Err Plant]
282+clearDeadPlants db = do
283+ _ <- deletePlantsByStage db Dead
284+ getAllPlants db
285+
286+
287+-- ****************************
288+-- | *Database functions* :
289+-- ****************************
290+
291+
292+-- | Error type for passing. It is not very specific.
293+-- Just minimal and non optimal for this example.
294+data Err = NotSpecified | NotFound deriving (Show ,Generic)
295+
296+instance ToJSON Err
297+
298+-- | Just for convinience for passing around the SessionId
299+-- and the Connection
300+data DBConnection = DB SessionId Connection
301+
302+
303+-- | Getting plants by their name.\
304+-- Because plant has name as primary key \
305+-- we can assume will get at most one result. \
306+-- Alternatively we could return a list.
307+getPlant :: DBConnection -> Text -> IO (Either Err Plant)
308+getPlant db n = defaultHead (Left NotFound) <$> (
309+ get db
310+ ( Restrict -- Restrict can be thought of as similar to "WITH" in SQL
311+ (AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom n))) -- This is the Predicate we are "restricting" our RelationalExprBase with
312+ (RelationVariable "plants" ())
313+ )
314+ :: IO [Either Err Plant] -- this is needed because our 'get' function is
315+ )
316+
317+defaultHead :: a -> [a] -> a
318+defaultHead d [] = d
319+defaultHead _ (x:_) = x
320+
321+-- | Getting all the plants
322+getAllPlants :: DBConnection -> IO [Either Err Plant]
323+getAllPlants db = get db (RelationVariable "plants" ())
324+
325+-- | Getting all the plants that satisfy the restrictions
326+getAllPlantsWith :: DBConnection -> Base.RestrictionPredicateExpr -> IO [Either Err Plant]
327+getAllPlantsWith db ex = get db (Restrict ex (RelationVariable "plants" ()))
328+
329+
330+-- | Saving a plant
331+savePlant :: (Traversable t) => DBConnection -> t Plant -> IO (Either Err ())
332+savePlant db sps = insert db sps "plants"
333+
334+-- | An alternative to update alone because due to updates
335+-- not being cached yet \
336+-- they have to be calculated every update. \
337+-- This seems like an alternative until caching is implemented.
338+updatePlantFst :: DBConnection -> Plant -> IO (Either Err ())
339+updatePlantFst db pln = do
340+ _ <- delete db pln ["name"] "plants"
341+ savePlant db [pln]
342+
343+-- | Updating a plant. Due to the way project 36 works, \
344+-- updates have to be executed every time.\
345+-- This is slow but won't be an issue soon because they will
346+-- be cached.\
347+-- But because of this project 36 can provide O(1) commits.
348+updatePlant :: DBConnection -> Plant -> IO (Either Err ())
349+updatePlant db sps = update
350+ db -- db connection
351+ sps -- plant value
352+ ["name"] -- the attributes to be updated by (in case of unique key)
353+ "plants" -- the relation we want to update on
354+
355+
356+-- | deleting all plants that have given name.
357+deletePlantByName :: DBConnection -> Text -> IO (Either Err ())
358+deletePlantByName db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom s))
359+
360+-- | deleting all plants that have given stage.
361+deletePlantsByStage :: DBConnection -> Stage -> IO (Either Err ())
362+deletePlantsByStage db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "stage" (NakedAtomExpr (toAtom s))
363+
364+
365+-- | Inserting the schema into the DB
366+createSchema :: DBConnection -> IO ()
367+createSchema (DB sessionId conn) = do
368+ _ <- handleIOErrorsAndQuit $ mapM (executeDatabaseContextExpr sessionId conn) [
369+ toAddTypeExpr (Proxy :: Proxy Stage) -- Adds the Type Stage as data to the DB
370+ , toDefineExpr (Proxy :: Proxy Plant) "plants" -- Creates the plants relation
371+ , databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a uniqe Key,
372+ -- Foreign Key restrictions are available too
373+ ]
374+ pure ()
375+
376+
377+-- | inserting some sample data
378+insertSampleData :: DBConnection -> IO (Either Err ())
379+insertSampleData (DB sid conn) = do
380+ insert (DB sid conn) [
381+ Plant "angu" "Caladenia angustata" Seed 0
382+ , Plant "thely" "Thelymitra alcockiae" Seed 0
383+ , Plant "monstera" "Araceae" Seed 0
384+ ] "plants"
385+
386+dbConnection :: IO DBConnection
387+dbConnection = do
388+ -- connect to the database
389+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
390+ -- The code below persists the data in a DB with the name "base". \\
391+-- let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\
392+ -- In addition minimal persistance is available. \\
393+-- let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback []
394+ conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo
395+ --create a database session at the default branch of the database
396+ sessionId <- handleIOErrorAndQuit $ createSessionAtHead conn defaultHeadName
397+ pure (DB sessionId conn)
398+
399+
400+-- | A polymorphic function to insert data (a traversable of data) into the DB
401+insert :: (Tupleable a, Traversable t) => DBConnection -> t a -> Base.RelVarName -> IO (Either Err ())
402+insert db rlv rlvName = executeWithTransaction db $ toInsertExpr rlv rlvName
403+
404+-- | A polymorphic function to update data in the DB.
405+-- An update in one funtion would take:
406+--
407+-- - SessionId
408+-- - Connection
409+-- - Tuplable a -- the Tuplable you want to update
410+-- - [AttributeName] -- the Attributes of the Tuplable you want to update those are of StringType
411+-- - RelVarName -- the name of the relation
412+--
413+-- With that you can via 'toUpdateExpr' create a 'DatabaseContextExpr' to be executed. \\
414+-- For inserting its very similarly done with 'toInsertExpr'.
415+update :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())
416+update db rlv attr rlvName = executeWithTransaction db $ toUpdateExpr rlvName attr rlv
417+
418+-- | A polymorphic function to delete data in the DB
419+delete :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())
420+delete db rlv attr rlvName = executeWithTransaction db $ toDeleteExpr rlvName attr rlv
421+
422+-- | A convinience function to make executing DBContextExpr with commiting simpler. \\
423+-- In particular for expr that just insert, delete and update.
424+-- Therefor ultimately return Either _ ()
425+executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ())
426+executeWithTransaction (DB sid conn) expr = do
427+ iEx <- handleError expr
428+ case iEx of
429+ Left e -> pure $ Left e
430+ Right v -> handleIOError $ withTransaction sid conn (executeDatabaseContextExpr sid conn v) (commit sid conn)
431+
432+-- | A polymorphic function to get data (a list of data and possibly errors) from the DB
433+get :: Tupleable b => DBConnection -> Base.RelationalExpr -> IO [Either Err b]
434+get (DB sessionId conn) q = do
435+ eRel <- executeRelationalExpr sessionId conn q
436+ e <- handleError eRel
437+ case e of
438+ Left err -> pure [Left err]
439+ Right pRel -> do
440+ ws <- Relation.toList pRel
441+ mapM (handleError . fromTuple) ws
442+
443+-- | for closing the DB connection.
444+-- Not really needed when using in-memory DB
445+closeConn :: DBConnection -> IO ()
446+closeConn (DB _ conn) = close conn
447+
448+
449+-- | Error handling is heavily inspired by 'blog.hs' the blog example \\
450+-- by (agentm)[https://github.com/agentm] (https://github.com/agentm/project-m36, commit: f8432522adaafeae7c32bc2b8b6cb09c00396fc6). \\
451+-- As stated there your application should have propper error handling.
452+handleIOErrorAndQuit :: Show e => IO (Either e a) -> IO a
453+handleIOErrorAndQuit m = do
454+ v <- m
455+ handleErrorAndQuit v
456+
457+handleError :: Show e => Either e a -> IO (Either Err a)
458+handleError eErr = case eErr of
459+ Left err -> print err $> Left NotSpecified
460+ Right v -> pure $ Right v
461+
462+handleIOError :: Show e => IO (Either e a) -> IO (Either Err a)
463+handleIOError m = do
464+ v <- m
465+ handleError v
466+
467+handleErrorAndQuit :: Show e => Either e a -> IO a
468+handleErrorAndQuit eErr = case eErr of
469+ Left err -> print err >> error "Quit."
470+ Right v -> pure v
471+
472+handleIOErrorsAndQuit :: Show e => IO [Either e a] -> IO [a]
473+handleIOErrorsAndQuit m = do
474+ eErrs <- m
475+ case lefts eErrs of
476+ [] -> pure (rights eErrs)
477+ err:_ -> handleErrorAndQuit (Left err)
478+