Harden the wootoken endpoints

src/WooCommerce.hs

@@ -47,8 +47,11 @@ instance Val WooToken where
   cast' _ = Nothing
 
 -- Database actions
-findWooToken :: ObjectId -> Action IO (Maybe Document)
+findWooToken :: Maybe ObjectId -> Action IO (Maybe Document)
-findWooToken oid = findOne (select ["owner" =: oid] "wootokens")
+findWooToken oid =
+  case oid of
+    Nothing -> return Nothing
+    Just o -> findOne (select ["owner" =: o] "wootokens")
 
 addUrl :: WooToken -> T.Text -> Action IO ()
 addUrl t u =

src/ZGoBackend.hs

@@ -673,8 +673,12 @@ routes pipe config = do
               else status noContent204
   -- Get the xeroaccount code
   get "/api/xeroaccount" $ do
-    oAdd <- param "address"
+    session <- param "session"
-    res <- liftAndCatchIO $ run (findToken oAdd)
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
+        res <- liftAndCatchIO $ run (findToken $ uaddress u)
         let c = cast' . Doc =<< res
         case c of
           Nothing -> status noContent204
@@ -687,14 +691,27 @@ routes pipe config = do
                  ])
   -- Save the xeroaccount code
   post "/api/xeroaccount" $ do
-    oAdd <- param "address"
+    session <- param "session"
     c <- param "code"
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
+        let oAdd = uaddress u
         liftAndCatchIO $ run (addAccCode oAdd c)
         status accepted202
   -- Get the WooCommerce token
   get "/api/wootoken" $ do
-    oid <- param "ownerid"
+    session <- param "session"
-    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
+        owner <- liftAndCatchIO $ run (findOwner $ uaddress u)
+        case cast' . Doc =<< owner of
+          Nothing -> status internalServerError500
+          Just o -> do
+            res <- liftAndCatchIO $ run (findWooToken $ o_id o)
             let t1 = cast' . Doc =<< res
             case t1 of
               Nothing -> status noContent204
@@ -708,19 +725,26 @@ routes pipe config = do
                      ])
   post "/api/wootoken" $ do
     oid <- param "ownerid"
+    session <- param "session"
+    user <- liftAndCatchIO $ run (findUser session)
+    case cast' . Doc =<< user of
+      Nothing -> status unauthorized401
+      Just u -> do
         res <- liftAndCatchIO $ run (findOwnerById oid)
-    let o1 = cast' . Doc =<< res
+        case cast' . Doc =<< res of
-    case o1 of
+          Nothing -> status badRequest400
-      Nothing -> status noContent204
           Just o -> do
+            if oaddress o == uaddress u
+              then do
                 liftAndCatchIO $ run (generateWooToken o)
                 status accepted202
+              else status forbidden403
   -- Authenticate the WooCommerce plugin
   get "/auth" $ do
     oid <- param "ownerid"
     t <- param "token"
     siteurl <- param "siteurl"
-    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
     let c1 = cast' . Doc =<< res
     case c1 of
       Nothing -> do
@@ -776,7 +800,7 @@ routes pipe config = do
     amount <- param "amount"
     sUrl <- param "siteurl"
     orderKey <- param "orderkey"
-    res <- liftAndCatchIO $ run (findWooToken (read oid))
+    res <- liftAndCatchIO $ run (findWooToken $ Just (read oid))
     let c = cast' . Doc =<< res
     case c of
       Nothing -> do
@@ -1409,7 +1433,8 @@ scanPayments config pipe = do
                      "WC" -> do
                        let wOwner = fst $ head sResult ! 2
                        wooT <-
