From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Jan 2018 12:13:09 +0100
Subject: WIP

---
 client/src/View/App.hs            |   8 +--
 client/src/View/Header.hs         |  13 +++--
 client/src/View/Payment/Add.hs    | 104 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Delete.hs |  51 +++++++++++++++++++
 client/src/View/Payment/Header.hs |  33 +++++++-----
 client/src/View/Payment/Pages.hs  |   2 +
 client/src/View/Payment/Table.hs  |  48 +++++++++++-------
 client/src/View/SignIn.hs         |  98 +++++++++++++++--------------------
 8 files changed, 261 insertions(+), 96 deletions(-)
 create mode 100644 client/src/View/Payment/Add.hs
 create mode 100644 client/src/View/Payment/Delete.hs

(limited to 'client/src/View')

diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 64ca303..9aa6c57 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -29,10 +29,12 @@ widget initResult =
               { _paymentIn_init = initSuccess
               }
             return ()
-          InitEmpty result ->
-            SignIn.view result
+          InitEmpty ->
+            SignIn.view SignIn.EmptyMessage
+          InitError error ->
+            SignIn.view (SignIn.ErrorMessage error)
 
-        signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
+        signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
 
     _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
 
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 4c74383..8f1fb78 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -13,9 +13,8 @@ import qualified Reflex.Dom       as R
 import           Common.Model     (Init (..), InitResult (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
-
+import qualified Component        as Component
 import           Component.Button (ButtonIn (..))
-import qualified Component.Button as Component
 import qualified Icon
 
 data HeaderIn = HeaderIn
@@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
   rec
-    signOut <- Component.button $ ButtonIn
-      { Component._buttonIn_class = R.constDyn "signOut item"
-      , Component._buttonIn_content = Icon.signOut
-      , Component._buttonIn_waiting = waiting
-      }
+    signOut <- Component.button $
+      (Component.defaultButtonIn Icon.signOut)
+        { _buttonIn_class = R.constDyn "signOut item"
+        , _buttonIn_waiting = waiting
+        }
     let signOutClic = Component._buttonOut_clic signOut
         waiting = R.leftmost
           [ fmap (const True) signOutClic
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
new file mode 100644
index 0000000..2eaec0f
--- /dev/null
+++ b/client/src/View/Payment/Add.hs
@@ -0,0 +1,104 @@
+module View.Payment.Add
+  ( view
+  , AddIn(..)
+  , AddOut(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Map               as M
+import qualified Data.Maybe             as Maybe
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (Event, MonadWidget)
+import qualified Reflex.Dom             as R
+import qualified Text.Read              as T
+
+import           Common.Model           (Category (..), CreatePayment (..),
+                                         Frequency (..))
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as Time
+import qualified Common.View.Format     as Format
+import           Component              (ButtonIn (..), InputIn (..),
+                                         InputOut (..), SelectIn (..),
+                                         SelectOut (..))
+import qualified Component              as Component
+import qualified Util.Ajax              as Ajax
+import qualified Util.WaitFor           as Util
+
+data AddIn = AddIn
+  { _addIn_categories :: [Category]
+  }
+
+data AddOut t = AddOut
+  { _addOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t)
+view addIn = do
+  R.divClass "add" $ do
+    R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
+
+    R.divClass "addContent" $ do
+      name <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+
+      cost <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+
+      currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+
+      date <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Cost
+          , _inputIn_initialValue = Format.shortDay currentDay
+          })
+
+      frequency <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Frequency
+        , _selectIn_initialValue = Punctual
+        , _selectIn_values = R.constDyn frequencies
+        })
+
+      category <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Category
+        , _selectIn_initialValue = 0
+        , _selectIn_values = R.constDyn categories
+        })
+
+      let payment = CreatePayment
+            <$> name
+            <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
+            <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
+            <*> category
+            <*> frequency
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          validate <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_waiting = waiting
+              , _buttonIn_submit = True
+              })
+
+          (_, waiting) <- Util.waitFor
+            (Ajax.post "/payment")
+            validate
+            payment
+
+        Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+      return AddOut
+        { _addOut_cancel = cancel
+        }
+
+  where
+    frequencies = M.fromList
+      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+      ]
+
+    categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
+      (_category_id c, _category_name c)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
new file mode 100644
index 0000000..a1be16d
--- /dev/null
+++ b/client/src/View/Payment/Delete.hs
@@ -0,0 +1,51 @@
+module View.Payment.Delete
+  ( view
+  , DeleteIn(..)
+  , DeleteOut(..)
+  ) where
+
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import           Component  (ButtonIn (..), ButtonOut (..))
+import qualified Component  as Component
+-- import qualified Util.Ajax              as Ajax
+-- import qualified Util.WaitFor           as Util
+
+data DeleteIn = DeleteIn
+  {}
+
+data DeleteOut t = DeleteOut
+  { _deleteOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
+view _ =
+  R.divClass "delete" $ do
+    R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
+
+    R.divClass "deleteContent" $ do
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          _ <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_submit = True
+              })
+
+          -- (_, waiting) <- Util.waitFor
+          --   (Ajax.post "/payment")
+          --   validate
+          --   payment
+
+        cancel <- Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+        return cancel
+
+      return DeleteOut
+        { _deleteOut_cancel = cancel
+        }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index a694136..d01dec6 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -16,9 +16,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, ExceedingPayer (..),
-                                         Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..))
+import           Common.Model           (Category, Currency,
+                                         ExceedingPayer (..), Frequency (..),
+                                         Income (..), Init (..), Payment (..),
+                                         User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Text       as T
@@ -26,9 +27,11 @@ import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
                                          InputIn (..), InputOut (..),
-                                         ModalIn (..))
+                                         ModalIn (..), ModalOut (..))
 import qualified Component              as Component
 import qualified Util.List              as L
