@@ -2,8 +2,11 @@
22{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}
33
44import ProjectM36.Client
5+import ProjectM36.Base
56import ProjectM36.Relation
67import ProjectM36.Tupleable
8+import ProjectM36.Atom (relationForAtom)
9+import ProjectM36.Tuple (atomForAttributeName)
710
811import Data.Either
912import GHC.Generics
@@ -13,10 +16,22 @@ import Data.Time.Clock
1316import Data.Time.Calendar
1417import Control.DeepSeq
1518import Data.Proxy
19+import Data.Monoid
20+import Data.List
21+import Control.Monad (when)
22+
23+import Web.Scotty as S
24+import qualified Text.Blaze.Html5 as H
25+import qualified Text.Blaze.Html5.Attributes as A
26+import Text.Blaze.Html.Renderer.Text
27+import Control.Monad.IO.Class (liftIO)
28+import Network.HTTP.Types.Status
29+import Data.Time.Format
1630
1731--define your data types
1832data Blog = Blog {
1933 title :: T.Text,
34+ entry :: T.Text,
2035 stamp :: UTCTime,
2136 category :: Category --note that this type is an algebraic data type
2237 }
@@ -64,7 +79,10 @@ main = do
6479
6580 createSchema sessionId conn
6681 insertSampleData sessionId conn
67− executeSampleQueries sessionId conn
82+ --executeSampleQueries sessionId conn
83+ scotty 3000 $ do
84+ S.get "/" (listBlogs sessionId conn)
85+ S.get "/blog/:blogid" (showBlogEntry sessionId conn)
6886
6987--define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them
7088createSchema :: SessionId -> Connection -> IO ()
@@ -79,16 +97,22 @@ createSchema sessionId conn = do
7997--create some sample values and insert them into the database's relation variables
8098insertSampleData :: SessionId -> Connection -> IO ()
8199insertSampleData sessionId conn = do
82− let blogs = [Blog { title = "Eat More Tofu",
100+ let blogs = [Blog { title = "Haskell Lenses",
101+ entry = "I wear Haskell rose-colored lenses.",
83102 stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),
84103 category = Food },
85− Blog { title = "Cat Falls Off Table",
104+ Blog { title = "Haskell Monad Analogy",
105+ entry = "Monads are like burritos going through intestines.",
86106 stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),
87107 category = Cats }
88108 ]
89− comments = [Comment { blogTitle = "Cat Falls Off Table",
109+ comments = [Comment { blogTitle = "Haskell Lenses",
90110 commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000),
91− contents = "more cats please" }]
111+ contents = "You suck!" },
112+ Comment {blogTitle = "Haskell Lenses",
113+ commentTime = UTCTime (fromGregorian 2017 7 9) (secondsToDiffTime 2000),
114+ contents = "I find your ideas intriguing and would like to subscribe to your newsletter."}
115+ ]
92116 insertBlogsExpr <- handleError $ toInsertExpr blogs "blog"
93117 handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr
94118
@@ -96,9 +120,75 @@ insertSampleData sessionId conn = do
96120 handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr
97121
98122--issue a query and marshal the data back to the original data value
123+{-
99124executeSampleQueries :: SessionId -> Connection -> IO ()
100125executeSampleQueries sessionId conn = do
101126 commentsRelation <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "comment" ())
102127
103128 comments <- toList commentsRelation >>= mapM (handleError . fromTuple) :: IO [Comment]
104129 print comments
130+-}
131+
132+handleWebError :: Either RelationalError a -> ActionM a
133+handleWebError (Left err) = render500 (H.toHtml (show err)) >> pure (error "bad")
134+handleWebError (Right v) = pure v
135+
136+listBlogs :: SessionId -> Connection -> ActionM ()
137+listBlogs sessionId conn = do
138+ eRel <- liftIO $ executeRelationalExpr sessionId conn (RelationVariable "blog" ())
139+ case eRel of
140+ Left err -> render500 (H.toHtml (show err))
141+ Right blogRel -> do
142+ blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]
143+ html . renderHtml $ do
144+ H.h1 "Blog Posts"
145+ mapM_ (\blog -> H.a H.! A.href (H.toValue $ "/blog/" <> title blog) $ H.h2 (H.toHtml (title blog))) blogs
146+
147+render500 :: H.Html -> ActionM ()
148+render500 msg = do
149+ html . renderHtml $ do
150+ H.h1 "Internal Server Error"
151+ H.p msg
152+ status internalServerError500
153+
154+showBlogEntry :: SessionId -> Connection -> ActionM ()
155+showBlogEntry sessionId conn = do
156+ blogid <- param "blogid"
157+ --query the database to return the blog entry with a relation-valued attribute of the associated comments
158+ let blogRestrictionExpr = AttributeEqualityPredicate "title" (NakedAtomExpr (TextAtom blogid))
159+ extendExpr = AttributeExtendTupleExpr "comments" (RelationAtomExpr commentsRestriction)
160+ commentsRestriction = Restrict
161+ (AttributeEqualityPredicate "blogTitle" (AttributeAtomExpr "title"))
162+ (RelationVariable "comment" ())
163+ eRel <- liftIO $ executeRelationalExpr sessionId conn (Extend extendExpr
164+ (Restrict
165+ blogRestrictionExpr
166+ (RelationVariable "blog" ())))
167+ let render = html . renderHtml
168+ formatStamp = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))
169+ case eRel of
170+ Left err -> render500 (H.toHtml (show err))
171+ --handle successful query execution
172+ Right rel -> case singletonTuple rel of
173+ Nothing -> do --no results for this blog id
174+ render (H.h1 "No such blog post")
175+ status status404
176+ Just blogTuple -> case fromTuple blogTuple of --just one blog post found- it's a match!
177+ Left err -> render500 (H.toHtml (show err))
178+ Right blog -> do
179+ --extract comments for the blog
180+ commentsAtom <- handleWebError (atomForAttributeName "comments" blogTuple)
181+ commentsRel <- handleWebError (relationForAtom commentsAtom)
182+ comments <- liftIO (toList commentsRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Comment]
183+ let commentsSorted = sortBy (\c1 c2 -> commentTime c1 `compare` commentTime c2) comments
184+ render $ do
185+ H.h1 (H.toHtml (title blog))
186+ H.p (H.toHtml ("Posted at " <> formatStamp (stamp blog)))
187+ H.p (H.toHtml (entry blog))
188+ H.hr
189+ H.h3 "Comments"
190+ mapM_ (\comment -> do
191+ H.p (H.toHtml ("Commented at " <> formatStamp (commentTime comment)))
192+ H.p (H.toHtml (contents comment))) commentsSorted
193+ when (length comments == 0) (H.p "No comments.")
194+