time-based order id

Author: functora

ghcjs/delivery-calculator/delivery-calculator.cabal

@@ -97,6 +97,7 @@ common pkg
     , network-uri
     , regex-compat
     , syb
+    , time
     , xlsx
 
   if flag(ghcid)

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

@@ -7,6 +7,7 @@ module App.Types
     St (..),
     newSt,
     Asset (..),
+    newOrderId,
     newAsset,
     verifyAsset,
     newFieldPair,
@@ -40,6 +41,7 @@ import qualified Data.ByteString.Base64.URL as B64URL
 import qualified Data.ByteString.Lazy as BL
 import Data.Functor.Barbie
 import qualified Data.Generics as Syb
+import qualified Data.Time.Format as TF
 import qualified Data.Version as Version
 import Functora.Cfg
 import Functora.Miso.Prelude
@@ -94,6 +96,7 @@ data St f = St
     stMerchantFeePercent :: Field DynamicField f,
     stOnlineOrOffline :: OnlineOrOffline,
     stPreview :: Field Unicode f,
+    stOrderId :: Field Unicode f,
     stScreen :: Screen,
     stEnableTheme :: Bool,
     stTheme :: Theme
@@ -123,6 +126,7 @@ newSt = do
   tele <- newTextField "Functora"
   fee <- newDynamicField $ DynamicFieldNumber 2
   pre <- newTextField "Delivery Calculator"
+  oid <- newOrderId ct
   pure
     St
       { stAssets = mempty,
@@ -134,6 +138,7 @@ newSt = do
         stMerchantFeePercent = fee & #fieldType .~ FieldTypePercent,
         stOnlineOrOffline = Online,
         stPreview = pre & #fieldType .~ FieldTypeTitle,
+        stOrderId = oid,
         stScreen = Main,
         stEnableTheme = True,
         stTheme = Theme.Matcha
@@ -160,6 +165,12 @@ instance TraversableB Asset
 
 deriving via GenericType (Asset Identity) instance Binary (Asset Identity)
 
+newOrderId :: (MonadIO m) => UTCTime -> m (Field Unicode Unique)
+newOrderId ct =
+  newTextField
+    . from @String @Unicode
+    $ TF.formatTime TF.defaultTimeLocale "%Y%m%d%H%M%S" ct
+
 newAsset :: (MonadIO m) => m (Asset Unique)
 newAsset = do
   link <-

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

@@ -155,7 +155,7 @@ screenWidget st@Model {modelState = St {stScreen = Main}} =
                 onClick . PushUpdate . Instant . EffectUpdate $ do
                   let doc = st ^. #modelState
                   imgs <- Jsm.fetchBlobUris doc
-                  Jsm.saveFile Xlsx.xlsxFile Xlsx.xlsxMime
+                  Jsm.saveFile (Xlsx.xlsxFile doc) Xlsx.xlsxMime
                     . from @BL.ByteString @ByteString
                     $ Xlsx.newXlsx doc imgs
               ]

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

@@ -84,18 +84,29 @@ menu st =
           Dialog.argsOptic = #modelMenu,
           Dialog.argsAction = PushUpdate . Instant,
           Dialog.argsContent =
-            Currency.selectCurrency
-              Currency.defOpts
-                { Currency.optsButtonLabel = Just "Marketplace currency",
-                  Currency.optsExtraOnClick = #modelLoading .~ True
-                }
-              Currency.Args
-                { Currency.argsModel = st,
-                  Currency.argsOptic = #modelState . #stAssetCurrency,
-                  Currency.argsAction = PushUpdate . Instant,
-                  Currency.argsEmitter = pushActionQueue st . Instant,
-                  Currency.argsCurrencies = #modelCurrencies
+            Field.textField
+              Field.Args
+                { Field.argsModel = st,
+                  Field.argsOptic = #modelState . #stOrderId,
+                  Field.argsAction = PushUpdate . Instant,
+                  Field.argsEmitter = pushActionQueue st . Instant
                 }
+              ( Field.defOpts
+                  & #optsLabel
+                  .~ Just ("Order id" :: Unicode)
+              )
+              <> Currency.selectCurrency
+                Currency.defOpts
+                  { Currency.optsButtonLabel = Just "Marketplace currency",
+                    Currency.optsExtraOnClick = #modelLoading .~ True
+                  }
+                Currency.Args
+                  { Currency.argsModel = st,
+                    Currency.argsOptic = #modelState . #stAssetCurrency,
+                    Currency.argsAction = PushUpdate . Instant,
+                    Currency.argsEmitter = pushActionQueue st . Instant,
+                    Currency.argsCurrencies = #modelCurrencies
+                  }
               <> Currency.selectCurrency
                 Currency.defOpts
                   { Currency.optsButtonLabel = Just "Merchant currency",

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

@@ -192,8 +192,11 @@ newImg (RowIndex rowIdx) (ColumnIndex colIdx) imgIdx rfc2397 =
             fiContents = rfc2397Bytes rfc2397
           }
 
-xlsxFile :: Unicode
-xlsxFile = "delivery-calculator.xlsx"
+xlsxFile :: St Unique -> Unicode
+xlsxFile st =
+  "delivery-calculator-"
+    <> (st ^. #stOrderId . #fieldOutput)
+    <> ".xlsx"
 
 xlsxMime :: Unicode
 xlsxMime = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"

ghcjs/delivery-calculator/src/Main.hs

@@ -382,10 +382,15 @@ syncInputs st = do
 
 evalModel :: (MonadThrow m, MonadUnliftIO m) => Model -> m (Model -> Model)
 evalModel prev = do
+  let oid = prev ^. #modelState . #stOrderId
   let oof = prev ^. #modelState . #stOnlineOrOffline
   let web = prev ^. #modelWebOpts
+  updateOid <-
+    if null $ oid ^. #fieldOutput
+      then getCurrentTime >>= newOrderId >>= pure . (#modelState . #stOrderId .~)
+      else pure id
   case oof of
-    Offline -> pure id
+    Offline -> pure updateOid
     Online ->
       Rates.withMarket web (prev ^. #modelMarket) $ do
         let prevCurs :: [Money.CurrencyInfo] =
@@ -443,7 +448,8 @@ evalModel prev = do
         let rateUpdated =
               nextQuote ^. #quoteCreatedAt
         pure
-          $ ( #modelState
+          $ updateOid
+          . ( #modelState
                 %~ Syb.everywhere
                   ( Syb.mkT $ \cur ->
                       fromMaybe cur