wip

Author: functora

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

@@ -13,9 +13,10 @@ module App.Types
     newFieldPairId,
     newTotal,
     inspectExchangeRate,
-    unShareUri,
-    stShortUri,
-    stLongUri,
+    mkShortUri,
+    unShortUri,
+    mkLongUri,
+    unLongUri,
     emitter,
     icon,
     vsn,
@@ -415,17 +416,19 @@ foldFieldPair :: Rational -> FieldPair DynamicField f -> Rational
 foldFieldPair acc =
   foldField acc . fieldPairValue
 
-stShortUri :: (MonadThrow m) => Model -> m URI
-stShortUri st = do
+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}
 
-stLongUri :: (MonadThrow m) => Model -> m URI
-stLongUri = stUri
+unShortUri :: (MonadIO m, MonadThrow m) => URI -> m (St Unique)
+unShortUri uri = do
+  st <- either throw pure . fromQuery $ URI.uriQuery uri
+  identityToUnique st
 
-stUri :: (MonadThrow m) => Model -> m URI
-stUri st = do
+mkLongUri :: (MonadThrow m) => Model -> m URI
+mkLongUri st = do
   uri <- mkURI $ from @Unicode @Prelude.Text baseUri
   qxs <-
     stQuery
@@ -452,26 +455,13 @@ stUri st = do
       { URI.uriQuery = qxs
       }
 
-stQuery :: (MonadThrow m) => St Identity -> m [URI.QueryParam]
-stQuery st = do
-  kSt <- URI.mkQueryKey "d"
-  vSt <- URI.mkQueryValue <=< encode $ encodeBinary st
-  pure [URI.QueryParam kSt vSt]
-  where
-    encode :: (MonadThrow m) => BL.ByteString -> m Text
-    encode =
-      either throw pure
-        . decodeUtf8Strict
-        . B64URL.encode
-        . from @BL.ByteString @ByteString
-
-unShareUri ::
+unLongUri ::
   ( MonadIO m,
     MonadThrow m
   ) =>
   URI ->
   m (Maybe (St Unique))
-unShareUri uri = do
+unLongUri uri = do
   kSt <- URI.mkQueryKey "d"
   case qsGet kSt $ URI.uriQuery uri of
     Nothing -> pure Nothing
@@ -484,6 +474,19 @@ unShareUri uri = do
       pure
         $ Just uSt
 
+stQuery :: (MonadThrow m) => St Identity -> m [URI.QueryParam]
+stQuery st = do
+  kSt <- URI.mkQueryKey "d"
+  vSt <- URI.mkQueryValue <=< encode $ encodeBinary st
+  pure [URI.QueryParam kSt vSt]
+  where
+    encode :: (MonadThrow m) => BL.ByteString -> m Text
+    encode =
+      either throw pure
+        . decodeUtf8Strict
+        . B64URL.encode
+        . from @BL.ByteString @ByteString
+
 baseUri :: Unicode
 #ifdef GHCID
 baseUri =

ghcjs/delivery-calculator/src/App/Widgets/Templates.hs

@@ -15,13 +15,12 @@ newModel ::
   Web.Opts ->
   MVar (Action -> IO ()) ->
   Maybe Model ->
-  URI ->
+  Maybe (St Unique) ->
   m Model
-newModel webOpts sink mSt uri = do
-  defSt <- maybe (liftIO newSt) pure $ mSt ^? _Just . #modelState
-  mApp <- unShareUri uri
+newModel webOpts sink mMod mApp = do
+  defSt <- maybe (liftIO newSt) pure $ mMod ^? _Just . #modelState
   donate <- newDonateViewer
-  market <- maybe Rates.newMarket pure $ mSt ^? _Just . #modelMarket
+  market <- maybe Rates.newMarket pure $ mMod ^? _Just . #modelMarket
   ct <- getCurrentTime
   pure
     Model
@@ -38,7 +37,7 @@ newModel webOpts sink mSt uri = do
         modelUriViewer = mempty,
         modelDonateViewer = donate,
         modelCurrencies =
-          fromMaybe [btc, usd, rub, cny] (mSt ^? _Just . #modelCurrencies),
+          fromMaybe [btc, usd, rub, cny] (mMod ^? _Just . #modelCurrencies),
         modelWebOpts = webOpts,
         modelMarket = market,
         modelTime = ct

ghcjs/delivery-calculator/src/Main.hs

@@ -47,10 +47,10 @@ main =
       )
     $ do
       uri <- URI.mkURI . inspect =<< getCurrentURI
-      mSt <- unShareUri uri
+      mSt <- handleAny (const $ pure Nothing) . fmap Just $ unShortUri uri
       web <- getWebOpts
       sink <- newEmptyMVar
-      st <- newModel web sink Nothing uri
+      st <- newModel web sink Nothing mSt
       startApp
         App
           { model = st,
@@ -148,7 +148,8 @@ updateModel (InitUpdate ext) prevSt = do
             .~ False
           opfsSync sink nextSt
         Just uri -> do
-          finSt <- newModel (nextSt ^. #modelWebOpts) mvSink (Just nextSt) uri
+          mSt <- unLongUri uri
+          finSt <- newModel (nextSt ^. #modelWebOpts) mvSink (Just nextSt) mSt
           liftIO
             . sink
             . PushUpdate
@@ -189,9 +190,9 @@ updateModel (EvalUpdate f) st = do
             . PushUpdate
             . PureUpdate
             $ unload
-        longUri <- stLongUri next
+        longUri <- mkLongUri next
         Jsm.insertStorage ("current-" <> vsn) longUri
-        shortUri <- stShortUri next
+        shortUri <- mkShortUri next
         uriViewer <-
           newFieldPair mempty
             . DynamicFieldText

ghcjs/delivery-calculator/test/App/TypesSpec.hs

@@ -11,7 +11,6 @@ import qualified Optics.Setter as Ops
 import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck.Instances ()
-import qualified Text.URI as URI
 
 data Expr
   = Lit Int
@@ -57,8 +56,9 @@ spec = do
   --   `shouldBe` Mul (Sub (Lit 2) (Lit 3)) (Lit 4)
   it "serialization" $ do
     var <- newEmptyMVar
-    st0 <- newModel Web.defOpts var Nothing =<< URI.mkURI "http://localhost"
-    uri <- stLongUri st0
-    st1 <- newModel Web.defOpts var Nothing uri
+    st0 <- newModel Web.defOpts var Nothing Nothing
+    uri <- mkLongUri st0
+    mSt <- unLongUri uri
+    st1 <- newModel Web.defOpts var Nothing mSt
     (st0 ^. #modelState . to uniqueToIdentity)
       `shouldBe` (st1 ^. #modelState . to uniqueToIdentity)