3.3: support for .try_or()

Author: divarvel

biscuit/src/Auth/Biscuit/Datalog/AST.hs

@@ -833,6 +833,7 @@ data Binary =
   | Any
   | Get
   | BinaryFfi Text
+  | Try
   deriving (Eq, Ord, Show, Lift)
 
 data Expression' (ctx :: DatalogContext) =
@@ -937,6 +938,7 @@ renderExpression =
         EBinary Any e e'            -> rm "any" e e'
         EBinary Get e e'            -> rm "get" e e'
         EBinary (BinaryFfi n) e e'  -> rm ("extern::" <> n) e e'
+        EBinary Try e e'            -> rm "try_or" e e'
         EClosure ps e               -> rC ps e
 
 -- | A biscuit block, containing facts, rules and checks.

biscuit/src/Auth/Biscuit/Datalog/Executor.hs

@@ -535,6 +535,7 @@ evalBinary _ Get (TermMap t) (LString s) = pure . fromMaybe LNull $ t !? StringK
 evalBinary _ Get _ _ = Left "Only arrays and maps support `.get()`"
 evalBinary _ Any _ _ = Left "internal error: leftover .any()"
 evalBinary _ All _ _ = Left "internal error: leftover .all()"
+evalBinary _ Try _ _ = Left "internal error: leftover .try_or()"
 evalBinary Limits{externFuncs} (BinaryFfi n) l r = runExternFunc externFuncs n l (Just r)
 
 checkedOp :: (Integer -> Integer -> Integer)
@@ -636,6 +637,18 @@ evaluateLazyOr l b lhs' (EClosure [] e) =
         _ -> Left "Expected boolean"
 evaluateLazyOr _ _ _  _ = Left "Expected closure"
 
+evaluateTry :: Limits
+            -> Bindings
+            -> Expression
+            -> Expression
+            -> Either String Value
+evaluateTry l b (EClosure [] e) e' = do
+  rhs <- evaluateExpression l b e'
+  case evaluateExpression l b e of
+    Right r -> Right r
+    Left _  -> Right rhs
+evaluateTry _ _ _ _                = Left "Expected closure"
+
 -- | Given bindings for variables, reduce an expression to a single
 -- datalog value
 evaluateExpression :: Limits
@@ -657,5 +670,6 @@ evaluateExpression l b = \case
     EBinary All e e' -> do
         lhs <- evaluateExpression l b e
         evaluateAll l b lhs e'
+    EBinary Try e e' -> evaluateTry l b e e'
     EBinary op e e' -> uncurry (evalBinary l op) =<< join bitraverse (evaluateExpression l b) (e, e')
     EClosure _ _ -> Left "Unexpected closure"

biscuit/src/Auth/Biscuit/Datalog/Parser.hs

@@ -353,14 +353,17 @@ binaryMethodParser = do
     , All          <$ chunk "all"
     , Get          <$ chunk "get"
     , BinaryFfi    <$> (chunk "extern::" *> identifierParser)
+    , Try          <$ chunk "try_or"
     ]
   _ <- l $ C.char '('
   e2 <- case method of
     Any -> uncurry EClosure . first pure <$> l closureParser
     All -> uncurry EClosure . first pure <$> l closureParser
     _   -> l expressionParser
   _ <- l $ C.char ')'
-  pure $ \e1 -> EBinary method e1 e2
+  pure $ \e1 -> case method of
+    Try -> EBinary method (EClosure [] e1) e2
+    _   -> EBinary method e1 e2
 
 unaryMethodParser :: Parser (Expression' 'WithSlices -> Expression' 'WithSlices)
 unaryMethodParser = do

biscuit/src/Auth/Biscuit/Proto.hs

@@ -254,6 +254,7 @@ data BinaryKind =
   | Any
   | Get
   | BinaryFfi
+  | Try
   deriving stock (Show, Enum, Bounded)
 
 data OpBinary = OpBinary

biscuit/src/Auth/Biscuit/ProtoBufAdapter.hs

@@ -482,6 +482,7 @@ pbToBinary s PB.OpBinary{kind, ffiName} =
         PB.All                   -> Right All
         PB.Any                   -> Right Any
         PB.Get                   -> Right Get
+        PB.Try                   -> Right Try
         PB.BinaryFfi -> do
           nameIdx <- maybeToRight "Missing extern call name" $ PB.getField ffiName
           name' <- getSymbol s $ SymbolRef nameIdx
@@ -529,6 +530,7 @@ binaryToPb s = \case
   Any -> PB.OpBinary { kind = PB.putField PB.Any, ffiName = PB.putField Nothing }
   All -> PB.OpBinary { kind = PB.putField PB.All, ffiName = PB.putField Nothing }
   Get -> PB.OpBinary { kind = PB.putField PB.Get, ffiName = PB.putField Nothing }
+  Try -> PB.OpBinary { kind = PB.putField PB.Try, ffiName = PB.putField Nothing }
   BinaryFfi n -> PB.OpBinary
     { kind = PB.putField PB.BinaryFfi
     , ffiName = PB.putField . Just . getSymbolRef $ getSymbolCode s n

biscuit/test/Spec/Executor.hs

@@ -170,6 +170,7 @@ exprEval = do
     , ("{1}.intersection({\"test\"})", TermSet (Set.fromList []))
     , ("{1}.union({1})", TermSet (Set.fromList [LInteger 1]))
     , ("{1}.union({\"test\"})", TermSet (Set.fromList [LInteger 1, LString "test"]))
+    , ("(true === 12).try_or(42)", LInteger 42)
     ]
 
 exprEvalError :: TestTree
@@ -186,6 +187,7 @@ exprEvalError = do
     , ("\"toto\".matches(\"to\")", "Regex evaluation is disabled")
     , ("9223372036854775807 + 1", "integer overflow")
     , ("-9223372036854775808 - 1", "integer underflow")
+    , ("true.try_or(true === 12)", "Equality mismatch") -- the right-hand-side of try_or is eager
     ]
 
 rulesWithConstraints :: TestTree

biscuit/test/Spec/SampleReader.hs

@@ -230,7 +230,7 @@ processTestCase :: (String -> IO ())
                 -> Assertion
 processTestCase step rootPk TestCase{..}
   | fst filename == "test018_unbound_variables_in_rule.bc" = step "Skipping for now (unbound variables are now caught before evaluation)"
-  | fst filename `elem` ["test036_secp256r1.bc", "test037_secp256r1_third_party.bc", "test038_try_op.bc"] = step "Skipping for now (not supported yet)"
+  | fst filename `elem` ["test036_secp256r1.bc", "test037_secp256r1_third_party.bc"] = step "Skipping for now (not supported yet)"
   | otherwise = do
     step "Parsing "
     let vList = Map.toList validations