git.iko.soy/project-m36
on disk_format_proposal help sign in
project-m36/examples/blog.hs
218 lines 9.5 kB history raw
1-- a simple example of a blog schema
2{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
4import ProjectM36.Client
5import ProjectM36.Base
6import ProjectM36.Relation
7import ProjectM36.Tupleable
8import ProjectM36.Atom (relationForAtom)
9import ProjectM36.Tuple (atomForAttributeName)
11import Data.Either
12import GHC.Generics
13import Data.Binary
14import qualified Data.Text as T
15import qualified Data.Text.Lazy as TL
16import Data.Time.Clock
17import Data.Time.Calendar
18import Control.DeepSeq
19import Data.Proxy
20import Data.Monoid
21import Data.List
22import Control.Monad (when, forM_)
24import Web.Scotty as S
25import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea)
26import Text.Blaze.Html5.Attributes (name, href, type_, method, action, value)
27import Text.Blaze.Html.Renderer.Text
28import Control.Monad.IO.Class (liftIO)
29import Network.HTTP.Types.Status
30import Data.Time.Format
32--define your data types
33data Blog = Blog {
34 title :: T.Text,
35 entry :: T.Text,
36 stamp :: UTCTime,
37 category :: Category --note that this type is an algebraic data type
38 }
39 deriving (Generic, Show) --derive Generic so that Tupleable can use default instances
41--instantiate default Tupleable instances
42instance Tupleable Blog
44data Comment = Comment {
45 blogTitle :: T.Text,
46 commentTime :: UTCTime,
47 contents :: T.Text
48 } deriving (Generic, Show)
50instance Tupleable Comment
52data Category = Food | Cats | Photos | Other T.Text -- note that this data type could not be represented by an "enumeration" as found in SQL databases
53 deriving (Atomable, Eq, Show, NFData, Binary, Generic) -- derive Atomable so that values of this type can be stored as a database value
55-- add some short-hand error handling- your application should have proper handling
56handleIOError :: Show e => IO (Either e a) -> IO a
57handleIOError m = do
58 v <- m
59 handleError v
61handleError :: Show e => Either e a -> IO a
62handleError eErr = case eErr of
63 Left err -> print err >> error "Died due to errors."
64 Right v -> pure v
66handleIOErrors :: Show e => IO [Either e a] -> IO [a]
67handleIOErrors m = do
68 eErrs <- m
69 case lefts eErrs of
70 [] -> pure (rights eErrs)
71 err:_ -> handleError (Left err)
73main :: IO ()
74main = do
75 --connect to the database
76 let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
77 conn <- handleIOError $ connectProjectM36 connInfo
79 sessionId <- handleIOError $ createSessionAtHead conn "master"
81 createSchema sessionId conn
82 insertSampleData sessionId conn
83 --create the web routes
84 scotty 3000 $ do
85 S.get "/" (listBlogs sessionId conn)
86 S.get "/blog/:blogid" (showBlogEntry sessionId conn)
87 S.post "/comment" (addComment sessionId conn)
89--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them
90createSchema :: SessionId -> Connection -> IO ()
91createSchema sessionId conn = do
92 _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [
93 toAddTypeExpr (Proxy :: Proxy Category),
94 toDefineExpr (Proxy :: Proxy Blog) "blog",
95 toDefineExpr (Proxy :: Proxy Comment) "comment",
96 databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]),
97 databaseContextExprForUniqueKey "blog" ["title"]
98 ]
99 pure ()
101--create some sample values and insert them into the database's relation variables
102insertSampleData :: SessionId -> Connection -> IO ()
103insertSampleData sessionId conn = do
104 let blogs = [Blog { title = "Haskell Lenses",
105 entry = "I wear Haskell rose-colored lenses.",
106 stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),
107 category = Food },
108 Blog { title = "Haskell Monad Analogy",
109 entry = "Monads are like burritos going through intestines.",
110 stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),
111 category = Cats }
112 ]
113 comments = [Comment { blogTitle = "Haskell Lenses",
114 commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000),
115 contents = "You suck!" },
116 Comment {blogTitle = "Haskell Lenses",
117 commentTime = UTCTime (fromGregorian 2017 7 9) (secondsToDiffTime 2000),
118 contents = "I find your ideas intriguing and would like to subscribe to your newsletter."}
119 ]
120 insertBlogsExpr <- handleError $ toInsertExpr blogs "blog"
121 handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr
123 insertCommentsExpr <- handleError $ toInsertExpr comments "comment"
124 handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr
126-- handle relational errors with scotty
127handleWebError :: Either RelationalError a -> ActionM a
128handleWebError (Left err) = render500 (toHtml (show err)) >> pure (error "bad")
129handleWebError (Right v) = pure v
131-- show a page with all the blog entries
132listBlogs :: SessionId -> Connection -> ActionM ()
133listBlogs sessionId conn = do
134 eRel <- liftIO $ executeRelationalExpr sessionId conn (RelationVariable "blog" ())
135 case eRel of
136 Left err -> render500 (toHtml (show err))
137 Right blogRel -> do
138 blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]
139 let sortedBlogs = sortBy (\b1 b2 -> stamp b1 `compare` stamp b2) blogs
140 html . renderHtml $ do
141 h1 "Blog Posts"
142 forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog))
144render500 :: Html -> ActionM ()
145render500 msg = do
146 html . renderHtml $ do
147 h1 "Internal Server Error"
148 p msg
149 status internalServerError500
151--display one blog post along with its comments
152showBlogEntry :: SessionId -> Connection -> ActionM ()
153showBlogEntry sessionId conn = do
154 blogid <- param "blogid"
155 --query the database to return the blog entry with a relation-valued attribute of the associated comments
156 let blogRestrictionExpr = AttributeEqualityPredicate "title" (NakedAtomExpr (TextAtom blogid))
157 extendExpr = AttributeExtendTupleExpr "comments" (RelationAtomExpr commentsRestriction)
158 commentsRestriction = Restrict
159 (AttributeEqualityPredicate "blogTitle" (AttributeAtomExpr "title"))
160 (RelationVariable "comment" ())
161 eRel <- liftIO $ executeRelationalExpr sessionId conn (Extend extendExpr
162 (Restrict
163 blogRestrictionExpr
164 (RelationVariable "blog" ())))
165 let render = html . renderHtml
166 formatStamp = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))
167 case eRel of
168 Left err -> render500 (toHtml (show err))
169 --handle successful query execution
170 Right rel -> case singletonTuple rel of
171 Nothing -> do --no results for this blog id
172 render (h1 "No such blog post")
173 status status404
174 Just blogTuple -> case fromTuple blogTuple of --just one blog post found- it's a match!
175 Left err -> render500 (toHtml (show err))
176 Right blog -> do
177 --extract comments for the blog
178 commentsAtom <- handleWebError (atomForAttributeName "comments" blogTuple)
179 commentsRel <- handleWebError (relationForAtom commentsAtom)
180 comments <- liftIO (toList commentsRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Comment]
181 let commentsSorted = sortBy (\c1 c2 -> commentTime c1 `compare` commentTime c2) comments
182 render $ do
183 --show blog details
184 h1 (toHtml (title blog))
185 p (toHtml ("Posted at " <> formatStamp (stamp blog) <> " under " <> show (category blog)))
186 p (toHtml (entry blog))
187 hr
188 h3 "Comments"
189 --list the comments
190 forM_ commentsSorted $ \comment -> do
191 p (toHtml ("Commented at " <> formatStamp (commentTime comment)))
192 p (toHtml (contents comment))
193 when (null comments) (p "No comments.")
194 --add a comment form
195 h3 "Add a Comment"
196 form ! method "POST" ! action "/comment" $ do
197 input ! type_ "hidden" ! name "blogid" ! value (toValue blogid)
198 textarea ! name "contents" $ ""
199 input ! type_ "submit"
201--add a comment to a blog post
202addComment :: SessionId -> Connection -> ActionM ()
203addComment sessionId conn = do
204 blogid <- param "blogid"
205 commentText <- param "contents"
206 now <- liftIO getCurrentTime
208 case toInsertExpr [Comment {blogTitle = blogid,
209 commentTime = now,
210 contents = commentText }] "comment" of
211 Left err -> handleWebError (Left err)
212 Right insertExpr -> do
213 eRet <- liftIO (withTransaction sessionId conn (executeDatabaseContextExpr sessionId conn insertExpr) (commit sessionId conn))
214 case eRet of
215 Left err -> handleWebError (Left err)
216 Right _ ->
217 redirect (TL.fromStrict ("/blog/" <> blogid))