Category deletion by Administrator.

src/DBOp/CRUDCategory.hs

-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeFamilies          #-}
 
 module DBOp.CRUDCategory where
 
-import           Import
+import           Import             hiding ((==.))
 
 import           Database.Esqueleto
 
@@ -23,8 +24,25 @@ selectAllCategory ::
      , MonadIO m
      )
   => ReaderT b m [Entity Categories]
-selectAllCategory =
+selectAllCategory = do
   select $
-  from $ \category -> do
-    orderBy [asc (category ^. CategoriesName)]
-    return category
+    from $ \category -> do
+      orderBy [asc (category ^. CategoriesName)]
+      return category
+
+deleteCategory ::
+     ( BaseBackend backend ~ SqlBackend
+     , PersistQueryWrite backend
+     , BackendCompatible SqlBackend backend
+     , PersistUniqueRead backend
+     , MonadIO m
+     )
+  => Key Categories
+  -> ReaderT backend m ()
+deleteCategory cid = do
+  cat <-
+    select $
+    from $ \category -> do
+      where_ (category ^. CategoriesId ==. val cid)
+      return category
+  forM_ cat (deleteCascade . entityKey)

src/Flux/AdmCategory.hs

-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE GADTs             #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 module Flux.AdmCategory where
 
@@ -32,3 +33,17 @@ getAllCategories ::
   => HandlerFor site [Entity Categories]
 getAllCategories = liftHandler $ runDB $ selectAllCategory
 
+deleteCategoryCascade ::
+     ( BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
+     , PersistUniqueRead (YesodPersistBackend (HandlerSite m))
+     , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+     , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
+     , YesodPersist (HandlerSite m)
+     , MonadHandler m
+     )
+  => Grouping
+  -> Key Categories
+  -> m ()
+deleteCategoryCascade Administrator cid = liftHandler $ runDB $ deleteCategory cid
+deleteCategoryCascade _ _ =
+  permissionDenied "You're not allowed to do this (category deletion)."

src/Handler/Adm/Category.hs

@@ -48,20 +48,35 @@ getAdmCategoryR = do
     [whamlet|
       <form method=post enctype=#{enctc}>
         ^{widc}
-        <input .button-primary value=create type=submit>
+        <input .button-primary name=create value=create type=submit>
       <hr>
       <form method=post enctype=#{enctl}>
         ^{widl}
-        <input .button-primary value=delete type=submit>
+        <input .button-primary name=delete value=delete type=submit>
     |]
 
 postAdmCategoryR :: Handler Html
 postAdmCategoryR = do
   (uid, name, group) <- allowedToAdmin
-  ((res, _), _) <- runFormPost createCategoryForm
-  case res of
-    FormFailure x -> invalidArgs x
-    FormSuccess r -> do
-      _ <- createCategory group (createCategoryFormName r)
-      redirect AdmCategoryR
-    _ -> invalidArgs ["Good job, smarty pants!"]
+  createparam <- lookupPostParam "create"
+  deleteparam <- lookupPostParam "delete"
+  case (createparam, deleteparam) of
+    (Nothing, Nothing) -> invalidArgs ["At least be sure of what you want."]
+    (Just _, Nothing) -> do
+      ((res, _), _) <- runFormPost createCategoryForm
+      case res of
+        FormFailure x -> invalidArgs x
+        FormSuccess r -> do
+          _ <- createCategory group (createCategoryFormName r)
+          redirect AdmCategoryR
+        _ -> invalidArgs ["Good job, smarty pants!"]
+    (Nothing, Just _) -> do
+      allcategories <- getAllCategories
+      ((res, _), _) <- runFormPost $ selectCategoryForm allcategories
+      case res of
+        FormFailure x -> invalidArgs x
+        FormSuccess r -> do
+          deleteCategoryCascade group $ toSqlKey $ selectCategoryFormId r
+          redirect AdmCategoryR
+        _ -> invalidArgs ["Good job, smarty pants!"]
+    (Just _, Just _) -> invalidArgs ["Make up your mind, my dear admin."]