+import           View.Payment.Add       (AddIn (..), AddOut (..))
+import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
   { _headerIn_init :: Init
@@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes punctualPayments users currency
+    payerAndAdd incomes punctualPayments users categories currency
     (searchName, searchFrequency)  <- searchLine
     let searchPayments = getSearchPayments searchName searchFrequency payments
     infos searchPayments users currency
@@ -56,6 +59,7 @@ widget headerIn =
     payments = _init_payments init
     punctualPayments = filter ((==) Punctual . _payment_frequency) payments
     users = _init_users init
+    categories = _init_categories init
     currency = _init_currency init
 
 getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
@@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do
   n <- name
   f <- frequency
   pure $ flip filter payments (\p ->
-    (  T.search n (_payment_name p)
+    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
     && (_payment_frequency p == f)
     ))
 
-payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
-payerAndAdd incomes payments users currency = do
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
     R.divClass "exceedingPayers" $
@@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
+      , _buttonIn_tabIndex = Nothing
+      , _buttonIn_submit = False
       })
-    _ <- Component.modal $ ModalIn
-      { _modalIn_show    = addPayment
-      , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement"
-      }
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = addPayment
+        , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+        }
     return ()
 
 searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
@@ -99,6 +107,7 @@ searchLine = do
     searchName <- _inputOut_value <$> (Component.input $ InputIn
       { _inputIn_reset = R.never
       , _inputIn_label = Msg.get Msg.Search_Name
+      , _inputIn_initialValue = ""
       })
 
     let frequencies = M.fromList
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 55ceb9f..d14b640 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -82,5 +82,7 @@ pageButton currentPage page content = do
         if cp == Just p then "page current" else "page"
     , _buttonIn_content = content
     , _buttonIn_waiting = R.never
+    , _buttonIn_tabIndex = Nothing
+    , _buttonIn_submit = False
     })
   return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index a49be5c..23d7225 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,23 +4,28 @@ module View.Payment.Table
   , TableOut(..)
   ) where
 
-import qualified Data.List          as L
-import qualified Data.Map           as M
-import           Data.Text          (Text)
-import qualified Data.Text          as T
-import           Prelude            hiding (init)
-import           Reflex.Dom         (Dynamic, MonadWidget)
-import qualified Reflex.Dom         as R
-
-import           Common.Model       (Category (..), Init (..), Payment (..),
-                                     PaymentCategory (..), User (..))
-import qualified Common.Model       as CM
-import qualified Common.Msg         as Msg
-import qualified Common.Util.Text   as T
-import qualified Common.View.Format as Format
+import qualified Data.List           as L
+import qualified Data.Map            as M
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+import           Prelude             hiding (init)
+import           Reflex.Dom          (Dynamic, MonadWidget)
+import qualified Reflex.Dom          as R
+
+import           Common.Model        (Category (..), Init (..), Payment (..),
+                                      PaymentCategory (..), User (..))
+import qualified Common.Model        as CM
+import qualified Common.Msg          as Msg
+import qualified Common.Util.Text    as T
+import qualified Common.View.Format  as Format
+import           Component           (ButtonIn (..), ButtonOut (..),
+                                      ModalIn (..), ModalOut (..))
+import qualified Component           as Component
+import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+import qualified View.Payment.Delete as Delete
 
 import qualified Icon
