wip

Author: functora

ghcjs/cryptogram/cryptogram.cabal

@@ -89,17 +89,11 @@ common pkg
     , base
     , base64-bytestring
     , bytestring
-    , containers
     , functora-ghcjs
-    , microlens
     , miso
     , miso-functora
     , modern-uri
-    , network-uri
-    , regex-compat
     , syb
-    , time
-    , xlsx
 
   if flag(ghcid)
     build-depends: jsaddle
@@ -152,5 +146,4 @@ test-suite cryptogram-test
   build-depends:
     , aeson
     , hspec
-    , optics-core
     , quickcheck-instances

ghcjs/cryptogram/src/App/Init.hs

@@ -5,18 +5,16 @@ where
 
 import App.Types
 import Functora.Miso.Prelude
-import qualified Functora.Web as Web
 
 newModel ::
   ( MonadThrow m,
     MonadUnliftIO m
   ) =>
-  Web.Opts ->
   MVar (Action -> IO ()) ->
   Maybe Model ->
   Maybe (St Unique) ->
   m Model
-newModel webOpts sink mMod mApp = do
+newModel sink mMod mApp = do
   defSt <- maybe (liftIO newSt) pure $ mMod ^? _Just . #modelState
   donate <- newDonateViewer
   pure
@@ -26,9 +24,7 @@ newModel webOpts sink mMod mApp = do
         modelDonate = Closed,
         modelLoading = True,
         modelState = fromMaybe defSt mApp,
-        modelUriViewer = mempty,
-        modelDonateViewer = donate,
-        modelWebOpts = webOpts
+        modelDonateViewer = donate
       }
 
 newDonateViewer :: (MonadIO m) => m [FieldPair DynamicField Unique]

ghcjs/cryptogram/src/App/Types.hs

@@ -8,10 +8,8 @@ module App.Types
     newSt,
     newFieldPair,
     newFieldPairId,
-    mkShortUri,
-    unShortUri,
-    mkLongUri,
-    unLongUri,
+    mkUri,
+    unUri,
     emitter,
     icon,
     vsn,
@@ -26,6 +24,7 @@ import qualified Data.ByteString.Lazy as BL
 import Data.Functor.Barbie
 import qualified Data.Generics as Syb
 import qualified Data.Version as Version
+import qualified Functora.Aes as Aes
 import Functora.Cfg
 import Functora.Miso.Prelude
 import qualified Functora.Miso.Theme as Theme
@@ -37,7 +36,6 @@ import qualified Functora.Miso.Types as FM
 import qualified Functora.Miso.Widgets.Field as Field
 import qualified Functora.Miso.Widgets.Icon as Icon
 import qualified Functora.Prelude as Prelude
-import qualified Functora.Web as Web
 import qualified Paths_cryptogram as Paths
 import qualified Text.URI as URI
 
@@ -47,9 +45,7 @@ data Model = Model
     modelDonate :: OpenedOrClosed,
     modelLoading :: Bool,
     modelState :: St Unique,
-    modelUriViewer :: [FieldPair DynamicField Unique],
-    modelDonateViewer :: [FieldPair DynamicField Unique],
-    modelWebOpts :: Web.Opts
+    modelDonateViewer :: [FieldPair DynamicField Unique]
   }
   deriving stock (Eq, Generic)
 
@@ -61,10 +57,9 @@ data Action
   | PushUpdate (Update Model)
 
 data St f = St
