Skip to content

Commit b0950ed

Browse files
functorafunctora
committed
cryptogram wip
1 parent d762400 commit b0950ed

File tree

6 files changed

+121
-34
lines changed

6 files changed

+121
-34
lines changed

‎ghcjs/cryptogram/cryptogram.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ common pkg
2020

2121
other-modules:
2222
App.Init
23+
App.Jsm
2324
App.Types
2425
App.Widgets.Donate
2526
App.Widgets.Main

‎ghcjs/cryptogram/flake.nix‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,12 @@
1414
app-ghcid = pkgs.writeScriptBin "app-ghcid" ''
1515
${pkgs.ghcid}/bin/ghcid --test="Main.main" --command="${pkgs.cabal-install}/bin/cabal new-repl ${label} --disable-optimization --repl-options=-fobject-code --repl-options=-fno-break-on-exception --repl-options=-fno-break-on-error --repl-options=-v1 --repl-options=-ferror-spans --repl-options=-j -fghcid"
1616
'';
17+
app-tunnel = pkgs.writeShellApplication {
18+
name = "app-tunnel";
19+
text = ''
20+
${pkgs.cloudflared}/bin/cloudflared --url http://localhost:8080/
21+
'';
22+
};
1723
app-serve-latest = pkgs.writeShellApplication rec {
1824
name = "app-serve-latest";
1925
text = ''
@@ -133,6 +139,7 @@
133139
pkgs.postgresql
134140
inputs.ghc-wasm-meta.packages.${system}.all_9_10
135141
app-ghcid
142+
app-tunnel
136143
app-serve-latest
137144
app-release-wasm
138145
app-release-latest

‎ghcjs/cryptogram/src/App/Jsm.hs‎

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
module App.Jsm
2+
( getChatId,
3+
switchInlineQuery,
4+
insertSecureStorage,
5+
selectSecureStorage,
6+
)
7+
where
8+
9+
import Functora.Cfg
10+
import Functora.Miso.Prelude
11+
import qualified GHCJS.Types as JS
12+
import Language.Javascript.JSaddle ((!))
13+
import qualified Language.Javascript.JSaddle as JS
14+
15+
getPkg :: JSM JS.JSVal
16+
getPkg = do
17+
window <- JS.jsg ("window" :: Unicode)
18+
window ! ("Telegram" :: Unicode) ! ("WebApp" :: Unicode)
19+
20+
getSub :: Unicode -> JSM JS.JSVal
21+
getSub arg = do
22+
pkg <- getPkg
23+
pkg ! arg
24+
25+
getChatId :: JSM Int
26+
getChatId = do
27+
pkg <- getPkg
28+
ini <- pkg ! ("initDataUnsafe" :: Unicode)
29+
rcvr <- ini ! ("receiver" :: Unicode)
30+
chat <- ini ! ("chat" :: Unicode)
31+
user <- ini ! ("user" :: Unicode)
32+
isRcvr <- ghcjsPure $ JS.isTruthy rcvr
33+
isChat <- ghcjsPure $ JS.isTruthy chat
34+
let subj =
35+
if
36+
| isRcvr -> rcvr
37+
| isChat -> chat
38+
| otherwise -> user
39+
uid <- subj ! ("id" :: Unicode)
40+
JS.fromJSValUnchecked uid
41+
42+
switchInlineQuery :: Unicode -> JSM ()
43+
switchInlineQuery val = do
44+
obj <- getPkg
45+
void $ obj ^. JS.js1 @Unicode "switchInlineQuery" val
46+
47+
insertSecureStorage :: (Binary a) => Unicode -> a -> JSM ()
48+
insertSecureStorage key val = do
49+
sub <- getSub "SecureStorage"
50+
void
51+
$ sub
52+
^. JS.js2 @Unicode "setItem" key (encodeBinaryB64Url @Unicode val)
53+
54+
selectSecureStorage ::
55+
(Show a, Data a, Binary a) => Unicode -> (Maybe a -> JSM ()) -> JSM ()
56+
selectSecureStorage key after = do
57+
sub <- getSub "SecureStorage"
58+
fun <- JS.function $ \_ _ ->
59+
handleAny
60+
( \e -> do
61+
alert . from @String @Unicode $ displayException e
62+
after Nothing
63+
)
64+
. \case
65+
[failure, success] -> do
66+
bad <- ghcjsPure $ JS.isTruthy failure
67+
if bad
68+
then throwString @Unicode "selectSecureStorage failure!"
69+
else do
70+
raw <-
71+
JS.fromJSValUnchecked @Unicode success
72+
val <-
73+
either (throwString @Unicode . inspect) pure
74+
$ decodeBinaryB64Url raw
75+
after
76+
$ Just val
77+
_ ->
78+
throwString @Unicode "selectSecureStorage bad argv!"
79+
void
80+
$ sub
81+
^. JS.js2 @Unicode "getItem" key fun

‎ghcjs/cryptogram/src/App/Types.hs‎

Lines changed: 19 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ module App.Types
77
St (..),
88
newSt,
99
newFieldPair,
10-
newFieldPairId,
1110
mkUri,
1211
unUri,
1312
emitter,
@@ -28,10 +27,7 @@ import qualified Functora.Aes as Aes
2827
import Functora.Cfg
2928
import Functora.Miso.Prelude
3029
import qualified Functora.Miso.Theme as Theme
31-
import Functora.Miso.Types as X hiding
32-
( newFieldPair,
33-
newFieldPairId,
34-
)
30+
import Functora.Miso.Types as X hiding (newFieldPair)
3531
import qualified Functora.Miso.Types as FM
3632
import qualified Functora.Miso.Widgets.Field as Field
3733
import qualified Functora.Miso.Widgets.Icon as Icon
@@ -57,9 +53,10 @@ data Action
5753
| PushUpdate (Update Model)
5854

5955
data St f = St
60-
{ stKm :: Aes.Km,
56+
{ stReq :: StReq,
6157
stIkm :: Field Unicode f,
62-
stMsg :: Field Unicode f,
58+
stInp :: Unicode,
59+
stOut :: Field Unicode f,
6360
stEnableTheme :: Bool,
6461
stTheme :: Theme
6562
}
@@ -79,16 +76,24 @@ instance TraversableB St
7976

8077
deriving via GenericType (St Identity) instance Binary (St Identity)
8178

79+
data StReq = StReq
80+
{ stReqKm :: Aes.Km,
81+
stReqMsg :: Maybe Aes.Crypto
82+
}
83+
deriving stock (Eq, Ord, Show, Read, Data, Generic)
84+
deriving (Binary) via GenericType StReq
85+
8286
newSt :: (MonadIO m) => m (St Unique)
8387
newSt = do
8488
km <- Aes.randomKm 32
8589
ikm <- newPasswordField . decodeUtf8 $ km ^. #kmIkm . #unIkm
86-
msg <- newTextField mempty
90+
out <- newTextField mempty
8791
pure
8892
St
89-
{ stKm = km,
93+
{ stReq = StReq km Nothing,
9094
stIkm = ikm,
91-
stMsg = msg,
95+
stInp = mempty,
96+
stOut = out,
9297
stEnableTheme = True,
9398
stTheme = Theme.Matcha
9499
}
@@ -108,17 +113,6 @@ newFieldPair key val = do
108113
. #fieldOptsAllowCopy
109114
.~ False
110115

111-
newFieldPairId ::
112-
Unicode ->
113-
DynamicField ->
114-
FieldPair DynamicField Identity
115-
newFieldPairId key val = do
116-
FM.newFieldPairId key val
117-
& #fieldPairValue
118-
. #fieldOpts
119-
. #fieldOptsAllowCopy
120-
.~ False
121-
122116
mkUri :: (MonadThrow m) => Model -> m URI
123117
mkUri st = do
124118
uri <- mkURI $ from @Unicode @Prelude.Text baseUri
@@ -139,9 +133,9 @@ mkUri st = do
139133
& #fieldOutput
140134
.~ DynamicFieldText mempty
141135
)
142-
. uniqueToIdentity
143-
$ st
144-
^. #modelState
136+
$ uniqueToIdentity
137+
( st ^. #modelState
138+
)
145139
pure
146140
$ uri
147141
{ URI.uriQuery = qxs
@@ -168,7 +162,7 @@ unUri uri = do
168162

169163
stQuery :: (MonadThrow m) => St Identity -> m [URI.QueryParam]
170164
stQuery st = do
171-
kSt <- URI.mkQueryKey "d"
165+
kSt <- URI.mkQueryKey "startapp"
172166
vSt <- URI.mkQueryValue <=< encode $ encodeBinary st
173167
pure [URI.QueryParam kSt vSt]
174168
where

‎ghcjs/cryptogram/src/App/Widgets/Main.hs‎

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,12 @@
11
module App.Widgets.Main (mainWidget) where
22

3+
import qualified App.Jsm as Jsm
34
import App.Types
45
import qualified App.Widgets.Menu as Menu
56
import Functora.Miso.Prelude
67
import qualified Functora.Miso.Widgets.BrowserLink as BrowserLink
78
import qualified Functora.Miso.Widgets.Flex as Flex
9+
import qualified Functora.Miso.Widgets.Icon as Icon
810
import qualified Functora.Miso.Widgets.Spinner as Spinner
911
import Miso hiding (at, view)
1012

@@ -76,7 +78,17 @@ screenWidget _ =
7678
]
7779
]
7880
)
79-
mempty
81+
[ button_
82+
[ onClick . PushUpdate . ImpureUpdate $ do
83+
doc <- liftIO newSt
84+
cid <- Jsm.getChatId
85+
Jsm.switchInlineQuery $ "Success " <> inspect cid
86+
pure $ (#modelMenu .~ Closed) . (#modelState .~ doc)
87+
]
88+
[ icon Icon.IconBitcoin,
89+
text " Donate"
90+
]
91+
]
8092

8193
tosWidget :: View Action
8294
tosWidget =

‎nix/configuration.nix‎

Lines changed: 0 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -705,14 +705,6 @@ in {
705705
extraPortals = [pkgs.xdg-desktop-portal-gtk];
706706
config.common.default = "*";
707707
};
708-
709-
#
710-
# Via/Vial
711-
#
712-
services.udev.packages = with pkgs; [
713-
via
714-
];
715-
716708
#
717709
# Firejail
718710
#

0 commit comments

Comments
 (0)