Banned tag admin page

Pinging @chrisdone, decided to just bite the bullet and do it anyway

Application.hs

@@ -61,6 +61,7 @@ import           Handler.Package
 import           Handler.PackageList
 import           Handler.CompressorStatus
 import           Handler.Tag
+import           Handler.BannedTags
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

Handler/BannedTags.hs

@@ -0,0 +1,37 @@
+module Handler.BannedTags where
+
+import Import
+import Data.Slug (unSlug, mkSlug, Slug)
+
+checkSlugs :: Monad m => Textarea -> m (Either Text [Slug])
+checkSlugs (Textarea t) =
+    return $ first tshow $ (mapM mkSlug $ filter (not . null) $ lines $ filter (/= '\r') t)
+
+fromSlugs :: [Slug] -> Textarea
+fromSlugs = Textarea . unlines . map unSlug
+
+getBannedTagsR :: Handler Html
+getBannedTagsR = do
+    Entity _ user <- requireAuth
+    extra <- getExtra
+    when (unSlug (userHandle user) `notMember` adminUsers extra)
+        $ permissionDenied "You are not an administrator"
+    curr <- fmap (map (bannedTagTag . entityVal))
+          $ runDB $ selectList [] [Asc BannedTagTag]
+    ((res, widget), enctype) <- runFormPost $ renderDivs
+        $ areq
+            (checkMMap checkSlugs fromSlugs textareaField)
+            "Banned tags (one per line)" $ Just curr
+    case res of
+        FormSuccess tags -> do
+            runDB $ do
+                deleteWhere ([] :: [Filter BannedTag])
+                insertMany_ $ map BannedTag tags
+            setMessage "Tags updated"
+            redirect BannedTagsR
+        _ -> defaultLayout $ do
+            setTitle "Banned Tags"
+            $(widgetFile "banned-tags")
+
+putBannedTagsR :: Handler Html
+putBannedTagsR = getBannedTagsR

Settings.hs

@@ -67,6 +67,7 @@ widgetFile = (if development then widgetFileReload
 data Extra = Extra
     { storeConfig :: !BlobStoreConfig
     , hackageRoot :: !HackageRoot
+    , adminUsers  :: !(HashSet Text)
     }
     deriving Show
 
@@ -74,6 +75,7 @@ parseExtra :: DefaultEnv -> Object -> Parser Extra
 parseExtra _ o = Extra
     <$> o .: "blob-store"
     <*> (HackageRoot <$> o .: "hackage-root")
+    <*> o .:? "admin-users" .!= mempty
 
 data BlobStoreConfig = BSCFile !FilePath
                      | BSCAWS !FilePath !Text !Text !Text !Text

config/routes

@@ -31,4 +31,5 @@
 /package/#PackageName/unlike PackageUnlikeR POST
 /package/#PackageName/tag PackageTagR POST
 /tags TagListR GET
-/tag/#Slug TagR GET
+/tag/#Slug TagR GET
+/banned-tags BannedTagsR GET PUT

config/settings.yml-sample

@@ -3,6 +3,8 @@ Default: &defaults
   port: 3000
   approot: "http://localhost:3000"
   hackage-root: http://hackage.fpcomplete.com
+  admin-users:
+  - fpcomplete
 
 Development:
   <<: *defaults

stackage-server.cabal

@@ -46,6 +46,7 @@ library
                      Handler.PackageList
                      Handler.CompressorStatus
                      Handler.Tag
+                     Handler.BannedTags
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT

templates/banned-tags.hamlet

@@ -0,0 +1,6 @@
+<div .container>
+    <h1>Banned Tags
+    <a href=@{TagListR}>List of viewable tags
+    <form method=post action=@{BannedTagsR}?_method=PUT enctype=#{enctype}>
+        ^{widget}
+        <button .btn>Update banned tags

templates/banned-tags.lucius

@@ -0,0 +1,4 @@
+textarea {
+    width: 500px;
+    height: 400px;
+}