Add random token for orders

src/Order.hs

@@ -29,11 +29,12 @@ data ZGoOrder =
     , qpaid :: Bool
     , qexternalInvoice :: T.Text
     , qshortCode :: T.Text
+    , qtoken :: T.Text
     }
   deriving (Eq, Show, Generic)
 
 instance ToJSON ZGoOrder where
-  toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC) =
+  toJSON (ZGoOrder i a s ts c cur p t tZ l paid eI sC tk) =
     case i of
       Just oid ->
         object
@@ -50,6 +51,7 @@ instance ToJSON ZGoOrder where
           , "paid" .= paid
           , "externalInvoice" .= eI
           , "shortCode" .= sC
+          , "token" .= tk
           ]
       Nothing ->
         object
@@ -66,6 +68,7 @@ instance ToJSON ZGoOrder where
           , "paid" .= paid
           , "externalInvoice" .= eI
           , "shortCode" .= sC
+          , "token" .= tk
           ]
 
 instance FromJSON ZGoOrder where
@@ -84,6 +87,7 @@ instance FromJSON ZGoOrder where
       pd <- obj .: "paid"
       eI <- obj .: "externalInvoice"
       sC <- obj .: "shortCode"
+      tk <- obj .: "token"
       pure $
         ZGoOrder
           (if not (null i)
@@ -101,9 +105,10 @@ instance FromJSON ZGoOrder where
           pd
           eI
           sC
+          tk
 
 instance Val ZGoOrder where
-  val (ZGoOrder i a s ts c cur p t tZ l pd eI sC) =
+  val (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
     if isJust i
       then Doc
              [ "_id" =: i
@@ -119,6 +124,7 @@ instance Val ZGoOrder where
              , "paid" =: pd
              , "externalInvoice" =: eI
              , "shortCode" =: sC
+             , "token" =: tk
              ]
       else Doc
              [ "address" =: a
@@ -133,6 +139,7 @@ instance Val ZGoOrder where
              , "paid" =: pd
              , "externalInvoice" =: eI
              , "shortCode" =: sC
+             , "token" =: tk
              ]
   cast' (Doc d) = do
     i <- B.lookup "_id" d
@@ -148,7 +155,8 @@ instance Val ZGoOrder where
     pd <- B.lookup "paid" d
     eI <- B.lookup "externalInvoice" d
     sC <- B.lookup "shortCode" d
-    Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC)
+    tk <- B.lookup "token" d
+    Just (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk)
   cast' _ = Nothing
 
 -- Type to represent an order line item
@@ -224,12 +232,17 @@ updateOrderTotals o =
     (qpaid o)
     (qexternalInvoice o)
     (qshortCode o)
+    (qtoken o)
   where
     newTotal :: ZGoOrder -> Double
     newTotal x = foldr tallyItems 0 (qlines x)
     tallyItems :: LineItem -> Double -> Double
     tallyItems y z = (lqty y * lcost y) + z
 
+setOrderToken :: T.Text -> ZGoOrder -> ZGoOrder
+setOrderToken token (ZGoOrder i a s ts c cur p t tZ l pd eI sC tk) =
+  ZGoOrder i a s ts c cur p t tZ l pd eI sC token
+
 findOrder :: T.Text -> Action IO (Maybe Document)
 findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")
 

src/ZGoBackend.hs

@@ -12,6 +12,8 @@ import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (try)
 import Control.Monad
 import Control.Monad.IO.Class
+import Crypto.RNG (newCryptoRNGState, runCryptoRNGT)
+import Crypto.RNG.Utils (randomString)
 import Data.Aeson
 import Data.Array
 import qualified Data.Bson as B
@@ -832,6 +834,7 @@ routes pipe config = do
                                 (T.concat
                                    [T.pack sUrl, "-", ordId, "-", orderKey])
                                 ""
+                                ""
                         newId <- liftAndCatchIO $ run (insertWooOrder newOrder)
                         status ok200
                         Web.Scotty.json (object ["order" .= show newId])
@@ -1169,6 +1172,14 @@ routes pipe config = do
       Just u -> do
         if uaddress u == qaddress q
           then do
+            if qtoken q == ""
+              then do
+                t <- liftIO generateToken
+                _ <-
+                  liftAndCatchIO $
+                  run (upsertOrder $ setOrderToken (T.pack t) q)
+                status created201
+              else do
                 _ <- liftAndCatchIO $ run (upsertOrder q)
                 status created201
           else status forbidden403
@@ -1585,4 +1596,9 @@ checkUser run s = do
   user <- run (findUser s)
   return $ cast' . Doc =<< user
 
+generateToken :: IO String
+generateToken = do
+  rngState <- newCryptoRNGState
+  runCryptoRNGT rngState $ randomString 16 "abcdef0123456789"
+
 debug = flip trace