Still improvements

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

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

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

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