yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

wip

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2018-12-22 20:24:18 +01:00
parent 01788538a3
commit 9199751351
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
3 changed files with 120 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
src/Aggreact.hs
View file

@ -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)

93
src/Aggreact/Comments.hs
View file

@ -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.text "<<<~o~ Aggreact ~o~>>>"
H.div $
H.code "Aggreact"
data CommentPage =
CommentPage
data CommentsPage =
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
toMarkup CommentPage {..} = do
instance H.ToMarkup CommentsPage where
toMarkup cp@CommentsPage {..} = do
let roots = comments IxSet.@= ParentId Nothing
boilerplate $ do
H.h2 $
H.a H.! A.href (fromString (toS url)) $ H.text url
H.form H.! A.action "/comments" H.! A.method "post" $ do
-- H.label "userid"
H.input H.! A.type_ "hidden" H.! A.name "userid" H.! A.value "user-001"
-- H.br
-- H.label "parent"
H.input H.! A.type_ "hidden" H.! A.name "parent"
-- H.br
-- H.label "slug"
H.input H.! A.type_ "hidden" H.! A.name "slug" H.! A.value (fromString (toS url))
-- H.br
-- H.label "content"
-- H.br
(H.textarea H.! A.name "content" H.! A.rows "6" H.! A.cols "60") ""
H.br
H.input H.! A.type_ "submit" H.! A.value "add comment"
H.ul $ traverse_ (showChildren comments) (IxSet.toList roots)
where
fromId (Id x) = x
fromUserId (UserId x) = x
-- showChildren :: Comments -> Comment -> _
showChildren cs comment =
H.li $ do
displayComment comment
let children = cs IxSet.@= ParentId (Just (fromId (id comment)))
if IxSet.null children
then return ()
else H.ul $ traverse_ (showChildren cs) (IxSet.toList children)
displayComment comment = do
let cid = UUID.toString (fromId (id comment))
H.div H.! A.id (fromString cid) H.! A.class_ "metas" $ do
H.a H.! A.href (fromString ('#':cid)) $ "§ "
H.text (fromUserId (userid 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))
H.h2 $ H.a H.! A.href (fromString (toS url)) $ H.text url
commentForm url "anonymous coward" ""
H.ul $ traverse_ (showChildren comments (viewTime cp)) (IxSet.toList roots)
fromId (Id x) = x
fromUserId (UserId x) = x
commentForm slug user parent =
H.form H.! A.action "/comments" H.! A.method "post" $ do
H.input H.! A.type_ "hidden" H.! A.name "userid" H.! A.value user
H.input H.! A.type_ "hidden" H.! A.name "parent" H.! A.value parent
H.input H.! A.type_ "hidden" H.! A.name "slug" H.! A.value (fromString (toS slug))
(H.textarea H.! A.name "content" H.! A.rows "6" H.! A.cols "60") ""
H.br
H.input H.! A.type_ "submit" H.! A.value "add comment"
showChildren cs vt comment =
H.li $ do
displayComment comment vt
let children = cs IxSet.@= ParentId (Just (fromId (id comment)))
if IxSet.null children
then return ()
else H.ul $ traverse_ (showChildren cs vt) (IxSet.toList children)
displayComment comment vt = do
let cid = UUID.toString (fromId (id comment))
H.div H.! A.id (fromString cid) H.! A.class_ "metas" $ do
H.a H.! A.href (fromString ('#':cid)) $ "§ "
H.text (fromUserId (userid comment))
H.span H.! A.class_ "time" $ do
H.text " - "
H.text $ toS . humanReadableDuration . realToFrac . diffUTCTime vt (created comment)
H.text " ago"
H.pre $ H.text (toS (content comment))
data DBConf = DBConf { filePath :: FilePath }

62
src/Aggreact/Css.hs
View file

@ -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
marginTop (em 1)
li ? marginTop (em 1)
".metas" ? do
fontSize (px 11)
color grey