diff options
27 files changed, 285 insertions, 116 deletions
diff --git a/.tmuxinator.yml b/.tmuxinator.yml index 1576496..2d52bb4 100644 --- a/.tmuxinator.yml +++ b/.tmuxinator.yml @@ -6,8 +6,8 @@ windows: - app: panes: - client: - - make clean-client watch-client + - make watch-client - server: - - make clean-server watch-server + - make watch-server - db: - sqlite3 database @@ -75,9 +75,7 @@ TODO ### Code -- modal as body child https://stackoverflow.com/questions/33711392/what-is-the-proper-way-in-reflex-dom-to-handle-a-modal-dialog - Move up element ids security (editOwn is actually at db level). -- move persistence methods to a module. - try DuplicateRecordFields (https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields) ### Tooling diff --git a/client/client.cabal b/client/client.cabal index 0aec05f..26ad2ec 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -10,7 +10,7 @@ Cabal-version: >=1.10 Executable client Main-Is: Main.hs - Ghc-options: -Wall -Werror + -- Ghc-options: -Wall -Werror Hs-source-dirs: src Default-language: Haskell2010 @@ -22,10 +22,12 @@ Executable client Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , bytestring , common , containers + , data-default + , ghcjs-dom-jsffi , jsaddle-dom , reflex-dom , text diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs index 0a89c6e..6ea02fa 100644 --- a/client/src/Component/Form.hs +++ b/client/src/Component/Form.hs @@ -6,7 +6,7 @@ import qualified Data.Map as M import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -form :: forall t m a. (MonadWidget t m) => m a -> m a +form :: forall t m a. MonadWidget t m => m a -> m a form content = R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $ content diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs index 1d70c90..72091c9 100644 --- a/client/src/Component/Modal.hs +++ b/client/src/Component/Modal.hs @@ -1,14 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Component.Modal ( ModalIn(..) , ModalOut(..) , modal ) where -import qualified Data.Map as M -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Control.Monad (void) +import qualified Data.Map as M +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import qualified GHCJS.DOM.Node as Node +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R +import qualified Reflex.Dom.Class as R + +import qualified Util.Dom as Dom data ModalIn t m a = ModalIn { _modalIn_show :: Event t () @@ -29,16 +34,22 @@ modal modalIn = do , False <$ curtainClick ] - let attr = flip fmap showModal (\s -> M.fromList $ - [ ("style", if s then "display:block" else "display:none") - , ("class", "modal") - ]) - - (curtainClick, content) <- R.elDynAttr "div" attr $ do + (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank cont <- R.divClass "modalContent" $ _modalIn_content modalIn return (R.domEvent R.Click curtain, cont) + body <- Dom.getBody + let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn) + R.performEvent_ $ void `fmap` moveBackdrop + return $ ModalOut { _modalOut_content = content } + +getAttributes :: Bool -> LM.Map Text Text +getAttributes show = + M.fromList $ + [ ("style", if show then "display:block" else "display:none") + , ("class", "modal") + ] diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs index 876548e..17a4958 100644 --- a/client/src/Component/Select.hs +++ b/client/src/Component/Select.hs @@ -19,7 +19,7 @@ data SelectOut t a = SelectOut { _selectOut_value :: Dynamic t a } -select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a) +select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a) select selectIn = R.divClass "selectInput" $ do R.el "label" $ R.text (_selectIn_label selectIn) diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs index 1e8e4c7..14675df 100644 --- a/client/src/Util/Ajax.hs +++ b/client/src/Util/Ajax.hs @@ -1,20 +1,55 @@ module Util.Ajax - ( post + ( postJson + , delete ) where -import Data.Aeson (ToJSON) -import Data.Text (Text) -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R +import Data.Aeson (ToJSON) +import Data.Default (def) +import qualified Data.Map.Lazy as LM +import Data.Text (Text) +import Reflex.Dom (Dynamic, Event, IsXhrPayload, MonadWidget, + XhrRequest, XhrRequestConfig (..), XhrResponse, + XhrResponseHeaders (..)) +import qualified Reflex.Dom as R -post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text)) -post url input = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = R.postJson url <$> input - getResult response = - case R._xhrResponse_responseText response of - Just responseText -> - if R._xhrResponse_status response == 200 - then Right responseText - else Left responseText - _ -> Left "NoKey" +postJson + :: forall t m a. (MonadWidget t m, ToJSON a) + => Text + -> Event t a + -> m (Event t (Either Text Text)) +postJson url input = + fmap getResult <$> + R.performRequestAsync (R.postJson url <$> input) + +delete + :: forall t m. MonadWidget t m + => Dynamic t Text + -> Event t () + -> m (Event t (Either Text Text)) +delete url fire = + fmap getResult <$> + R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire) + +getResult :: XhrResponse -> Either Text Text +getResult response = + case R._xhrResponse_responseText response of + Just responseText -> + if R._xhrResponse_status response == 200 + then Right responseText + else Left responseText + _ -> Left "NoKey" + +request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a +request method url sendData = + let + config = XhrRequestConfig + { _xhrRequestConfig_headers = def + , _xhrRequestConfig_user = def + , _xhrRequestConfig_password = def + , _xhrRequestConfig_responseType = def + , _xhrRequestConfig_responseHeaders = def + , _xhrRequestConfig_withCredentials = False + , _xhrRequestConfig_sendData = sendData + } + in + R.xhrRequest method url config diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs index f3e9c88..55b8521 100644 --- a/client/src/Util/Dom.hs +++ b/client/src/Util/Dom.hs @@ -1,12 +1,31 @@ module Util.Dom - ( divVisibleIf + ( divIfDyn + , divIfEvent + , divVisibleIf , divClassVisibleIf + , getBody ) where -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (Dynamic, MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified GHCJS.DOM as Dom +import qualified GHCJS.DOM.Document as Document +import qualified GHCJS.DOM.HTMLCollection as HTMLCollection +import GHCJS.DOM.Types (Element) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a) +divIfDyn cond = divIfEvent (R.updated cond) + +divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a) +divIfEvent cond empty content = + R.widgetHold empty (flip fmap cond (\show -> + if show + then + content + else + empty)) divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a divVisibleIf cond content = divClassVisibleIf cond "" content @@ -17,3 +36,10 @@ divClassVisibleIf cond className content = "div" (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond) content + +getBody :: forall t m. MonadWidget t m => m Element +getBody = do + document <- Dom.currentDocumentUnchecked + nodelist <- Document.getElementsByTagName document ("body" :: String) + Just body <- nodelist `HTMLCollection.item` 0 + return body diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs index 5ff09dd..8b1b56e 100644 --- a/client/src/View/Payment/Add.hs +++ b/client/src/View/Payment/Add.hs @@ -23,7 +23,7 @@ import Component (ButtonIn (..), InputIn (..), SelectOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data AddIn = AddIn { _addIn_categories :: [Category] @@ -83,8 +83,8 @@ view addIn = do , _buttonIn_submit = True }) - (_, waiting) <- Util.waitFor - (Ajax.post "/payment") + (_, waiting) <- WaitFor.waitFor + (Ajax.postJson "/payment") validate payment diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs index a1be16d..03cf267 100644 --- a/client/src/View/Payment/Delete.hs +++ b/client/src/View/Payment/Delete.hs @@ -4,24 +4,27 @@ module View.Payment.Delete , DeleteOut(..) ) where -import Reflex.Dom (Event, MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Msg as Msg -import Component (ButtonIn (..), ButtonOut (..)) -import qualified Component as Component --- import qualified Util.Ajax as Ajax --- import qualified Util.WaitFor as Util - -data DeleteIn = DeleteIn - {} +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model.Payment (PaymentId) +import qualified Common.Msg as Msg +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component +import qualified Util.Ajax as Ajax +-- import qualified Util.WaitFor as WaitFor + +data DeleteIn t = DeleteIn + { _deleteIn_id :: Dynamic t PaymentId + } data DeleteOut t = DeleteOut { _deleteOut_cancel :: Event t () } -view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t) -view _ = +view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t) +view deleteIn = R.divClass "delete" $ do R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm @@ -29,14 +32,19 @@ view _ = cancel <- R.divClass "buttons" $ do rec - _ <- Component._buttonOut_clic <$> (Component.button $ + confirm <- Component._buttonOut_clic <$> (Component.button $ (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm)) { _buttonIn_class = R.constDyn "confirm" , _buttonIn_submit = True }) - -- (_, waiting) <- Util.waitFor - -- (Ajax.post "/payment") + let url = flip fmap (_deleteIn_id deleteIn) (\id -> + T.concat ["/payment/", T.pack . show $ id] + ) + Ajax.delete url confirm + + -- (_, waiting) <- WaitFor.waitFor + -- (Ajax.delete "/payment") -- validate -- payment diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index fd46c25..be7f6d5 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do R.text "+ " R.text . Format.price currency $ _exceedingPayer_amount p ) - addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn + addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = R.constDyn "addPayment" , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add , _buttonIn_waiting = R.never @@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do }) rec modalOut <- Component.modal $ ModalIn - { _modalIn_show = addPayment + { _modalIn_show = addPaymentClic , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories } } diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index 23d7225..13cedda 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -118,7 +118,7 @@ paymentRow init payment = modalOut <- Component.modal $ ModalIn { _modalIn_show = deletePayment , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut - , _modalIn_content = Delete.view (DeleteIn {}) + , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment }) } return () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 21d0fcc..24e5be0 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -16,7 +16,7 @@ import Component (ButtonIn (..), ButtonOut (..), InputIn (..), InputOut (..)) import qualified Component as Component import qualified Util.Ajax as Ajax -import qualified Util.WaitFor as Util +import qualified Util.WaitFor as WaitFor data SignInMessage = SuccessMessage Text @@ -43,8 +43,8 @@ view signInMessage = , _buttonIn_submit = True } - (signInResult, waiting) <- Util.waitFor - (\email -> Ajax.post "/askSignIn" (SignIn <$> email)) + (signInResult, waiting) <- WaitFor.waitFor + (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email)) (_buttonOut_clic button) (_inputOut_value input) diff --git a/common/common.cabal b/common/common.cabal index 6e5c8fb..151326a 100644 --- a/common/common.cabal +++ b/common/common.cabal @@ -21,12 +21,14 @@ Library Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , text , time Exposed-modules: Common.Model + Common.Model.CreatePayment + Common.Model.Payment Common.Msg Common.Util.Text Common.Util.Time @@ -39,7 +41,6 @@ Library Common.Model.Category Common.Model.CreateCategory Common.Model.CreateIncome - Common.Model.CreatePayment Common.Model.Currency Common.Model.EditCategory Common.Model.EditIncome @@ -49,7 +50,6 @@ Library Common.Model.Init Common.Model.InitResult Common.Model.Payer - Common.Model.Payment Common.Model.PaymentCategory Common.Model.SignIn Common.Model.User diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index a6828d5..6e5f246 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -38,8 +38,8 @@ data Key = | Error_SignOut | Form_AlreadyExists - | Form_CostMustNotBeNull - | Form_Empty + | Form_NonEmpty + | Form_NonNullNumber | Form_GreaterIntThan Int | Form_InvalidCategory | Form_InvalidColor diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 5ea12ad..70eb978 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -157,16 +157,16 @@ m l Form_AlreadyExists = English -> "Dupplicate field" French -> "Doublon" -m l Form_CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l Form_Empty = +m l Form_NonEmpty = case l of English -> "Required field" French -> "Champ requis" +m l Form_NonNullNumber = + case l of + English -> "Number must not be null" + French -> "Le nombre ne doit pas être nul" + m l (Form_GreaterIntThan number) = case l of English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] diff --git a/common/src/Common/Model/CreatePayment.hs b/common/src/Common/Model/CreatePayment.hs index cd0b01d..c61423c 100644 --- a/common/src/Common/Model/CreatePayment.hs +++ b/common/src/Common/Model/CreatePayment.hs @@ -1,5 +1,6 @@ module Common.Model.CreatePayment - ( CreatePayment(..) + ( CreatePaymentError(..) + , CreatePayment(..) ) where import Data.Aeson (FromJSON, ToJSON) @@ -10,6 +11,17 @@ import GHC.Generics (Generic) import Common.Model.Category (CategoryId) import Common.Model.Frequency (Frequency) +data CreatePaymentError = CreatePaymentError + { _createPaymentError_name :: Maybe Text + , _createPaymentError_cost :: Maybe Text + , _createPaymentError_date :: Maybe Text + , _createPaymentError_category :: Maybe Text + , _createPaymentError_frequency :: Maybe Text + } deriving (Show, Generic) + +instance FromJSON CreatePaymentError +instance ToJSON CreatePaymentError + data CreatePayment = CreatePayment { _createPayment_name :: Text , _createPayment_cost :: Int diff --git a/default.nix b/default.nix index 15dfdae..657de1b 100644 --- a/default.nix +++ b/default.nix @@ -6,9 +6,9 @@ let repo = "reflex-platform"; rev = "504b0344dfa6d03e4c89cf70ab9792b0a1fa021b"; sha256 = "01hvdwc6bw48falpha5kaq4p7w98hc804kkwrayipb5ld1snchpz"; + # rev = "a457c21ceb32ea27f66f3fae930e5d8bf7ec768d"; + # sha256 = "0drzvma2q809b6hafdlq4k23mnlbmy8ny5qz140ya76zizbq34vs"; }) {}; - - buildInputs = [ pkgs.noDemon ]; in reflex-platform.project ({ pkgs, ... }: { packages = { diff --git a/server/server.cabal b/server/server.cabal index 2bfd18d..2c6bef1 100644 --- a/server/server.cabal +++ b/server/server.cabal @@ -21,7 +21,7 @@ Executable server Build-depends: aeson - , base >=4.9 && <4.11 + , base >=4.9 && <5 , base64-bytestring , blaze-builder , blaze-html @@ -103,7 +103,8 @@ Executable server Secure SendMail Util.Time - Validation + Validation.Atomic + Validation.CreatePayment View.Mail.SignIn View.Mail.WeeklyReport View.Page diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e1936f0..4edbf6a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -18,6 +18,7 @@ import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +import qualified Validation.CreatePayment as CreatePaymentValidation list :: ActionM () list = @@ -26,12 +27,18 @@ list = ) create :: CreatePayment -> ActionM () -create (CreatePayment name cost date category frequency) = +create createPayment@(CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + case CreatePaymentValidation.validate createPayment of + Nothing -> + (liftIO . Query.run $ do + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId + Just validationError -> + do + status Status.badRequest400 + json validationError ) editOwn :: EditPayment -> ActionM () diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs index ce427c0..2677fd8 100644 --- a/server/src/Design/Modal.hs +++ b/server/src/Design/Modal.hs @@ -2,9 +2,11 @@ module Design.Modal ( design ) where -import Data.Monoid ((<>)) - import Clay +import Data.Monoid ((<>)) + +import qualified Design.View.Payment.Add as Add +import qualified Design.View.Payment.Delete as Delete design :: Css design = do @@ -31,6 +33,9 @@ design = do sym borderRadius (px 5) boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5) + ".add" ? Add.design + ".delete" ? Delete.design + ".paymentModal" & do ".radioGroup" ? ".title" ? display none ".selectInput" ? do diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs index 2102ff8..0d59fa0 100644 --- a/server/src/Design/View/Payment.hs +++ b/server/src/Design/View/Payment.hs @@ -4,7 +4,6 @@ module Design.View.Payment import Clay -import qualified Design.View.Payment.Add as Add import qualified Design.View.Payment.Header as Header import qualified Design.View.Payment.Pages as Pages import qualified Design.View.Payment.Table as Table @@ -12,6 +11,5 @@ import qualified Design.View.Payment.Table as Table design :: Css design = do ".header" ? Header.design - ".add" ? Add.design ".table" ? Table.design ".pages" ? Pages.design diff --git a/server/src/Design/View/Payment/Delete.hs b/server/src/Design/View/Payment/Delete.hs new file mode 100644 index 0000000..5597f5b --- /dev/null +++ b/server/src/Design/View/Payment/Delete.hs @@ -0,0 +1,32 @@ +module Design.View.Payment.Delete + ( design + ) where + +import Clay + +import qualified Design.Color as Color +import qualified Design.Constants as Constants +import qualified Design.Helper as Helper + +design :: Css +design = do + ".deleteHeader" ? do + backgroundColor Color.chestnutRose + fontSize (px 18) + color Color.white + sym padding (px 20) + textAlign (alignSide sideCenter) + borderRadius (px 5) (px 5) (px 0) (px 0) + + ".deleteContent" ? do + sym padding (px 20) + + ".buttons" ? do + display flex + justifyContent spaceAround + marginTop (em 1.5) + + ".confirm" ? + Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten + ".undo" ? + Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten diff --git a/server/src/Main.hs b/server/src/Main.hs index e298a06..745071c 100644 --- a/server/src/Main.hs +++ b/server/src/Main.hs @@ -37,7 +37,7 @@ main = do S.put "/payment" $ S.jsonData >>= Payment.editOwn - S.delete "/payment" $ do + S.delete "/payment/:id" $ do paymentId <- S.param "id" Payment.deleteOwn paymentId @@ -47,7 +47,7 @@ main = do S.put "/income" $ S.jsonData >>= Income.editOwn - S.delete "/income" $ do + S.delete "/income/:id" $ do incomeId <- S.param "id" Income.deleteOwn incomeId @@ -57,6 +57,6 @@ main = do S.put "/category" $ S.jsonData >>= Category.edit - S.delete "/category" $ do + S.delete "/category/:id" $ do categoryId <- S.param "id" Category.delete categoryId diff --git a/server/src/Validation.hs b/server/src/Validation.hs deleted file mode 100644 index fd739cd..0000000 --- a/server/src/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/server/src/Validation/Atomic.hs b/server/src/Validation/Atomic.hs new file mode 100644 index 0000000..d15ad49 --- /dev/null +++ b/server/src/Validation/Atomic.hs @@ -0,0 +1,32 @@ +module Validation.Atomic + ( nonEmpty + , nonNullNumber + -- , number + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Common.Msg as Msg + +nonEmpty :: Text -> Maybe Text +nonEmpty str = + if T.null str + then Just $ Msg.get Msg.Form_NonEmpty + else Nothing + +nonNullNumber :: Int -> Maybe Text +nonNullNumber n = + if n == 0 + then Just $ Msg.get Msg.Form_NonNullNumber + else Nothing + +-- number :: (Int -> Bool) -> Text -> Maybe Int +-- number numberForm str = +-- case reads (T.unpack str) :: [(Int, String)] of +-- (num, _) : _ -> +-- if numberForm num +-- then Just num +-- else Nothing +-- _ -> +-- Nothing diff --git a/server/src/Validation/CreatePayment.hs b/server/src/Validation/CreatePayment.hs new file mode 100644 index 0000000..fbcdb7c --- /dev/null +++ b/server/src/Validation/CreatePayment.hs @@ -0,0 +1,25 @@ +module Validation.CreatePayment + ( validate + ) where + +import Data.Maybe (catMaybes) + +import Common.Model.CreatePayment (CreatePayment (..), + CreatePaymentError (..)) +import qualified Validation.Atomic as Atomic + +validate :: CreatePayment -> Maybe CreatePaymentError +validate p = + if not . null . catMaybes $ [ nameError, costError ] + then Just createPaymentError + else Nothing + where + nameError = Atomic.nonEmpty . _createPayment_name $ p + costError = Atomic.nonNullNumber . _createPayment_cost $ p + createPaymentError = CreatePaymentError + { _createPaymentError_name = nameError + , _createPaymentError_cost = costError + , _createPaymentError_date = Nothing + , _createPaymentError_category = Nothing + , _createPaymentError_frequency = Nothing + } |