Use a better project structure

9 files changed, 510 insertions, 0 deletions

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
new file mode 100644
index 0000000..f21798c
--- /dev/null
+++ b/client/src/Component/Button.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Component.Button
+  ( ButtonIn(..)
+  , buttonInDefault
+  , ButtonOut(..)
+  , button
+  ) where
+
+import qualified Data.Map as M
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget, Event)
+import qualified Reflex.Dom as R
+
+import qualified Icon
+
+data ButtonIn t m = ButtonIn
+  { _buttonIn_class :: Text
+  , _buttonIn_content :: m ()
+  , _buttonIn_waiting :: Event t Bool
+  }
+
+buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m
+buttonInDefault = ButtonIn
+  { _buttonIn_class = ""
+  , _buttonIn_content = R.blank
+  , _buttonIn_waiting = R.never
+  }
+
+data ButtonOut t = ButtonOut
+  { _buttonOut_clic :: Event t ()
+  }
+
+button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
+button buttonIn = do
+  attr <- R.holdDyn
+    (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)])
+    (fmap
+      (\w -> M.fromList $
+        [ ("type", "button") ]
+        <> if w
+             then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])]
+             else [("class", _buttonIn_class buttonIn)])
+      (_buttonIn_waiting buttonIn))
+  (e, _) <- R.elDynAttr' "button" attr $ do
+    Icon.loading
+    R.divClass "content" $ _buttonIn_content buttonIn
+  return $ ButtonOut
+    { _buttonOut_clic = R.domEvent R.Click e
+    }
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
new file mode 100644
index 0000000..7111630
--- /dev/null
+++ b/client/src/Component/Input.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Component.Input
+  ( InputIn(..)
+  , InputOut(..)
+  , input
+  ) where
+
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:))
+import qualified Reflex.Dom as R
+
+data InputIn t a b = InputIn
+  { _inputIn_reset :: Event t a
+  , _inputIn_placeHolder :: Text
+  }
+
+data InputOut t = InputOut
+  { _inputOut_value :: Dynamic t Text
+  , _inputOut_enter :: Event t ()
+  }
+
+input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
+input inputIn = do
+  let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn)
+  let value = fmap (const "") (_inputIn_reset inputIn)
+  textInput <- R.textInput $ R.def & R.attributes .~ placeHolder
+                                   & R.setValue .~ value
+  let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+  return $ InputOut
+    { _inputOut_value = R._textInput_value textInput
+    , _inputOut_enter = enter
+    }
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
new file mode 100644
index 0000000..7223def
--- /dev/null
+++ b/client/src/Icon.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Icon
+  ( loading
+  , signOut
+  , clone
+  , edit
+  , delete
+  ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
+
+clone :: forall t m. MonadWidget t m => m ()
+clone =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
+
+edit :: forall t m. MonadWidget t m => m ()
+edit =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
+
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+
+svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
+svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/Main.hs b/client/src/Main.hs
new file mode 100644
index 0000000..1f167d4
--- /dev/null
+++ b/client/src/Main.hs
@@ -0,0 +1,40 @@
+module Main
+  ( main
+  ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LB
+import Data.JSString.Text (textFromJSString)
+import qualified Data.Text.Encoding as T
+import qualified GHCJS.DOM as Dom
+import qualified GHCJS.DOM.NonElementParentNode as Dom
+import GHCJS.DOM.Types (JSM, Element, JSString)
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(InitEmpty))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+import qualified View.App as App
+
+main :: JSM ()
+main = do
+  initResult <- readInit
+  App.widget initResult
+
+readInit :: JSM InitResult
+readInit = do
+  document <- Dom.currentDocumentUnchecked
+  initNode <- Dom.getElementById document "init"
+  case initNode of
+    Just node -> do
+      text <- textFromJSString <$> js_getInnerText node
+      return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
+        Just init -> init
+        Nothing -> initParseError
+    _ ->
+      return initParseError
+  where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
+
+foreign import javascript unsafe "$1[\"innerText\"]"
+  js_getInnerText :: Element -> IO JSString
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
new file mode 100644
index 0000000..1466811
--- /dev/null
+++ b/client/src/View/App.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.App
+  ( widget
+  ) where
+
+import qualified Reflex.Dom as R
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(..))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+import View.Header (HeaderIn(..))
+import View.Payment (PaymentIn(..))
+import qualified View.Header as Header
+import qualified View.Payment as Payment
+import qualified View.SignIn as SignIn
+
+widget :: InitResult -> IO ()
+widget initResult =
+  R.mainWidget $ do
+    headerOut <- Header.view $ HeaderIn
+      { _headerIn_initResult = initResult
+      }
+
+    let signOut = Header._headerOut_signOut headerOut
+
+        initialContent = case initResult of
+          InitSuccess initSuccess -> do
+            _ <- Payment.widget $ PaymentIn
+              { _paymentIn_init = initSuccess
+              }
+            return ()
+          InitEmpty result ->
+            SignIn.view result
+
+        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+
+    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+
+    R.blank
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
new file mode 100644
index 0000000..705e054
--- /dev/null
+++ b/client/src/View/Header.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Header
+  ( view
+  , HeaderIn(..)
+  , HeaderOut(..)
+  ) where
+
+import qualified Data.Map as M
+import Data.Time (NominalDiffTime)
+import Reflex.Dom (MonadWidget, Event)
+import qualified Reflex.Dom as R
+import Prelude hiding (init, error)
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult(..), Init(..), User(..))
+import qualified Common.Model as CM
+
+import Component.Button (ButtonIn(..))
+import qualified Component.Button as Component
+import qualified Icon
+
+data HeaderIn = HeaderIn
+  { _headerIn_initResult :: InitResult
+  }
+
+data HeaderOut t = HeaderOut
+  { _headerOut_signOut :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view headerIn =
+  R.el "header" $ do
+
+    R.divClass "title" $
+      R.text $ Message.get Key.App_Title
+
+    signOut <- nameSignOut $ _headerIn_initResult headerIn
+
+    return $ HeaderOut
+      { _headerOut_signOut = signOut
+      }
+
+nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
+nameSignOut initResult = case initResult of
+  (InitSuccess init) -> do
+    rec
+      attr <- R.holdDyn
+        (M.singleton "class" "nameSignOut")
+        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+      signOut <- R.elDynAttr "nameSignOut" attr $ do
+        case CM.findUser (_init_currentUser init) (_init_users init) of
+          Just user -> R.divClass "name" $ R.text (_user_name user)
+          Nothing -> R.blank
+        signOutButton
+
+    return signOut
+  _ ->
+    return R.never
+
+signOutButton :: forall t m. MonadWidget t m => m (Event t ())
+signOutButton = do
+  rec
+    signOut <- Component.button $ ButtonIn
+      { Component._buttonIn_class = "signOut item"
+      , Component._buttonIn_content = Icon.signOut
+      , Component._buttonIn_waiting = waiting
+      }
+    let signOutClic = Component._buttonOut_clic signOut
+        waiting = R.leftmost
+          [ fmap (const True) signOutClic
+          , fmap (const False) signOutSuccess
+          ]
+    signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime)
+
+  return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess
+
+  where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
+        askSignOut signOut =
+          fmap getResult <$> R.performRequestAsync xhrRequest
+          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+                getResult = (== 200) . R._xhrResponse_status
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
new file mode 100644
index 0000000..e80790b
--- /dev/null
+++ b/client/src/View/Payment.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment
+  ( widget
+  , PaymentIn(..)
+  , PaymentOut(..)
+  ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Init)
+
+import View.Payment.Table (TableIn(..))
+import qualified View.Payment.Table as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+data PaymentOut = PaymentOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
+widget paymentIn = do
+  R.divClass "payment" $ do
+    _ <- Table.widget $ TableIn
+      { _tableIn_init = _paymentIn_init paymentIn
+      }
+    return $ PaymentOut {}
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
new file mode 100644
index 0000000..f3eb9a7
--- /dev/null
+++ b/client/src/View/Payment/Table.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment.Table
+  ( widget
+  , TableIn(..)
+  , TableOut(..)
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.List as L
+import qualified Data.Map as M
+import Prelude hiding (init)
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..))
+import qualified Common.Model as CM
+import qualified Common.Util.Text as T
+import qualified Common.View.Format as Format
+
+import qualified Icon
+
+data TableIn = TableIn
+  { _tableIn_init :: Init
+  }
+
+data TableOut = TableOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
+widget tableIn = do
+  R.divClass "table" $
+    R.divClass "lines" $ do
+      R.divClass "header" $ do
+        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
+        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
+        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
+        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
+        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+        R.divClass "cell" $ R.blank
+        R.divClass "cell" $ R.blank
+        R.divClass "cell" $ R.blank
+      let init = _tableIn_init tableIn
+          payments = _init_payments init
+      mapM_
+        (paymentRow init)
+        (take 8 . reverse . L.sortOn _payment_date $ payments)
+  return $ TableOut {}
+
+paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m ()
+paymentRow init payment =
+  R.divClass "row" $ do
+    R.divClass "cell name" . R.text $ _payment_name payment
+    R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment
+    R.divClass "cell user" $
+      case CM.findUser (_payment_user payment) (_init_users init) of
+        Just user -> R.text (_user_name user)
+        _ -> R.blank
+    R.divClass "cell category" $
+      case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of
+        Just category ->
+          R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $
+            R.text $ _category_name category
+        _ ->
+          R.blank
+    R.divClass "cell date" $ do
+      R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment)
+      R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment)
+    R.divClass "cell button" . R.el "button" $ Icon.clone
+    R.divClass "cell button" $
+      if _payment_user payment == (_init_currentUser init)
+        then R.el "button" $ Icon.edit
+        else R.blank
+    R.divClass "cell button" $
+      if _payment_user payment == (_init_currentUser init)
+        then R.el "button" $ Icon.delete
+        else R.blank
+
+findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
+findCategory categories paymentCategories paymentName = do
+  paymentCategory <- L.find
+    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+    paymentCategories
+  L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
new file mode 100644
index 0000000..e164ee7
--- /dev/null
+++ b/client/src/View/SignIn.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.SignIn
+  ( 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 (MonadWidget, Event)
+import qualified Reflex.Dom as R
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (SignIn(SignIn))
+
+import Component.Input (InputIn(..), InputOut(..))
+import Component.Button (ButtonIn(..), ButtonOut(..))
+import qualified Component.Button as Component
+import qualified Component.Input 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_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        }
+
+      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 = ""
+        , _buttonIn_content = R.text (Message.get Key.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 "/signIn" . 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
+  R.blank
+
+  where showInitResult (Left error) = showError error
+        showInitResult (Right (Just success)) = showSuccess success
+        showInitResult (Right Nothing) = R.blank
+
+        showResult (Left error) = showError error
+        showResult (Right success) = showSuccess success
+
+        showError = R.divClass "error" . R.text
+        showSuccess = R.divClass "success" . R.text