diff --git a/aggreact.cabal b/aggreact.cabal index b64a5b2..459dd02 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 30f126ffbddf3a9a0ea62f05f8a4b9f3b92fe9389e35647b298afcf322175739 +-- hash: 27862505c7dc62ea262fb1247ffa1117a3eeb29926688e1a74f5033583e42a66 name: aggreact version: 0.1.0.0 @@ -40,6 +40,7 @@ library Aggreact.Homepage Aggreact.Html Aggreact.Scopes + Aggreact.Servant.Errors Aggreact.Slugs Aggreact.Slugs.Server Aggreact.Slugs.StoreService diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs index 8e7ec79..091c0c5 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -59,8 +59,6 @@ type CommentAPI = "comments" :> Capture "slug" Text :> Get '[HTML,JSON] CommentsPage - :<|> "slugs" - :> Get '[JSON] [Slug] :<|> "comments" :> ReqBody '[JSON, FormUrlEncoded] NewComment :> PostCreated '[HTML,JSON] CreatedComment @@ -80,7 +78,6 @@ commentAPI Handlers{..} authResult = _ -> Nothing in showComments muser authorizationHandler commentHandler - :<|> showSlugs muser authorizationHandler commentHandler :<|> postNewComment muser authorizationHandler commentHandler :<|> showComment muser authorizationHandler commentHandler @@ -97,11 +94,6 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do , canComment = hasScope (Scope "comment" Read) muser } -showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug] -showSlugs muser AuthorizationHandler{..} ch = do - _ <- filterAccess (Scope "comment" Read) muser - liftIO (getSlugs ch) - showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentPage showComment muser AuthorizationHandler{..} CommentHandler{..} i = do _ <- filterAccess (Scope "comment" Read) muser diff --git a/src/Aggreact/Slugs/Server.hs b/src/Aggreact/Slugs/Server.hs index 698a085..957d89b 100644 --- a/src/Aggreact/Slugs/Server.hs +++ b/src/Aggreact/Slugs/Server.hs @@ -57,7 +57,7 @@ import Servant.Auth.Server (AuthResult (..)) import Servant.HTML.Blaze (HTML) type SlugAPI = - "slugs" :> Get '[JSON] [Slug] + "slugs" :> Get '[HTML,JSON] SlugsPage :<|> "slugs" :> Capture "slug" Text :> Get '[HTML,JSON] SlugPage @@ -84,10 +84,15 @@ slugAPI Handlers{..} authResult = showSlugs :: Maybe User -> AuthorizationHandler -> SlugHandler - -> Handler [Slug] -showSlugs muser AuthorizationHandler{..} sh = do - _ <- filterAccess (Scope "comment" Read) muser - liftIO (getSlugs sh) + -> Handler SlugsPage +showSlugs muser AuthorizationHandler{..} SlugHandler{..} = do + _ <- filterAccess (Scope "slug" Read) muser + now <- liftIO getCurrentTime + slugs <- liftIO getSlugs + return SlugsPage { slugs = slugs + , viewTime = now + , muser = muser + , canCreateSlug = hasScope (Scope "slug" Write) muser } showSlug :: Maybe User -> AuthorizationHandler @@ -96,10 +101,10 @@ showSlug :: Maybe User -> Handler SlugPage showSlug muser AuthorizationHandler{..} SlugHandler{..} slUrl = do _ <- filterAccess (Scope "slug" Read) muser - (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := slUrl]}) + (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs Filter {params = ["slugUrl" := slUrl]} case slugs of [] -> notFound "Cannot find the slug you're looking for" muser - (s:[]) -> do + [s] -> do now <- liftIO getCurrentTime return SlugPage { spSlug = s @@ -120,7 +125,7 @@ postNewSlug :: Maybe User -> Handler CreatedSlug postNewSlug muser AuthorizationHandler{..} SlugHandler{..} ns = do _ <- filterAccess (Scope "slug" Write) muser - (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := (slugUrl ns)]}) + (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs Filter {params = ["slugUrl" := slugUrl ns]} if null slugs then CreatedSlug <$> liftIO getCurrentTime diff --git a/src/Aggreact/Slugs/Views.hs b/src/Aggreact/Slugs/Views.hs index 52f6967..28ddd6b 100644 --- a/src/Aggreact/Slugs/Views.hs +++ b/src/Aggreact/Slugs/Views.hs @@ -58,6 +58,33 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A + +-- * List of Slugs + +data SlugsPage = + SlugsPage + { slugs :: [Slug] + , viewTime :: UTCTime + , muser :: Maybe User + , canCreateSlug :: Bool + } + +instance ToJSON SlugsPage where + toJSON sp = toJSON (slugs sp) + +instance H.ToMarkup SlugsPage where + toMarkup SlugsPage{..} = boilerplate (loginWidget muser) $ do + H.h2 "Slugs" + slugForm canCreateSlug (fmap (toS. nick . val) muser) + traverse_ displayOneSlug slugs + +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) + -- * Single Slug Page data SlugPage = @@ -78,20 +105,18 @@ instance H.ToMarkup SlugPage where H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl))) $ H.text "Slug" H.text " for " extlink sl sl - -- displaySlug slug slugPageViewTime (pure ()) - slugForm canCreateSlug sl (fmap (toS. nick . val) muser) + slugForm canCreateSlug (fmap (toS. nick . val) muser) -slugForm :: StringConv a [Char] - => Bool - -> a +slugForm :: Bool -> Maybe Text -> H.Html -slugForm False _ _ = H.div (H.i (H.text "You can't create a new slug")) -slugForm True slUrl Nothing = slugForm True slUrl (Just "anonymous coward") -slugForm True slUrl (Just userNick) = +slugForm False _ = H.div (H.i (H.text "You can't create a new slug")) +slugForm True Nothing = slugForm True (Just "anonymous coward") +slugForm True (Just userNick) = H.form ! A.action "/slugs" ! A.method "post" $ do H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick) - H.input ! A.type_ "hidden" ! A.name "slugUrl" ! A.value (cvt slUrl) + H.label ! A.for "slugUrl" $ H.text "URL" + H.input ! A.name "slugUrl" ! A.value "" H.br H.input ! A.type_ "submit" ! A.value "add slug" @@ -115,8 +140,7 @@ slugLink sl = do instance H.ToMarkup CreatedSlug where toMarkup CreatedSlug{..} = - boilerplate (loginWidget muser) $ do + boilerplate (loginWidget muser) $ H.h2 $ do H.text "Slugs for " slugLink createdSlug - -- displayOneSlug slug viewTime