Allow to remove only unused categories

11 files changed, 107 insertions, 61 deletions

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 37020da..bcff377 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -57,7 +57,7 @@ view input reset validate = do
           ]
 
         inputAttr = R.ffor value (\v ->
-          if T.null v && _in_inputType input /= "date"
+          if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color"
             then M.empty
             else M.singleton "class" "filled")
 
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index f82cfa6..1482f91 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -21,7 +21,8 @@ data In m t h r = In
   , _in_cloneModal  :: r -> Modal.Content t m
   , _in_editModal   :: r -> Modal.Content t m
   , _in_deleteModal :: r -> Modal.Content t m
-  , _in_isOwner     :: r -> Bool
+  , _in_canEdit     :: r -> Bool
+  , _in_canDelete   :: r -> Bool
   }
 
 data Out t = Out
@@ -62,8 +63,6 @@ view input =
                 , Modal._in_content = _in_cloneModal input row
                 }
 
-            let isOwner = _in_isOwner input row
-
             let visibleIf cond =
                   R.elAttr
                     "div"
@@ -71,7 +70,7 @@ view input =
 
             editButton <-
               R.divClass "cell button" $
-                visibleIf isOwner $
+                visibleIf (_in_canEdit input row) $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.edit)
 
@@ -83,7 +82,7 @@ view input =
 
             deleteButton <-
               R.divClass "cell button" $
-                visibleIf isOwner $
+                visibleIf (_in_canDelete input row) $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.delete)
 
diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs
index 77a331a..5b41bb6 100644
--- a/client/src/View/Category/Category.hs
+++ b/client/src/View/Category/Category.hs
@@ -53,13 +53,14 @@ view input = do
     deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
     result <- Loadable.viewShowValueWhileLoading categoryPage $
-      \(CategoryPage page categories count) -> do
+      \(CategoryPage page categories usedCategories count) -> do
         header <- headerView
 
         table <- Table.view $ Table.In
           { Table._in_currentUser = _in_currentUser input
           , Table._in_currency = _in_currency input
           , Table._in_categories = categories
+          , Table._in_usedCategories = usedCategories
           , Table._in_users = _in_users input
           }
 
@@ -75,18 +76,19 @@ view input = do
 
 headerView :: forall t m. MonadWidget t m => m (Event t ())
 headerView =
-  R.divClass "titleButton" $ do
-    R.el "h1" $
-      R.text $
-        Msg.get Msg.Category_Title
-
-    addCategory <- Button._out_clic <$>
-      (Button.view . Button.defaultIn . R.text $
-        Msg.get Msg.Category_Add)
-
-    addCategory <- Modal.view $ Modal.In
-      { Modal._in_show    = addCategory
-      , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
-      }
-
-    return addCategory
+  R.divClass "withMargin" $
+    R.divClass "titleButton" $ do
+      R.el "h1" $
+        R.text $
+          Msg.get Msg.Category_Title
+
+      addCategory <- Button._out_clic <$>
+        (Button.view . Button.defaultIn . R.text $
+          Msg.get Msg.Category_Add)
+
+      addCategory <- Modal.view $ Modal.In
+        { Modal._in_show    = addCategory
+        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
+        }
+
+      return addCategory
diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs
index fbe76e9..90d013d 100644
--- a/client/src/View/Category/Table.hs
+++ b/client/src/View/Category/Table.hs
@@ -10,8 +10,8 @@ import qualified Data.Text               as T
 import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
-import           Common.Model            (Category (..), Currency, User (..),
-                                          UserId)
+import           Common.Model            (Category (..), CategoryId, Currency,
+                                          User (..), UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
 import qualified Common.View.Format      as Format
@@ -24,10 +24,11 @@ import qualified Util.Either             as EitherUtil
 import qualified View.Category.Form      as Form
 
 data In t = In
-  { _in_currentUser :: UserId
-  , _in_currency    :: Currency
-  , _in_categories  :: [Category]
-  , _in_users       :: [User]
+  { _in_currentUser    :: UserId
+  , _in_currency       :: Currency
+  , _in_categories     :: [Category]
+  , _in_usedCategories :: [CategoryId]
+  , _in_users          :: [User]
   }
 
 data Out t = Out
@@ -60,7 +61,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = const True
+    , Table._in_canEdit = const True
+    , Table._in_canDelete = not . flip elem (_in_usedCategories input) . _category_id
     }
 
   return $ Out
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index c7f172b..7b7940d 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -59,7 +59,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId
+    , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId
+    , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId
     }
 
   return $ Out
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 6744d3a..bfa0fb9 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -74,7 +74,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user
+    , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user
+    , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user
     }
 
   return $ Out
diff --git a/common/src/Common/Model/CategoryPage.hs b/common/src/Common/Model/CategoryPage.hs
index 476b4ce..e20f49f 100644
--- a/common/src/Common/Model/CategoryPage.hs
+++ b/common/src/Common/Model/CategoryPage.hs
@@ -5,12 +5,13 @@ module Common.Model.CategoryPage
 import           Data.Aeson            (FromJSON, ToJSON)
 import           GHC.Generics          (Generic)
 
-import           Common.Model.Category (Category)
+import           Common.Model.Category (Category, CategoryId)
 
 data CategoryPage = CategoryPage
-  { _categoryPage_page       :: Int
-  , _categoryPage_categories :: [Category]
-  , _categoryPage_totalCount :: Int
+  { _categoryPage_page           :: Int
+  , _categoryPage_categories     :: [Category]
+  , _categoryPage_usedCategories :: [CategoryId]
+  , _categoryPage_totalCount     :: Int
   } deriving (Eq, Show, Generic)
 
 instance FromJSON CategoryPage
diff --git a/common/src/Common/Validation/Atomic.hs b/common/src/Common/Validation/Atomic.hs
index 2a356df..4bb7cad 100644
--- a/common/src/Common/Validation/Atomic.hs
+++ b/common/src/Common/Validation/Atomic.hs
@@ -7,6 +7,7 @@ module Common.Validation.Atomic
   , color
   ) where
 
+import qualified Data.Char          as Char
 import           Data.Text          (Text)
 import qualified Data.Text          as T
 import           Data.Time.Calendar (Day)
@@ -47,6 +48,10 @@ day str =
     Just d  -> V.Success d
     Nothing -> V.Failure $ Msg.get Msg.Form_InvalidDate
 
--- TODO: validate
 color :: Text -> Validation Text Text
-color str = V.Success str
+color str =
+  if T.take 1 str == "#" && T.all Char.isHexDigit (T.drop 1 str) then
+    V.Success str
+
+  else
+    V.Failure (Msg.get Msg.Form_InvalidColor)
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