Toward an executable

aggreact.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 2f996683b334732c7c907582b5ed809106726926753941072b6a9edab56229c5
+-- hash: a1ac6adc85594bcb24c0862b8aa2efd0aef6579e4ab183263e137cbdfeef1dfe
 
 name:           aggreact
 version:        0.1.0.0
@@ -39,6 +39,7 @@ library
       acid-state
     , aeson
     , base >=4.8 && <5
+    , blaze-html
     , cereal
     , cereal-text
     , cereal-time
@@ -47,10 +48,13 @@ library
     , protolude
     , safecopy
     , servant
+    , servant-blaze
     , servant-server
     , text
     , time
     , uuid
+    , wai
+    , warp
   default-language: Haskell2010
 
 executable aggreact

package.yaml

@@ -29,6 +29,7 @@ library:
   dependencies:
   - aeson
   - acid-state
+  - blaze-html
   - cereal
   - cereal-text
   - cereal-time
@@ -36,10 +37,13 @@ library:
   - ixset
   - safecopy
   - servant
+  - servant-blaze
   - servant-server
   - text
   - time
   - uuid
+  - wai
+  - warp
 executables:
   aggreact:
     main: Main.hs

src-exe/Main.hs

@@ -1,6 +1,8 @@
 import           Protolude
 
-import           Aggreact  (inc)
+import           Aggreact  (mainServe,Conf(..))
+import           Aggreact  (mainServe)
 
 main :: IO ()
-main = print (inc 41)
+main = do
+  mainServe db (Conf 3000)

src/Aggreact.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE DataKinds     #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE Strict        #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE Strict               #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 {- |
 Module      : Aggreact
@@ -23,14 +25,29 @@ module Aggreact
 
 import           Protolude
 
-import Aggreact.Comments
+import           Aggreact.Comments
 
-import           Servant.API
+import           Network.Wai              (Application)
+import qualified Network.Wai.Handler.Warp as Warp
+import           Servant
+import           Servant.HTML.Blaze
 
 type CommentAPI =
-  "comments" :> Capture "stub" Text :> Get '[JSON] Comments
+  "comments" :> Capture "slug" Text :> Get '[HTML] Comments
 
-data Conf = Conf { port :: Int16 }
+data Conf = Conf { port :: Int }
 
-mainServe :: Conf -> IO ()
-mainServe = undefined
+showComments :: DB Comments -> Text -> Handler Comments
+showComments db = liftIO . getCommentsBySlug db . Slug
+
+api :: Proxy CommentAPI
+api = Proxy
+
+server :: DB Comments -> Server CommentAPI
+server db = showComments db
+
+app :: DB Comments -> Application
+app db = serve api (server db)
+
+mainServe :: DB Comments -> Conf -> IO ()
+mainServe db conf = Warp.run (port conf) (app db)

src/Aggreact/Comments.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveDataTypeable   #-}
@@ -28,16 +29,23 @@ module Aggreact.Comments
     Id (..)
   , Comment (..)
   , Comments
+  , Slug (..)
+  , ParentId (..)
+  , UserId (..)
+  , DB
     -- * Operations
   , initialComments
   , createNewComment
+  , getCommentsBySlug
+  , getCommentsByParentId
   ) where
 
 import           Protolude                 hiding (get, put)
 
 import qualified Control.Exception         as Ex
+import           Data.Acid                 (AcidState, Query, Update,
+                                            makeAcidic)
 import qualified Data.Acid                 as Acid
-import           Data.Acid                 (Query, Update, makeAcidic, AcidState)
 import           Data.Aeson                (FromJSON, ToJSON)
 import           Data.Char                 (isAlphaNum)
 import           Data.Data                 (Data (..))
@@ -51,7 +59,9 @@ import           Data.Time.Clock.Serialize ()
 import           Data.Typeable             (Typeable)
 import           Data.UUID                 (UUID)
 import qualified Data.UUID                 as UUID
-import qualified Data.UUID.V4              as UUID
+import qualified Data.UUID.V4              as UUIDV4
+
+import qualified Text.Blaze.Html5          as H
 
 -- * Comments
 
@@ -83,7 +93,7 @@ deriving instance FromJSON  Id
 deriving instance ToJSON    Id
 deriving instance Serialize Id
 
-newtype ParentId = ParentId UUID deriving (Eq,Ord,Generic,Data)
+newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Generic,Data)
 deriving instance FromJSON  ParentId
 deriving instance ToJSON    ParentId
 deriving instance Serialize ParentId
@@ -102,6 +112,8 @@ newtype Content  = Content Text   deriving (Eq,Ord,Generic,Data)
 deriving instance FromJSON  Content
 deriving instance ToJSON    Content
 deriving instance Serialize Content
+instance StringConv Content Text where
+  strConv l (Content t) = strConv l t
 
 newtype Term     = Term Text      deriving (Eq,Ord,Generic)
 
@@ -155,15 +167,15 @@ commentById cid = do
   comments <- ask
   return (IxSet.getOne (comments IxSet.@= cid))
 
-commentsByParentId :: ParentId -> Query Comments [Comment]
+commentsByParentId :: ParentId -> Query Comments Comments
 commentsByParentId pid = do
   comments <- ask
-  return (IxSet.toList (comments IxSet.@= pid))
+  return (comments IxSet.@= pid)
 
-commentsBySlug :: Slug -> Query Comments [Comment]
+commentsBySlug :: Slug -> Query Comments Comments
 commentsBySlug rid = do
   comments <- ask
-  return (IxSet.toList (comments IxSet.@= rid))
+  return (comments IxSet.@= rid)
 
 $(makeAcidic ''Comments [ 'createComment
                         , 'updateComment
@@ -178,8 +190,29 @@ type DB a = AcidState a
 
 createNewComment :: DB Comments -> ParentId -> Slug -> UserId -> Content -> IO Comment
 createNewComment db pid s uid txt = do
-  newId <- fmap Id UUID.nextRandom
+  newId <- fmap Id UUIDV4.nextRandom
   now <- getCurrentTime
   let newComment = Comment newId pid s now txt uid
   Acid.update db (UpdateComment newComment)
   return newComment
+
+getCommentsBySlug :: DB Comments -> Slug -> IO Comments
+getCommentsBySlug db s = Acid.query db (CommentsBySlug s)
+
+getCommentsByParentId :: DB Comments -> ParentId -> IO Comments
+getCommentsByParentId db s = Acid.query db (CommentsByParentId s)
+
+instance H.ToMarkup Comments where
+  toMarkup comments = do
+    let roots = comments IxSet.@= ParentId Nothing
+    H.ul $ traverse_ (showChildren comments) (IxSet.toList roots)
+    where
+      -- showChildren :: Comments -> Comment -> _
+      showChildren cs comment =
+        H.li $ do
+          H.div (H.text (toS (content comment)))
+          let children = cs IxSet.@= id comment
+          if IxSet.null children
+            then return ()
+            else H.ul $ traverse_ (showChildren cs) (IxSet.toList children)
+