Skip to content

Commit 56b03b3

Browse files
functorafunctora
committed
delivery calculator asset input verification
1 parent 746df99 commit 56b03b3

File tree

8 files changed

+153
-56
lines changed

8 files changed

+153
-56
lines changed

‎ghcjs/delivery-calculator/delivery-calculator.cabal‎

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 2.2
22
name: delivery-calculator
3-
version: 0.1.0.4
3+
version: 0.1.0.5
44
synopsis: Delivery Calculator
55
category: Web
66
build-type: Simple
@@ -95,13 +95,13 @@ common pkg
9595
, miso
9696
, miso-functora
9797
, modern-uri
98+
, network-uri
99+
, regex-compat
98100
, syb
99101
, xlsx
100102

101103
if flag(ghcid)
102-
build-depends:
103-
, jsaddle
104-
, network-uri
104+
build-depends: jsaddle
105105

106106
if os(wasi)
107107
build-depends: jsaddle-wasm
@@ -115,9 +115,7 @@ executable delivery-calculator
115115
build-depends: containers
116116

117117
if ((impl(ghcjs) || arch(javascript)) || os(wasi))
118-
build-depends:
119-
, jsaddle
120-
, network-uri
118+
build-depends: jsaddle
121119

122120
else
123121
build-depends:

‎ghcjs/delivery-calculator/src/App/Types.hs‎

Lines changed: 72 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module App.Types
88
newSt,
99
Asset (..),
1010
newAsset,
11+
verifyAsset,
1112
newFieldPair,
1213
newFieldPairId,
1314
newTotal,
@@ -56,7 +57,9 @@ import qualified Functora.Prelude as Prelude
5657
import qualified Functora.Rates as Rates
5758
import qualified Functora.Web as Web
5859
import Lens.Micro ((^..))
60+
import qualified Network.URI as NetUri
5961
import qualified Paths_delivery_calculator as Paths
62+
import qualified Text.Regex as Re
6063
import qualified Text.URI as URI
6164

6265
data Model = Model
@@ -143,7 +146,8 @@ newSt = do
143146

144147
data Asset f = Asset
145148
{ assetFieldPairs :: [FieldPair DynamicField f],
146-
assetModalState :: OpenedOrClosed
149+
assetModalState :: OpenedOrClosed,
150+
assetMustVerify :: Bool
147151
}
148152
deriving stock (Generic)
149153

@@ -188,12 +192,70 @@ newAsset = do
188192
required qty,
189193
comment
190194
],
191-
assetModalState = Opened
195+
assetModalState = Opened,
196+
assetMustVerify = False
192197
}
193198
where
194199
required :: FieldPair DynamicField Unique -> FieldPair DynamicField Unique
195200
required = #fieldPairValue . #fieldRequired .~ True
196201

