diff --git a/src/Order.hs b/src/Order.hs index b62d6ef..1aeefdb 100644 --- a/src/Order.hs +++ b/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") diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index 6bb9fc7..b032f89 100644 --- a/src/ZGoBackend.hs +++ b/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,8 +1172,16 @@ routes pipe config = do Just u -> do if uaddress u == qaddress q then do - _ <- liftAndCatchIO $ run (upsertOrder q) - status created201 + 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 --Delete order Web.Scotty.delete "/api/order/:id" $ do @@ -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