Merge branch 'with-ghcjs' into 'master'

Use Haskell on the frontend

See merge request guyonvarch/shared-cost!2

5 files changed, 423 insertions, 0 deletions

diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
new file mode 100644
index 0000000..59f6a0d
--- /dev/null
+++ b/client/src/View/Income/Form.hs
@@ -0,0 +1,119 @@
+module View.Income.Form
+  ( view
+  , In(..)
+  , Operation(..)
+  ) where
+
+import           Control.Monad.IO.Class   (liftIO)
+import           Data.Aeson               (Value)
+import qualified Data.Aeson               as Aeson
+import qualified Data.Maybe               as Maybe
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import qualified Data.Time.Calendar       as Calendar
+import qualified Data.Time.Clock          as Time
+import           Data.Validation          (Validation)
+import qualified Data.Validation          as V
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+import           Common.Model             (CreateIncomeForm (..),
+                                           EditIncomeForm (..), Income (..))
+import qualified Common.Msg               as Msg
+import qualified Common.Util.Time         as TimeUtil
+import qualified Common.Validation.Income as IncomeValidation
+import qualified Component.Input          as Input
+import qualified Component.Modal          as Modal
+import qualified Component.ModalForm      as ModalForm
+import qualified Util.Ajax                as Ajax
+
+data In = In
+  { _in_operation :: Operation
+  }
+
+data Operation
+  = New
+  | Clone Income
+  | Edit Income
+
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m
+view input cancel = do
+
+  rec
+    let reset = R.leftmost
+          [ "" <$ ModalForm._out_cancel modalForm
+          , "" <$ ModalForm._out_validate modalForm
+          , "" <$ cancel
+          ]
+
+    modalForm <- ModalForm.view $ ModalForm.In
+      { ModalForm._in_headerLabel = headerLabel
+      , ModalForm._in_ajax        = ajax "/api/income"
+      , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
+      }
+
+  return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm)
+
+  where
+
+    form
+      :: Event t String
+      -> Event t ()
+      -> m (Dynamic t (Validation Text Value))
+    form reset confirm = do
+      amount <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Income_Amount
+          , Input._in_initialValue = amount
+          , Input._in_validation = IncomeValidation.amount
+          })
+        (amount <$ reset)
+        confirm)
+
+      currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+      let initialDate = T.pack . Calendar.showGregorian $ date currentDay
+
+      date <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Income_Date
+          , Input._in_initialValue = initialDate
+          , Input._in_inputType = "date"
+          , Input._in_hasResetButton = False
+          , Input._in_validation = IncomeValidation.date
+          })
+        (initialDate <$ reset)
+        confirm)
+
+      return $ do
+        a <- amount
+        d <- date
+        return . V.Success $ mkPayload a d
+
+    op = _in_operation input
+
+    amount =
+      case op of
+        New     -> ""
+        Clone i -> T.pack . show . _income_amount $ i
+        Edit i  -> T.pack . show . _income_amount $ i
+
+    date currentDay =
+      case op of
+        Edit i -> _income_date i
+        _      -> currentDay
+
+    ajax =
+      case op of
+        Edit _ -> Ajax.put
+        _      -> Ajax.post
+
+    headerLabel =
+      case op of
+        Edit _ -> Msg.get Msg.Income_Edit
+        _      -> Msg.get Msg.Income_AddLong
+
+    mkPayload =
+      case op of
+        Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b
+        _      -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
new file mode 100644
index 0000000..a26e16a
--- /dev/null
+++ b/client/src/View/Income/Header.hs
@@ -0,0 +1,77 @@
+module View.Income.Header
+  ( view
+  , In(..)
+  , Out(..)
+  ) 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 Clock
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Currency, Income (..),
+                                         IncomeHeader (..), User (..))
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
+
+import qualified Component.Button       as Button
+import qualified Component.Modal        as Modal
+import qualified View.Income.Form       as Form
+
+data In t = In
+  { _in_users    :: [User]
+  , _in_header   :: IncomeHeader
+  , _in_currency :: Currency
+  }
+
+data Out t = Out
+  { _out_add :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input =
+  R.divClass "withMargin" $ do
+
+    currentTime <- liftIO Clock.getCurrentTime
+
+    case _incomeHeader_since $ _in_header input of
+      Nothing ->
+        R.blank
+
+      Just since ->
+        R.el "div" $ do
+
+          R.el "h1" $ do
+            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since))
+
+          R.el "ul" $
+            flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) ->
+              R.el "li" $
+                R.text $
+                  T.intercalate " "
+                    [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input)
+                    , "−"
+                    , Format.price (_in_currency input) amount
+                    ]
+
+    R.divClass "titleButton" $ do
+      R.el "h1" $
+        R.text $
+          Msg.get Msg.Income_MonthlyNet
+
+      addIncome <- Button._out_clic <$>
+        (Button.view . Button.defaultIn . R.text $
+          Msg.get Msg.Income_AddLong)
+
+      addIncome <- Modal.view $ Modal.In
+        { Modal._in_show    = addIncome
+        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
+        }
+
+      return $ Out
+        { _out_add = addIncome
+        }
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
new file mode 100644
index 0000000..7be8091
--- /dev/null
+++ b/client/src/View/Income/Income.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+module View.Income.Income
+  ( view
+  , In(..)
+  ) where
+
+import           Data.Aeson          (FromJSON)
+import qualified Data.Maybe          as Maybe
+import qualified Data.Text           as T
+import           Reflex.Dom          (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom          as R
+
+import           Common.Model        (Currency, Income (..), IncomePage (..),
+                                      User, UserId)
+
+import qualified Component.Pages     as Pages
+import           Loadable            (Loadable (..))
+import qualified Loadable
+import qualified Util.Ajax           as AjaxUtil
+import qualified Util.Reflex         as ReflexUtil
+import qualified Util.Reflex         as ReflexUtil
+import qualified View.Income.Header  as Header
+import qualified View.Income.Reducer as Reducer
+import qualified View.Income.Table   as Table
+
+data In t = In
+  { _in_users       :: [User]
+  , _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
+  rec
+    incomePage <- Reducer.reducer $ Reducer.In
+      { Reducer._in_page         = page
+      , Reducer._in_addIncome    = R.leftmost [headerAddIncome, tableAddIncome]
+      , Reducer._in_editIncome   = editIncome
+      , Reducer._in_deleteIncome = deleteIncome
+      }
+
+    let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+        eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
+
+    page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
+    headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
+    tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+    editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+    deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+
+    result <- Loadable.viewShowValueWhileLoading incomePage $
+      \(IncomePage page header incomes count) -> do
+        header <- Header.view $ Header.In
+          { Header._in_users = _in_users input
+          , Header._in_header = header
+          , Header._in_currency = _in_currency input
+          }
+
+        table <- Table.view $ Table.In
+          { Table._in_currentUser = _in_currentUser input
+          , Table._in_currency = _in_currency input
+          , Table._in_incomes = incomes
+          , Table._in_users = _in_users input
+          }
+
+        pages <- Pages.view $ Pages.In
+          { Pages._in_total = R.constDyn count
+          , Pages._in_perPage = Reducer.perPage
+          , Pages._in_page = page
+          }
+
+        return (header, table, pages)
+
+  return ()
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
new file mode 100644
index 0000000..ea9f664
--- /dev/null
+++ b/client/src/View/Income/Reducer.hs
@@ -0,0 +1,59 @@
+module View.Income.Reducer
+  ( perPage
+  , reducer
+  , In(..)
+  ) where
+
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (IncomePage)
+
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
+import qualified Util.Ajax    as AjaxUtil
+import qualified Util.Either  as EitherUtil
+
+perPage :: Int
+perPage = 7
+
+data In t a b c = In
+  { _in_page         :: Event t Int
+  , _in_addIncome    :: Event t a
+  , _in_editIncome   :: Event t b
+  , _in_deleteIncome :: Event t c
+  }
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage))
+reducer input = do
+
+  postBuild <- R.getPostBuild
+
+  currentPage <- R.holdDyn 1 (_in_page input)
+
+  let loadPage =
+        R.leftmost
+          [ 1 <$ postBuild
+          , _in_page input
+          , 1 <$ _in_addIncome input
+          , R.tag (R.current currentPage) (_in_editIncome input)
+          , R.tag (R.current currentPage) (_in_deleteIncome input)
+          ]
+
+  getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+  R.holdDyn
+    Loading
+    (R.leftmost
+      [ Loading <$ loadPage
+      , Loadable.fromEither <$> getResult
+      ])
+
+  where
+    pageUrl p =
+      "api/incomes?page="
+      <> (T.pack . show $ p)
+      <> "&perPage="
+      <> (T.pack . show $ perPage)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
new file mode 100644
index 0000000..7b7940d
--- /dev/null
+++ b/client/src/View/Income/Table.hs
@@ -0,0 +1,93 @@
+module View.Income.Table
+  ( view
+  , In(..)
+  , Out(..)
+  ) where
+
+import qualified Data.Maybe              as Maybe
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import           Reflex.Dom              (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom              as R
+
+import           Common.Model            (Currency, Income (..), User (..),
+                                          UserId)
+import qualified Common.Model            as CM
+import qualified Common.Msg              as Msg
+import qualified Common.View.Format      as Format
+
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table         as Table
+import qualified Util.Ajax               as Ajax
+import qualified Util.Either             as EitherUtil
+import qualified View.Income.Form        as Form
+
+data In t = In
+  { _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  , _in_incomes     :: [Income]
+  , _in_users       :: [User]
+  }
+
+data Out t = Out
+  { _out_add    :: Event t ()
+  , _out_edit   :: Event t ()
+  , _out_delete :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+
+  table <- Table.view $ Table.In
+    { Table._in_headerLabel = headerLabel
+    , Table._in_rows = _in_incomes input
+    , Table._in_cell = cell (_in_users input) (_in_currency input)
+    , Table._in_cloneModal = \income ->
+      Form.view $ Form.In
+        { Form._in_operation = Form.Clone income
+        }
+    , Table._in_editModal = \income ->
+      Form.view $ Form.In
+        { Form._in_operation = Form.Edit income
+        }
+    , Table._in_deleteModal = \income ->
+      ConfirmDialog.view $ ConfirmDialog.In
+        { ConfirmDialog._in_header  = Msg.get Msg.Income_DeleteConfirm
+        , ConfirmDialog._in_confirm = \e -> do
+          res <- Ajax.delete
+            (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income])
+            e
+          return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+        }
+    , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId
+    , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId
+    }
+
+  return $ Out
+    { _out_add = Table._out_add table
+    , _out_edit = Table._out_edit table
+    , _out_delete = Table._out_delete table
+    }
+
+data Header
+  = UserHeader
+  | AmountHeader
+  | DateHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel UserHeader   = Msg.get Msg.Income_Name
+headerLabel DateHeader   = Msg.get Msg.Income_Date
+headerLabel AmountHeader = Msg.get Msg.Income_Amount
+
+cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m ()
+cell users currency header income =
+  case header of
+    UserHeader ->
+      R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
+
+    DateHeader ->
+      R.text . Format.longDay . _income_date $ income
+
+    AmountHeader ->
+      R.text . Format.price currency . _income_amount $ income