-  { stPwd :: Field Unicode f,
-    stEncReq :: Field Unicode f,
-    stDecReq :: Field Unicode f,
-    stDecRes :: Field Unicode f,
+  { stKm :: Aes.Km,
+    stIkm :: Field Unicode f,
+    stMsg :: Field Unicode f,
     stEnableTheme :: Bool,
     stTheme :: Theme
   }
@@ -78,10 +73,6 @@ deriving stock instance (Hkt f) => Show (St f)
 
 deriving stock instance (Hkt f) => Data (St f)
 
-deriving via (GenericType (St f)) instance (Hkt f) => ToQuery (St f)
-
-deriving via (GenericType (St Identity)) instance FromQuery (St Identity)
-
 instance FunctorB St
 
 instance TraversableB St
@@ -90,16 +81,14 @@ deriving via GenericType (St Identity) instance Binary (St Identity)
 
 newSt :: (MonadIO m) => m (St Unique)
 newSt = do
-  pwd <- newTextField mempty
-  encReq <- newTextField mempty
-  decReq <- newTextField mempty
-  decRes <- newTextField mempty
+  km <- Aes.randomKm 32
+  ikm <- newPasswordField . decodeUtf8 $ km ^. #kmIkm . #unIkm
+  msg <- newTextField mempty
   pure
     St
-      { stPwd = pwd,
-        stEncReq = encReq,
-        stDecReq = decReq,
-        stDecRes = decRes,
+      { stKm = km,
+        stIkm = ikm,
+        stMsg = msg,
         stEnableTheme = True,
         stTheme = Theme.Matcha
       }
@@ -130,19 +119,8 @@ newFieldPairId key val = do
     . #fieldOptsAllowCopy
     .~ False
 
-mkShortUri :: (MonadThrow m) => Model -> m URI
-mkShortUri st = do
-  uri <- mkURI $ from @Unicode @Prelude.Text baseUri
-  let qxs = toQuery . uniqueToIdentity $ modelState st
-  pure $ uri {URI.uriQuery = qxs}
-
-unShortUri :: (MonadIO m, MonadThrow m) => URI -> m (St Unique)
-unShortUri uri = do
-  st <- either throw pure . fromQuery $ URI.uriQuery uri
-  identityToUnique st
-
-mkLongUri :: (MonadThrow m) => Model -> m URI
-mkLongUri st = do
+mkUri :: (MonadThrow m) => Model -> m URI
+mkUri st = do
   uri <- mkURI $ from @Unicode @Prelude.Text baseUri
   qxs <-
     stQuery
@@ -169,13 +147,13 @@ mkLongUri st = do
       { URI.uriQuery = qxs
       }
 
-unLongUri ::
+unUri ::
   ( MonadIO m,
     MonadThrow m
   ) =>
   URI ->
   m (Maybe (St Unique))
-unLongUri uri = do
+unUri uri = do
   kSt <- URI.mkQueryKey "d"
   case qsGet kSt $ URI.uriQuery uri of
     Nothing -> pure Nothing

ghcjs/cryptogram/src/Main.hs

@@ -22,7 +22,6 @@ import qualified Data.Generics as Syb
 import qualified Data.Map as Map
 import qualified Functora.Miso.Jsm as Jsm
 import Functora.Miso.Prelude
-import qualified Functora.Web as Web
 import Language.Javascript.JSaddle ((!))
 import qualified Language.Javascript.JSaddle as JS
 import qualified Miso
@@ -44,10 +43,9 @@ main =
       )
     $ do
       uri <- URI.mkURI . inspect =<< getCurrentURI
-      mSt <- handleAny (const $ pure Nothing) . fmap Just $ unShortUri uri
-      web <- getWebOpts
+      mSt <- handleAny (const $ pure Nothing) $ unUri uri
       sink <- newEmptyMVar
-      st <- newModel web sink Nothing mSt
+      st <- newModel sink Nothing mSt
       startApp
         App
           { model = st,
@@ -60,15 +58,6 @@ main =
             logLevel = Off
           }
 
-getWebOpts :: JSM Web.Opts
-getWebOpts = do
-#ifdef wasi_HOST_OS
-  ctx <- JS.askJSM
-  pure $ Web.defOpts ctx
-#else
-  pure Web.defOpts
-#endif
-
 #if !defined(__GHCJS__) && !defined(ghcjs_HOST_OS) && !defined(wasi_HOST_OS)
 runApp :: JSM () -> IO ()
 runApp app = do
@@ -133,7 +122,7 @@ updateModel (InitUpdate mShortSt) prevSt = do
               .~ False
           Just {} -> do
             let st = mShortSt
-            finSt <- newModel (nextSt ^. #modelWebOpts) mvSink (Just nextSt) st
+            finSt <- newModel mvSink (Just nextSt) st
             liftIO
               . sink
               . PushUpdate
@@ -143,9 +132,9 @@ updateModel (InitUpdate mShortSt) prevSt = do
               & #modelLoading
               .~ False
       Just uri -> do
-        mLongSt <- unLongUri uri
+        mLongSt <- unUri uri
         let st = mShortSt <|> mLongSt
-        finSt <- newModel (nextSt ^. #modelWebOpts) mvSink (Just nextSt) st
+        finSt <- newModel mvSink (Just nextSt) st
         liftIO
           . sink
           . PushUpdate
@@ -182,7 +171,7 @@ updateModel (EvalUpdate f) st = do
             . PushUpdate
             . PureUpdate
             $ unload
-        longUri <- mkLongUri next
+        longUri <- mkUri next
         Jsm.insertStorage ("cryptogram-" <> vsn) longUri
         pure Noop,
       do

ghcjs/cryptogram/test/App/TypesSpec.hs

@@ -1,33 +1,13 @@
 module App.TypesSpec (spec) where
 
+import App.Init
 import App.Types
-import App.Widgets.Templates
 import qualified Data.Aeson as A
-import qualified Data.Generics as Syb
 import Functora.Miso.Prelude hiding (prop)
-import qualified Functora.Web as Web
-import qualified Optics.Generic as Ops
-import qualified Optics.Setter as Ops
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck.Instances ()
 
-data Expr
-  = Lit Int
-  | Add Expr Expr
-  | Sub Expr Expr
-  | Mul Expr Expr
-  deriving stock (Eq, Ord, Show, Data, Generic)
-
-expr :: Expr
-expr = Add (Sub (Lit 1) (Lit 2)) (Lit 3)
-
-fun :: Expr -> Expr
-fun = \case
-  Add a b -> Mul a b
-  Lit i -> Lit (i + 1)
-  a -> a
-
 spec :: Spec
 spec = do
   prop "Identity/JSON" $ \txt -> do
@@ -38,27 +18,11 @@ spec = do
     txtJson `shouldBe` wrapJson
     A.decode txtJson `shouldBe` Just txt
     A.decode wrapJson `shouldBe` Just wrap
-  it "syb/everywhere"
-    -- good?
-    $ Syb.everywhere (Syb.mkT fun) expr
-    `shouldBe` Mul (Sub (Lit 2) (Lit 3)) (Lit 4)
-  it "generic-lens/types"
-    -- bad?
-    $ over types fun expr
-    `shouldBe` Mul (Sub (Lit 1) (Lit 2)) (Lit 3)
-  it "optics-core/gplate"
-    -- bad?
-    $ Ops.over Ops.gplate fun expr
-    `shouldBe` Add (Sub (Lit 1) (Lit 2)) (Lit 4)
-  -- it "soplate"
-  --   -- good?
-  --   $ over soplate fun expr
-  --   `shouldBe` Mul (Sub (Lit 2) (Lit 3)) (Lit 4)
   it "serialization" $ do
     var <- newEmptyMVar
-    st0 <- newModel Web.defOpts var Nothing Nothing
-    uri <- mkLongUri st0
-    mSt <- unLongUri uri
-    st1 <- newModel Web.defOpts var Nothing mSt
+    st0 <- newModel var Nothing Nothing
+    uri <- mkUri st0
+    mSt <- unUri uri
+    st1 <- newModel var Nothing mSt
     (st0 ^. #modelState . to uniqueToIdentity)
       `shouldBe` (st1 ^. #modelState . to uniqueToIdentity)