Allow to remove only unused categories

3 files changed, 59 insertions, 24 deletions

diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 36ce3fc..371ba78 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -22,6 +22,7 @@ import           Model.CreateCategory      (CreateCategory (..))
 import           Model.EditCategory        (EditCategory (..))
 import qualified Model.Query               as Query
 import qualified Persistence.Category      as CategoryPersistence
+import qualified Persistence.Payment       as PaymentPersistence
 import qualified Secure
 import qualified Validation.Category       as CategoryValidation
 
@@ -36,8 +37,9 @@ list page perPage =
   Secure.loggedAction (\_ ->
     (liftIO . Query.run $ do
       categories <- CategoryPersistence.list page perPage
+      usedCategories <- PaymentPersistence.usedCategories
       count <- CategoryPersistence.count
-      return $ CategoryPage page categories count
+      return $ CategoryPage page categories usedCategories count
     ) >>= json
   )
 
@@ -76,7 +78,6 @@ delete :: CategoryId -> ActionM ()
 delete categoryId =
   Secure.loggedAction (\_ -> do
     deleted <- liftIO . Query.run $ do
-      -- TODO: delete only if no payment has this category
       CategoryPersistence.delete categoryId
     if deleted
       then
diff --git a/server/src/Persistence/Category.hs b/server/src/Persistence/Category.hs
index 2934b28..b0a6fca 100644
--- a/server/src/Persistence/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -10,7 +10,7 @@ module Persistence.Category
 import qualified Data.Maybe             as Maybe
 import           Data.Text              (Text)
 import           Data.Time.Clock        (getCurrentTime)
-import           Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import           Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
 import qualified Database.SQLite.Simple as SQLite
 import           Prelude                hiding (id)
 
@@ -46,10 +46,12 @@ list :: Int -> Int -> Query [Category]
 list page perPage =
   Query (\conn ->
     map (\(Row c) -> c) <$>
-      SQLite.query
+      SQLite.queryNamed
           conn
-          "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY edited_at, created_at DESC LIMIT ? OFFSET ?"
-          (perPage, (page - 1) * perPage)
+          "SELECT * FROM category WHERE deleted_at IS NULL ORDER BY name LIMIT :limit OFFSET :offset"
+          [ ":limit" := perPage
+          , ":offset" := (page - 1) * perPage
+          ]
   )
 
 listAll :: Query [Category]
@@ -60,43 +62,61 @@ listAll =
   )
 
 create :: Text -> Text -> Query ()
-create categoryName categoryColor =
+create name color =
   Query (\conn -> do
-    now <- getCurrentTime
-    SQLite.execute
+    currentTime <- getCurrentTime
+    SQLite.executeNamed
       conn
-      "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
-      (categoryName, categoryColor, now)
+      "INSERT INTO category (name, color, created_at) VALUES (:name, :color, :created_at)"
+      [ ":name" := name
+      , ":color" := color
+      , ":created_at" := currentTime
+      ]
   )
 
 edit :: CategoryId -> Text -> Text -> Query Bool
-edit categoryId categoryName categoryColor =
+edit id name color =
   Query (\conn -> do
     mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
-      (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
+      (SQLite.queryNamed conn "SELECT * FROM category WHERE id = :id" [ ":id" := id ])
     if Maybe.isJust mbCategory
       then do
-        now <- getCurrentTime
-        SQLite.execute
+        currentTime <- getCurrentTime
+        SQLite.executeNamed
           conn
-          "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?"
-          (now, categoryName, categoryColor, categoryId)
+          "UPDATE category SET edited_at = :editedAt, name = :name, color = :color WHERE id = :id"
+          [ ":editedAt" := currentTime
+          , ":name" := name
+          , ":color" := color
+          , ":id" := id
+          ]
         return True
       else
         return False
   )
 
+data BoolRow = BoolRow Int
+
+instance FromRow BoolRow where
+  fromRow = BoolRow <$> SQLite.field
+
 delete :: CategoryId -> Query Bool
-delete categoryId =
+delete id =
   Query (\conn -> do
-    mbCategory <- fmap (\(Row c) -> c) . Maybe.listToMaybe <$>
-      (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
-    if Maybe.isJust mbCategory
+    mbPayment <- (fmap (\(BoolRow b) -> b) . Maybe.listToMaybe) <$>
+      (SQLite.queryNamed
+        conn
+        "SELECT true FROM payment WHERE category = :id AND deleted_at IS NULL"
+        [ ":id" := id ])
+    if Maybe.isNothing mbPayment
       then do
-        now <- getCurrentTime
-        SQLite.execute
+        currentTime <- getCurrentTime
+        SQLite.executeNamed
           conn
-          "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId)
+          "UPDATE category SET deleted_at = :deletedAt WHERE id = :id AND deleted_at IS NULL"
+          [ ":deletedAt" := currentTime
+          , ":id" := id
+          ]
         return True
       else
         return False
diff --git a/server/src/Persistence/Payment.hs b/server/src/Persistence/Payment.hs
index a0cd580..b3eb141 100644
--- a/server/src/Persistence/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -12,6 +12,7 @@ module Persistence.Payment
   , searchCategory
   , repartition
   , getPreAndPostPaymentRepartition
+  , usedCategories
   ) where
 
 import           Data.Map                       (Map)
@@ -310,6 +311,19 @@ searchCategory paymentName =
         ]
   )
 
+usedCategories :: Query [CategoryId]
+usedCategories =
+  Query (\conn -> do
+    map (\(CategoryIdRow p) -> p) <$>
+      SQLite.query_
+        conn
+        (SQLite.Query $ T.intercalate " "
+          [ "SELECT DISTINCT category"
+          , "FROM payment"
+          , "WHERE deleted_at IS NULL"
+          ])
+  )
+
 data UserCostRow = UserCostRow (UserId, Int)
 
 instance FromRow UserCostRow where