From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Sep 2017 22:14:48 +0200 Subject: Bootstrap with GHCJS and reflex: - setup login and logout, - first draft of payment view. --- src/client/View/App.hs | 44 ++++++++++++ src/client/View/Color.elm | 12 ---- src/client/View/Date.elm | 57 --------------- src/client/View/Errors.elm | 21 ------ src/client/View/Events.elm | 15 ---- src/client/View/Form.elm | 152 --------------------------------------- src/client/View/Header.elm | 60 ---------------- src/client/View/Header.hs | 86 ++++++++++++++++++++++ src/client/View/Payment.hs | 33 +++++++++ src/client/View/Payment/Table.hs | 90 +++++++++++++++++++++++ src/client/View/Plural.elm | 11 --- src/client/View/SignIn.hs | 86 ++++++++++++++++++++++ 12 files changed, 339 insertions(+), 328 deletions(-) create mode 100644 src/client/View/App.hs delete mode 100644 src/client/View/Color.elm delete mode 100644 src/client/View/Date.elm delete mode 100644 src/client/View/Errors.elm delete mode 100644 src/client/View/Events.elm delete mode 100644 src/client/View/Form.elm delete mode 100644 src/client/View/Header.elm create mode 100644 src/client/View/Header.hs create mode 100644 src/client/View/Payment.hs create mode 100644 src/client/View/Payment/Table.hs delete mode 100644 src/client/View/Plural.elm create mode 100644 src/client/View/SignIn.hs (limited to 'src/client/View') diff --git a/src/client/View/App.hs b/src/client/View/App.hs new file mode 100644 index 0000000..1466811 --- /dev/null +++ b/src/client/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/src/client/View/Color.elm b/src/client/View/Color.elm deleted file mode 100644 index a2a20c7..0000000 --- a/src/client/View/Color.elm +++ /dev/null @@ -1,12 +0,0 @@ -module View.Color exposing (..) - -import Color exposing (Color) - -chestnutRose : Color -chestnutRose = Color.rgb 207 92 86 - -white : Color -white = Color.white - -silver : Color -silver = Color.rgb 200 200 200 diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm deleted file mode 100644 index 6df971b..0000000 --- a/src/client/View/Date.elm +++ /dev/null @@ -1,57 +0,0 @@ -module View.Date exposing - ( shortMonthAndYear - , shortView - , longView - , monthView - ) - -import Date exposing (..) -import Date.Extra.Core as Date -import String - -import Model.Translations exposing (..) - -shortMonthAndYear : Month -> Int -> Translations -> String -shortMonthAndYear month year translations = - let params = - [ String.pad 2 '0' (toString (Date.monthToInt month)) - , toString year - ] - in getParamMessage params translations "ShortMonthAndYear" - -shortView : Date -> Translations -> String -shortView date translations = - let params = - [ String.pad 2 '0' (toString (Date.day date)) - , String.pad 2 '0' (toString (Date.monthToInt (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "ShortDate" - -longView : Date -> Translations -> String -longView date translations = - let params = - [ toString (Date.day date) - , (getMessage translations (getMonthKey (Date.month date))) - , toString (Date.year date) - ] - in getParamMessage params translations "LongDate" - -monthView : Translations -> Month -> String -monthView translations month = getMessage translations (getMonthKey month) - -getMonthKey : Month -> String -getMonthKey month = - case month of - Jan -> "January" - Feb -> "February" - Mar -> "March" - Apr -> "April" - May -> "May" - Jun -> "June" - Jul -> "July" - Aug -> "August" - Sep -> "September" - Oct -> "October" - Nov -> "November" - Dec -> "December" diff --git a/src/client/View/Errors.elm b/src/client/View/Errors.elm deleted file mode 100644 index 3e25c99..0000000 --- a/src/client/View/Errors.elm +++ /dev/null @@ -1,21 +0,0 @@ -module View.Errors exposing - ( view - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model.Translations exposing (Translations, getMessage) - -view : Translations -> List String -> Html msg -view translations errors = - ul - [ class "errors" ] - ( List.map (errorView translations) errors) - -errorView : Translations -> String -> Html msg -errorView translations error = - li - [ class "error" ] - [ text <| getMessage translations error ] diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm deleted file mode 100644 index d71d67d..0000000 --- a/src/client/View/Events.elm +++ /dev/null @@ -1,15 +0,0 @@ -module View.Events exposing - ( onSubmitPrevDefault - ) - -import Json.Decode as Decode -import Html exposing (..) -import Html.Events exposing (..) -import Html.Attributes exposing (..) - -onSubmitPrevDefault : msg -> Attribute msg -onSubmitPrevDefault value = - onWithOptions - "submit" - { defaultOptions | preventDefault = True } - (Decode.succeed value) diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm deleted file mode 100644 index 977ca0a..0000000 --- a/src/client/View/Form.elm +++ /dev/null @@ -1,152 +0,0 @@ -module View.Form exposing - ( textInput - , colorInput - , selectInput - , radioInputs - , hiddenSubmit - ) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) -import Maybe.Extra as Maybe - -import FontAwesome -import View.Color as Color - -import Form exposing (Form, FieldState) -import Form.Input as Input -import Form.Error as FormError exposing (ErrorValue(..)) -import Form.Field as Field - -import Msg exposing (Msg) - -import LoggedData exposing (LoggedData) - -import Model.Translations as Translations exposing (Translations) - -textInput : Translations -> Form String a -> String -> String -> Html Form.Msg -textInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - fieldId = formName ++ fieldName - in div - [ classList - [ ("textInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ Input.textInput - field - [ id fieldId - , classList [ ("filled", Maybe.isJust field.value) ] - , value (Maybe.withDefault "" field.value) - ] - , label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , button - [ type_ "button" - , onClick (Form.Input fieldName Form.Text Field.EmptyField) - , tabindex -1 - ] - [ FontAwesome.times Color.silver 15 ] - , formError translations field - ] - -colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg -colorInput translations form formName fieldName = - let field = Form.getFieldAsString fieldName form - in div - [ classList - [ ("colorInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) ] - , Input.textInput - field - [ id (formName ++ fieldName) - , type_ "color" - ] - ] - -radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg -radioInputs translations form formName radioName fieldNames = - let field = Form.getFieldAsString radioName form - in div - [ classList - [ ("radioGroup", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ div - [ class "title" ] - [ text (Translations.getMessage translations (formName ++ radioName) ) ] - , div - [ class "radioInputs" ] - (List.map (radioInput translations field formName) fieldNames) - , formError translations field - ] - -radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg -radioInput translations field formName fieldName = - div - [ class "radioInput" ] - [ Input.radioInput - field.path - field - [ id (formName ++ fieldName) - , value fieldName - , checked (field.value == Just fieldName) - ] - , label - [ for (formName ++ fieldName) ] - [ text (Translations.getMessage translations (formName ++ fieldName)) - ] - ] - -selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg -selectInput translations form formName selectName options = - let field = Form.getFieldAsString selectName form - fieldId = formName ++ selectName - in div - [ classList - [ ("selectInput", True) - , ("error", Maybe.isJust field.liveError) - ] - ] - [ label - [ for fieldId ] - [ text (Translations.getMessage translations fieldId) ] - , Input.selectInput - (("", "") :: options) - field - [ id fieldId ] - , formError translations field - ] - -formError : Translations -> FieldState String a -> Html msg -formError translations field = - case field.liveError of - Just error -> - let errorElement error params = - div - [ class "errorMessage" ] - [ text (Translations.getParamMessage params translations error) ] - in case error of - CustomError key -> errorElement key [] - SmallerIntThan n -> errorElement "SmallerIntThan" [toString n] - GreaterIntThan n -> errorElement "GreaterIntThan" [toString n] - error -> errorElement (toString error) [] - Nothing -> - text "" - -hiddenSubmit : msg -> Html msg -hiddenSubmit msg = - button - [ style [ ("display", "none") ] - , onClick msg - ] - [] diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm deleted file mode 100644 index 12fb87c..0000000 --- a/src/client/View/Header.elm +++ /dev/null @@ -1,60 +0,0 @@ -module View.Header exposing - ( view - ) - -import Dict - -import FontAwesome -import View.Color as Color - -import Page exposing (..) - -import Html exposing (..) -import Html.Attributes exposing (..) -import Html.Events exposing (..) - -import Model exposing (Model) -import Model.Translations exposing (getMessage) -import Msg exposing (..) -import Model.View exposing (..) - -view : Model -> Html Msg -view model = - header - [] - ( [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ] - ++ let item page name = - a - [ href (Page.toHash page) - , classList - [ ("item", True) - , ("current", model.page == page) - ] - ] - [ text (getMessage model.translations name) - ] - in case model.view of - LoggedInView { me, users } -> - [ item Home "PaymentsTitle" - , item Income "Income" - , item Categories "Categories" - , item Statistics "Statistics" - , div - [ class "nameSignOut" ] - [ div - [ class "name" ] - [ Dict.get me users - |> Maybe.map .name - |> Maybe.withDefault "" - |> text - ] - , button - [ class "signOut item" - , onClick SignOut - ] - [ FontAwesome.power_off Color.white 30 ] - ] - ] - _ -> - [] - ) diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs new file mode 100644 index 0000000..32738f1 --- /dev/null +++ b/src/client/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.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 new file mode 100644 index 0000000..e80790b --- /dev/null +++ b/src/client/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/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs new file mode 100644 index 0000000..878e7da --- /dev/null +++ b/src/client/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.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/Plural.elm b/src/client/View/Plural.elm deleted file mode 100644 index c36eaca..0000000 --- a/src/client/View/Plural.elm +++ /dev/null @@ -1,11 +0,0 @@ -module View.Plural exposing - ( plural - ) - -import Model.Translations exposing (Translations, getMessage) - -plural : Translations -> Int -> String -> String -> String -plural translations n single multiple = - let singleMessage = getMessage translations single - multipleMessage = getMessage translations multiple - in (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs new file mode 100644 index 0000000..e164ee7 --- /dev/null +++ b/src/client/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 -- cgit v1.2.3