-                         access p master dbName $ findWooToken (read wOwner)
+                         access p master dbName $
+                         findWooToken $ Just (read wOwner)
                        let wT = wooT >>= (cast' . Doc)
                        case wT of
                          Nothing -> error "Failed to read WooCommerce token"

test/Spec.hs

@@ -232,18 +232,32 @@ main = do
               req <-
                 testGet
                   "/api/xeroaccount"
-                  [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
-                  , ("address", Just "Zaddy")
-                  ]
               res <- httpJSON req
               getResponseStatus (res :: Response A.Value) `shouldBe` ok200
-            it "returns 401 with invalid session" $ do
+            it "reading returns 401 with invalid session" $ do
               req <-
                 testGet
                   "/api/xeroaccount"
                   [("session", Just "fnelrkgnlyebrlvns82949")]
               res <- httpLBS req
               getResponseStatus res `shouldBe` unauthorized401
+            it "setting returns 401 with invalid session" $ do
+              req <-
+                testPost
+                  "/api/xeroaccount"
+                  [("session", Just "fnelrkgnlyebrlvns82949")]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` unauthorized401
+            it "setting succeeds with valid session" $ do
+              req <-
+                testPost
+                  "/api/xeroaccount"
+                  [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
+                  , ("code", Just "ZEC")
+                  ]
+              res <- httpLBS req
+              getResponseStatus res `shouldBe` accepted202
         describe "User endpoint" $ do
           it "returns a user for a session" $ do
             req <-
@@ -289,7 +303,7 @@ main = do
                 testDelete
                   "/api/user/"
                   "6272a90f2b05a74cf1000003"
-                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+                  [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa")]
               res <- httpLBS req
               getResponseStatus res `shouldBe` ok200
         describe "Owner endpoint" $
@@ -553,7 +567,25 @@ main = do
               res <- httpLBS req
               getResponseStatus res `shouldBe` ok200
         describe "WooCommerce endpoints" $ do
-          it "generate token" $ do
+          it "generate token with invalid session gives 401" $ do
+            req <-
+              testPost
+                "/api/wootoken"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("session", Just "35bfb9c2-9ad2-fake-adda-99d63b8dcdcd")
+                ]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` unauthorized401
+          it "generate token with mismatched session gives 403" $ do
+            req <-
+              testPost
+                "/api/wootoken"
+                [ ("ownerid", Just "627ad3492b05a76be3000001")
+                , ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dfake")
+                ]
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` forbidden403
+          it "generate token with valid session succeeds" $ do
             req <-
               testPost
                 "/api/wootoken"
@@ -741,7 +773,7 @@ main = do
             let myOrder =
                   ZGoOrder
                     (Just (read "627ab3ea2b05a76be3000001"))
-                    "Zaddy"
+                    "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
                     "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
                     myTs
                     False
@@ -769,25 +801,26 @@ main = do
               Just o2 -> qpaid o2 `shouldBe` True
         describe "Xero data" $ do
           it "token is saved" $ \p -> do
-            let myToken =
+            t <-
-                  XeroToken
+              access p master "test" $
-                    Nothing
+              findToken
-                    "Zaddy"
+                "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
-                    "superFakeToken123"
-                    1800
-                    "anotherSuperFakeToken"
-                    (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
-                    (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
-                    ""
-            _ <- access p master "test" $ upsertToken myToken
-            t <- access p master "test" $ findToken "Zaddy"
             let t1 = (cast' . Doc) =<< t
             case t1 of
               Nothing -> True `shouldBe` False
-              Just t2 -> t_address t2 `shouldBe` "Zaddy"
+              Just t2 ->
+                t_address t2 `shouldBe`
+                "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
           it "code is saved" $ \p -> do
-            _ <- access p master "test" $ addAccCode "Zaddy" "ZEC"
+            _ <-
-            t <- access p master "test" $ findToken "Zaddy"
+              access p master "test" $
+              addAccCode
+                "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
+                "ZEC"
+            t <-
+              access p master "test" $
+              findToken
+                "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
             let t1 = (cast' . Doc) =<< t
             case t1 of
               Nothing -> True `shouldBe` False
@@ -1054,6 +1087,8 @@ startAPI config = do
   _ <- access pipe master "test" (Database.MongoDB.delete (select [] "users"))
   _ <- access pipe master "test" (Database.MongoDB.delete (select [] "items"))
   _ <- access pipe master "test" (Database.MongoDB.delete (select [] "orders"))
+  _ <-
+    access pipe master "test" (Database.MongoDB.delete (select [] "xerotokens"))
   let myUser =
         User
           (Just (read "6272a90f2b05a74cf1000001" :: ObjectId))
@@ -1066,7 +1101,7 @@ startAPI config = do
         User
           (Just (read "6272a90f2b05a74cf1000003" :: ObjectId))
           "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
-          "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
+          "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdaa"
           1613487
           "8ea140fbb30615d6cae383c4f62f3ad9afb10b804f63138d5b53990bd56e0162"
           True
@@ -1156,6 +1191,17 @@ startAPI config = do
   case proSessionTest of
     Doc pS1 -> access pipe master "test" (insert_ "prosessions" pS1)
     _ -> fail "Couldn't save test ZGoProSession in DB"
+  let myToken =
+        XeroToken
+          Nothing
+          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
+          "superFakeToken123"
+          1800
+          "anotherSuperFakeToken"
+          (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
+          (UTCTime (fromGregorian 2022 9 16) (secondsToDiffTime 0))
+          ""
+  _ <- access pipe master "test" $ upsertToken myToken
   --let myWooToken =
         --WooToken
           --Nothing