diff --git a/src/Foundation.hs b/src/Foundation.hs
index b91f7ae..a1e97d4 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -132,11 +132,11 @@ instance Yesod App where
}
]
- let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
- let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
+ -- let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
+ -- let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
- let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
- let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
+ -- let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
+ -- let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
diff --git a/src/Handler/Comment.hs b/src/Handler/Comment.hs
index e5d9191..fbf2156 100644
--- a/src/Handler/Comment.hs
+++ b/src/Handler/Comment.hs
@@ -17,6 +17,9 @@ import Handler.Helper
getCommentR :: CommentId -> Handler Html
getCommentR _ = error "Not yet implemented: getCommentR"
+isCommentCreator :: Key Comment
+ -> (UserId -> Comment -> HandlerFor App TypedContent)
+ -> Handler TypedContent
isCommentCreator commentId f =
testLogged $ \userId -> do
maybeComment <- runDB $ get commentId
diff --git a/src/Handler/Entry.hs b/src/Handler/Entry.hs
index 1648516..0e97c6b 100644
--- a/src/Handler/Entry.hs
+++ b/src/Handler/Entry.hs
@@ -17,8 +17,6 @@ where
import Import
import Handler.Helper
-import Yesod.Auth
-import Yesod.Markdown
import Data.Maybe
import Data.Tree
@@ -58,18 +56,17 @@ getCommentSons comments father@(Entity commentId _) =
(father,
filter (\(Entity _ c) -> commentReplyTo c == Just commentId) comments)
--- showCommentForest :: [Tree (Entity Comment)] -> Hamlet
showCommentForest [] _ _ _ _ _ = [whamlet|$newline never
- |]
+ |]
showCommentForest trees creators currentId wdg enc voteComments=
[whamlet|$newline always
$forall tree <- trees
^{showCommentTree tree creators currentId wdg enc voteComments}|]
--- cssClassVoteForVote :: (Eq a) => a
--- -> [(a, [Entity (VoteCommentGeneric backend)])]
--- -> Text
+cssClassVoteForVote :: (IsMap map,
+ MapValue map ~ [Entity VoteComment])
+ => ContainerKey map -> map -> Text
cssClassVoteForVote commentId voteComments =
maybe "" strOfVote (lookup commentId voteComments)
where
@@ -126,8 +123,8 @@ showCommentTree tree creators currentId widget enctype voteComments=
&& currentId == maybeCreator
creatorOfEntity :: CommentId -> [(CommentId,[Entity User])] -> Text
-creatorOfEntity entityId creators =
- maybe "Anonymous Coward" entUserIdent (lookup entityId creators)
+creatorOfEntity entId creators =
+ maybe "Anonymous Coward" entUserIdent (lookup entId creators)
where
entUserIdent [] = "Anonymous Coward"
entUserIdent ((Entity _ creator):_) = userIdent creator
@@ -154,6 +151,7 @@ emptyEntryForm = renderDivs $ EntryRequest
<*> aopt urlField "Url" Nothing
<*> aopt textareaField "Text" Nothing
+loginWidget :: Maybe a -> WidgetFor App ()
loginWidget maybeUserId =
[whamlet|$newline always
$if isNothing maybeUserId
diff --git a/src/Handler/Helper.hs b/src/Handler/Helper.hs
index 5e4b502..0b93479 100644
--- a/src/Handler/Helper.hs
+++ b/src/Handler/Helper.hs
@@ -93,21 +93,21 @@ humanReadableRelativeTime currentTime createdTime =
showDuration duration
where
duration = diffUTCTime currentTime createdTime
- second, minute, hour, day, year :: NominalDiffTime
- second = fromIntegral (1 :: Int)
- minute = (fromIntegral ( 60 :: Int)) * second
+ oneSecond, minute, hour, day, year :: NominalDiffTime
+ oneSecond = fromIntegral (1 :: Int)
+ minute = (fromIntegral ( 60 :: Int)) * oneSecond
hour = (fromIntegral ( 60 :: Int)) * minute
day = (fromIntegral ( 24 :: Int)) * hour
year = (fromIntegral (365 :: Int)) * day
seconds,minutes,hours,days,years :: NominalDiffTime -> NominalDiffTime
- seconds t = t / second
+ seconds t = t / oneSecond
minutes t = t / minute
hours t = t / hour
days t = t / day
years t = t / year
showTime t = show (floor t :: Integer)
showDuration t
- | t < second = "Just now"
+ | t < oneSecond = "Just now"
| t < minute = pack $ (showTime $ seconds t) ++ " seconds ago"
| t < hour = pack $ (showTime $ minutes t) ++ " minutes ago"
| t < day = pack $ (showTime $ hours t) ++ " hours ago"
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 4076c33..5a2e880 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -1,6 +1,9 @@
-{-# LANGUAGE TupleSections, OverloadedStrings, NoImplicitPrelude #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Home
( getHomeR
, postEntriesR
@@ -11,6 +14,9 @@ import Import
import Handler.Helper
import Data.Maybe
+intScore :: Entry -> Integer
+intScore = floor . scoreForEntry
+
-- |The `EntryRequest` correspond to the data needed
-- to create a new entry.
data EntryRequest = EntryRequest {
@@ -125,7 +131,7 @@ getHomeR = do
-- |When we receive a post request on HomeR resource (/ path)
-- |We create a new resource
--- postEntriesR :: Handler RepHtmlJson
+postEntriesR :: Handler TypedContent
postEntriesR =
testLogged $ \currentUserId -> do
((res,_),_) <- runFormPost entryForm
@@ -143,7 +149,7 @@ postEntriesR =
True -> errorPageJson "You must enter some text or some URL"
False -> do
entryId <- runDB $ insert newEntry
- voteId <- runDB $ insert $ Vote currentUserId entryId 1
+ _voteId <- runDB $ insert $ Vote currentUserId entryId 1
setMessage $ toHtml (title personRequest)
redirect $ EntryR entryId
_ -> errorPageJson "Please correct your entry form"
diff --git a/src/Lib/Css/Helper.hs b/src/Lib/Css/Helper.hs
index 1dee342..32a241f 100644
--- a/src/Lib/Css/Helper.hs
+++ b/src/Lib/Css/Helper.hs
@@ -90,23 +90,23 @@ textEmphColor=base01
altbackground, altbackHighlightColor, altforeground, alttextcolor :: String
alttextSecondaryColor, alttextEmphColor :: String
-altbackground=base01
-altbackHighlightColor=base02
-altforeground=base0
+altbackground=base2
+altbackHighlightColor=base2
+altforeground=base00
alttextcolor=altforeground
-alttextSecondaryColor=base01
-alttextEmphColor=base1
+alttextSecondaryColor=base1
+alttextEmphColor=base01
base03, base02, base01, base00, base0, base1, base2, base3 :: String
-base03="#002b36"
-base02="#073642"
-base01="#586e75"
-base00="#657b83"
-base0="#839496"
-base1="#93a1a1"
-base2="#eee8d5"
-base3="#fdf6e3"
+base03="hsl(218,20%,12%)"
+base02="hsl(218,20%,16%)"
+base01="hsl(218,20%,45%)"
+base00="hsl(218,20%,50%)"
+base0="hsl(218,20%,60%)"
+base1="hsl(218,20%,65%)"
+base2="hsl(218,20%,95%)"
+base3="hsl(218,20%,97%)"
yellow , orange , red , magenta , violet , blue , cyan , green :: String
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet
index 4ac551b..c759600 100644
--- a/templates/default-layout-wrapper.hamlet
+++ b/templates/default-layout-wrapper.hamlet
@@ -12,6 +12,7 @@
+