link to add slug

src/Aggreact.hs

@@ -80,7 +80,7 @@ serverAuthenticated :: Settings
                     -> AuthResult User
                     -> Server Authenticated
 serverAuthenticated Settings{..} authresult =
-       homepageAPI commentHandler authresult
+       homepageAPI commentHandler authorizationHandler authresult
   :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
   :<|> slugAPI (Aggreact.Slugs.Handlers userHandler slugHandler authorizationHandler) authresult
   :<|> userAPI userHandler authorizationHandler authresult

src/Aggreact/Css.hs

@@ -145,6 +145,25 @@ genCss = do
     display inlineBlock
     content (stringContent "[-]")
     cursor pointer
+  ".button" ? do
+    fontWeight bold
+    fontSize (px 11)
+    textDecoration none
+    borderBottom solid (px 0) solblue
+    borderTop solid (px 0) solblue
+    borderLeft solid (px 0) solblue
+    borderRight solid (px 0) solblue
+    backgroundColor base2
+    padding (ex 1) (ex 1) (ex 1) (ex 1)
+    margin (ex 1) (ex 1) (ex 1) (ex 0)
+    hover & do
+      backgroundColor base3
+      cursor pointer
+      color base01
+    active & do
+      cursor pointer
+      backgroundColor solyellow
+      color white
   input # ("type" |= "submit") ? do
     fontWeight bold
     borderBottom solid (px 0) solblue

src/Aggreact/Homepage.hs

@@ -39,11 +39,15 @@ module Aggreact.Homepage
 
 import           Protolude
 
+import           Aggreact.Authorization      (Access (..),
+                                              AuthorizationHandler (..))
 import           Aggreact.Comments           (Comment, CommentHandler (..),
                                               Slug (..), displayOneComment)
 import           Aggreact.Css                (genCss)
 import           Aggreact.Html               (boilerplate, extlink, urlEncode)
+import           Aggreact.Scopes             (Scope (..))
 import           Aggreact.Users              (User, loginWidget)
+
 import           Clay                        (Css)
 import           Data.String                 (IsString (..))
 import qualified Data.Text                   as Text
@@ -60,35 +64,40 @@ data Homepage = Homepage { latestSlugs    :: [(Slug,Int)]
                          , latestComments :: [Comment]
                          , viewTime       :: UTCTime
                          , muser          :: Maybe User
+                         , canCreateSlug  :: Bool
                          }
 
-
 type HomepageAPI =
   "main.css" :> Get '[CSS] Css
   :<|> Get '[HTML] Homepage
 
 homepageAPI :: CommentHandler
+            -> AuthorizationHandler
             -> Servant.Auth.Server.AuthResult User
             -> Server HomepageAPI
-homepageAPI commentHandler authResult =
+homepageAPI commentHandler authorizationHandler authResult =
   let muser = case authResult of
         (Authenticated user) -> Just user
         _                    -> Nothing
   in
        return genCss
-  :<|> getHomepage muser commentHandler
+  :<|> getHomepage muser authorizationHandler commentHandler
 
-getHomepage :: Maybe User -> CommentHandler -> Handler Homepage
-getHomepage muser commentHandler =
+getHomepage :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler Homepage
+getHomepage muser AuthorizationHandler{..} commentHandler = do
+  let canCreateSlug = hasScope (Scope "slug" Write) muser
   liftIO $ Homepage <$> getLatestSlugs commentHandler
                     <*> getTopSlugs commentHandler
                     <*> getLatestComments commentHandler
                     <*> getCurrentTime
                     <*> return muser
+                    <*> return canCreateSlug
 
 instance H.ToMarkup Homepage where
   toMarkup Homepage {..} = boilerplate (loginWidget muser) $ do
     H.p "Bienvenue sur Aggreact!"
+    when canCreateSlug $
+      H.p $ H.a H.! A.class_ "button" H.! A.href (fromString "/slugs") $ "Add new slug"
     H.h2 "Latest Slugs"
     H.ul $ traverse_ htmlSlug latestSlugs
     H.h2 "Top"

src/Aggreact/Slugs/Views.hs

@@ -80,9 +80,10 @@ instance H.ToMarkup SlugsPage where
 displayOneSlug :: Slug -> H.Html
 displayOneSlug sl = do
   let slurl = slugUrl (val sl)
-  H.a ! A.href ("/comments/" <> cvt (urlEncode (toS slurl))) $ H.text "Slug"
-  H.text " for "
-  extlink slurl (toS slurl)
+  H.p $ do
+    H.a ! A.href ("/comments/" <> cvt (urlEncode (toS slurl))) $ H.text "Slug"
+    H.text " for "
+    extlink slurl (toS slurl)
 
 -- * Single Slug Page