-import qualified Util.Dom           as Dom
+import qualified Util.Dom            as Dom
 
 data TableIn t = TableIn
   { _tableIn_init        :: Init
@@ -105,8 +110,17 @@ paymentRow init payment =
           M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")]
     R.elDynAttr "div" modifyAttrs $
       R.el "button" $ Icon.edit
-    R.elDynAttr "div" modifyAttrs $
-      R.el "button" $ Icon.delete
+    deletePayment <- R.elDynAttr "div" modifyAttrs $
+      _buttonOut_clic <$> (Component.button $
+        (Component.defaultButtonIn Icon.delete)
+          { _buttonIn_class = R.constDyn "deletePayment" })
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = deletePayment
+        , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Delete.view (DeleteIn {})
+        }
+    return ()
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 89be737..912aea2 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,11 +1,10 @@
 module View.SignIn
-  ( view
+  ( SignInMessage (..)
+  , view
   ) where
 
 import qualified Data.Either  as Either
-import           Data.Monoid  ((<>))
 import           Data.Text    (Text)
-import           Data.Time    (NominalDiffTime)
 import           Prelude      hiding (error)
 import           Reflex.Dom   (Event, MonadWidget)
 import qualified Reflex.Dom   as R
@@ -16,62 +15,47 @@ import qualified Common.Msg   as Msg
 import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
-
-view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
-view result =
-  R.divClass "signIn" $ do
-    rec
-      input <- Component.input $ InputIn
-        { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-        }
-
-      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-
-      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
-        [ fmap (const True) userWantsEmailValidation
-        , fmap (const False) signInResult
-        ]
-
-      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
-
-      let validatedEmail = R.tagPromptlyDyn
-            (_inputOut_value input)
-            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
-
-      let waiting = R.leftmost
-            [ fmap (const True) validatedEmail
-            , fmap (const False) signInResult
-            ]
-
-      button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn "validate"
-        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
-        , _buttonIn_waiting = waiting
-        }
-
-      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
-
-    showSignInResult result signInResult
-
-askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
-askSignIn email =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just key ->
-              if R._xhrResponse_status response == 200 then Right key else Left key
-            _ -> Left "NoKey"
-
-showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
-showSignInResult result signInResult = do
-  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+import qualified Util.Ajax    as Ajax
+import qualified Util.WaitFor as Util
+
+data SignInMessage =
+  SuccessMessage Text
+  | ErrorMessage Text
+  | EmptyMessage
+
+view :: forall t m. MonadWidget t m => SignInMessage -> m ()
+view signInMessage =
+  R.divClass "signIn" $
+    Component.form $ do
+      rec
+        input <- Component.input $ InputIn
+          { _inputIn_reset = R.ffilter Either.isRight signInResult
+          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
+          , _inputIn_initialValue = ""
+          }
+
+        button <- Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
+            { _buttonIn_class = R.constDyn "validate"
+            , _buttonIn_waiting = waiting
+            , _buttonIn_submit = True
+            }
+
+        (signInResult, waiting) <- Util.waitFor
+          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+          (_buttonOut_clic button)
+          (_inputOut_value input)
+
+      showSignInResult signInMessage signInResult
+
+showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
+showSignInResult signInMessage signInResult = do
+  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
   R.blank
 
-  where showInitResult (Left error)           = showError error
-        showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing)        = R.blank
+  where showInitResult (SuccessMessage success) = showSuccess success
+        showInitResult (ErrorMessage error)     = showError error
+        showInitResult EmptyMessage             = R.blank
 
         showResult (Left error)    = showError error
         showResult (Right success) = showSuccess success
-- 
cgit v1.2.3