Fix Spock.subcomponents warnings (#181)

guide.cabal

@@ -75,6 +75,7 @@ library
       Guide.Views.Utils
         Guide.Views.Utils.Input
     Guide.Cache
+    Guide.Routes
   other-modules:
     Imports
   build-depends:       Spock

src/Guide/Handlers.hs

@@ -28,7 +28,7 @@ import qualified Text.Atom.Feed  as Atom
 import qualified Data.Text.All as T
 import qualified Data.Text.Lazy.All as TL
 -- Web
-import Web.Spock hiding (head, get, text)
+import Web.Spock hiding (head, get, renderRoute, text)
 import qualified Web.Spock as Spock
 import Web.Spock.Lucid
 import Lucid hiding (for_)
@@ -44,6 +44,7 @@ import Guide.State
 import Guide.Types
 import Guide.Utils
 import Guide.Views
+import Guide.Routes
 
 methods :: GuideM ctx ()
 methods = do
@@ -53,40 +54,40 @@ methods = do
   otherMethods
 
 renderMethods :: GuideM ctx ()
-renderMethods = Spock.subcomponent "render" $ do
+renderMethods = do
   -- Notes for a category
-  Spock.get (categoryVar <//> "notes") $ \catId -> do
+  Spock.get (renderRoute <//> categoryVar <//> "notes") $ \catId -> do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderCategoryNotes category
   -- Item colors
-  Spock.get (itemVar <//> "colors") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "colors") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     let hue = getItemHue category item
     json $ M.fromList [("light" :: Text, hueToLightColor hue),
                        ("dark" :: Text, hueToDarkColor hue)]
   -- Item info
-  Spock.get (itemVar <//> "info") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "info") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemInfo category item
   -- Item description
-  Spock.get (itemVar <//> "description") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "description") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     lucidIO $ renderItemDescription item
   -- Item ecosystem
-  Spock.get (itemVar <//> "ecosystem") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     lucidIO $ renderItemEcosystem item
   -- Item notes
-  Spock.get (itemVar <//> "notes") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "notes") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemNotes category item
 
 setMethods :: GuideM ctx ()
-setMethods = Spock.subcomponent "set" $ do
-  Spock.post (categoryVar <//> "info") $ \catId -> do
+setMethods = do
+  Spock.post (setRoute <//> categoryVar <//> "info") $ \catId -> do
     -- TODO: [easy] add a cross-link saying where the form is handled in the
     -- code and other notes saying where stuff is rendered, etc
     title' <- T.strip <$> param' "title"
@@ -129,7 +130,7 @@ setMethods = Spock.subcomponent "set" $ do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderCategoryInfo category
   -- Notes for a category
-  Spock.post (categoryVar <//> "notes") $ \catId -> do
+  Spock.post (setRoute <//> categoryVar <//> "notes") $ \catId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (notes.mdText) <$> dbQuery (GetCategory catId)
@@ -146,7 +147,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item info
-  Spock.post (itemVar <//> "info") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "info") $ \itemId -> do
     -- TODO: [easy] add a cross-link saying where the form is handled in the
     -- code and other notes saying where stuff is rendered, etc
     name' <- T.strip <$> param' "name"
@@ -192,7 +193,7 @@ setMethods = Spock.subcomponent "set" $ do
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemInfo category item
   -- Item description
-  Spock.post (itemVar <//> "description") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "description") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (description.mdText) <$> dbQuery (GetItem itemId)
@@ -209,7 +210,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item ecosystem
-  Spock.post (itemVar <//> "ecosystem") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
@@ -226,7 +227,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item notes
-  Spock.post (itemVar <//> "notes") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "notes") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (notes.mdText) <$> dbQuery (GetItem itemId)
@@ -244,7 +245,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Trait
-  Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
+  Spock.post (setRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
@@ -262,9 +263,9 @@ setMethods = Spock.subcomponent "set" $ do
           ("merged" :: Text, merge original content' modified)]
 
 addMethods :: GuideM ctx ()
-addMethods = Spock.subcomponent "add" $ do
+addMethods = do
   -- New category
-  Spock.post "category" $ do
+  Spock.post (addRoute <//> "category") $ do
     title' <- param' "content"
     -- If the category exists already, don't create it
     cats <- view categories <$> dbQuery GetGlobalState
@@ -282,7 +283,7 @@ addMethods = Spock.subcomponent "add" $ do
     Spock.text ("/haskell/" <> categorySlug category)
 
   -- New item in a category
-  Spock.post (categoryVar <//> "item") $ \catId -> do
+  Spock.post (addRoute <//> categoryVar <//> "item") $ \catId -> do
     name' <- param' "name"
     -- TODO: do something if the category doesn't exist (e.g. has been
     -- already deleted)
@@ -299,7 +300,7 @@ addMethods = Spock.subcomponent "add" $ do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderItem category newItem
   -- Pro (argument in favor of an item)
-  Spock.post (itemVar <//> "pro") $ \itemId -> do
+  Spock.post (addRoute <//> itemVar <//> "pro") $ \itemId -> do
     content' <- param' "content"
     traitId <- randomLongUid
     (edit, newTrait) <- dbUpdate (AddPro itemId traitId content')
@@ -307,7 +308,7 @@ addMethods = Spock.subcomponent "add" $ do
     addEdit edit
     lucidIO $ renderTrait itemId newTrait
   -- Con (argument against an item)
-  Spock.post (itemVar <//> "con") $ \itemId -> do
+  Spock.post (addRoute <//> itemVar <//> "con") $ \itemId -> do
     content' <- param' "content"
     traitId <- randomLongUid
     (edit, newTrait) <- dbUpdate (AddCon itemId traitId content')
@@ -318,68 +319,66 @@ addMethods = Spock.subcomponent "add" $ do
 otherMethods :: GuideM ctx ()
 otherMethods = do
   -- Moving things
-  Spock.subcomponent "move" $ do
-    -- Move item
-    Spock.post itemVar $ \itemId -> do
-      direction :: Text <- param' "direction"
-      uncache (CacheItem itemId) $ do
-        edit <- dbUpdate (MoveItem itemId (direction == "up"))
-        addEdit edit
-    -- Move trait
-    Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
-      direction :: Text <- param' "direction"
-      uncache (CacheItemTraits itemId) $ do
-        edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
-        addEdit edit
+  -- Move item
+  Spock.post (moveRoute <//> itemVar) $ \itemId -> do
+    direction :: Text <- param' "direction"
+    uncache (CacheItem itemId) $ do
+      edit <- dbUpdate (MoveItem itemId (direction == "up"))
+      addEdit edit
+  -- Move trait
+  Spock.post (moveRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
+    direction :: Text <- param' "direction"
+    uncache (CacheItemTraits itemId) $ do
+      edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
+      addEdit edit
 
-  -- Deleting things
-  Spock.subcomponent "delete" $ do
-    -- Delete category
-    Spock.post categoryVar $ \catId ->
-      uncache (CacheCategory catId) $ do
-        mbEdit <- dbUpdate (DeleteCategory catId)
-        mapM_ addEdit mbEdit
-    -- Delete item
-    Spock.post itemVar $ \itemId ->
-      uncache (CacheItem itemId) $ do
-        mbEdit <- dbUpdate (DeleteItem itemId)
-        mapM_ addEdit mbEdit
-    -- Delete trait
-    Spock.post (itemVar <//> traitVar) $ \itemId traitId ->
-      uncache (CacheItemTraits itemId) $ do
-        mbEdit <- dbUpdate (DeleteTrait itemId traitId)
-        mapM_ addEdit mbEdit
+-- Deleting things
+  -- Delete category
+  Spock.post (deleteRoute <//> categoryVar) $ \catId ->
+    uncache (CacheCategory catId) $ do
+      mbEdit <- dbUpdate (DeleteCategory catId)
+      mapM_ addEdit mbEdit
+  -- Delete item
+  Spock.post (deleteRoute <//> itemVar) $ \itemId ->
+    uncache (CacheItem itemId) $ do
+      mbEdit <- dbUpdate (DeleteItem itemId)
+      mapM_ addEdit mbEdit
+  -- Delete trait
+  Spock.post (deleteRoute <//> itemVar <//> traitVar) $ \itemId traitId ->
+    uncache (CacheItemTraits itemId) $ do
+      mbEdit <- dbUpdate (DeleteTrait itemId traitId)
+      mapM_ addEdit mbEdit
 
   -- Feeds
   -- TODO: this link shouldn't be absolute [absolute-links]
   baseUrl <- (// "haskell") . _baseUrl <$> getConfig
-  Spock.subcomponent "feed" $ do
-    -- Feed for items in a category
-    Spock.get categoryVar $ \catId -> do
-      category <- dbQuery (GetCategory catId)
-      let sortedItems = reverse $ sortBy cmp (category^.items)
-            where cmp = comparing (^.created) <> comparing (^.uid)
-      let route = "feed" <//> categoryVar
-      let feedUrl = baseUrl // renderRoute route (category^.uid)
-          feedTitle = Atom.TextString (T.unpack (category^.title) ++
-                                       " – Haskell – Aelve Guide")
-          feedLastUpdate = case sortedItems of
-            (item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
-            _        -> ""
-      let feedBase = Atom.nullFeed (T.unpack feedUrl) feedTitle feedLastUpdate
-      entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems
-      atomFeed $ feedBase {
-        Atom.feedEntries = entries,
-        Atom.feedLinks   = [Atom.nullLink (T.unpack feedUrl)] }
+
+  -- Feed for items in a category
+  Spock.get (feedRoute <//> categoryVar) $ \catId -> do
+    category <- dbQuery (GetCategory catId)
+    let sortedItems = reverse $ sortBy cmp (category^.items)
+          where cmp = comparing (^.created) <> comparing (^.uid)
+    let route = "feed" <//> categoryVar
+    let feedUrl = baseUrl // Spock.renderRoute route (category^.uid)
+        feedTitle = Atom.TextString (T.unpack (category^.title) ++
+                                     " – Haskell – Aelve Guide")
+        feedLastUpdate = case sortedItems of
+          (item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
+          _        -> ""
+    let feedBase = Atom.nullFeed (T.unpack feedUrl) feedTitle feedLastUpdate
+    entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems
+    atomFeed $ feedBase {
+      Atom.feedEntries = entries,
+      Atom.feedLinks   = [Atom.nullLink (T.unpack feedUrl)] }
 
 adminMethods :: AdminM ctx ()
-adminMethods = Spock.subcomponent "admin" $ do
+adminMethods = do
   -- Accept an edit
-  Spock.post ("edit" <//> var <//> "accept") $ \n -> do
+  Spock.post (adminRoute <//> "edit" <//> var <//> "accept") $ \n -> do
     dbUpdate (RemovePendingEdit n)
     return ()
   -- Undo an edit
-  Spock.post ("edit" <//> var <//> "undo") $ \n -> do
+  Spock.post (adminRoute <//> "edit" <//> var <//> "undo") $ \n -> do
     (edit, _) <- dbQuery (GetEdit n)
     res <- undoEdit edit
     case res of
@@ -388,10 +387,10 @@ adminMethods = Spock.subcomponent "admin" $ do
                      dbUpdate (RemovePendingEdit n)
                      Spock.text ""
   -- Accept a range of edits
-  Spock.post ("edits" <//> var <//> var <//> "accept") $ \m n -> do
+  Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "accept") $ \m n -> do
     dbUpdate (RemovePendingEdits m n)
   -- Undo a range of edits
-  Spock.post ("edits" <//> var <//> var <//> "undo") $ \m n -> do
+  Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "undo") $ \m n -> do
     edits <- dbQuery (GetEdits m n)
     s <- dbQuery GetGlobalState
     failed <- fmap catMaybes $ for edits $ \(edit, details) -> do
@@ -405,7 +404,7 @@ adminMethods = Spock.subcomponent "admin" $ do
       [] -> Spock.text ""
       _  -> lucidIO $ renderEdits s failed
   -- Create a checkpoint
-  Spock.post "create-checkpoint" $ do
+  Spock.post (adminRoute <//> "create-checkpoint") $ do
     db <- _db <$> Spock.getState
     createCheckpoint' db
 

src/Guide/Main.hs

@@ -68,6 +68,7 @@ import Guide.JS (JS(..), allJSFunctions)
 import Guide.Utils
 import Guide.Cache
 import Guide.Session
+import Guide.Routes (authRoute, haskellRoute)
 
 
 {- Note [acid-state]
@@ -249,7 +250,7 @@ guideApp waiMetrics = do
 
       -- Main page
       Spock.get root $
-        lucidWithConfig $ renderRoot
+        lucidWithConfig renderRoot
 
       -- Admin page
       prehook authHook $ prehook adminHook $ do
@@ -263,7 +264,7 @@ guideApp waiMetrics = do
 
       -- Donation page
       Spock.get "donate" $
-        lucidWithConfig $ renderDonate
+        lucidWithConfig renderDonate
 
       -- Static pages
       Spock.get "unwritten-rules" $ lucidWithConfig $
@@ -274,57 +275,55 @@ guideApp waiMetrics = do
         renderStaticMd "License" "license.md"
 
       -- Haskell
-      Spock.subcomponent "haskell" $ do
-        Spock.get root $ do
-          s <- dbQuery GetGlobalState
-          q <- param "q"
-          (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
-          let act = case q of
-                Nothing -> Action'MainPageVisit
-                Just x  -> Action'Search x
-          baseUrl <- _baseUrl <$> getConfig
-          dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
-          lucidWithConfig $ renderHaskellRoot s q
-        -- Category pages
-        Spock.get var $ \path -> do
-          -- The links look like /parsers-gao238b1 (because it's nice when
-          -- you can find out where a link leads just by looking at it)
-          let (_, catId) = T.breakOnEnd "-" path
-          when (T.null catId) $
-            Spock.jumpNext
-          mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
-          case mbCategory of
-            Nothing -> Spock.jumpNext
-            Just category -> do
-              (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
-              baseUrl <- _baseUrl <$> getConfig
-              dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
-                           mbIP time baseUrl mbReferrer mbUA
-              -- If the slug in the url is old (i.e. if it doesn't match the
-              -- one we would've generated now), let's do a redirect
-              when (categorySlug category /= path) $
-                -- TODO: this link shouldn't be absolute [absolute-links]
-                Spock.redirect ("/haskell/" <> categorySlug category)
-              lucidWithConfig $ renderCategoryPage category
-        -- The add/set methods return rendered parts of the structure (added
-        -- categories, changed items, etc) so that the Javascript part could
-        -- take them and inject into the page. We don't want to duplicate
-        -- rendering on server side and on client side.
-        methods
-      
-      Spock.subcomponent "auth" $ do
-        -- plain "/auth" logs out a logged-in user and lets a logged-out user
-        -- log in (this is not the best idea, granted, and we should just
-        -- shot logged-in users a “logout” link and logged-out users a
-        -- “login” link instead)
-        Spock.get root $ do
-          user <- getLoggedInUser
-          if isJust user
-            then Spock.redirect "auth/logout"
-            else Spock.redirect "auth/login"
-        Spock.getpost "login" $ authRedirect "/" $ loginAction
-        Spock.get "logout" $ logoutAction 
-        Spock.getpost "register" $ authRedirect "/" $ signupAction
+      Spock.get (haskellRoute <//> root) $ do
+        s <- dbQuery GetGlobalState
+        q <- param "q"
+        (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
+        let act = case q of
+              Nothing -> Action'MainPageVisit
+              Just x  -> Action'Search x
+        baseUrl <- _baseUrl <$> getConfig
+        dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
+        lucidWithConfig $ renderHaskellRoot s q
+      -- Category pages
+      Spock.get (haskellRoute <//> var) $ \path -> do
+        -- The links look like /parsers-gao238b1 (because it's nice when
+        -- you can find out where a link leads just by looking at it)
+        let (_, catId) = T.breakOnEnd "-" path
+        when (T.null catId)
+          Spock.jumpNext
+        mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
+        case mbCategory of
+          Nothing -> Spock.jumpNext
+          Just category -> do
+            (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
+            baseUrl <- _baseUrl <$> getConfig
+            dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
+                         mbIP time baseUrl mbReferrer mbUA
+            -- If the slug in the url is old (i.e. if it doesn't match the
+            -- one we would've generated now), let's do a redirect
+            when (categorySlug category /= path) $
+              -- TODO: this link shouldn't be absolute [absolute-links]
+              Spock.redirect ("/haskell/" <> categorySlug category)
+            lucidWithConfig $ renderCategoryPage category
+      -- The add/set methods return rendered parts of the structure (added
+      -- categories, changed items, etc) so that the Javascript part could
+      -- take them and inject into the page. We don't want to duplicate
+      -- rendering on server side and on client side.
+      methods
+
+      -- plain "/auth" logs out a logged-in user and lets a logged-out user
+      -- log in (this is not the best idea, granted, and we should just
+      -- shot logged-in users a “logout” link and logged-out users a
+      -- “login” link instead)
+      Spock.get (authRoute <//> root) $ do
+        user <- getLoggedInUser
+        if isJust user
+          then Spock.redirect "auth/logout"
+          else Spock.redirect "auth/login"
+      Spock.getpost "login" $ authRedirect "/" loginAction
+      Spock.get "logout" logoutAction
+      Spock.getpost "register" $ authRedirect "/" signupAction
 
 loginAction :: GuideAction ctx ()
 loginAction = do
@@ -353,7 +352,7 @@ logoutAction = do
 signupAction :: GuideAction ctx ()
 signupAction = do
   r <- runForm "register" registerForm
-  case r of 
+  case r of
     (v, Nothing) -> do
       formHtml <- protectForm registerFormView v
       lucidWithConfig $ renderRegister formHtml
@@ -384,7 +383,7 @@ adminHook :: ListContains n User xs => GuideAction (HVect xs) (HVect (IsAdmin ':
 adminHook = do
   oldCtx <- getContext
   let user = findFirst oldCtx
-  if user ^. userIsAdmin 
+  if user ^. userIsAdmin
     then return (IsAdmin :&: oldCtx)
     else Spock.text "Not authorized."
 
@@ -393,7 +392,7 @@ authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
 authRedirect path action = do
   user <- getLoggedInUser
   case user of
-    Just _ -> do
+    Just _ ->
       Spock.redirect path
     Nothing -> action
 
@@ -404,9 +403,9 @@ authRedirect path action = do
 -- templates and clears the cache whenever a change occurs, so that you
 -- wouldn't see cached pages.
 startTemplateWatcher :: IO ()
-startTemplateWatcher = void $ do
+startTemplateWatcher = void $
   Slave.fork $ FSNotify.withManager $ \mgr -> do
-    FSNotify.watchTree mgr "templates/" (const True) $ \_ -> do
+    FSNotify.watchTree mgr "templates/" (const True) $ \_ ->
       emptyCache
     forever $ threadDelay 1000000
 

src/Guide/Routes.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+
+module Guide.Routes
+  ( addRoute
+  , adminRoute
+  , authRoute
+  , deleteRoute
+  , haskellRoute
+  , feedRoute
+  , moveRoute
+  , renderRoute
+  , setRoute
+  ) where
+
+import Web.Spock (Path)
+import Web.Routing.Combinators (PathState(Open))
+
+haskellRoute :: Path '[] 'Open
+haskellRoute = "haskell"
+
+authRoute :: Path '[] 'Open
+authRoute = "auth"
+
+setRoute :: Path '[] 'Open
+setRoute = "set"
+
+addRoute :: Path '[] 'Open
+addRoute = "add"
+
+moveRoute :: Path '[] 'Open
+moveRoute = "move"
+
+deleteRoute :: Path '[] 'Open
+deleteRoute = "delete"
+
+feedRoute :: Path '[] 'Open
+feedRoute = "feed"
+
+renderRoute :: Path '[] 'Open
+renderRoute = "render"
+
+adminRoute :: Path '[] 'Open
+adminRoute = "admin"