diff options
Diffstat (limited to 'client/src/View/Payment/Form.hs')
| -rw-r--r-- | client/src/View/Payment/Form.hs | 199 |
1 files changed, 0 insertions, 199 deletions
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs deleted file mode 100644 index 6c31fad..0000000 --- a/client/src/View/Payment/Form.hs +++ /dev/null @@ -1,199 +0,0 @@ -module View.Payment.Form - ( view - , In(..) - , Operation(..) - ) where - -import Control.Monad (join) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (Value) -import qualified Data.Aeson as Aeson -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Map as M -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (NominalDiffTime) -import Data.Time.Calendar (Day) -import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Clock -import Data.Validation (Validation) -import qualified Data.Validation as V -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R -import qualified Text.Read as T - -import Common.Model (Category (..), CategoryId, - CreatePaymentForm (..), - EditPaymentForm (..), - Frequency (..), Payment (..)) -import qualified Common.Msg as Msg -import qualified Common.Util.Time as TimeUtil -import qualified Common.Validation.Payment as PaymentValidation - -import qualified Component.Input as Input -import qualified Component.Modal as Modal -import qualified Component.ModalForm as ModalForm -import qualified Component.Select as Select -import qualified Util.Ajax as Ajax -import qualified Util.Either as EitherUtil -import qualified Util.Validation as ValidationUtil - -data In t = In - { _in_categories :: [Category] - , _in_operation :: Operation t - , _in_frequency :: Frequency - } - -data Operation t - = New - | Clone Payment - | Edit Payment - -view :: forall t m a. MonadWidget t m => In t -> 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/payment" - , 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 (NonEmpty Text) Value)) - form reset confirm = do - name <- Input.view - (Input.defaultIn - { Input._in_label = Msg.get Msg.Payment_Name - , Input._in_initialValue = name - , Input._in_validation = PaymentValidation.name - }) - (name <$ reset) - confirm - - cost <- Input._out_raw <$> (Input.view - (Input.defaultIn - { Input._in_label = Msg.get Msg.Payment_Cost - , Input._in_initialValue = cost - , Input._in_validation = PaymentValidation.cost - }) - (cost <$ reset) - confirm) - - currentDate <- date - - date <- - case frequency of - Punctual -> do - Input._out_raw <$> (Input.view - (Input.defaultIn - { Input._in_label = Msg.get Msg.Payment_Date - , Input._in_initialValue = currentDate - , Input._in_inputType = "date" - , Input._in_hasResetButton = False - , Input._in_validation = PaymentValidation.date - }) - (currentDate <$ reset) - confirm) - Monthly -> - return . R.constDyn $ currentDate - - setCategory <- - R.debounce (1 :: NominalDiffTime) (R.updated $ Input._out_raw name) - >>= (return . R.ffilter (\name -> T.length name >= 3)) - >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>))) - >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe)) - - category <- Select._out_value <$> (Select.view $ Select.In - { Select._in_label = Msg.get Msg.Payment_Category - , Select._in_initialValue = category - , Select._in_value = setCategory - , Select._in_values = R.constDyn categories - , Select._in_reset = category <$ reset - , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input) - , Select._in_validate = confirm - }) - - return $ do - n <- Input._out_value name - c <- cost - d <- date - cat <- category - return (mkPayload - <$> ValidationUtil.nelError n - <*> V.Success c - <*> V.Success d - <*> ValidationUtil.nelError cat - <*> V.Success frequency) - - frequencies = - M.fromList - [ (Punctual, Msg.get Msg.Payment_PunctualMale) - , (Monthly, Msg.get Msg.Payment_MonthlyMale) - ] - - categories = M.fromList . flip map (_in_categories input) $ \c -> - (_category_id c, _category_name c) - - category = - case op of - New -> -1 - Clone p -> _payment_category p - Edit p -> _payment_category p - - op = _in_operation input - - name = - case op of - New -> "" - Clone p -> _payment_name p - Edit p -> _payment_name p - - cost = - case op of - New -> "" - Clone p -> T.pack . show . _payment_cost $ p - Edit p -> T.pack . show . _payment_cost $ p - - date = do - currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay - return . T.pack . Calendar.showGregorian $ - case op of - New -> currentDay - Clone p -> currentDay - Edit p -> _payment_date p - - frequency = - case op of - New -> _in_frequency input - Clone p -> _payment_frequency p - Edit p -> _payment_frequency p - - headerLabel = - case op of - New -> Msg.get Msg.Payment_Add - Clone _ -> Msg.get Msg.Payment_CloneLong - Edit _ -> Msg.get Msg.Payment_EditLong - - ajax = - case op of - Edit _ -> Ajax.put - _ -> Ajax.post - - mkPayload = - case op of - Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e - _ -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e |