wip

src/Aggreact.hs

@@ -33,7 +33,9 @@ import           Aggreact.Css             (genCss)
 
 import           Clay                     (Css)
 import qualified Data.Acid                   as Acid
+import qualified Data.IxSet                  as IxSet
 import           Data.Time                (getCurrentTime)
+import qualified Data.UUID                   as UUID
 import           Network.Wai              (Application)
 import qualified Network.Wai.Handler.Warp as Warp
 import           Servant
@@ -45,6 +47,7 @@ type CommentAPI = Get '[HTML] Homepage
   :<|> "slugs" :> Get '[JSON] [Slug]
   :<|> "main.css" :> Get '[CSS] Css
   :<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> Post '[JSON] Comment
+  :<|> "comment" :> Capture "commentId" Text :> Get '[HTML,JSON] CommentPage
 
 data Conf = Conf { port :: Int
                  , dbcomments :: DB Comments }
@@ -55,6 +58,17 @@ showComments db s = do
   now <- liftIO getCurrentTime
   return CommentPage { url = s, viewTime = now, comments = cs }
 
+showComment :: DB Comments -> Text -> Handler CommentPage
+showComment db i = do
+  case UUID.fromText i of
+    Nothing -> throwError err404
+    Just uuid -> do
+      cs <- liftIO . getCommentById db . Id $ uuid
+      now <- liftIO getCurrentTime
+      case cs of
+        Just c -> return CommentPage { url = i, viewTime = now, comments = IxSet.fromList [c] }
+        _ -> throwError err404
+
 listSlugs :: DB Comments -> Handler [Slug]
 listSlugs = liftIO . slugs
 
@@ -68,6 +82,7 @@ server db =
   :<|> listSlugs db
   :<|> return genCss
   :<|> liftIO . createNewComment db
+  :<|> showComment db
 
 app :: DB Comments -> Application
 app db = serve api (server db)

src/Aggreact/Comments.hs

@@ -29,7 +29,7 @@ module Aggreact.Comments
     -- * Types
     Id (..)
   , Comment (..)
-  , CommentPage (..)
+  , CommentsPage (..)
   , NewComment (..)
   , Comments
   , Slug (..)
@@ -43,6 +43,7 @@ module Aggreact.Comments
   , slugs
   , getCommentsBySlug
   , getCommentsByParentId
+  , getCommentById
     -- * HTML
   , boilerplate
   ) where
@@ -249,6 +250,9 @@ createNewComment db (NewComment pid s txt uid) = do
 slugs :: DB Comments -> IO [Slug]
 slugs db = Acid.query db GetSlugs
 
+getCommentById :: DB Comments -> Id -> IO (Maybe Comment)
+getCommentById db i = Acid.query db (CommentById i)
+
 getCommentsBySlug :: DB Comments -> Slug -> IO Comments
 getCommentsBySlug db s = Acid.query db (CommentsBySlug s)
 
@@ -265,62 +269,57 @@ boilerplate innerHtml =
       H.h1 "Aggreact"
       innerHtml
       H.hr
-      H.div $ do
+      H.div $
-        H.text "<<<~o~ Aggreact ~o~>>>"
+        H.code "Aggreact"
 
-data CommentPage =
+data CommentsPage =
-  CommentPage
+  CommentsPage
   { url      :: Text
   , viewTime :: UTCTime
   , comments :: Comments
   }
 
-instance ToJSON CommentPage where
+instance ToJSON CommentsPage where
   toJSON cp = toJSON (comments cp)
 
-instance H.ToMarkup CommentPage where
+instance H.ToMarkup CommentsPage where
-  toMarkup CommentPage {..} = do
+  toMarkup cp@CommentsPage {..} = do
     let roots = comments IxSet.@= ParentId Nothing
     boilerplate $ do