202+
verifyAsset :: Asset Unique -> [View Action]
203+
verifyAsset asset =
204+
case assetFieldPairs asset of
205+
(link : photo : price : qty : _)
206+
| assetMustVerify asset -> do
207+
let failures =
208+
intersperse (text " ")
209+
$ verifyLink
210+
(link ^. #fieldPairValue . #fieldInput . #uniqueValue)
211+
<> verifyPhoto
212+
(photo ^. #fieldPairValue . #fieldInput . #uniqueValue)
213+
<> verifyPrice
214+
(price ^. #fieldPairValue . #fieldOutput)
215+
<> verifyQty
216+
(qty ^. #fieldPairValue . #fieldOutput)
217+
if null failures
218+
then mempty
219+
else [blockquote_ mempty failures]
220+
_ ->
221+
mempty
222+
223+
verifyLink :: Unicode -> [View Action]
224+
verifyLink "" = [text "Link is missing!"]
225+
verifyLink txt =
226+
case Re.matchRegex uriRe . from @Unicode @String $ uriOnlyChars txt of
227+
Just [uri, _] ->
228+
if isJust $ Re.matchRegex marketRe uri
229+
then mempty
230+
else [text "Link has unsupported marketplace!"]
231+
_ -> [text "Link should have exactly one URL!"]
232+
233+
verifyPhoto :: Unicode -> [View Action]
234+
verifyPhoto "" = [text "Photo is missing!"]
235+
verifyPhoto txt =
236+
case Re.matchRegex uriRe str of
237+
Just [_, _] -> mempty
238+
_ -> [text "Photo is incorrect!"]
239+
where
240+
str = from @Unicode @String $ uriOnlyChars txt
241+
242+
verifyPrice :: DynamicField -> [View Action]
243+
verifyPrice = \case
244+
DynamicFieldNumber x | x > 0 -> mempty
245+
_ -> [text "Price must be a positive number!"]
246+
247+
verifyQty :: DynamicField -> [View Action]
248+
verifyQty = \case
249+
DynamicFieldNumber x | x > 0 -> mempty
250+
_ -> [text "Quantity must be a positive number!"]
251+
252+
uriOnlyChars :: Unicode -> Unicode
253+
uriOnlyChars =
254+
omap $ \x ->
255+
if NetUri.isAllowedInURI x
256+
then x
257+
else ' '
258+
197259
newFieldPair ::
198260
( MonadIO m
199261
) =>
@@ -511,3 +573,11 @@ apkLink =
511573
<> "/delivery-calculator-v"
512574
<> vsn
513575
<> ".apk"
576+
577+
uriRe :: Re.Regex
578+
uriRe =
579+
Re.mkRegex "((https?|ftp)://[^\\s/$.?#].[^\\s]*)"
580+
581+
marketRe :: Re.Regex
582+
marketRe =
583+
Re.mkRegex "(tb\\.cn|1688\\.com|dewu\\.com|taobao\\.com|tmall\\.com)"

‎ghcjs/delivery-calculator/src/App/Widgets/Asset.hs‎

Lines changed: 52 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -39,38 +39,39 @@ assetViewer st idx =
3939
: FieldPairs.fieldPairsViewer fieldPairsOpts args
4040
]
4141
<> ( Dialog.dialog
42-
( Dialog.defOpts
43-
{ Dialog.optsTitle = Just title,
44-
Dialog.optsHeaderRight =
45-
const
46-
[ button_
47-
[type_ "reset", onClick removeAction]
48-
[icon Icon.IconDelete],
49-
button_
50-
[type_ "submit", onClick saveAction]
51-
[icon Icon.IconSave]
52-
],
53-
Dialog.optsFooterRight =
54-
const
55-
[ button_
56-
[type_ "reset", onClick removeAction]
57-
[icon Icon.IconDelete, text " Remove"],
58-
button_
59-
[type_ "submit", onClick saveAction]
60-
[icon Icon.IconSave, text " Save"]
61-
]
62-
}
63-
)
42+
Dialog.defOpts
43+
{ Dialog.optsTitle = Just title,
44+
Dialog.optsExtraOnClose = saveUpdate,
45+
Dialog.optsHeaderRight =
46+
const
47+
[ button_
48+
[type_ "reset", onClick removeAction]
49+
[icon Icon.IconDelete],
50+
button_
51+
[type_ "submit", onClick saveAction]
52+
[icon Icon.IconSave]
53+
],
54+
Dialog.optsFooterRight =
55+
const
56+
[ button_
57+
[type_ "reset", onClick removeAction]
58+
[icon Icon.IconDelete, text " Remove"],
59+
button_
60+
[type_ "submit", onClick saveAction]
61+
[icon Icon.IconSave, text " Save"]
62+
]
63+
}
6464
Dialog.Args
6565
{ Dialog.argsModel = st,
6666
Dialog.argsOptic = modalOptic,
6767
Dialog.argsAction = PushUpdate . Instant,
6868
Dialog.argsContent =
69-
FieldPairs.fieldPairsEditor
70-
args
71-
fieldPairsOpts
72-
{ FieldPairs.optsAdvanced = False
73-
}
69+
failures False
70+
<> FieldPairs.fieldPairsEditor
71+
args
72+
fieldPairsOpts
73+
{ FieldPairs.optsAdvanced = False
74+
}
7475
}
7576
)
7677
where
@@ -98,9 +99,30 @@ assetViewer st idx =
9899
saveAction =
99100
PushUpdate
100101
. Instant
101-
. PureUpdate
102-
$ cloneTraversal modalOptic
103-
.~ Closed
102+
$ PureUpdate saveUpdate
103+
saveUpdate =
104+
( #modelState
105+
. #stAssets
106+
. ix idx
107+
. #assetMustVerify
108+
.~ True
109+
)
110+
. if null $ failures True
111+
then cloneTraversal modalOptic .~ Closed
112+
else cloneTraversal modalOptic .~ Opened
113+
failures forceVerify =
114+
maybe
115+
mempty
116+
( verifyAsset
117+
. ( if forceVerify
118+
then #assetMustVerify .~ True
119+
else id
120+
)
121+
)
122+
$ st
123+
^? #modelState
124+
. #stAssets
125+
. ix idx
104126

105127
fieldPairsOpts :: FieldPairs.Opts model action
106128
fieldPairsOpts =

‎ghcjs/delivery-calculator/trapeze.yaml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,8 @@
11
platforms:
22
android:
33
appName: Delivery Calculator
4-
versionCode: 4
5-
versionName: 0.1.0.4
4+
versionCode: 5
5+
versionName: 0.1.0.5
66
packageName: com.functora.delivery_calculator
77
manifest:
88
- file: AndroidManifest.xml

‎ghcjs/miso-functora/src/Functora/Miso/Jsm/Generic.hs‎

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Functora.Miso.Jsm.Generic
66
removeAt,
77
openBrowserPage,
88
enterOrEscapeBlur,
9+
blur,
910
insertStorage,
1011
selectStorage,
1112
selectBarcode,
@@ -114,19 +115,18 @@ enterOrEscapeBlur :: Uid -> KeyCode -> Update model
114115
enterOrEscapeBlur uid (KeyCode code) =
115116
EffectUpdate $ do
116117
let enterOrEscape = [13, 27] :: [Int]
117-
when (code `elem` enterOrEscape) $ do
118-
--
119-
-- TODO : refactor this
120-
--
121-
res <-
122-
either throw pure
123-
. decodeUtf8Strict @Unicode
124-
. unTagged
125-
$ "document.getElementById('"
126-
<> htmlUid uid
127-
<> "').blur();"
128-
void
129-
$ JS.eval res
118+
when (code `elem` enterOrEscape) $ blur uid
119+
120+
blur :: Uid -> JSM ()
121+
blur uid = do
122+
el <-
123+
getElementById
124+
. either impureThrow id
125+
. decodeUtf8Strict
126+
. unTagged
127+
$ htmlUid uid
128+
is <- ghcjsPure $ JS.isTruthy el
129+
when is . void $ el ^. JS.js0 @Unicode "blur"
130130

131131
insertStorage :: (ToJSON a) => Unicode -> a -> JSM ()
132132
insertStorage key raw = do

‎ghcjs/miso-functora/src/Functora/Miso/Prelude.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Miso as X hiding
1919
Text,
2020
URI,
2121
at,
22+
blur,
2223
close,
2324
consoleLog,
2425
for_,

‎ghcjs/miso-functora/src/Functora/Miso/Widgets/Field.hs‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -865,7 +865,12 @@ insertAction Full {fullArgs = args, fullParser = parser} selector =
865865
( updateInput
866866
. (cloneTraversal optic . #fieldOutput .~ out)
867867
)
868-
$ Jsm.popupText @Unicode "Success!"
868+
$ do
869+
whenJust
870+
(prev ^? cloneTraversal optic . #fieldInput . #uniqueUid)
871+
Jsm.blur
872+
Jsm.popupText @Unicode
873+
"Success!"
869874
where
870875
prev = args ^. #argsModel
871876
optic = args ^. #argsOptic

‎pub/functora/src/prelude/Functora/Prelude.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -200,6 +200,7 @@ import qualified Data.HMAC as HMAC
200200
import Data.List.Extra as X (enumerate, notNull, nubOrd, nubOrdBy, nubOrdOn)
201201
import qualified Data.Map.Merge.Strict as Map
202202
import Data.Maybe as X (listToMaybe)
203+
import Data.MonoTraversable as X (omap)
203204
import qualified Data.MonoTraversable as Mono
204205
import Data.MonoTraversable.Unprefixed as X (intercalate)
205206
import Data.Ratio as X ((%))
@@ -211,7 +212,6 @@ import Data.Sequences as X hiding
211212
Utf8 (..),
212213
catMaybes,
213214
dropWhile,
214-
filter,
215215
filterM,
216216
find,
217217
fromList,
@@ -287,6 +287,7 @@ import Universum as X hiding
287287
catchAny,
288288
decodeUtf8',
289289
drop,
290+
filter,
290291
finally,
291292
fromInteger,
292293
fromIntegral,

0 commit comments

Comments
 (0)