diff options
Diffstat (limited to 'src/client')
| l--------- | src/client/Common | 1 | ||||
| -rw-r--r-- | src/client/Component/Button.hs | 53 | ||||
| -rw-r--r-- | src/client/Component/Input.hs | 34 | ||||
| -rw-r--r-- | src/client/Debug.hs | 17 | ||||
| -rw-r--r-- | src/client/Icon.hs | 44 | ||||
| -rw-r--r-- | src/client/Main.hs | 41 | ||||
| -rw-r--r-- | src/client/View/App.hs | 44 | ||||
| -rw-r--r-- | src/client/View/Header.hs | 86 | ||||
| -rw-r--r-- | src/client/View/Payment.hs | 33 | ||||
| -rw-r--r-- | src/client/View/Payment/Table.hs | 90 | ||||
| -rw-r--r-- | src/client/View/SignIn.hs | 86 |
11 files changed, 0 insertions, 529 deletions
diff --git a/src/client/Common b/src/client/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/client/Common +++ /dev/null @@ -1 +0,0 @@ -../common
\ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs deleted file mode 100644 index f21798c..0000000 --- a/src/client/Component/Button.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# 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/src/client/Component/Input.hs b/src/client/Component/Input.hs deleted file mode 100644 index 7111630..0000000 --- a/src/client/Component/Input.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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/src/client/Debug.hs b/src/client/Debug.hs deleted file mode 100644 index 0c5c979..0000000 --- a/src/client/Debug.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Debug - ( event - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event, Dynamic) -import qualified Reflex.Dom as R - -event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () -event name e = do - count <- R.count e :: m (Dynamic t Int) - let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count - R.el "div" $ R.dynText text diff --git a/src/client/Icon.hs b/src/client/Icon.hs deleted file mode 100644 index 7223def..0000000 --- a/src/client/Icon.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# 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/src/client/Main.hs b/src/client/Main.hs deleted file mode 100644 index c5f2c50..0000000 --- a/src/client/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -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 - putStrLn . show $ initResult - 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/src/client/View/App.hs b/src/client/View/App.hs deleted file mode 100644 index 1466811..0000000 --- a/src/client/View/App.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# 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/src/client/View/Header.hs b/src/client/View/Header.hs deleted file mode 100644 index 32738f1..0000000 --- a/src/client/View/Header.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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.User as User - -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 User.find (_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/src/client/View/Payment.hs b/src/client/View/Payment.hs deleted file mode 100644 index e80790b..0000000 --- a/src/client/View/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# 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/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs deleted file mode 100644 index 878e7da..0000000 --- a/src/client/View/Payment/Table.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# 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.User as User -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 User.find (_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/src/client/View/SignIn.hs b/src/client/View/SignIn.hs deleted file mode 100644 index e164ee7..0000000 --- a/src/client/View/SignIn.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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 |