Fixed most details, made lot of raw entries
This commit is contained in:
Yann Esposito (Yogsototh)
parent
1bf856ea09
commit
5876ae4ace
GPG key ID:
7B19A4C650D59646
4 changed files with 124 additions and 66 deletions
|
|
@ -176,13 +176,20 @@ type CommentAPI = Get '[HTML] Homepage
|
|||
|
||||
handlers :: CommentHandler -> Server CommentAPI
|
||||
handlers h =
|
||||
Homepage <$> liftIO (getSlugs h)
|
||||
initHomepage h
|
||||
:<|> showComments h
|
||||
:<|> liftIO (getSlugs h)
|
||||
:<|> return genCss
|
||||
:<|> liftIO . createComment h
|
||||
:<|> showComment h
|
||||
|
||||
initHomepage :: CommentHandler -> Handler Homepage
|
||||
initHomepage h =
|
||||
liftIO $ Homepage <$> getLatestSlugs h
|
||||
<*> getTopSlugs h
|
||||
<*> getLatestComments h
|
||||
<*> getCurrentTime
|
||||
|
||||
showComments :: CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments CommentHandler{..} s = do
|
||||
(SR (Paginated cs _ _)) <- liftIO $
|
||||
|
|
|
|||
|
|
@ -54,11 +54,12 @@ module Aggreact.Comments
|
|||
, newCommentHandler
|
||||
, CommentHandler(..)
|
||||
-- * HTML
|
||||
, displayOneComment
|
||||
) where
|
||||
|
||||
import Protolude hiding (get, put)
|
||||
|
||||
import Aggreact.Html (boilerplate)
|
||||
import Aggreact.Html (boilerplate,urlEncode)
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||
|
|
@ -247,7 +248,7 @@ instance H.ToMarkup CommentPage where
|
|||
let sl = cp & commentPageComment & val & slug & unSlug
|
||||
cid = commentPageUrl cp
|
||||
H.h2 $ do
|
||||
H.a ! A.href ("/comments/" <> cvt sl <> "#" <> cvt cid) $ H.text "Comment"
|
||||
H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl)) <> "#" <> cvt cid) $ H.text "Comment"
|
||||
H.text " for "
|
||||
extlink sl sl
|
||||
displayComment (commentPageComment cp) (commentPageViewTime cp) (return ())
|
||||
|
|
@ -282,9 +283,7 @@ commentForm :: StringConv a [Char] => a -> H.AttributeValue -> Maybe H.Attribute
|
|||
commentForm slug user mparent =
|
||||
H.form ! A.action "/comments" ! A.method "post" $ do
|
||||
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value user
|
||||
case mparent of
|
||||
Just parent -> H.input ! A.type_ "hidden" ! A.name "parent" ! A.value parent
|
||||
_ -> return ()
|
||||
H.input ! A.type_ "hidden" ! A.name "parent" ! A.value (fromMaybe "" mparent)
|
||||
H.input ! A.type_ "hidden" ! A.name "slug" ! A.value (cvt slug)
|
||||
(H.textarea ! A.name "content" ! A.rows "6" ! A.cols "60" ! A.maxlength "5000") ""
|
||||
H.br
|
||||
|
|
@ -298,6 +297,27 @@ showChildren cs vt comment = H.li $
|
|||
then return ()
|
||||
else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children)
|
||||
|
||||
displayOneComment :: Comment -> UTCTime -> H.Markup
|
||||
displayOneComment comment vt = do
|
||||
let inputid = "toggle-" <> UUID.toString (toS (id comment))
|
||||
H.input ! A.type_ "checkbox" ! A.class_ "toggleinput" ! A.id (cvt inputid)
|
||||
H.div $ do
|
||||
let cid = UUID.toString (toS (id comment))
|
||||
s = slug (val comment)
|
||||
H.div ! A.id (cvt cid) ! A.class_ "metas" $ do
|
||||
H.label ! A.for (cvt inputid) ! A.class_ "togglelabel" $ H.span (H.text "[-]")
|
||||
H.a ! A.href (cvt ('#':cid)) $ "§ "
|
||||
H.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text (toS s)
|
||||
H.text " - "
|
||||
H.text (fromUserId (userid (val comment)))
|
||||
H.span ! A.class_ "time" $ do
|
||||
H.text " - "
|
||||
H.text . toS . humanReadableDuration . realToFrac $ diffUTCTime vt (created (metas comment))
|
||||
H.text " ago"
|
||||
H.div ! A.class_ "tohide" $ do
|
||||
H.pre $ H.text (toS (content (val comment)))
|
||||
H.a ! A.href (cvt ("/comment/" <> cid)) ! A.class_ "small" $ "reply"
|
||||
|
||||
displayComment :: Comment -> UTCTime -> H.Markup -> H.Markup
|
||||
displayComment comment vt children = do
|
||||
let inputid = "toggle-" <> UUID.toString (toS (id comment))
|
||||
|
|
@ -358,6 +378,17 @@ getSlugs' :: DBStore -> IO [Slug]
|
|||
getSlugs' SQLiteState{..} =
|
||||
liftIO $ query_ conn (conv ("SELECT DISTINCT slug FROM " <> stTablename <> " ORDER BY created LIMIT 100"))
|
||||
|
||||
getTopSlugs' :: DBStore -> IO [(Slug,Int)]
|
||||
getTopSlugs' SQLiteState{..} =
|
||||
liftIO $ query_ conn (conv ("SELECT slug,COUNT(id) FROM " <> stTablename <> " GROUP BY slug ORDER BY COUNT(id) DESC LIMIT 100"))
|
||||
|
||||
getLatestSlugs' :: DBStore -> IO [(Slug,Int)]
|
||||
getLatestSlugs' SQLiteState{..} =
|
||||
liftIO $ query_ conn (conv ("SELECT DISTINCT slug,COUNT(id) FROM " <> stTablename <> " GROUP BY slug ORDER BY created DESC LIMIT 100"))
|
||||
|
||||
getLatestComments' :: DBStore -> IO [Comment]
|
||||
getLatestComments' SQLiteState{..} =
|
||||
liftIO $ query_ conn (conv ("SELECT * FROM " <> stTablename <> " ORDER BY created DESC LIMIT 20"))
|
||||
|
||||
-- | A comment handler, handle all impure operations needed to Comments
|
||||
data CommentHandler = CommentHandler
|
||||
|
|
@ -368,17 +399,23 @@ data CommentHandler = CommentHandler
|
|||
, searchComments :: CommentSearchQuery -> IO CommentSearchResult
|
||||
, stopDBComments :: IO ()
|
||||
, getSlugs :: IO [Slug]
|
||||
, getTopSlugs :: IO [(Slug,Int)]
|
||||
, getLatestSlugs :: IO [(Slug,Int)]
|
||||
, getLatestComments :: IO [Comment]
|
||||
}
|
||||
|
||||
-- | Init a new comment handler
|
||||
newCommentHandler :: CommentConf -> IO CommentHandler
|
||||
newCommentHandler conf = do
|
||||
dbstore <- initDBComments conf
|
||||
pure $ CommentHandler { createComment = createComment' dbstore
|
||||
, readComment = readComment' dbstore
|
||||
, updateComment = updateComment' dbstore
|
||||
, deleteComment = deleteComment' dbstore
|
||||
, searchComments = searchComments' dbstore
|
||||
, stopDBComments = stopDBComments' dbstore
|
||||
, getSlugs = getSlugs' dbstore
|
||||
pure $ CommentHandler { createComment = createComment' dbstore
|
||||
, readComment = readComment' dbstore
|
||||
, updateComment = updateComment' dbstore
|
||||
, deleteComment = deleteComment' dbstore
|
||||
, searchComments = searchComments' dbstore
|
||||
, stopDBComments = stopDBComments' dbstore
|
||||
, getSlugs = getSlugs' dbstore
|
||||
, getTopSlugs = getTopSlugs' dbstore
|
||||
, getLatestSlugs = getLatestSlugs' dbstore
|
||||
, getLatestComments = getLatestComments' dbstore
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,25 +1,25 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
|
||||
{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ...
|
||||
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
|
||||
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String)
|
||||
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
|
||||
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
|
||||
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
|
||||
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
|
||||
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
|
||||
{-# LANGUAGE PartialTypeSignatures #-} --
|
||||
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
|
||||
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
|
||||
{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ...
|
||||
{-# LANGUAGE Strict #-} -- a la Clojure
|
||||
{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y)
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{- |
|
||||
Module : Aggreact.Comments
|
||||
Description : Example of a library file.
|
||||
|
|
@ -39,30 +39,31 @@ module Aggreact.Homepage
|
|||
|
||||
import Protolude
|
||||
|
||||
import Prelude (String)
|
||||
import Aggreact.Comments (Slug (..))
|
||||
import Aggreact.Html (boilerplate)
|
||||
import Aggreact.Comments (Comment, Slug (..),
|
||||
displayOneComment)
|
||||
import Aggreact.Html (boilerplate, urlEncode)
|
||||
|
||||
import Data.String (IsString (..))
|
||||
import Data.Time (UTCTime)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import qualified Data.Char as Char
|
||||
import Text.Printf
|
||||
|
||||
encode :: Char -> String
|
||||
encode c
|
||||
| c == ' ' = "+"
|
||||
| Char.isAlphaNum c || c `elem` ("-._~" :: String) = [c]
|
||||
| otherwise = printf "%%%02X" c
|
||||
|
||||
urlEncode :: String -> String
|
||||
urlEncode = concatMap encode
|
||||
newtype Homepage = Homepage { topSlugs :: [Slug] }
|
||||
data Homepage = Homepage { latestSlugs :: [(Slug,Int)]
|
||||
, topSlugs :: [(Slug,Int)]
|
||||
, latestComments :: [Comment]
|
||||
, viewTime :: UTCTime
|
||||
}
|
||||
|
||||
instance H.ToMarkup Homepage where
|
||||
toMarkup Homepage {..} = boilerplate $ do
|
||||
H.p "Bienvenue sur Aggreact!"
|
||||
H.h2 "Latest slugs"
|
||||
H.h2 "Latest Slugs"
|
||||
H.ul $ traverse_ htmlSlug latestSlugs
|
||||
H.h2 "Top"
|
||||
H.ul $ traverse_ htmlSlug topSlugs
|
||||
where htmlSlug (Slug s) =
|
||||
H.li (H.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text s)
|
||||
H.h2 "Latest comments"
|
||||
H.ul $ traverse_ (flip displayOneComment viewTime) latestComments
|
||||
where htmlSlug ((Slug s),n) =
|
||||
H.li $ do
|
||||
H.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text s
|
||||
H.div H.! A.class_ "metas" $ H.text (show n <> " comments")
|
||||
|
|
|
|||
|
|
@ -1,18 +1,18 @@
|
|||
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
|
||||
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
|
||||
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
|
||||
{-# LANGUAGE TupleSections #-} -- (a,,) instead of \x y -> (a,x,y)
|
||||
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
|
||||
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
|
||||
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- newtype Id = Id Text deriving (StringConv Id String)
|
||||
{-# LANGUAGE DeriveGeneric #-} -- deriving ToJSON ...
|
||||
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
|
||||
{-# LANGUAGE StandaloneDeriving #-} -- write deriving instance ...
|
||||
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
|
||||
{-# LANGUAGE PartialTypeSignatures #-} --
|
||||
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
|
||||
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{- |
|
||||
Module : Aggreact.Html
|
||||
|
|
@ -28,14 +28,18 @@ Main datastructures
|
|||
-}
|
||||
module Aggreact.Html
|
||||
( boilerplate
|
||||
, urlEncode
|
||||
)
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import Prelude (String)
|
||||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import Text.Printf
|
||||
|
||||
container :: H.Html -> H.Html
|
||||
container = H.div ! A.class_ "container"
|
||||
|
|
@ -58,3 +62,12 @@ boilerplate innerHtml =
|
|||
H.a ! A.href "https://haskell.org" $ "Haskell"
|
||||
H.text " by "
|
||||
H.a ! A.href "http://yannesposito.com" $ "ye"
|
||||
|
||||
encode :: Char -> String
|
||||
encode c
|
||||
| c == ' ' = "+"
|
||||
| Char.isAlphaNum c || c `elem` ("-._~" :: String) = [c]
|
||||
| otherwise = printf "%%%02X" c
|
||||
|
||||
urlEncode :: String -> String
|
||||
urlEncode = concatMap encode
|
||||
|
|
|
|||
Loading…
Reference in a new issue