-      H.h2 $
+      H.h2 $ H.a H.! A.href (fromString (toS url)) $ H.text url
-        H.a H.! A.href (fromString (toS url)) $ H.text url
+      commentForm url "anonymous coward" ""
-      H.form H.! A.action "/comments" H.! A.method "post" $ do
+      H.ul $ traverse_ (showChildren comments (viewTime cp)) (IxSet.toList roots)
-        -- H.label "userid"
+
-        H.input H.! A.type_ "hidden" H.! A.name "userid" H.! A.value "user-001"
+fromId (Id x) = x
-        -- H.br
+fromUserId (UserId x) = x
-        -- H.label "parent"
+
-        H.input H.! A.type_ "hidden" H.! A.name "parent"
+commentForm slug user parent =
-        -- H.br
+  H.form H.! A.action "/comments" H.! A.method "post" $ do
-        -- H.label "slug"
+    H.input H.! A.type_ "hidden" H.! A.name "userid" H.! A.value user
-        H.input H.! A.type_ "hidden" H.! A.name "slug" H.! A.value (fromString (toS url))
+    H.input H.! A.type_ "hidden" H.! A.name "parent" H.! A.value parent
-        -- H.br
+    H.input H.! A.type_ "hidden" H.! A.name "slug" H.! A.value (fromString (toS slug))
-        -- H.label "content"
+    (H.textarea H.! A.name "content" H.! A.rows "6" H.! A.cols "60") ""
-        -- H.br
+    H.br
-        (H.textarea H.! A.name "content" H.! A.rows "6" H.! A.cols "60") ""
+    H.input H.! A.type_ "submit" H.! A.value "add comment"
-        H.br
+
-        H.input H.! A.type_ "submit" H.! A.value "add comment"
+showChildren cs vt comment =
-      H.ul $ traverse_ (showChildren comments) (IxSet.toList roots)
+  H.li $ do
-    where
+    displayComment comment vt
-      fromId (Id x) = x
+    let children = cs IxSet.@= ParentId (Just (fromId (id comment)))
-      fromUserId (UserId x) = x
+    if IxSet.null children
-      -- showChildren :: Comments -> Comment -> _
+      then return ()
-      showChildren cs comment =
+      else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children)
-        H.li $ do
+
-          displayComment comment
+displayComment comment vt = do
-          let children = cs IxSet.@= ParentId (Just (fromId (id comment)))
+  let cid = UUID.toString (fromId (id comment))
-          if IxSet.null children
+  H.div H.! A.id (fromString cid) H.! A.class_ "metas" $ do
-            then return ()
+      H.a H.! A.href (fromString ('#':cid)) $ "§ "
-            else H.ul $ traverse_ (showChildren cs) (IxSet.toList children)
+      H.text (fromUserId (userid comment))
-      displayComment comment = do
+      H.span H.! A.class_ "time" $ do
-        let cid = UUID.toString (fromId (id comment))
+        H.text " - "
-        H.div H.! A.id (fromString cid) H.! A.class_ "metas" $ do
+        H.text $ toS . humanReadableDuration . realToFrac . diffUTCTime vt (created comment)
-            H.a H.! A.href (fromString ('#':cid)) $ "§ "
+        H.text " ago"
-            H.text (fromUserId (userid comment))
+  H.pre $ H.text (toS (content comment))
-            H.span H.! A.class_ "time" $ do
-              H.text " - "
-              H.text . toS . humanReadableDuration . realToFrac . diffUTCTime viewTime . created $ comment
-              H.text " ago"
-        H.pre $ H.text (toS (content comment))
 
 
 data DBConf = DBConf { filePath :: FilePath }

src/Aggreact/Css.hs

@@ -1,5 +1,6 @@
 module Aggreact.Css where
 
+import Protolude
 import Clay
 
 yBorderColor :: Color
@@ -8,6 +9,40 @@ yBorderColor = grey
 accentColor :: Color
 accentColor = orange
 
+solyellow    :: Color
+solyellow    = rgb 181 137   0
+solorange    :: Color
+solorange    = rgb 203  75  22
+solred       :: Color
+solred       = rgb 220  50  47
+solmagenta   :: Color
+solmagenta   = rgb 211  54 130
+solviolet    :: Color
+solviolet    = rgb 108 113 196
+solblue      :: Color
+solblue      = rgb  38 139 210
+solcyan      :: Color
+solcyan      = rgb  42 161 152
+solgreen     :: Color
+solgreen     = rgb 133 153   0
+
+base03    :: Color
+base03    = rgb   0  43  54
+base02    :: Color
+base02    = rgb   7  54  66
+base01    :: Color
+base01    = rgb  88 110 117
+base00    :: Color
+base00    = rgb 101 123 131
+base0     :: Color
+base0     = rgb 131 148 150
+base1     :: Color
+base1     = rgb 147 161 161
+base2     :: Color
+base2     = rgb 238 232 213
+base3     :: Color
+base3     = rgb 253 246 227
+
 genCss :: Css
 genCss = do
   body ? do
@@ -17,8 +52,30 @@ genCss = do
     maxWidth (px 800)
     lineHeight (em 1.5)
     margin (px 0) auto (px 0) auto
-    borderLeft solid (em 1) yBorderColor
+    -- borderLeft solid (em 1) yBorderColor
     paddingLeft (em 1)
+    paddingTop (em 1)
+    paddingBottom (em 1)
+    color (rgb 64 64 64)
+  forM_ [h1,h2,h3,h4,h5,h6] $ \x ->
+    x ? do
+      fontWeight bold
+      fontSize (em 1)
+  h1 ? color solyellow
+  h1 # before ? content (stringContent "# ")
+  h2 ? color solorange
+  h2 # before ? content (stringContent "## ")
+  h3 ? color solred
+  h3 # before ? content (stringContent "### ")
+  h4 ? color solmagenta
+  h4 # before ? content (stringContent "#### ")
+  h5 ? color solviolet
+  h5 # before ? content (stringContent "##### ")
+  h6 ? color solblue
+  h6 # before ? content (stringContent "###### ")
+  a ? color solblue
+  a # visited ? color solviolet
+  a # hover ? color solorange
   label ? do
     minWidth (em 7)
     display inlineBlock
@@ -34,8 +91,7 @@ genCss = do
     marginTop (em 1)
     paddingLeft (em 2)
     marginLeft (px 0)
-  li ? do
+  li ? marginTop (em 1)
-    marginTop (em 1)
   ".metas" ? do
     fontSize (px 11)
     color grey