├── CODEOWNERS ├── tools ├── vim │ ├── LICENSE │ ├── doc │ │ └── soutei.txt │ ├── ftdetect │ │ └── soutei.vim │ ├── README │ └── syntax │ │ └── soutei.vim └── emacs │ └── soutei-mode.el ├── core ├── test │ ├── Main.hs │ ├── examples │ │ ├── loops.ava │ │ ├── fair-conjunction.ava │ │ ├── fair-disjunction.ava │ │ └── path.ava │ ├── PDPSpec.hs │ ├── ParserSpec.hs │ ├── Fixtures.hs │ ├── ModeCheckSpec.hs │ └── SemanticsSpec.hs ├── src │ ├── Language │ │ ├── Avaleryar.hs │ │ └── Avaleryar │ │ │ ├── PrettyPrinter.hs │ │ │ ├── PDP │ │ │ └── Handle.hs │ │ │ ├── ModeCheck.hs │ │ │ ├── Parser.hs │ │ │ ├── Testing.hs │ │ │ ├── PDP.hs │ │ │ ├── Syntax.hs │ │ │ └── Semantics.hs │ └── Control │ │ └── Monad │ │ └── FBackTrackT.hs ├── package.yaml ├── LICENSE ├── avaleryar.cabal └── bench │ └── Main.hs ├── .gitignore ├── cabal.project ├── repl ├── repl │ └── avai.hs ├── package.yaml ├── avaleryar-repl.cabal └── src │ └── Language │ └── Avaleryar │ └── Repl.hs ├── stack.yaml ├── extras ├── package.yaml ├── avaleryar-extras.cabal └── src │ └── Language │ └── Avaleryar │ ├── Native │ ├── Config.hs │ ├── Base.hs │ └── JSON.hs │ └── Instances.hs ├── Jenkinsfile ├── .stylish-haskell.yaml └── README.md /CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @deviant-logic 2 | -------------------------------------------------------------------------------- /tools/vim/LICENSE: -------------------------------------------------------------------------------- 1 | BSD3, same as avaleryar 2 | -------------------------------------------------------------------------------- /tools/vim/doc/soutei.txt: -------------------------------------------------------------------------------- 1 | I definitaly don't know what to put in here. 2 | -------------------------------------------------------------------------------- /core/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# 2 | OPTIONS_GHC -F -pgmF hspec-discover 3 | #-} 4 | -------------------------------------------------------------------------------- /tools/vim/ftdetect/soutei.vim: -------------------------------------------------------------------------------- 1 | au BufNewFile,BufRead *.ava set filetype=soutei 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | stack.yaml.lock 2 | .stack-work 3 | dist-newstyle 4 | *.tix 5 | *.ava 6 | .history 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./core 3 | -- ./extras -- see comment in stack.yaml 4 | ./repl 5 | -------------------------------------------------------------------------------- /core/test/examples/loops.ava: -------------------------------------------------------------------------------- 1 | 2 | loop1(?x) :- loop1(?x). 3 | 4 | loop2(?x) :- loop2(?x). 5 | loop2(?y) :- loop2(?y). 6 | -------------------------------------------------------------------------------- /repl/repl/avai.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import qualified Language.Avaleryar.Repl as Repl 5 | 6 | main :: IO () 7 | main = Repl.main 8 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.6 2 | packages: 3 | - ./core 4 | # - ./extras # avaleryar-extras isn't getting the use I'd hoped; gonna stop building it for a bit. 5 | - ./repl 6 | extra-deps: 7 | - qq-literals-0.1.0.1 8 | - jsonpath-0.1.0.1 9 | -------------------------------------------------------------------------------- /tools/vim/README: -------------------------------------------------------------------------------- 1 | I am far from knowledgable about writing vim plugins. But the tutorial said I 2 | should have a README. 3 | 4 | In theory, if you're using vundle, you ought to be able to do: 5 | 6 | ``` 7 | Plugin 'Simspace/avaleryar', { 'rtp': 'tools/vim' } 8 | ``` 9 | -------------------------------------------------------------------------------- /extras/package.yaml: -------------------------------------------------------------------------------- 1 | name: avaleryar-extras 2 | version: 0.0.1.1 3 | 4 | library: 5 | source-dirs: src 6 | dependencies: 7 | - base 8 | - avaleryar 9 | 10 | - aeson 11 | - attoparsec 12 | - containers 13 | - jose-jwt 14 | - jsonpath 15 | - mtl 16 | - postgresql-simple 17 | - text 18 | - time 19 | -------------------------------------------------------------------------------- /core/test/examples/fair-conjunction.ava: -------------------------------------------------------------------------------- 1 | ;; -*- mode: prolog -*- 2 | 3 | ;; b gives two answers, c gives infinite success for both, d rejects b''s 4 | ;; first answer, but we still get to the second. 5 | 6 | a(?x) :- b(?x), c(?y), d(?x). 7 | b(0). 8 | b(1). 9 | c(0). 10 | c(?x) :- c(?x). 11 | d(1). 12 | 13 | 14 | ;; This should succeed 15 | 16 | ; a(?x). 17 | 18 | 19 | -------------------------------------------------------------------------------- /core/test/examples/fair-disjunction.ava: -------------------------------------------------------------------------------- 1 | ;; -*- mode: prolog -*- 2 | 3 | ;; b is the disjunction of c, an infinite success, and d. None of c''s 4 | ;; successes lead to a success for a, but d is still reached. 5 | 6 | a(?x) :- b(?x), d(?x). 7 | b(?x) :- c(?x). 8 | b(?x) :- d(?x). 9 | c(0). 10 | c(?x) :- c(?x). 11 | d(1). 12 | 13 | ;; This should succeed 14 | 15 | ; a(?x) 16 | 17 | -------------------------------------------------------------------------------- /repl/package.yaml: -------------------------------------------------------------------------------- 1 | name: avaleryar-repl 2 | version: 0.0.1.1 3 | 4 | library: 5 | source-dirs: src 6 | dependencies: 7 | - base 8 | - avaleryar 9 | 10 | - containers 11 | - haskeline 12 | - mtl 13 | - optparse-applicative 14 | - read-editor 15 | - repline 16 | - text 17 | - wl-pprint-text 18 | 19 | executables: 20 | avai: 21 | source-dirs: repl 22 | main: avai.hs 23 | dependencies: 24 | - avaleryar-repl 25 | - base 26 | -------------------------------------------------------------------------------- /core/test/examples/path.ava: -------------------------------------------------------------------------------- 1 | ; -*- mode: prolog -*- 2 | 3 | path(?x, ?y) :- 4 | path(?x, ?z), 5 | edge(?z, ?y). 6 | 7 | path(?x, ?y) :- 8 | edge(?x, ?y). 9 | 10 | edge(1, 2). 11 | edge(2, 3). 12 | edge(3, 4). 13 | edge(3, 1). 14 | edge(1, 5). 15 | edge(5, 4). 16 | 17 | 18 | ;; These should all succeed 19 | ; path(1, 2) 20 | ; path(1, 3) 21 | ; path(1, 4) 22 | ; path(1, 5) 23 | ; path(2, 1) 24 | ; path(2, 3) 25 | ; path(2, 4) 26 | ; path(2, 5) 27 | ; path(3, 1) 28 | ; path(3, 2) 29 | ; path(3, 4) 30 | ; path(3, 5) 31 | ; path(5, 4) 32 | 33 | ;; These should all fail 34 | 35 | ; path(4, 1) 36 | ; path(4, 2) 37 | ; path(4, 3) 38 | ; path(4, 5) 39 | ; path(5, 1) 40 | ; path(5, 2) 41 | ; path(5, 3) 42 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar.hs: -------------------------------------------------------------------------------- 1 | 2 | module Language.Avaleryar (module Ava) where 3 | 4 | import Language.Avaleryar.Parser as Ava (fct, parseFile, parseText, qry, rls) 5 | import Language.Avaleryar.PDP as Ava (PDPConfig(..), PDPError(..), pdpConfig, pdpConfigText) 6 | import Language.Avaleryar.PDP.Handle as Ava 7 | (PDPHandle, checkQuery, dumpDb, newHandle, retractAssertion, submitAssertion, submitFile, submitText, 8 | unsafeSubmitAssertion, unsafeSubmitFile, unsafeSubmitText) 9 | import Language.Avaleryar.Semantics as Ava (NativeDb, ToNative(..), compileRules, mkNativeDb, mkNativePred) 10 | import Language.Avaleryar.Syntax as Ava (Fact, Factual(..), Query, Rule, Valuable(..), fact, lit, query, val) 11 | 12 | 13 | -------------------------------------------------------------------------------- /extras/avaleryar-extras.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: c34fefab011b8b7b41eb151f3d14c93938504336118a3e86ece1c64448e2a9b6 8 | 9 | name: avaleryar-extras 10 | version: 0.0.1 11 | build-type: Simple 12 | 13 | library 14 | exposed-modules: 15 | Language.Avaleryar.Instances 16 | Language.Avaleryar.Native.Base 17 | Language.Avaleryar.Native.Config 18 | Language.Avaleryar.Native.JSON 19 | other-modules: 20 | Paths_avaleryar_extras 21 | hs-source-dirs: 22 | src 23 | build-depends: 24 | aeson 25 | , attoparsec 26 | , avaleryar 27 | , base 28 | , containers 29 | , jose-jwt 30 | , jsonpath 31 | , mtl 32 | , postgresql-simple 33 | , text 34 | , time 35 | default-language: Haskell2010 36 | -------------------------------------------------------------------------------- /core/package.yaml: -------------------------------------------------------------------------------- 1 | name: avaleryar 2 | version: 0.0.1.1 3 | 4 | library: 5 | source-dirs: src 6 | dependencies: 7 | - base 8 | 9 | - containers 10 | - deepseq 11 | - filepath 12 | - hashable 13 | - megaparsec 14 | - mtl 15 | - qq-literals 16 | - template-haskell 17 | - text 18 | - wl-pprint-text 19 | 20 | tests: 21 | avaleryar-tests: 22 | main: Main.hs 23 | source-dirs: [test] 24 | build-tools: 25 | - hspec-discover 26 | dependencies: 27 | - base 28 | - avaleryar 29 | 30 | - hspec 31 | - hspec-core 32 | 33 | - HUnit 34 | - QuickCheck 35 | - containers 36 | - directory 37 | - filepath 38 | - text 39 | 40 | benchmarks: 41 | avaleryar-benchmarks: 42 | main: Main.hs 43 | source-dirs: [bench] 44 | dependencies: 45 | - base 46 | - avaleryar 47 | 48 | - criterion 49 | - wl-pprint-text 50 | - text 51 | -------------------------------------------------------------------------------- /tools/vim/syntax/soutei.vim: -------------------------------------------------------------------------------- 1 | if exists("b:current_syntax") 2 | finish 3 | endif 4 | 5 | syntax keyword souteiKeyword says 6 | highlight link souteiKeyword Keyword 7 | 8 | syntax match souteiComment "\v;.*$" 9 | highlight link souteiComment Comment 10 | 11 | syntax match souteiOperator "\v:-" 12 | syntax match souteiOperator "\v," 13 | syntax match souteiOperator "\v\." 14 | highlight link souteiOperator Operator 15 | 16 | syntax match souteiNumber "\v[1-9][0-9]*" 17 | highlight link souteiNumber Number 18 | 19 | syntax match souteiConstant "\v\#[tf]" 20 | highlight link souteiConstant Constant 21 | 22 | syntax region souteiString start=/\v"/ skip=/\v\\./ end=/\v"/ 23 | highlight link souteiString String 24 | 25 | syntax match souteiVariable "\v\?[a-zA-Z!@$%&*/<=>~_^][a-zA-Z0-9!@$%&*/<=>~_^?+-]*" 26 | highlight link souteiVariable Identifier 27 | 28 | syntax keyword souteiSpecial system application 29 | highlight link souteiSpecial Special 30 | 31 | let b:current_syntax = "soutei" 32 | -------------------------------------------------------------------------------- /extras/src/Language/Avaleryar/Native/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | 4 | -- | Support for making load-time configuration values available at run-time. 5 | 6 | module Language.Avaleryar.Native.Config 7 | ( 8 | configDb 9 | ) where 10 | 11 | import Control.Applicative 12 | import Control.Monad.IO.Class 13 | import Data.Foldable 14 | import qualified Data.Map as Map 15 | import Data.Text (Text) 16 | 17 | import Language.Avaleryar.Syntax 18 | import Language.Avaleryar.Semantics 19 | 20 | configDb :: (Factual a, MonadIO m) => Maybe Text -> [a] -> NativeDb m 21 | configDb sub = mkNativeDb (maybe "config" ("config/" <> ) sub) . combineFacts 22 | 23 | combineFacts :: (MonadIO m, Factual a) => [a] -> [NativePred m] 24 | combineFacts as = toList nps 25 | where nps = Map.fromListWith go [(p, mkNativeFact f) | f@(Lit p _) <- toFact <$> as ] 26 | go (NativePred np m) (NativePred np' _) = NativePred (\args -> np args <|> np' args) m -- the @m@s are the same due to 'mkNativePred' 27 | -------------------------------------------------------------------------------- /repl/avaleryar-repl.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 04a067f4d0a41b6b40646342fdc0c272b0239b3c57d98f407671de7670a1503d 8 | 9 | name: avaleryar-repl 10 | version: 0.0.1.1 11 | build-type: Simple 12 | 13 | library 14 | exposed-modules: 15 | Language.Avaleryar.Repl 16 | other-modules: 17 | Paths_avaleryar_repl 18 | hs-source-dirs: 19 | src 20 | build-depends: 21 | avaleryar 22 | , base 23 | , containers 24 | , haskeline 25 | , mtl 26 | , optparse-applicative 27 | , read-editor 28 | , repline 29 | , text 30 | , wl-pprint-text 31 | default-language: Haskell2010 32 | 33 | executable avai 34 | main-is: avai.hs 35 | other-modules: 36 | Paths_avaleryar_repl 37 | hs-source-dirs: 38 | repl 39 | build-depends: 40 | avaleryar-repl 41 | , base 42 | default-language: Haskell2010 43 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/PrettyPrinter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | module Language.Avaleryar.PrettyPrinter where 4 | 5 | import Data.Foldable 6 | import qualified Data.Text as T 7 | import Debug.Trace (trace, traceM) 8 | import Text.PrettyPrint.Leijen.Text 9 | 10 | import Language.Avaleryar.Semantics (RulesDb) 11 | import Language.Avaleryar.Syntax 12 | 13 | putQuery :: Lit TextVar -> IO () 14 | putQuery = putDoc . pretty 15 | 16 | putFacts :: Foldable t => t Fact -> IO () 17 | putFacts = traverse_ (putDoc . pretty . factToRule @TextVar) 18 | 19 | putRulesDb :: RulesDb -> IO () 20 | putRulesDb = putDoc . pretty 21 | 22 | putAssertion :: Value -> [Pred] -> IO () 23 | putAssertion assn ps = putDoc $ prettyAssertion assn ps 24 | 25 | traceP :: Pretty a => a -> b -> b 26 | traceP = trace . T.unpack . displayTStrict . renderOneLine . pretty 27 | 28 | traceMP :: (Pretty a, Applicative f) => a -> f () 29 | traceMP = traceM . T.unpack . displayTStrict . renderOneLine . pretty 30 | -------------------------------------------------------------------------------- /core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, SimSpace Corporation 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /core/test/PDPSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | 6 | module PDPSpec where 7 | 8 | import Language.Avaleryar.Parser 9 | import Language.Avaleryar.PDP 10 | import Language.Avaleryar.PDP.Handle as Hdl 11 | import Language.Avaleryar.Semantics 12 | import Language.Avaleryar.Syntax 13 | 14 | import Test.Hspec 15 | 16 | ndb :: NativeDb 17 | ndb = mkNativeDb "test" preds 18 | where preds = [ mkNativePred "range" $ \f t -> [I x | x <- [f..t]] 19 | , mkNativePred "boom" $ [T "tick", "tick", "tick", error "boom"]] 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "pdp configuration" $ do 24 | it "respects maxAnswers and maxDepth" $ do 25 | let conf = either (error . show) id $ pdpConfigText ndb "foo(?x) :- :test says range(1, 20, ?x)." 26 | ans n = [Lit (Pred "foo" 1) [Val $ I x] | x <- [1..n]] 27 | rq = runQuery' [] [qry| foo(?y) |] 28 | 29 | -- These feel a bit brittle. Caveat lector. 30 | runPDP' rq conf `shouldReturn` Success (ans 10) 31 | runPDP' (withMaxAnswers 5 $ rq) conf `shouldReturn` Success (ans 5) 32 | runPDP' (withMaxDepth 1 $ rq) conf `shouldReturn` FuelExhausted 33 | runPDP' (withMaxDepth 2 $ rq) conf `shouldReturn` Success (ans 1) 34 | 35 | -- TODO: more tests 36 | 37 | describe "querying" $ do 38 | it "doesn't do extra work when (only) checking" $ do 39 | hdl <- either (error . show) newHandle $ pdpConfigText ndb "foo(?x) :- :test says boom(?x)." 40 | 41 | checkQuery hdl [] "foo" [Val "tick"] `shouldReturn` Right True 42 | checkQuery hdl [] "foo" [Val "boom"] `shouldThrow` errorCall "boom" 43 | Hdl.runQuery hdl [] "foo" [Val "tick"] `shouldThrow` errorCall "boom" 44 | -------------------------------------------------------------------------------- /tools/emacs/soutei-mode.el: -------------------------------------------------------------------------------- 1 | (defvar soutei-mode-hook nil) 2 | 3 | (defface soutei-keyword-face 4 | '((t (:inherit font-lock-keyword-face))) 5 | "Soutei keywords") 6 | 7 | (defface soutei-operator-face 8 | '((t (:inherit font-lock-builtin-face))) 9 | "Soutei builtin operators") 10 | 11 | (defvar soutei-indent-width 2 12 | "indentation width used by auto-indent functions") 13 | 14 | (defvar soutei-mode-map (make-keymap) 15 | "Keymap for soutei major mode") 16 | 17 | (defvar soutei-mode-syntax-table 18 | (let ((syn-table (make-syntax-table))) 19 | (modify-syntax-entry ?- "_" syn-table) 20 | (modify-syntax-entry ?\; "<" syn-table) 21 | (modify-syntax-entry ?\n ">" syn-table) 22 | (modify-syntax-entry ?% "_" syn-table) ;; comment in prolog; override here 23 | syn-table) 24 | "Syntax table for `soutei-mode'" 25 | ) 26 | 27 | (defconst soutei-font-lock-keywords 28 | '( 29 | (";.*" . 'font-lock-comment-face) 30 | ("says" . 'soutei-keyword-face) 31 | (":-" . 'soutei-operator-face) 32 | ("," . 'soutei-operator-face) 33 | ("\\." . 'soutei-operator-face) 34 | ("#[tf]" . 'font-lock-constant-face) 35 | ("\\?[a-zA-Z!@$%&*/<=>~_^][a-zA-Z0-9!@$%&*/<=>~_^?+-]*" . 'font-lock-variable-name-face) 36 | )) 37 | 38 | (define-derived-mode soutei-mode prolog-mode "Soutei" 39 | "Major mode for editing Soutei files" 40 | :syntax-table soutei-mode-syntax-table 41 | (set (make-local-variable 'comment-start) ";") 42 | (set (make-local-variable 'comment-end) "") 43 | (set (make-local-variable 'comment-start-skip) ";+ *") 44 | (set (make-local-variable 'prolog-indent-width) soutei-indent-width) 45 | (set 'font-lock-defaults '(soutei-font-lock-keywords))) 46 | 47 | (add-to-list 'auto-mode-alist '("\\.ava\\'" . soutei-mode)) 48 | 49 | 50 | (provide 'soutei-mode) 51 | -------------------------------------------------------------------------------- /core/avaleryar.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 30fac0c3b148d219353f8644d0c0934b9b681991e4892964c8bbf9aba9738fc7 8 | 9 | name: avaleryar 10 | version: 0.0.1.1 11 | license: BSD3 12 | license-file: LICENSE 13 | build-type: Simple 14 | 15 | library 16 | exposed-modules: 17 | Control.Monad.FBackTrackT 18 | Language.Avaleryar 19 | Language.Avaleryar.ModeCheck 20 | Language.Avaleryar.Parser 21 | Language.Avaleryar.PDP 22 | Language.Avaleryar.PDP.Handle 23 | Language.Avaleryar.PrettyPrinter 24 | Language.Avaleryar.Semantics 25 | Language.Avaleryar.Syntax 26 | Language.Avaleryar.Testing 27 | other-modules: 28 | Paths_avaleryar 29 | hs-source-dirs: 30 | src 31 | build-depends: 32 | base 33 | , containers 34 | , deepseq 35 | , filepath 36 | , hashable 37 | , megaparsec 38 | , mtl 39 | , qq-literals 40 | , template-haskell 41 | , text 42 | , wl-pprint-text 43 | default-language: Haskell2010 44 | 45 | test-suite avaleryar-tests 46 | type: exitcode-stdio-1.0 47 | main-is: Main.hs 48 | other-modules: 49 | Fixtures 50 | ModeCheckSpec 51 | ParserSpec 52 | PDPSpec 53 | SemanticsSpec 54 | Paths_avaleryar 55 | hs-source-dirs: 56 | test 57 | build-tool-depends: 58 | hspec-discover:hspec-discover 59 | build-depends: 60 | HUnit 61 | , QuickCheck 62 | , avaleryar 63 | , base 64 | , containers 65 | , directory 66 | , filepath 67 | , hspec 68 | , hspec-core 69 | , text 70 | default-language: Haskell2010 71 | 72 | benchmark avaleryar-benchmarks 73 | type: exitcode-stdio-1.0 74 | main-is: Main.hs 75 | other-modules: 76 | Paths_avaleryar 77 | hs-source-dirs: 78 | bench 79 | build-depends: 80 | avaleryar 81 | , base 82 | , criterion 83 | , text 84 | , wl-pprint-text 85 | default-language: Haskell2010 86 | -------------------------------------------------------------------------------- /core/test/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module ParserSpec where 5 | 6 | import Control.Monad 7 | import Data.Either 8 | import Data.Foldable 9 | import System.Directory 10 | import System.FilePath 11 | 12 | import Language.Avaleryar.Parser 13 | import Language.Avaleryar.Syntax 14 | 15 | import Fixtures 16 | 17 | import Test.Hspec 18 | 19 | spec :: Spec 20 | spec = do 21 | 22 | describe "quasiquoters" $ do 23 | it "parse queries" $ do 24 | [qry| quasi-query(?var, symbol, "quoted string", #f, 5, #t, -7) |] 25 | `shouldBe` Lit (Pred "quasi-query" 7) [ Var "var" 26 | , Val "symbol" 27 | , Val "quoted string" 28 | , Val (B False) 29 | , Val (I 5) 30 | , Val (B True) 31 | , Val (I (-7))] 32 | 33 | it "parse facts" $ do 34 | [fct| fact(symbol) |] `shouldBe` Lit (Pred "fact" 1) [Val "symbol"] 35 | 36 | it "parse rules" $ do 37 | let ruleA = Rule (Lit (Pred "a" 1) [Var "x"]) [ARCurrent `Says` Lit (Pred "b" 1) [Var "x"] ] 38 | ruleB = Rule (Lit (Pred "b" 1) [Var "x"]) [ARCurrent `Says` Lit (Pred "c" 1) [Var "y"] 39 | , ARCurrent `Says` Lit (Pred "a" 1) [Var "x"] ] 40 | ruleC = Rule (Lit (Pred "c" 1) [Var "y"]) [ARTerm (Val "t") `Says` Lit (Pred "a" 2) [Var "x", Var "y"] 41 | , ARNative "nat" `Says` Lit (Pred "b" 1) [Var "y"] ] 42 | [rls| a(?x) :- b(?x). b(?x) :- c(?y), a(?x). c(?y) :- t says a(?x, ?y), :nat says b(?y). |] 43 | `shouldBe` [ ruleA, ruleB, ruleC ] 44 | 45 | 46 | describe "file parser" $ do 47 | it "parses examples" $ do 48 | files <- filter ((== ".ava") . takeExtension) <$> listDirectory exampleDir 49 | when (null files) $ expectationFailure ("no .ava files in example directory: " <> exampleDir) 50 | for_ files $ \file -> do 51 | parsed <- parseFile (exampleFile file) 52 | parsed `shouldSatisfy` isRight 53 | -------------------------------------------------------------------------------- /extras/src/Language/Avaleryar/Native/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | Generally useful native predicates. 5 | 6 | module Language.Avaleryar.Native.Base 7 | ( 8 | db 9 | ) where 10 | 11 | import Control.Monad.IO.Class 12 | import Data.Time.Clock.POSIX 13 | import Data.Time.Format (parseTimeM, defaultTimeLocale) 14 | import Data.Text (Text, unpack, toLower, toUpper, strip) 15 | import qualified Data.Text as Text 16 | 17 | import Language.Avaleryar.Semantics (mkNativeDb, mkNativePred, Solely(..), NativeDb) 18 | import Language.Avaleryar.Syntax (Value(..)) 19 | 20 | db :: MonadIO m => NativeDb m 21 | db = mkNativeDb "base" [ mkNativePred "lt" $ (<) @Value 22 | , mkNativePred "gt" $ (>) @Value 23 | , mkNativePred "lt=" $ (<=) @Value 24 | , mkNativePred "gt=" $ (>=) @Value 25 | , mkNativePred "max" $ max @Value 26 | , mkNativePred "min" $ min @Value 27 | -- Arithmetic 28 | , mkNativePred "add" $ arith (+) 29 | , mkNativePred "sub" $ arith (-) 30 | , mkNativePred "mul" $ arith (*) 31 | , mkNativePred "mod" $ arith mod 32 | , mkNativePred "abs" $ I . abs 33 | , mkNativePred "even" $ even @Int 34 | , mkNativePred "odd" $ odd @Int 35 | -- Time 36 | , mkNativePred "posix-time" posixTime 37 | , mkNativePred "parse-time" parseTime 38 | -- Text 39 | , mkNativePred "length" $ Solely . Text.length 40 | , mkNativePred "concat" $ (\t t' -> T $ t <> t') -- nearly looks like APL... 41 | , mkNativePred "lc" $ Solely . toLower 42 | , mkNativePred "uc" $ Solely . toUpper 43 | , mkNativePred "strip" $ Solely . strip 44 | , mkNativePred "lines" $ fmap Solely . Text.lines 45 | , mkNativePred "words" $ fmap Solely . Text.words 46 | , mkNativePred "substr" $ Text.isInfixOf 47 | , mkNativePred "starts-with" $ Text.isPrefixOf 48 | , mkNativePred "ends-with" $ Text.isSuffixOf 49 | ] 50 | 51 | posixTime :: IO Value 52 | posixTime = I . truncate <$> getPOSIXTime 53 | 54 | parseTime :: Text -> Text -> Maybe Value 55 | parseTime fs ts = do 56 | utc <- parseTimeM True defaultTimeLocale (unpack fs) (unpack ts) 57 | pure . I . truncate $ utcTimeToPOSIXSeconds utc 58 | 59 | arith :: (Int -> Int -> Int) -> Int -> Int -> Value 60 | arith f x y = I $ f x y 61 | -------------------------------------------------------------------------------- /extras/src/Language/Avaleryar/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | 9 | 10 | module Language.Avaleryar.Instances where 11 | 12 | import Data.Aeson (FromJSON(..), ToJSON(..), (.:), (.=)) 13 | import qualified Data.Aeson as A 14 | import Database.PostgreSQL.Simple.FromField 15 | import Database.PostgreSQL.Simple.FromRow 16 | import Database.PostgreSQL.Simple.ToField 17 | import Database.PostgreSQL.Simple.ToRow 18 | 19 | import Language.Avaleryar.Syntax 20 | 21 | instance ToJSON Value where 22 | toJSON (I i) = toJSON i 23 | toJSON (T t) = toJSON t 24 | toJSON (B b) = toJSON b 25 | 26 | instance FromJSON Value where 27 | parseJSON (A.String s) = pure $ T s 28 | parseJSON (A.Bool b) = pure $ B b 29 | parseJSON (A.Number n) = pure $ I (truncate n) -- FIXME: Suck less 30 | parseJSON _ = fail "couldn't parse value" -- FIXME: Suck less 31 | 32 | deriving newtype instance ToJSON RawVar 33 | deriving newtype instance FromJSON RawVar 34 | 35 | instance ToJSON (Term RawVar) where 36 | toJSON (Val v) = toJSON v 37 | toJSON (Var v) = A.object ["var" .= v] 38 | 39 | instance FromJSON (Term RawVar) where 40 | parseJSON (A.Object v) = Var <$> v .: "var" 41 | parseJSON v = Val <$> parseJSON v 42 | 43 | instance ToJSON (Lit RawVar) where 44 | toJSON (Lit (Pred p _) args) = A.object ["pred" .= p, "args" .= args] 45 | 46 | instance FromJSON (Lit RawVar) where 47 | parseJSON = A.withObject "literal" $ \o -> do 48 | p <- o .: "pred" 49 | args <- o .: "args" 50 | pure $ Lit (Pred p (length args)) args 51 | 52 | instance ToField Value where 53 | toField = toJSONField 54 | 55 | instance FromField Value where 56 | fromField = fromJSONField 57 | 58 | instance ToField (Term RawVar) where 59 | toField = toJSONField 60 | 61 | instance FromField (Term RawVar) where 62 | fromField = fromJSONField 63 | 64 | -- | Encodes a 'Lit' @foo(bar, ?baz)@ as a @text@ column with @foo@ and a @jsonb@ column using the 65 | -- aeson encoding of the argument list (@["bar", {"var":"baz"}]@). I'm pretty sure logic 66 | -- programming systems index off the entire functor (i.e., @foo/2@), but I figure maintaining the 67 | -- right invariant on a length column probably isn't worth the effort when we could just as easily 68 | -- use an expression index on the length of the argument list. 69 | instance ToRow (Lit RawVar) where 70 | toRow (Lit (Pred p _) args) = toRow (p, toJSON args) 71 | 72 | -- | Expects rows of the form @(text, jsonb)@ where the @jsonb@ is the same representation as the 73 | -- aeson instance for 'Lit'. 74 | instance FromRow (Lit RawVar) where 75 | fromRow = do 76 | p <- field 77 | args <- fieldWith fromJSONField 78 | pure $ Lit (Pred p (length args)) args 79 | -------------------------------------------------------------------------------- /core/test/Fixtures.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Fixtures where 6 | 7 | import Control.Monad 8 | import Data.Map (Map) 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import System.CPUTime 12 | import System.FilePath 13 | import System.Timeout 14 | 15 | import Language.Avaleryar.Parser 16 | import Language.Avaleryar.Semantics 17 | import Language.Avaleryar.Syntax 18 | 19 | import Test.Hspec 20 | import Test.QuickCheck (arbitrary, generate) 21 | 22 | shouldSucceed, shouldFail, shouldNotTimeout :: (HasCallStack) => IO TestResult -> Expectation 23 | shouldSucceed io = io >>= (`shouldSatisfy` isSuccess) 24 | where isSuccess (Result (Success _)) = True 25 | isSuccess _ = False 26 | shouldFail io = io >>= (`shouldSatisfy` isFailure) 27 | where isFailure (Result (Success _)) = False 28 | isFailure _ = True 29 | shouldNotTimeout io = io `shouldNotReturn` Timeout 30 | 31 | exampleDir :: FilePath 32 | exampleDir = "test/examples" 33 | 34 | exampleFile :: FilePath -> FilePath 35 | exampleFile fp = exampleDir fp 36 | 37 | testRulesDb :: RulesDb 38 | testRulesDb = insertRuleAssertion "system" rm mempty 39 | where rm = compileRules "system" . fmap (fmap unRawVar) $ [rls| loop(?x) :- loop(?x). |] 40 | 41 | testNativeDb :: NativeDb 42 | testNativeDb = mkNativeDb "prim" preds 43 | where preds = [ mkNativePred "not=" $ (/=) @Value -- lift bool to pred on 'Value' 44 | , mkNativePred "even" $ even @Int -- lift bool to pred on 'Valuable Int' 45 | , mkNativePred "rev" $ Solely . T.reverse -- lift text transform to pred(+, -) 46 | , mkNativePred "lines" $ fmap Solely . T.lines -- lift list to multiple successes 47 | , mkNativePred "cpu-time" $ cpuTime -- lift IO to pred 48 | , mkNativePred "silly" $ silly -- lift IO list to multiple successes 49 | ] 50 | silly :: Int -> IO [(Int, Bool)] 51 | silly n = replicateM n (generate @(Int, Bool) arbitrary) 52 | 53 | cpuTime :: IO (Solely Int) 54 | cpuTime = Solely . fromInteger <$> getCPUTime 55 | 56 | testNativeModes :: Map Text (Map Pred ModedLit) 57 | testNativeModes = fmap (fmap nativeSig) . unNativeDb $ testNativeDb 58 | 59 | testDb :: Db 60 | testDb = Db testRulesDb testNativeDb 61 | 62 | timeoutSecs :: Int -> IO a -> IO (Maybe a) 63 | timeoutSecs n = timeout $ n * 10 ^ (6 :: Int) 64 | 65 | -- | TODO: Push this back into 'runAvaleryar' or 'runM'... 66 | data TestResult = Result (AvaResults (Lit EVar)) | Timeout 67 | deriving (Eq, Ord, Read, Show) 68 | 69 | testResult :: Maybe (AvaResults (Lit EVar)) -> TestResult 70 | testResult = maybe Timeout Result 71 | 72 | queryRules :: HasCallStack => Lit TextVar -> [Rule RawVar] -> IO TestResult 73 | queryRules q rs = do 74 | let rdb = insertRuleAssertion "qq" rm mempty 75 | rm = compileRules "qq" . fmap (fmap unRawVar) $ rs 76 | go = runAvaleryar 500 10 (Db rdb testNativeDb) $ compileQuery' "qq" q 77 | 78 | testResult <$> timeoutSecs 1 go 79 | 80 | queryFile :: HasCallStack => FilePath -> Lit TextVar -> IO TestResult 81 | queryFile p q = do 82 | Right rs <- parseFile p 83 | let rdb = insertRuleAssertion "system" rm mempty 84 | rm = compileRules "system" . fmap (fmap unRawVar) $ rs 85 | go = runAvaleryar 500 10 (Db rdb testNativeDb) $ compileQuery' "system" q 86 | 87 | testResult <$> timeoutSecs 1 go 88 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/PDP/Handle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Language.Avaleryar.PDP.Handle where 6 | 7 | import Control.Concurrent.MVar 8 | import Control.DeepSeq (NFData) 9 | import Control.Monad.Except 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | import Data.Map (Map) 13 | import qualified Data.Map as Map 14 | import Data.Text (Text) 15 | import GHC.Generics (Generic) 16 | 17 | import Language.Avaleryar.PDP (PDP(..), PDPConfig(..), PDPError, withMaxAnswers) 18 | import qualified Language.Avaleryar.PDP as PDP 19 | import Language.Avaleryar.Semantics 20 | import Language.Avaleryar.Syntax 21 | 22 | data PDPHandle = PDPHandle PDPConfig (MVar RulesDb) deriving Generic 23 | 24 | instance NFData PDPHandle 25 | 26 | newHandle :: PDPConfig -> IO PDPHandle 27 | newHandle c = PDPHandle c <$> newMVar mempty 28 | 29 | withPDPHandle :: PDPHandle -> PDP a -> IO (Either PDPError a) 30 | withPDPHandle (PDPHandle c mv) (PDP ma) = do 31 | rdb <- liftIO $ readMVar mv 32 | flip evalStateT rdb . runExceptT $ runReaderT ma c 33 | 34 | modifyWithPDPHandle :: PDPHandle -> PDP a -> IO (Either PDPError a) 35 | modifyWithPDPHandle (PDPHandle c mv) (PDP ma) = liftIO . modifyMVar mv $ \rdb -> do 36 | (a, rdb') <- flip runStateT rdb . runExceptT $ runReaderT ma c 37 | pure (rdb', a) 38 | 39 | submitAssertion :: PDPHandle -> Text -> [Rule RawVar] -> [Fact] -> IO (Either PDPError ()) 40 | submitAssertion h assn rules facts = modifyWithPDPHandle h $ PDP.submitAssertion assn rules facts 41 | 42 | unsafeSubmitAssertion :: PDPHandle -> Text -> [Rule RawVar] -> IO (Either PDPError ()) 43 | unsafeSubmitAssertion h assn rules = modifyWithPDPHandle h $ PDP.unsafeSubmitAssertion assn rules 44 | 45 | retractAssertion :: PDPHandle -> Text -> IO (Either PDPError ()) 46 | retractAssertion h = modifyWithPDPHandle h . PDP.retractAssertion 47 | 48 | submitFile :: PDPHandle -> Maybe String -> FilePath -> [Fact] -> IO (Either PDPError ()) 49 | submitFile h assn path facts = modifyWithPDPHandle h $ PDP.submitFile assn path facts 50 | 51 | unsafeSubmitFile :: PDPHandle -> Maybe String -> FilePath -> IO (Either PDPError ()) 52 | unsafeSubmitFile h assn path = modifyWithPDPHandle h $ PDP.unsafeSubmitFile assn path 53 | 54 | submitText :: PDPHandle -> Text -> Text -> [Fact] -> IO (Either PDPError ()) 55 | submitText h assn text facts = modifyWithPDPHandle h $ PDP.submitText assn text facts 56 | 57 | unsafeSubmitText :: PDPHandle -> Text -> Text -> IO (Either PDPError ()) 58 | unsafeSubmitText h assn text = modifyWithPDPHandle h $ PDP.unsafeSubmitText assn text 59 | 60 | runQuery :: PDPHandle -> [Fact] -> Text -> [Term TextVar] -> IO (Either PDPError QueryResults) 61 | runQuery h facts p args = withPDPHandle h $ PDP.runQuery facts p args 62 | 63 | runDetailedQuery :: PDPHandle -> [Fact] -> Text -> [Term TextVar] -> IO (Either PDPError DetailedQueryResults) 64 | runDetailedQuery h facts p args = withPDPHandle h $ PDP.runDetailedQuery facts p args 65 | 66 | checkQuery :: PDPHandle -> [Fact] -> Text -> [Term TextVar] -> IO (Either PDPError Bool) 67 | checkQuery h facts p args = withPDPHandle h $ do 68 | res <- withMaxAnswers 1 $ PDP.runQuery facts p args 69 | pure . not . null $ res 70 | 71 | dumpDb :: PDPHandle -> IO (Map Value [Pred]) 72 | dumpDb (PDPHandle PDPConfig {..} mv) = do 73 | RulesDb rdb <- insertRuleAssertion "system" systemAssertion <$> readMVar mv 74 | pure $ fmap Map.keys rdb 75 | -------------------------------------------------------------------------------- /core/test/ModeCheckSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | 6 | module ModeCheckSpec where 7 | 8 | import Control.Monad 9 | import Data.Foldable 10 | import System.Directory 11 | import System.FilePath 12 | 13 | import Language.Avaleryar.ModeCheck 14 | import Language.Avaleryar.Parser 15 | import Language.Avaleryar.Syntax 16 | 17 | import Fixtures 18 | 19 | import Test.Hspec 20 | 21 | testModeCheck :: HasCallStack => [Rule RawVar] -> Either ModeError () 22 | testModeCheck = modeCheck testNativeModes 23 | 24 | -- | These are verbose to get more coverage of the error-message generation 25 | wellModed, illModed :: HasCallStack => [Rule RawVar] -> Expectation 26 | wellModed rules = case testModeCheck rules of 27 | Left !err -> expectationFailure $ show err 28 | Right !() -> pure () 29 | 30 | illModed rules = case testModeCheck rules of 31 | Left !_ -> pure () 32 | Right !() -> expectationFailure "no mode error reported" 33 | 34 | 35 | spec :: Spec 36 | spec = do 37 | describe "mode checking" $ do 38 | it "passes for example files" $ do 39 | files <- filter ((== ".ava") . takeExtension) <$> listDirectory exampleDir 40 | parsed <- traverse (parseFile . exampleFile) files 41 | when (null files) $ expectationFailure ("no .ava files in example directory: " <> exampleDir) 42 | for_ parsed $ \case 43 | Right p -> wellModed p 44 | Left err -> expectationFailure err 45 | 46 | it "complains about ill-moded, non-native rules" $ do 47 | illModed [rls| may(?x). |] -- FV in rule head 48 | illModed [rls| may(?x, ?y) :- may(?x). |] -- FV in rule head 49 | illModed [rls| may(?x) :- ?x says may(?x). |] -- FV in assertion position 50 | wellModed [rls| may(read). |] -- Facts are well moded 51 | wellModed [rls| may(read) :- a says may(?x). |] 52 | 53 | it "complains about missing native assertions and predicates" $ do 54 | illModed [rls| foo(?a) :- :not-a-thing says foo(?a). |] -- unbound assertion 55 | illModed [rls| foo(?a) :- :prim says foo(?a). |] -- unbound predicate 56 | 57 | it "respects mode-restricted predicates" $ do 58 | illModed [rls| foo(?a) :- :prim says rev(?a, a-is-free). |] -- rev(+, -) 59 | wellModed [rls| foo(?a) :- :prim says rev(a-is-free, ?a). |] 60 | wellModed [rls| foo(?a) :- :prim says cpu-time(?a). |] -- cpu-time(-) 61 | 62 | illModed [rls| foo(?a) :- :prim says silly(?n, ?a, ?b). |] -- silly(+, -, -) 63 | wellModed [rls| foo(?a) :- someone says something(?b), 64 | :prim says silly(5, ?a, ?b). |] 65 | 66 | it "works on the examples from the paper" $ do 67 | -- Goofus doesn't ground out his variables... 68 | -- ...Gallant is careful not to try to enumerate the universe 69 | illModed [rls| may(?access) :- application says ip-address(?IP), 70 | application says ip-of(?IP, "192.168.0.0/8"), 71 | ?admin says may(?access).|] 72 | wellModed [rls| may(?access) :- application says ip-address(?IP), 73 | application says ip-of(?IP, "192.168.0.0/8"), 74 | administrator(?admin), ; need to ground out ?admin 75 | ?admin says may(?access).|] 76 | illModed [rls| may(?access) :- application says user(?user), 77 | super-user(?user). |] -- ?access free in head 78 | 79 | wellModed [rls| may(?access) :- application says user(?user), 80 | super-user(?user), 81 | known-access(?access). ; ground out ?access 82 | known-access(read). ; not actually necessary for the test 83 | known-access(write). |] 84 | 85 | -- ACL style would require us to be able to enumerate all the resources, which would be bad. 86 | illModed [rls| may(?user, ?access, ?resource) :- super-user(?user), 87 | known-access(?access). |] 88 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/ModeCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Language.Avaleryar.ModeCheck where 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.State 10 | import Data.Bool 11 | import Data.Foldable 12 | import Data.Map (Map) 13 | import qualified Data.Map as Map 14 | import Data.Text (Text, pack) 15 | import Text.Megaparsec (sourcePosPretty) 16 | import Text.PrettyPrint.Leijen.Text (Pretty(..), colon, squotes) 17 | 18 | import Language.Avaleryar.Syntax 19 | 20 | data ModeEnv = ModeEnv 21 | { nativeModes :: Map Text (Map Pred ModedLit) 22 | , groundedVars :: [RawVar] } 23 | 24 | data ModeError 25 | = UnboundNativeAssertion Text 26 | | UnboundNativePredicate Text Pred 27 | | FVModeRestricted RawVar 28 | | FVInAssertionPosition RawVar 29 | | FVInRuleHead RawVar 30 | deriving (Eq, Ord, Read, Show) 31 | 32 | instance Pretty ModeError where 33 | pretty (UnboundNativeAssertion assn) = "unbound native assertion: " <> squotes (pretty assn) 34 | pretty (UnboundNativePredicate assn prd) = 35 | "unbound native predicate: " 36 | <> squotes (pretty prd) 37 | <> " in assertion " 38 | <> squotes (pretty assn) 39 | pretty (FVModeRestricted (RawVar v l)) = 40 | pretty (sourcePosPretty l) <> colon <> "variable: " 41 | <> squotes (pretty v) 42 | <> " is free in mode restricted position" 43 | pretty (FVInAssertionPosition (RawVar v l)) = 44 | pretty (sourcePosPretty l) <> colon <> "variable: " 45 | <> squotes (pretty v) 46 | <> " appears free in assertion position" 47 | pretty (FVInRuleHead (RawVar v l)) = 48 | pretty (sourcePosPretty l) <> colon <> "variable " 49 | <> squotes (pretty v) 50 | <> " appears free in rule head" 51 | 52 | 53 | newtype ModeCheck m a = ModeCheck { unModeCheck :: ExceptT ModeError (StateT ModeEnv m) a } 54 | deriving (Functor, Applicative, Monad, MonadError ModeError) 55 | 56 | getNativeMode :: Monad m => Text -> Pred -> ModeCheck m ModedLit 57 | getNativeMode assn p = ModeCheck $ do 58 | amap <- gets nativeModes 59 | pmap <- maybe (throwError $ UnboundNativeAssertion assn) pure $ Map.lookup assn amap 60 | maybe (throwError $ UnboundNativePredicate assn p) pure $ Map.lookup p pmap 61 | 62 | displayPred :: Pred -> Text 63 | displayPred (Pred f n) = f <> "/" <> (pack . show $ n) 64 | 65 | ground :: (Monad m, Foldable f) => f RawVar -> ModeCheck m () 66 | ground vs = ModeCheck (modify go) 67 | where go env@ModeEnv {..} = env { groundedVars = toList vs <> groundedVars } 68 | 69 | grounded :: Monad m => RawVar -> ModeCheck m Bool 70 | grounded v = ModeCheck $ gets (elem v . groundedVars) 71 | 72 | modeCheckRule :: Monad m => Rule RawVar -> ModeCheck m () 73 | modeCheckRule (Rule hd body) = traverse_ modeCheckBody body >> modeCheckHead hd 74 | where modeCheckBody (ARNative assn `Says` Lit p bas) = do 75 | Lit _ mas <- getNativeMode assn p 76 | zipWithM_ modeCheckArg mas bas 77 | modeCheckBody (ARTerm aref `Says` Lit _ bas) = do 78 | case aref of 79 | Var v -> grounded v >>= bool (throwError $ FVInAssertionPosition v) (pure ()) 80 | _ -> pure () 81 | 82 | traverse_ ground bas 83 | modeCheckBody (ARCurrent `Says` Lit _ bas) = traverse_ ground bas 84 | 85 | 86 | modeCheckArg (Val _) a = ground a -- treat constants like in-mode variables 87 | modeCheckArg (Var (Out _)) a = ground a -- predicates ground in-mode variables 88 | modeCheckArg (Var (In _)) (Val _) = pure () 89 | modeCheckArg (Var (In _)) (Var v) = do 90 | isGrounded <- grounded v 91 | unless isGrounded $ throwError (FVModeRestricted v) 92 | 93 | modeCheckHead = traverse_ $ \v -> do 94 | isGrounded <- grounded v 95 | unless isGrounded $ throwError (FVInRuleHead v) 96 | 97 | modeCheck :: (Foldable t) => Map Text (Map Pred ModedLit) -> t (Rule RawVar) -> Either ModeError () 98 | modeCheck native = traverse_ $ flip evalState (ModeEnv native mempty) . runExceptT . unModeCheck . modeCheckRule 99 | -------------------------------------------------------------------------------- /Jenkinsfile: -------------------------------------------------------------------------------- 1 | properties([ 2 | buildDiscarder( 3 | logRotator(artifactDaysToKeepStr: '60', artifactNumToKeepStr: '3', daysToKeepStr: '60', numToKeepStr: '20') 4 | ), 5 | ]) 6 | 7 | /* Init Constants */ 8 | String haskellWorkDir="/home/remotejenkins/workspace/haskell-work-dir" 9 | 10 | /* Init global variables for later use */ 11 | String userId="" 12 | 13 | import jenkins.model.CauseOfInterruption.UserInterruption 14 | import org.jenkinsci.plugins.workflow.steps.FlowInterruptedException 15 | 16 | timestamps { 17 | 18 | // Cancel older builds. 19 | Run previousBuild = currentBuild.rawBuild.getPreviousBuildInProgress() 20 | while (previousBuild != null) { 21 | if (previousBuild.isInProgress()) { 22 | def executor = previousBuild.getExecutor() 23 | if (executor != null) { 24 | echo ">> Aborting older build #${previousBuild.number}" 25 | executor.interrupt(Result.ABORTED, new UserInterruption( 26 | "Aborted by newer build #${currentBuild.number}" 27 | )) 28 | } 29 | } 30 | previousBuild = previousBuild.getPreviousBuildInProgress() 31 | } 32 | 33 | node ('pipelines') { 34 | try { 35 | stage('build') { 36 | parallel ( 37 | failFast: true, 38 | haskellBuild: { 39 | withEnv(["HASKELL_WORK_DIR=${haskellWorkDir}"]) { 40 | sh(script: 'mkdir -p $HASKELL_WORK_DIR') 41 | } 42 | dir(path: "${haskellWorkDir}/") { 43 | def scmVars = checkout([ 44 | $class: 'GitSCM', 45 | branches: [[ name: env.CHANGE_BRANCH ]], 46 | userRemoteConfigs: [[credentialsId: '010e0c41-651f-4f83-8706-b5f4281d9e9c', url: 'git@github.com:Simspace/avaleryar.git']], 47 | extensions: [[$class: 'CleanBeforeCheckout']], 48 | ]) 49 | 50 | /* Notify committer that job is starting and where */ 51 | def committerEmail = sh(script: 'git --no-pager show -s --format="%ae"', returnStdout: true).trim() 52 | userId = slackUserIdFromEmail("$committerEmail") 53 | slackSend(color: 'good', notifyCommitters: true, message: "<@$userId> Your Job has started here: <$BUILD_URL>") 54 | 55 | /* Build haskell binaries */ 56 | sh ''' 57 | # no -Werror until ghc 8.8 is on everywhere 58 | stack test avaleryar avaleryar-repl --ghc-options='-Wall' --fast 59 | # run the benchmarks with a 10-second timeout 60 | stack bench avaleryar --fast --ba '-o ava-benchmarks.html --junit ava-benchmarks.xml --time-limit 10' 61 | ''' 62 | junit 'core/ava-benchmarks.xml' 63 | publishHTML(target : [ 64 | allowMissing: false, 65 | alwaysLinkToLastBuild: true, 66 | keepAll: true, 67 | reportDir: 'core', 68 | reportFiles: 'ava-benchmarks.html', 69 | reportName: 'Benchmarks' 70 | ]) 71 | } 72 | } 73 | ) 74 | } 75 | stage('clean-up') { 76 | /* Notify committer that job succeeded */ 77 | slackSend(color: 'good', notifyCommitters: true, message: "<@$userId> Your Job has succeeded. : <$BUILD_URL>") 78 | } 79 | 80 | // Catches the abort signal, want to skip the input() 81 | } catch(FlowInterruptedException caught) { 82 | stage('clean-up') { 83 | slackSend(color: 'good', notifyCommitters: true, message: "<@$userId> Your Job has been aborted: <$BUILD_URL>") 84 | } 85 | 86 | // Catches all other failure reasons 87 | } catch(caught) { 88 | currentBuild.result = "FAILED" 89 | stage('clean-up') { 90 | slackSend(color: 'bad', notifyCommitters: true, message: "<@$userId> Your Job has Failed. Do you want to keep the generated portal for further debugging? <$BUILD_URL>") 91 | } 92 | throw caught 93 | } 94 | } 95 | } 96 | -------------------------------------------------------------------------------- /core/test/SemanticsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module SemanticsSpec where 6 | 7 | import Control.Monad 8 | 9 | import Language.Avaleryar.Parser 10 | import Language.Avaleryar.Semantics 11 | import Language.Avaleryar.Syntax 12 | 13 | import Fixtures 14 | 15 | import Test.Hspec 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "infinite loops" $ do 20 | it "don't run forever on a simple loop" $ do 21 | shouldNotTimeout $ queryFile (exampleFile "loops.ava") [qry| loop1(?z) |] 22 | 23 | it "don't run forever on a less simple loop" $ do 24 | shouldNotTimeout $ queryFile (exampleFile "loops.ava") [qry| loop2(?z) |] 25 | 26 | it "have limited output" $ do 27 | Just answers <- timeoutSecs 1 $ runAvaleryar 5000 10 testDb (msum . replicate 74 $ pure ()) 28 | length answers `shouldBe` 10 29 | 30 | it "demonstrate fair conjunction" $ do 31 | shouldSucceed $ queryFile (exampleFile "fair-conjunction.ava") [qry| a(?x) |] 32 | 33 | it "demonstrate fair disjunction" $ do 34 | shouldSucceed $ queryFile (exampleFile "fair-disjunction.ava") [qry| a(?x) |] 35 | 36 | -- TODO: This is slow for some reason, to the tune of 2 seconds in ghcid 37 | it "finds paths" $ do 38 | let go = queryFile (exampleFile "path.ava") 39 | 40 | -- verbose for errors with line numbers 41 | shouldSucceed $ go [qry| path(1, 2) |] 42 | shouldSucceed $ go [qry| path(1, 3) |] 43 | shouldSucceed $ go [qry| path(1, 4) |] 44 | shouldSucceed $ go [qry| path(1, 5) |] 45 | shouldSucceed $ go [qry| path(2, 1) |] 46 | shouldSucceed $ go [qry| path(2, 3) |] 47 | shouldSucceed $ go [qry| path(2, 4) |] 48 | shouldSucceed $ go [qry| path(2, 5) |] 49 | shouldSucceed $ go [qry| path(3, 1) |] 50 | shouldSucceed $ go [qry| path(3, 2) |] 51 | shouldSucceed $ go [qry| path(3, 4) |] 52 | shouldSucceed $ go [qry| path(3, 5) |] 53 | shouldSucceed $ go [qry| path(5, 4) |] 54 | 55 | shouldFail $ go [qry| path(4, 1) |] 56 | shouldFail $ go [qry| path(4, 2) |] 57 | shouldFail $ go [qry| path(4, 3) |] 58 | shouldFail $ go [qry| path(4, 5) |] 59 | shouldFail $ go [qry| path(5, 1) |] 60 | shouldFail $ go [qry| path(5, 2) |] 61 | shouldFail $ go [qry| path(5, 3) |] 62 | 63 | describe "native predicate typeclass wizardry" $ do 64 | it "works on bool-valued functions on Value" $ do 65 | shouldSucceed $ queryRules [qry| baz(a) |] 66 | [rls| foo(a). 67 | bar(b). 68 | baz(?x) :- 69 | foo(?x), 70 | bar(?y), 71 | :prim says not=(?x, ?y). |] 72 | 73 | it "works on bool-valued functions on Valuable" $ do 74 | shouldSucceed $ queryRules [qry| baz(?x) |] 75 | [rls| foo(2). 76 | baz(?x) :- 77 | foo(?x), 78 | :prim says even(?x). |] 79 | 80 | it "works on Valuable-valued functions" $ do 81 | shouldSucceed $ queryRules [qry| palindrome(bob) |] 82 | [rls| palindrome(?x) :- :prim says rev(?x, ?x). |] 83 | 84 | shouldFail $ queryRules [qry| palindrome(alice) |] 85 | [rls| palindrome(?x) :- :prim says rev(?x, ?x). |] 86 | 87 | it "turns lists into multiple successes" $ do 88 | Result (Success answers) <- queryRules [qry| bar(?rows) |] 89 | [rls| foo("a\nb\nc"). 90 | bar(?rows) :- foo(?text), 91 | :prim says lines(?text, ?rows). |] 92 | answers `shouldMatchList` [ Lit (Pred "bar" 1) [Val "a"] 93 | , Lit (Pred "bar" 1) [Val "b"] 94 | , Lit (Pred "bar" 1) [Val "c"] ] 95 | 96 | it "works on IO computations" $ do 97 | shouldSucceed $ queryRules [qry| time(?t) |] 98 | [rls| time(?t) :- :prim says cpu-time(?t). |] 99 | shouldFail $ queryRules [qry| time(0) |] -- presumably the cpu time is nonzero 100 | [rls| time(?t) :- :prim says cpu-time(?t). |] 101 | 102 | 103 | it "works on all the things (Int -> IO [(Int, Bool)])" $ do 104 | Result (Success answers) <- queryRules [qry| go(?b, ?x, 5) |] 105 | [rls| go(?b, ?x, ?n) :- :prim says silly(?n, ?x, ?b). |] 106 | length answers `shouldBe` 5 107 | 108 | -------------------------------------------------------------------------------- /extras/src/Language/Avaleryar/Native/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | -- | Native avaleryar predicates for working with JSON 5 | 6 | module Language.Avaleryar.Native.JSON 7 | ( JwtConfig(..) 8 | , unsecuredJwtConfig 9 | , db 10 | , allClaims 11 | , securedClaims 12 | , unsecuredClaims 13 | ) where 14 | 15 | import Control.Applicative 16 | import Control.Monad.Except 17 | import Data.Aeson (fromJSON) 18 | import qualified Data.Aeson as Aeson 19 | import qualified Data.Attoparsec.Text as AT 20 | import Data.Bifunctor (first) 21 | import Data.Foldable (toList) 22 | import Data.JSONPath 23 | import Data.Text (Text) 24 | import Data.Text.Encoding (encodeUtf8) 25 | import GHC.Generics (Generic) 26 | import qualified Jose.Jwa as Jwt 27 | import Jose.Jwk 28 | import Jose.Jwt hiding (decode) 29 | import qualified Jose.Jwt as Jwt 30 | 31 | import Language.Avaleryar.Instances () 32 | import Language.Avaleryar.Semantics (NativeDb(..), mkNativeDb, mkNativePred) 33 | import Language.Avaleryar.Syntax (Value(..)) 34 | 35 | runJsonPath :: Text -> Aeson.Value -> Either String [Value] 36 | runJsonPath path val = do 37 | pes <- AT.parseOnly jsonPath path 38 | fmap (foldMap toList . fmap fromJSON) $ executeJSONPathEither pes val 39 | 40 | runJsonPath' :: Text -> Aeson.Value -> [Value] 41 | runJsonPath' path val = concat $ runJsonPath path val 42 | 43 | extractJsonPath :: Text -> Text -> [Value] 44 | extractJsonPath path json = concat $ Aeson.eitherDecodeStrict (encodeUtf8 json) >>= runJsonPath path 45 | 46 | data JwtConfig = JwtConfig 47 | { jwks :: [Jwk] 48 | , jwtEncoding :: Maybe JwtEncoding 49 | } deriving (Eq, Show, Generic) 50 | 51 | unsecuredJwtConfig :: JwtConfig 52 | unsecuredJwtConfig = JwtConfig [] (Just $ JwsEncoding Jwt.None) 53 | 54 | -- | Extracts the signed/encrypted content from a 'JwtContent', but failing on 'Unsecured' data. 55 | securedJwtContent :: JwtContent -> Either String Aeson.Value 56 | securedJwtContent (Jws (_, bs)) = Aeson.eitherDecodeStrict bs 57 | securedJwtContent (Jwe (_, bs)) = Aeson.eitherDecodeStrict bs 58 | securedJwtContent (Unsecured _) = Left "content is unsecured" 59 | 60 | -- | Extracts the 'Unsecured' content from a 'JwtContent'. 61 | unsecuredJwtContent :: JwtContent -> Either String Aeson.Value 62 | unsecuredJwtContent (Unsecured bs) = Aeson.eitherDecodeStrict bs 63 | unsecuredJwtContent _ = Left "content is not unsecured" 64 | 65 | -- | Extracts content from a 'JwtContent' regardless of its securedness. Used for the 66 | -- @unsecured-claim@ predicate. 67 | allJwtContent :: JwtContent -> Either String Aeson.Value 68 | allJwtContent content = unsecuredJwtContent content <|> securedJwtContent content 69 | 70 | claims :: (JwtContent -> Either String Aeson.Value) -> JwtConfig -> Text -> Text -> IO [Value] 71 | claims extractor (JwtConfig ks encoding) json path = do 72 | content <- Jwt.decode ks encoding (encodeUtf8 json) 73 | pure $ toList (first show content >>= extractor) >>= runJsonPath' path -- TODO: Suck less 74 | 75 | -- | Underlying implementation of the @unsecured-claim@ predicate. 76 | allClaims :: JwtConfig -> Text -> Text -> IO [Value] 77 | allClaims = claims allJwtContent 78 | 79 | -- | Underlying implementation of the @claim@ predicate. 80 | securedClaims :: JwtConfig -> Text -> Text -> IO [Value] 81 | securedClaims = claims securedJwtContent 82 | 83 | -- | As 'securedClaims', but **only** extracts unsecured claims---does not correspond to any 84 | -- predicate. 85 | unsecuredClaims :: JwtConfig -> Text -> Text -> IO [Value] 86 | unsecuredClaims = claims unsecuredJwtContent 87 | 88 | -- TODO: Implement a baked-in @expired@ check---this is implementable via @posix-time@ in @:base@ 89 | -- and @claim@, but it would be nicer to have it pre-canned. 90 | 91 | -- | Creates a native database in an assertion named @:json@ that provides predicates for extracting 92 | -- data from json values via jsonpath and for extracting claims from encoded JWTs similarly. 93 | -- 94 | -- FIXME: Currently, configuring JWT decoding is a little crufty---the database needs to be 95 | -- configured with a 'JwtConfig' that contains the data we nee to pass on to 'Jwt.decode'. This is 96 | -- irksomely static and rather inflexible, but will do for now. For testing, we provide 97 | -- 'unsecuredJwtConfig' which will allow the decrypting of unsecured JWTs, though they will only be 98 | -- accessible via the @unsecured-claim@ predicate. Hopefully this is sufficiently awkward to 99 | -- discourage brazenly insecure use of this capability. 100 | db :: MonadIO m => JwtConfig -> NativeDb m 101 | db jc = mkNativeDb "json" [ mkNativePred "path" extractJsonPath 102 | , mkNativePred "claim" $ claims securedJwtContent jc 103 | , mkNativePred "unsecured-claim" $ claims allJwtContent jc] 104 | 105 | 106 | 107 | -------------------------------------------------------------------------------- /core/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | 6 | module Main where 7 | 8 | import Criterion.Main 9 | import Data.Bool 10 | import Data.Text (pack) 11 | import Text.PrettyPrint.Leijen.Text (displayTStrict, renderPretty, vcat, Pretty(..)) 12 | 13 | import Language.Avaleryar 14 | import Language.Avaleryar.PDP 15 | import Language.Avaleryar.Semantics hiding (env) 16 | import Language.Avaleryar.Syntax 17 | 18 | 19 | main :: IO () 20 | main = defaultMain benchmarks 21 | 22 | benchmarks :: [Benchmark] 23 | benchmarks = [ bgroup "clique" [clique n | n <- [5, 10, 25, 40]] 24 | , bgroup "line" [line n | n <- [5, 10, 25, 40]] 25 | , bgroup "loop" [loop n | n <- [50, 100, 500, 1000]] 26 | , bgroup "tight" [tight n | n <- [50, 100, 500, 1000]] 27 | , bgroup "parse" [parse n | n <- [50, 100, 500, 1000]] 28 | ] 29 | 30 | -- | Generate a complete graph of size @n@ and try to find a path from the first node to the last. 31 | -- It uses the potentially-really-bad transitive closure (see @path@ below), so if this is measuring 32 | -- anything, it's probably about interleaving. The @application@ assertion looks like this: 33 | -- 34 | -- @ 35 | -- edge(1, 1). 36 | -- edge(1, 2). 37 | -- edge(1, 3). 38 | -- edge(2, 1). 39 | -- edge(2, 2). 40 | -- edge(2, 3). 41 | -- edge(3, 1). 42 | -- edge(3, 2). 43 | -- edge(3, 3). 44 | -- etc... 45 | -- @ 46 | clique :: Int -> Benchmark 47 | clique n = do 48 | let path = [rls| path(?x, ?y) :- application says edge(?x, ?y). 49 | path(?x, ?z) :- path(?x, ?y), path(?y, ?z). |] 50 | edges = [lit "edge" [val x, val y] 51 | | x <- [1..n] 52 | , y <- [1..n]] 53 | go hdl = bench (show n) $ whnfIO $ do 54 | res <- checkQuery hdl edges "path" [val (1 :: Int), val n] 55 | either (error . show) (bool (error "no path found") (pure True)) res 56 | 57 | flip env go $ do 58 | let Right cfg = pdpConfigRules mempty path 59 | newHandle cfg {maxDepth = 4000} 60 | 61 | -- | Generates a linear sequence of @n@ facts and tries to find a path from the first node to the 62 | -- last. It uses a cons-list shaped @path@ rule. The @application@ assertion looks like this: 63 | -- 64 | -- @ 65 | -- edge(1, 2). 66 | -- edge(2, 3). 67 | -- edge(3, 4). 68 | -- etc... 69 | -- @ 70 | line :: Int -> Benchmark 71 | line n = do 72 | let path = [rls| path(?x, ?y) :- application says edge(?x, ?y). 73 | path(?x, ?z) :- application says edge(?x, ?y), path(?y, ?z). |] 74 | edges = [lit "edge" [val x, val y] 75 | | (x, y) <- zip [1..pred n] [2..n]] 76 | go hdl = bench (show n) $ whnfIO $ do 77 | res <- checkQuery hdl edges "path" [val (1 :: Int), val n] 78 | either (error . show) (bool (error "no path found") (pure True)) res 79 | 80 | flip env go $ do 81 | let Right cfg = pdpConfigRules mempty path 82 | newHandle cfg {maxDepth = 4000} 83 | 84 | -- | Generates a loop of five rules (@e@ implies @d@ implies @c@ implies @b@ implies @a@ implies 85 | -- @e@), each of arity 4 (so that the benchmark exercises the unification code), and then runs a 86 | -- query with @n@ fuel. 87 | loop :: Int -> Benchmark 88 | loop n = do 89 | let rules = [rls| a(?x, ?y, ?z, ?w) :- b(?x, ?y, ?z, ?w). 90 | b(?x, ?y, ?z, ?w) :- c(?x, ?y, ?z, ?w). 91 | c(?x, ?y, ?z, ?w) :- d(?x, ?y, ?z, ?w). 92 | d(?x, ?y, ?z, ?w) :- e(?x, ?y, ?z, ?w). 93 | e(?x, ?y, ?z, ?w) :- a(?x, ?y, ?z, ?w). |] 94 | go hdl = bench (show n) $ whnfIO $ do 95 | res <- checkQuery hdl [] "a" [val (i :: Int) | i <- [1..4]] 96 | either (error . show) (bool (pure True) (error "loop shouldn't succeed")) res 97 | 98 | flip env go $ do 99 | let Right cfg = pdpConfigRules mempty rules 100 | newHandle cfg {maxDepth = n} 101 | 102 | -- | As 'loop', but with arity 0 rules. This should be a better measure of the overhead of the 103 | -- underlying monad, at least insofar as there won't be unification/substitution overhead. Expect 104 | -- this to be faster than 'loop'. 105 | tight :: Int -> Benchmark 106 | tight n = do 107 | let rules = [rls| a :- b. b :- c. c :- d. d :- e. e :- a. |] 108 | go hdl = bench (show n) $ whnfIO $ do 109 | res <- checkQuery hdl [] "a" [] 110 | either (error . show) (bool (pure True) (error "tight shouldn't succeed")) res 111 | 112 | flip env go $ do 113 | let Right cfg = pdpConfigRules mempty rules 114 | newHandle cfg {maxDepth = n} 115 | 116 | -- | Generates @n@ rules, pretty prints them, then times how long it takes to parse them. The text 117 | -- look like this: 118 | -- 119 | -- @ 120 | -- rule-1(?x, ?y, ?z, ?w) :- 121 | -- application says rule-1-body(?x, ?y, ?z, ?w), 122 | -- application says rule-1-body(?x, ?y, ?z, ?w), 123 | -- application says rule-1-body(?x, ?y, ?z, ?w), 124 | -- application says rule-1-body(?x, ?y, ?z, ?w), 125 | -- application says rule-1-body(?x, ?y, ?z, ?w). 126 | -- 127 | -- rule-2(?x, ?y, ?z, ?w) :- 128 | -- application says rule-2-body(?x, ?y, ?z, ?w), 129 | -- application says rule-2-body(?x, ?y, ?z, ?w), 130 | -- application says rule-2-body(?x, ?y, ?z, ?w), 131 | -- application says rule-2-body(?x, ?y, ?z, ?w), 132 | -- application says rule-2-body(?x, ?y, ?z, ?w). 133 | -- 134 | -- etc... 135 | -- @ 136 | parse :: Int -> Benchmark 137 | parse n = go txt 138 | where rule x = Rule (lit (rn x) vars) [Says (ARTerm (val $ T "application")) (lit (rn x <> "-body") vars) | _ <- [1..5]] 139 | rn x = pack ("rule-" <> show x) 140 | vars = Var <$> [pack "x", "y", "z", "w"] 141 | rs = [rule x | x <- [1..n]] 142 | !txt = displayTStrict . renderPretty 1.0 50 . vcat . fmap pretty $ rs 143 | go = bench (show n) . nf (parseText "system") 144 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Language.Avaleryar.Parser 6 | ( -- * Parsers 7 | parseFile 8 | , parseFile' 9 | , parseFactFile 10 | , parseFacts 11 | , parseQuery 12 | , parseText 13 | -- * Quasiquoters 14 | , qry 15 | , fct 16 | , rls 17 | ) where 18 | 19 | import Control.Monad (void) 20 | import Data.Bifunctor (first) 21 | import Data.Either (partitionEithers) 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import qualified Data.Text.IO as T 25 | import Data.Void 26 | import Language.Haskell.TH.Quote (QuasiQuoter) 27 | import QQLiterals 28 | import Text.Megaparsec 29 | import Text.Megaparsec.Char 30 | import qualified Text.Megaparsec.Char.Lexer as L 31 | 32 | import Language.Avaleryar.Syntax hiding (lit, fact) 33 | 34 | type Parser = Parsec Void Text 35 | 36 | -- ws :: (MonadParsec e s m, Token s ~ Char) => m () 37 | ws :: Parser () 38 | ws = L.space space1 (L.skipLineComment ";") empty 39 | 40 | lexeme :: Parser a -> Parser a 41 | lexeme = L.lexeme ws 42 | 43 | symbol :: Text -> Parser Text 44 | symbol = L.symbol ws 45 | 46 | colon, comma, dot :: Parser () 47 | colon = void $ symbol ":" 48 | comma = void $ symbol "," 49 | dot = void $ symbol "." 50 | 51 | parens :: Parser a -> Parser a 52 | parens = between (symbol "(") (symbol ")") 53 | 54 | -- I'm stealing ':' for myself, might take more later 55 | symInit, symCont :: Parser Char 56 | symInit = letterChar <|> oneOf ("!@$%&*/<=>~_^" :: String) 57 | symCont = symInit <|> digitChar <|> oneOf ("+-?" :: String) 58 | 59 | stringLiteral :: Parser Text 60 | stringLiteral = T.pack <$> (char '"' *> manyTill L.charLiteral (char '"')) 61 | 62 | sym :: Parser Text 63 | sym = lexeme (T.pack <$> go) "symbol" 64 | where go = (:) <$> symInit <*> many symCont 65 | 66 | value :: Parser Value 67 | value = I <$> L.signed (pure ()) L.decimal 68 | <|> T <$> stringLiteral 69 | <|> T <$> sym -- unquoted symbols 70 | <|> B <$> (string "#t" *> pure True <|> string "#f" *> pure False) 71 | 72 | ident :: Parser Text 73 | ident = sym "identifer" 74 | 75 | var :: Parser RawVar 76 | var = do 77 | loc <- getSourcePos 78 | RawVar <$> (char '?' *> ident) <*> pure loc "variable" 79 | 80 | term :: Parser (Term RawVar) 81 | term = Var <$> var <|> Val <$> lexeme value 82 | 83 | lit :: Parser (Lit RawVar) 84 | lit = label "literal" $ do 85 | ftor <- ident 86 | args <- concat <$> optional (parens (term `sepBy` comma)) 87 | pure $ Lit (Pred ftor (length args)) args 88 | 89 | -- | A specialized version of 'lit' that fails faster for facts. Like 'rule' and unlike 'lit', 90 | -- parses a trailing 'dot'. 91 | fact :: Parser Fact 92 | fact = label "fact" $ do 93 | ftor <- ident 94 | args <- fmap Val <$> parens (value `sepBy` comma) 95 | dot 96 | pure $ Lit (Pred ftor (length args)) args 97 | 98 | -- | Like 'fact', but without the trailing 'dot'. FIXME: Suck less. 99 | fact' :: Parser Fact 100 | fact' = label "fact" $ do 101 | ftor <- ident 102 | args <- fmap Val <$> parens (value `sepBy` comma) 103 | pure $ Lit (Pred ftor (length args)) args 104 | 105 | aref :: Parser (ARef RawVar) 106 | aref = colon *> (ARNative <$> sym) <|> ARTerm <$> term 107 | 108 | currentAssertion :: Parser (ARef RawVar) 109 | currentAssertion = pure ARCurrent 110 | 111 | bodyLit :: Parser (BodyLit RawVar) 112 | bodyLit = Says <$> (try (aref <* symbol "says") <|> currentAssertion) <*> lit 113 | 114 | rule :: Parser (Rule RawVar) 115 | rule = Rule <$> lit <*> (body <|> dot *> pure []) 116 | where -- bodyLits = ( (try (term val *> symbol "says") *> lit val) <|> lit val) `sepBy1` comma 117 | bodyLits = bodyLit `sepBy1` comma 118 | body = symbol ":-" *> label "rule body" bodyLits <* dot 119 | 120 | directive :: Parser Directive 121 | directive = do 122 | void $ symbol ":-" 123 | label "directive" $ 124 | Directive <$> fact' <*> fact' `sepBy` comma <* dot 125 | 126 | -- ruleFile :: Parser [Rule RawVar] 127 | -- ruleFile = ws *> many rule 128 | 129 | factFile :: Parser [Fact] 130 | factFile = ws *> many fact 131 | 132 | -- FIXME: Suck less 133 | ruleFile' :: Parser ([Directive], [Rule RawVar]) 134 | ruleFile' = ws *> (partitionEithers <$> many (fmap Left directive <|> fmap Right rule)) 135 | 136 | parseFile' :: FilePath -> IO (Either String ([Directive], [Rule RawVar])) 137 | parseFile' path = do 138 | file <- T.readFile path 139 | pure . first errorBundlePretty $ parse ruleFile' path file 140 | 141 | parseText' :: Text -> Text -> Either String ([Directive], [Rule RawVar]) 142 | parseText' assn = first errorBundlePretty . parse ruleFile' (T.unpack assn) 143 | 144 | parseFile :: FilePath -> IO (Either String [Rule RawVar]) 145 | parseFile path = fmap snd <$> parseFile' path 146 | 147 | parseFactFile :: FilePath -> IO (Either String [Fact]) 148 | parseFactFile path = do 149 | file <- T.readFile path 150 | pure . first errorBundlePretty $ parse factFile path file 151 | 152 | parseFacts :: Text -> Either String [Fact] 153 | parseFacts src = first errorBundlePretty $ parse factFile "" src 154 | 155 | parseText :: Text -> Text -> Either String [Rule RawVar] 156 | parseText assn src = snd <$> parseText' assn src 157 | 158 | parseQuery :: Text -> Text -> Either String Query 159 | parseQuery assn = first errorBundlePretty . parse go (T.unpack assn) 160 | where go = ws *> fmap (fmap unRawVar) lit 161 | 162 | -- testParseFile :: FilePath -> IO (Either String [Rule RawVar]) 163 | -- testParseFile file = T.readFile file >>= pure . parseText (T.pack file) 164 | 165 | rulesQQParser :: String -> Either String [Rule RawVar] 166 | rulesQQParser = first errorBundlePretty . parse go "qq" . T.pack 167 | where go = ws *> many rule 168 | 169 | queryQQParser :: String -> Either String Query 170 | queryQQParser = first errorBundlePretty . parse go "qq" . T.pack 171 | where go = ws *> fmap (fmap unRawVar) lit 172 | 173 | factQQParser :: String -> Either String Fact 174 | factQQParser = first errorBundlePretty . parse go "qq" . T.pack 175 | where go = ws *> fmap (fmap $ error "variable in fact") lit 176 | 177 | 178 | rls :: QuasiQuoter 179 | rls = qqLiteral rulesQQParser 'rulesQQParser 180 | 181 | qry :: QuasiQuoter 182 | qry = qqLiteral queryQQParser 'queryQQParser 183 | 184 | fct :: QuasiQuoter 185 | fct = qqLiteral factQQParser 'factQQParser 186 | 187 | -------------------------------------------------------------------------------- /core/src/Control/Monad/FBackTrackT.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -w #-} 2 | 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | {- Haskell98! -} 9 | 10 | -- Simple Fair back-tracking monad TRANSFORMER 11 | -- Made by `transforming' the stand-alone monad from FBackTrack.hs, 12 | -- which, in turn, is based on the Scheme code book-si, 13 | -- `Stream implementation, with incomplete' as of Feb 18, 2005 14 | -- 15 | -- The transformatiion from a stand-alone Stream monad to a monad transformer 16 | -- is not at all similar to the trick described in Ralf Hinze's ICFP'00 paper, 17 | -- Deriving backtracking monad transformers. 18 | 19 | -- Haddock doesn't like @-- $Id@: $Id: FBackTrackT.hs,v 1.1.0.1 2005/10/31 22:34:25 oleg Exp oleg $ 20 | 21 | module Control.Monad.FBackTrackT 22 | ( Stream 23 | , yield 24 | , runM 25 | , runM' 26 | , observe 27 | , SG 28 | , MonadYield(..) 29 | ) where 30 | 31 | import Control.Applicative 32 | import Control.Monad 33 | import qualified Control.Monad.Fail as Fail 34 | import Control.Monad.Identity 35 | import Control.Monad.State 36 | import Control.Monad.Trans 37 | 38 | data StreamE m a 39 | = Nil 40 | | One a 41 | | Choice a (Stream m a) 42 | | Incomplete (Stream m a) 43 | deriving (Functor) 44 | 45 | newtype Stream m a = Stream { unStream :: m (StreamE m a) } 46 | deriving (Functor) 47 | 48 | instance Monad m => Applicative (Stream m) where 49 | pure = return 50 | {-# INLINE pure #-} 51 | (<*>) = ap 52 | {-# INLINE (<*>) #-} 53 | 54 | instance Monad m => Monad (Stream m) where 55 | return = Stream . return . One 56 | {-# INLINE return #-} 57 | 58 | m >>= f = Stream (unStream m >>= bind) 59 | where 60 | bind Nil = return Nil 61 | bind (One a) = unStream $ f a 62 | bind (Choice a r) = unStream $ f a `mplus` (yield (r >>= f)) 63 | bind (Incomplete i) = return $ Incomplete (i >>= f) 64 | {-# INLINE bind #-} 65 | {-# INLINE (>>=) #-} 66 | 67 | yield :: Monad m => Stream m a -> Stream m a 68 | yield = Stream . return . Incomplete 69 | {-# INLINE yield #-} 70 | 71 | instance Monad m => Alternative (Stream m) where 72 | empty = mzero 73 | {-# INLINE empty #-} 74 | (<|>) = mplus 75 | {-# INLINE (<|>) #-} 76 | 77 | instance Monad m => MonadPlus (Stream m) where 78 | mzero = Stream $ return Nil 79 | {-# INLINE mzero #-} 80 | 81 | mplus m1 m2 = Stream (unStream m1 >>= mplus') 82 | where 83 | mplus' Nil = return $ Incomplete m2 84 | mplus' (One a) = return $ Choice a m2 85 | mplus' (Choice a r) = return $ Choice a (mplus m2 r) -- interleaving! 86 | --mplus' (Incomplete i) = return $ Incomplete (mplus i m2) 87 | mplus' r@(Incomplete i) = unStream m2 >>= \r' -> 88 | case r' of 89 | Nil -> return r 90 | One b -> return $ Choice b i 91 | Choice b r' -> return $ Choice b (mplus i r') 92 | -- Choice _ _ -> Incomplete (mplus r' i) 93 | Incomplete j -> return . Incomplete . yield $ mplus i j 94 | {-# INLINE mplus #-} 95 | 96 | instance Monad m => Fail.MonadFail (Stream m) where 97 | fail _ = mzero 98 | {-# INLINE fail #-} 99 | 100 | instance MonadTrans Stream where 101 | lift m = Stream (m >>= return . One) 102 | {-# INLINE lift #-} 103 | 104 | instance MonadIO m => MonadIO (Stream m) where 105 | liftIO = lift . liftIO 106 | {-# INLINE liftIO #-} 107 | 108 | instance MonadState s m => MonadState s (Stream m) where 109 | get = lift get 110 | {-# INLINE get #-} 111 | put s = lift (put s) 112 | {-# INLINE put #-} 113 | 114 | -- run the Monad, to a specific depth, and give at most 115 | -- specified number of answers. The monad `m' may be strict (like IO), 116 | -- so we can't count on the laziness of the `[a]' 117 | runM :: Monad m => Maybe Int -> Maybe Int -> Stream m a -> m [a] 118 | runM d b s = runM' d b s >>= \(_, _, as) -> pure as 119 | 120 | -- Amended 2020/11/16: returns the remaining fuel in addition to the results. 121 | runM' :: Monad m => Maybe Int -> Maybe Int -> Stream m a -> m (Maybe Int, Maybe Int, [a]) 122 | runM' d b@(Just 0) _ = return (d, b, []) -- out of breath 123 | runM' d b m = unStream m >>= go d b 124 | where go d b Nil = return (d, b, []) 125 | go d b (One a) = return (d, b, [a]) 126 | go d b (Choice a r) = do (d', b', t) <- runM' d (liftM pred b) r; return (d', b', a:t) 127 | go d@(Just 0) b (Incomplete r) = return (d, b, []) -- exhausted depth 128 | go d b (Incomplete r) = runM' (liftM pred d) b r 129 | 130 | -- Don't try the following with the regular List monad or List comprehension! 131 | -- That would diverge instantly: all `i', `j', and `k' are infinite 132 | -- streams 133 | 134 | pythagorean_triples :: MonadPlus m => m (Int,Int,Int) 135 | pythagorean_triples = 136 | let number = (return 0) `mplus` (number >>= return . succ) in 137 | do 138 | i <- number 139 | guard $ i > 0 140 | j <- number 141 | guard $ j > 0 142 | k <- number 143 | guard $ k > 0 144 | guard $ i*i + j*j == k*k 145 | return (i,j,k) 146 | 147 | -- If you run this in GHCi, you can see that Indetity is a lazy monad 148 | -- and IO is strict: evaluating `test' prints the answers as they are computed. 149 | -- OTH, testio runs silently for a while and then prints all the answers 150 | -- at once 151 | test = runIdentity $ runM Nothing (Just 7) pythagorean_triples 152 | testio = runM Nothing (Just 7) pythagorean_triples >>= print 153 | 154 | 155 | -- The following code is not in general MonadPlus: it uses Incomplete 156 | -- explicitly. But it supports left recursion! Note that in OCaml, for example, 157 | -- we _must_ include that Incomplete data constructor to make 158 | -- the recursive definition well-formed. 159 | -- The code does *not* get stuck in the generation of primitive tuples 160 | -- like (0,1,1), (0,2,2), (0,3,3) etc. 161 | pythagorean_triples' :: Monad m => Stream m (Int,Int,Int) 162 | pythagorean_triples' = 163 | let number = (yield number >>= return . succ) `mplus` return 0 in 164 | do 165 | i <- number 166 | j <- number 167 | k <- number 168 | guard $ i*i + j*j == k*k 169 | return (i,j,k) 170 | 171 | test' = runIdentity $ runM Nothing (Just 27) pythagorean_triples' 172 | testio' = runM Nothing (Just 27) pythagorean_triples' >>= print 173 | 174 | pythagorean_triples'' :: Stream IO (Int,Int,Int) 175 | pythagorean_triples'' = 176 | let number = (yield number >>= return . succ) `mplus` return 0 in 177 | do 178 | i <- number 179 | j <- number 180 | k <- number 181 | liftIO $ print (i,j,k) 182 | guard $ i*i + j*j == k*k 183 | return (i,j,k) 184 | 185 | testio'' = runM Nothing (Just 7) pythagorean_triples'' >>= print 186 | 187 | -- a serious test of left recursion (due to Will Byrd) 188 | flaz x = yield (flaz x) `mplus` (yield (flaz x) `mplus` if x == 5 then return x else mzero) 189 | test_flaz = runIdentity $ runM Nothing (Just 15) (flaz 5) 190 | 191 | -- FBackTrackT implements LogicT 192 | type SG = Stream 193 | 194 | -- instance LogicT Stream where 195 | -- msplit m = Stream (unStream m >>= check) 196 | -- where 197 | -- check Nil = return . One $ Nothing 198 | -- check (One x) = return . One $ Just (x,mzero) 199 | -- check (Choice x m) = return . One $ Just (x,m) 200 | -- check (Incomplete m) = return . Incomplete $ msplit m 201 | 202 | -- Hinze's `observe' -- the opposite of `lift' 203 | -- observe . lift == id 204 | 205 | observe :: MonadFail m => Stream m a -> m a 206 | observe m = unStream m >>= pick1 207 | where pick1 Nil = fail "no anwers" 208 | pick1 (One a) = return a 209 | pick1 (Choice a _) = return a 210 | pick1 (Incomplete m) = observe m 211 | {-# INLINE observe #-} 212 | 213 | class Monad m => MonadYield m where 214 | yield' :: m a -> m a 215 | 216 | instance Monad m => MonadYield (Stream m) where 217 | yield' = yield 218 | {-# INLINE yield' #-} 219 | 220 | instance MonadYield m => MonadYield (StateT s m) where 221 | yield' (StateT sma) = StateT (yield' . sma) 222 | {-# INLINE yield' #-} 223 | -------------------------------------------------------------------------------- /repl/src/Language/Avaleryar/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE LiberalTypeSynonyms #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | module Language.Avaleryar.Repl where 11 | 12 | import Control.Applicative 13 | import Control.Monad.Reader 14 | import Data.Containers.ListUtils (nubOrd) 15 | import Data.Foldable 16 | import Data.IORef 17 | import Data.List (isPrefixOf) 18 | import qualified Data.Map as Map 19 | import Data.String 20 | import Data.Text (unpack, Text) 21 | import Options.Applicative as Opts 22 | import System.Exit (exitFailure) 23 | import System.Console.Repline as RL hiding (banner, options) 24 | import System.IO (hPutStrLn, stderr) 25 | import System.IO.Unsafe 26 | import System.ReadEditor (readEditorWith) 27 | import Text.PrettyPrint.Leijen.Text (Pretty(..)) 28 | import qualified Text.PrettyPrint.Leijen.Text as PP 29 | 30 | import Language.Avaleryar.Parser 31 | import Language.Avaleryar.PDP (PDPConfig, demoNativeDb, pdpConfig) 32 | import Language.Avaleryar.PDP.Handle 33 | import Language.Avaleryar.PrettyPrinter 34 | import Language.Avaleryar.Semantics (DetailedResults(..), DetailedQueryResults) 35 | import Language.Avaleryar.Syntax 36 | import Language.Avaleryar.Testing (runTestFile, putTestResults, TestResults) 37 | 38 | -- | Spin up a repl using the given 'PDPConfig', configuring its underlying 'PDPHandle' with a 39 | -- callback. 40 | replWithHandle :: PDPConfig -> (PDPHandle -> IO ()) -> IO () 41 | replWithHandle conf k = do 42 | let complete = Prefix (wordCompleter byWord) commandMatcher 43 | handle <- newHandle conf 44 | k handle 45 | runReaderT (evalRepl 46 | banner 47 | cmd 48 | options 49 | commandChar 50 | multilineStr 51 | complete 52 | ini 53 | fin) handle 54 | 55 | -- | As 'replWithHandle', doing no additional configuration. 56 | repl :: PDPConfig -> IO () 57 | repl conf = replWithHandle conf mempty 58 | 59 | main :: IO () 60 | main = do 61 | Args {..} <- execParser (info parseArgs mempty) 62 | conf <- pdpConfig demoNativeDb systemAssn >>= either diePretty pure 63 | let loadAssns h = for_ otherAssns $ either diePretty pure <=< unsafeSubmitFile h Nothing 64 | displayResults = traverse_ $ either putStrLn (traverse_ $ uncurry putTestResults) 65 | 66 | traverse_ (loadApplication <=< liftIO . readFile) appAssn 67 | 68 | if null testFiles 69 | then replWithHandle conf loadAssns 70 | else runTestFiles conf loadAssns testFiles >>= displayResults 71 | 72 | runTestFiles :: PDPConfig -> (PDPHandle -> IO ()) -> [FilePath] -> IO [Either String [(Text, TestResults)]] 73 | runTestFiles conf k = traverse (runTestFile conf k) 74 | 75 | data Args = Args 76 | { systemAssn :: FilePath 77 | , testFiles :: [FilePath] 78 | , otherAssns :: [FilePath] 79 | , appAssn :: Maybe FilePath 80 | } deriving (Eq, Show) 81 | 82 | parseArgs :: Opts.Parser Args 83 | parseArgs = Args <$> saParser <*> tfParser <*> oaParser <*> afParser 84 | where saParser = strOption $ fold saMods 85 | saMods = [short 's' 86 | , long "system" 87 | , value "system.ava" 88 | , showDefault 89 | , help "file containing the system assertion"] 90 | tfParser = many . strOption $ fold tfMods 91 | tfMods = [short 't' 92 | , long "test" 93 | , help "files containing tests to run"] 94 | oaParser = many . strArgument $ fold oaMods 95 | oaMods = [help "assertions to load (will be named after their filename)"] 96 | afParser = optional . strOption $ fold afMods 97 | afMods = [short 'a' 98 | , long "application" 99 | , help "file containing facts for the application assertion"] 100 | 101 | 102 | 103 | type Repl a = HaskelineT (ReaderT PDPHandle IO) a 104 | 105 | cmd :: Command Repl 106 | cmd q = do 107 | let parsed = parseQuery "" (fromString q) 108 | handle <- ask 109 | facts <- liftIO $ readIORef appFacts 110 | case parsed of 111 | Left err -> liftIO $ putStrLn err 112 | Right (Lit (Pred p _) args) -> 113 | liftIO (runDetailedQuery handle facts p args) >>= either (liftIO . putStrLn . show) putAnswers 114 | 115 | -- | TODO: repl options a la ghci's @+t@. 116 | putAnswers :: MonadIO m => DetailedQueryResults -> m () 117 | putAnswers DetailedResults {..} = liftIO $ putResults results *> putStats 118 | where putResults [] = putStrLn "no." 119 | putResults rs = putFacts rs 120 | putStats = putStrLn $ "(" <> depthUsage <> " fuel, " <> breadthUsage <> " answers)" 121 | depthUsage = show (initialDepth - remainingDepth) <> "/" <> show initialDepth 122 | breadthUsage = show (initialBreadth - remainingBreadth) <> "/" <> show initialBreadth 123 | 124 | banner :: MultiLine -> Repl String 125 | banner _ = pure "-? " 126 | 127 | options :: Options Repl 128 | options = [ ("load", load) 129 | , ("dump", dump) 130 | , ("app", app)] 131 | 132 | appFacts :: IORef [Fact] 133 | appFacts = unsafePerformIO $ newIORef [] 134 | {-# NOINLINE appFacts #-} 135 | 136 | load :: FilePath -> Repl () 137 | load path = dontCrash $ do 138 | handle <- ask 139 | liftIO $ do 140 | submitted <- submitFile handle Nothing path [] 141 | case submitted of 142 | Left err -> putStrLn $ path ++ ": " ++ show err 143 | Right () -> pure () 144 | 145 | dump :: String -> Repl () 146 | dump assns = do 147 | dumped <- ask >>= liftIO . dumpDb 148 | let assns' | null assns = Map.keys dumped 149 | | otherwise = fromString <$> words assns -- janky 150 | for_ (nubOrd assns') $ \assn -> liftIO $ do 151 | traverse_ (putAssertion assn) $ Map.lookup assn dumped 152 | liftIO $ putStrLn "" 153 | 154 | app :: String -> Repl () 155 | app _ = do 156 | currentFacts <- liftIO $ readIORef appFacts 157 | let hdr = "\n\n;; facts written above will be added to the 'application' assertion" 158 | body = unlines . fmap (prettyString @(Rule TextVar) . factToRule) $ currentFacts 159 | 160 | newSource <- liftIO $ readEditorWith (hdr <> "\n\n" <> body) 161 | liftIO $ loadApplication newSource 162 | 163 | -- | Helper for 'app' and the @-a@ argument. Takes the string containing (concrete-syntax) facts. 164 | loadApplication :: String -> IO () 165 | loadApplication src = do 166 | let parsed = parseFacts (fromString src) 167 | 168 | case parsed of 169 | Left err -> putStrLn err *> putStrLn "failed to load any facts." 170 | Right [] -> putStrLn "no facts provided, preserving current facts." 171 | Right fs -> do 172 | writeIORef appFacts fs 173 | putStrLn $ "loaded " <> (show $ length fs) <> " fact(s)." 174 | 175 | commandMatcher :: (MonadIO m, MonadReader PDPHandle m) => [(String, CompletionFunc m)] 176 | commandMatcher = [ (":load", fileCompleter) 177 | , (":dump", dumpCompleter) 178 | , (":app", RL.listCompleter []) 179 | ] 180 | where dumpCompleter ss = do -- TODO: inhibit duplicates a la zsh completion 181 | assns <- fmap prettyString <$> listAssertions 182 | RL.listCompleter assns ss 183 | 184 | listAssertions :: (MonadIO m, MonadReader PDPHandle m) => m [Value] 185 | listAssertions = ask >>= liftIO . fmap Map.keys . dumpDb 186 | 187 | prettyString :: Pretty p => p -> String 188 | prettyString = unpack . PP.displayTStrict . PP.renderCompact . pretty 189 | 190 | byWord :: forall m. (MonadIO m, MonadReader PDPHandle m) => WordCompleter m 191 | byWord n = do 192 | let names = [c | (c, _) <- commandMatcher @m] 193 | sysPreds <- ask >>= liftIO . dumpDb >>= pure . concat . Map.lookup "system" 194 | pure $ filter (isPrefixOf n) (names <> nubOrd [unpack p | (Pred p _) <- sysPreds]) 195 | 196 | ini :: Repl () 197 | ini = liftIO $ putStrLn "Avaleryar!" 198 | 199 | fin :: Repl ExitDecision 200 | fin = pure Exit 201 | 202 | commandChar :: Maybe Char 203 | commandChar = Just ':' 204 | 205 | multilineStr :: Maybe String 206 | multilineStr = Nothing 207 | 208 | diePretty :: (Pretty a, MonadIO m) => a -> m b 209 | diePretty x = liftIO $ do 210 | PP.hPutDoc stderr (pretty x) 211 | hPutStrLn stderr "" 212 | exitFailure 213 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: group 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | # long_list_align: inline 108 | long_list_align: new_line 109 | 110 | # Align empty list (importing instances) 111 | # 112 | # Empty list align has following options 113 | # 114 | # - inherit: inherit list_align setting 115 | # 116 | # - right_after: () is right after the module name: 117 | # 118 | # > import Vector.Instances () 119 | # 120 | # Default: inherit 121 | empty_list_align: inherit 122 | 123 | # List padding determines indentation of import list on lines after import. 124 | # This option affects 'long_list_align'. 125 | # 126 | # - : constant value 127 | # 128 | # - module_name: align under start of module name. 129 | # Useful for 'file' and 'group' align settings. 130 | list_padding: 4 131 | 132 | # Separate lists option affects formatting of import list for type 133 | # or class. The only difference is single space between type and list 134 | # of constructors, selectors and class functions. 135 | # 136 | # - true: There is single space between Foldable type and list of it's 137 | # functions. 138 | # 139 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 140 | # 141 | # - false: There is no space between Foldable type and list of it's 142 | # functions. 143 | # 144 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 145 | # 146 | # Default: true 147 | separate_lists: false 148 | 149 | # Space surround option affects formatting of import lists on a single 150 | # line. The only difference is single space after the initial 151 | # parenthesis and a single space before the terminal parenthesis. 152 | # 153 | # - true: There is single space associated with the enclosing 154 | # parenthesis. 155 | # 156 | # > import Data.Foo ( foo ) 157 | # 158 | # - false: There is no space associated with the enclosing parenthesis 159 | # 160 | # > import Data.Foo (foo) 161 | # 162 | # Default: false 163 | space_surround: false 164 | 165 | # Language pragmas 166 | - language_pragmas: 167 | # We can generate different styles of language pragma lists. 168 | # 169 | # - vertical: Vertical-spaced language pragmas, one per line. 170 | # 171 | # - compact: A more compact style. 172 | # 173 | # - compact_line: Similar to compact, but wrap each line with 174 | # `{-#LANGUAGE #-}'. 175 | # 176 | # Default: vertical. 177 | style: vertical 178 | 179 | # Align affects alignment of closing pragma brackets. 180 | # 181 | # - true: Brackets are aligned in same column. 182 | # 183 | # - false: Brackets are not aligned together. There is only one space 184 | # between actual import and closing bracket. 185 | # 186 | # Default: true 187 | align: true 188 | 189 | # stylish-haskell can detect redundancy of some language pragmas. If this 190 | # is set to true, it will remove those redundant pragmas. Default: true. 191 | remove_redundant: true 192 | 193 | # Replace tabs by spaces. This is disabled by default. 194 | # - tabs: 195 | # # Number of spaces to use for each tab. Default: 8, as specified by the 196 | # # Haskell report. 197 | # spaces: 8 198 | 199 | # Remove trailing whitespace 200 | - trailing_whitespace: {} 201 | 202 | # A common setting is the number of columns (parts of) code will be wrapped 203 | # to. Different steps take this into account. Default: 80. 204 | columns: 120 205 | 206 | # By default, line endings are converted according to the OS. You can override 207 | # preferred format here. 208 | # 209 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 210 | # 211 | # - lf: Convert to LF ("\n"). 212 | # 213 | # - crlf: Convert to CRLF ("\r\n"). 214 | # 215 | # Default: native. 216 | newline: native 217 | 218 | # Sometimes, language extensions are specified in a cabal file or from the 219 | # command line instead of using language pragmas in the file. stylish-haskell 220 | # needs to be aware of these, so it can parse the file correctly. 221 | # 222 | # No language extensions are enabled by default. 223 | language_extensions: 224 | - DataKinds 225 | - DefaultSignatures 226 | - DeriveDataTypeable 227 | - DeriveGeneric 228 | - DerivingStrategies 229 | - DerivingVia 230 | - EmptyDataDecls 231 | - FlexibleContexts 232 | - FlexibleInstances 233 | - GADTs 234 | - GeneralizedNewtypeDeriving 235 | - LambdaCase 236 | - MultiParamTypeClasses 237 | - NamedFieldPuns 238 | - NoImplicitPrelude 239 | - NoMonomorphismRestriction 240 | - OverloadedStrings 241 | - QuasiQuotes 242 | - RankNTypes 243 | - RecordWildCards 244 | - ScopedTypeVariables 245 | - StandaloneDeriving 246 | - TemplateHaskell 247 | - TupleSections 248 | - TypeApplications 249 | - TypeFamilies 250 | - TypeOperators 251 | - ViewPatterns 252 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/Testing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TupleSections #-} 4 | -- | A small unit-testing framework exploiting 'Directive's. This module probably belongs in a 5 | -- different package, but is provided here because it's convenient, helpful and it provides an 6 | -- example (though perhaps not an exemplar) of how directives can be used to provide extended 7 | -- functionality. 8 | -- 9 | -- NB: I'm not completely happy with how this has turned out, but I think it's a pretty decent 10 | -- approximation of what a decent approach might look like. I'm declaring partial victory on it for 11 | -- the time being, but I want to enumerate several concerns here as a guide for the axe-wielding 12 | -- successor, who will probably still be me. 13 | -- 14 | -- * This whole file is just too shaggy. It's possible it could be made more palatable by making 15 | -- the idea of a "'Directive' Parser" a real thing. 16 | -- 17 | -- * Everything here is too file-oriented. It should be easier to use this functionality 18 | -- programmatically, rather than by reading files off disk all the time. 19 | -- 20 | -- * There's something irksomely untidy about simultaneously allowing rules and directives to 21 | -- coexist in a file and yet more or less ignoring the rules that appear in "test files", so to 22 | -- speak. 23 | -- 24 | -- * Something isn't quite right about the whole 'TestResults' and 'putTestResults' stack. 25 | -- 26 | -- * We don't aggregate test results---would be nice to do percentages and make it more obvious 27 | -- when one amongst a large pile of tests has failed for better UX. 28 | -- 29 | -- * Trying this out has convinced me that we need negative tests as well (i.e., "this query 30 | -- fails"). 31 | -- 32 | -- * Trying this out has also convinced me that writing new databases to realize minor variants in 33 | -- query behavior is excessively laborious. A solution /might/ look like a collection of 34 | -- operations on databases (union, intersection, filter, cons, whatever). But it might be 35 | -- something completely different that I haven't thought of yet. 36 | -- 37 | -- * Every test framework should have @xfail@. It should be a SMOP to add it here, but I'm still 38 | -- ashamed to have left it off as of yet. 39 | 40 | module Language.Avaleryar.Testing 41 | ( Test(..) 42 | , TestCase(..) 43 | , TestDb 44 | , TestResult 45 | , TestResults 46 | , parseTestFile 47 | , runTestFile 48 | , withTestHandle 49 | , withTestHandle_ 50 | , prettyTestResults 51 | , putTestResults 52 | ) where 53 | 54 | import Data.Bool (bool) 55 | import Data.Foldable (for_, toList) 56 | import qualified Data.Map as Map 57 | import Data.Text (Text, splitOn) 58 | import Data.Void (vacuous) 59 | import Text.PrettyPrint.Leijen.Text hiding (bool, (<$>)) 60 | 61 | import Language.Avaleryar.PDP (PDPConfig(..), PDPError) 62 | import Language.Avaleryar.PDP.Handle 63 | import Language.Avaleryar.Semantics 64 | import Language.Avaleryar.Syntax 65 | import Language.Avaleryar.Parser (parseFile') 66 | 67 | 68 | data TestCase = TestCase 69 | { testName :: Text 70 | , testAssns :: [(Text, Text)] 71 | , testQueries :: [Query] 72 | } deriving (Eq, Ord, Show) 73 | 74 | data Test = Test 75 | { testCase :: TestCase 76 | , testDb :: TestDb 77 | } 78 | 79 | type TestDb = ([(Text, [Rule RawVar])], NativeDb) 80 | 81 | parseTestAssertion :: Term a -> Maybe (Text, Text) 82 | parseTestAssertion t = fromTerm t >>= go . splitOn "=" 83 | where go [assn] = Just (assn, assn) 84 | go [alias, assn] = Just (alias, assn) 85 | go _ = Nothing 86 | 87 | parseTestCase :: Directive -> Maybe TestCase 88 | parseTestCase (Directive (Lit (Pred "test" _) (tn:dbs)) tqs) = do 89 | let testQueries = vacuous <$> tqs 90 | testName <- fromTerm tn 91 | testAssns <- traverse parseTestAssertion dbs 92 | pure TestCase {..} 93 | parseTestCase _ = Nothing 94 | 95 | parseDb :: (Text, Text) -> Directive -> Maybe TestDb 96 | parseDb (alias, assn) (Directive (Lit (Pred "db" _) [Val (T dbn)]) fs) | assn == dbn = 97 | Just ([(alias, fmap factToRule fs)], mempty) 98 | parseDb (alias, assn) (Directive (Lit (Pred "native" _) [Val (T dbn)]) fs) | assn == dbn = 99 | Just (mempty, mkNativeDb alias $ factsToNative fs) 100 | parseDb _ _ = Nothing 101 | 102 | -- Have to group up all the facts to pass to 'compilePred' or else they won't succeed more than once 103 | -- (i.e., @native(stuff) may(read), may(write).@ can't succeed on both @may@s without this annoying 104 | -- grouping pass. 105 | -- 106 | -- TODO: The fake mode might be too strong, in which case we'd need some other plan? 107 | factsToNative :: [Fact] -> [NativePred] 108 | factsToNative fs = [NativePred (compilePred rs) (modeFor p) | (p, rs) <- Map.toList preds] 109 | where preds = Map.fromListWith (<>) [(p, [factToRule f]) | f@(Lit p _) <- fs] 110 | modeFor p@(Pred _ n) = Lit p (replicate n (Var outMode)) 111 | 112 | dbForTestCase :: [Directive] -> TestCase -> TestDb 113 | dbForTestCase dirs TestCase {..} = foldMap go testAssns 114 | where go p = maybe mempty id $ foldMap (parseDb p) dirs 115 | 116 | -- | Find assertions used by the 'Test' that aren't available in its 'TestDb'. 117 | -- 118 | -- FIXME: The implementation is pretty terrible and non-intuitive---we have to invert the aliasing 119 | -- we did in 'parseDb' to find the names of the missing assertions. I think it may still be a tad 120 | -- busted, but I'm moving on for now. 121 | missingAssertions :: Test -> [Text] 122 | missingAssertions (Test tc (rs, ndb)) = unalias . filter (`notElem` assns) $ (fst <$> testAssns tc) 123 | where assns = fmap fst rs <> (Map.keys . unNativeDb $ ndb) 124 | unalias = foldMap (toList . flip lookup (testAssns tc)) 125 | 126 | -- TODO: Pretty output for test results. 127 | data TestResult = Pass | Fail | Error PDPError 128 | deriving (Eq, Ord, Show) 129 | 130 | data TestError = MissingAssertions [Text] 131 | deriving (Eq, Ord, Show) 132 | 133 | type TestResults = Either TestError [(Query, TestResult)] 134 | 135 | instance Pretty TestResult where 136 | pretty Pass = "ok" 137 | pretty Fail = "fail" 138 | pretty (Error e) = pretty $ show e -- TODO: Suck Less 139 | 140 | instance Pretty TestError where 141 | pretty (MissingAssertions as) = "assertions missing: " <> (hsep . punctuate "," $ fmap pretty as) 142 | 143 | prettyTestResults :: Text -> TestResults -> Doc 144 | prettyTestResults tn rs = pretty tn <> nest 2 prs 145 | where prs = either pretty ((line<>) . vsep . fmap pr) $ rs 146 | pr (q, r) = fillBreak 30 (pretty q <> colon) <+> pretty r 147 | 148 | putTestResults :: Text -> TestResults -> IO () 149 | putTestResults tn rs = putDoc $ prettyTestResults tn rs <> line 150 | 151 | runTest :: PDPHandle -> Test -> IO TestResults 152 | runTest hdl t = go (missingAssertions t) 153 | where app = appAssertion t 154 | go [] = fmap Right . traverse (runTestQuery' hdl app) . testQueries . testCase $ t 155 | go as = pure . Left . MissingAssertions $ as 156 | 157 | runTestQuery :: PDPHandle -> [Fact] -> Query -> IO TestResult 158 | runTestQuery hdl app (Lit (Pred p _) as) = resultify <$> checkQuery hdl app p as 159 | where resultify = either Error (bool Fail Pass) 160 | 161 | runTestQuery' :: PDPHandle -> [Fact] -> Query -> IO (Query, TestResult) 162 | runTestQuery' hdl app q = (q,) <$> runTestQuery hdl app q 163 | 164 | -- | Sneakily smash the given DB of native assertions over the entries in the 'PDPConfig'. This 165 | -- leans on the whole left-biased map-union thing to let the tests using this override whatever was 166 | -- there before, when it can. 167 | insinuateNativeDb :: NativeDb -> PDPConfig -> PDPConfig 168 | insinuateNativeDb ndb conf@PDPConfig {..} = conf {nativeAssertions = ndb `go` nativeAssertions} 169 | where go (NativeDb n) (NativeDb nas) = NativeDb $ Map.unionWith (<>) n nas 170 | 171 | -- Remember the callback is for adding more assertions. 172 | withTestHandle :: PDPConfig -> (PDPHandle -> IO a) -> Test -> IO (TestResults, a) 173 | withTestHandle conf k t@(Test _ (assns, ndb)) = do 174 | hdl <- newHandle $ insinuateNativeDb ndb conf 175 | for_ assns $ uncurry (unsafeSubmitAssertion hdl) 176 | a <- k hdl 177 | results <- runTest hdl t 178 | pure (results, a) 179 | 180 | withTestHandle_ :: PDPConfig -> (PDPHandle -> IO ()) -> Test -> IO TestResults 181 | withTestHandle_ p k t = fst <$> withTestHandle p k t 182 | 183 | extractTests :: [Directive] -> [Test] 184 | extractTests dirs = go <$> cases 185 | where cases = foldMap (toList . parseTestCase) dirs 186 | go tc = Test tc $ dbForTestCase dirs tc 187 | 188 | -- | Turn a 'Rule' that's really a fact into a 'Fact' in fact. Hideously unsafe if you don't 189 | -- already know for sure it'll succeed. This function really shouldn't escape this module. 190 | ruleToFact :: Rule v -> Fact 191 | ruleToFact (Rule hd []) = fmap go hd 192 | where go _ = error "variable in rule coerced to fact---absurdity!" 193 | ruleToFact _ = error "body lits in rule coerced to fact---insanity!" 194 | 195 | -- | Construct an @application@ assertion to provide along with the test queries by picking the 196 | -- first assertion in the 'testDb' with the name (or, well alias) @application@. 197 | appAssertion :: Test -> [Fact] 198 | appAssertion = fmap ruleToFact . concat . lookup "application" . fst . testDb 199 | 200 | parseTestFile :: FilePath -> IO (Either String [Test]) 201 | parseTestFile fp = fmap (extractTests . fst) <$> parseFile' fp 202 | 203 | runTestFile :: PDPConfig -> (PDPHandle -> IO ()) -> FilePath -> IO (Either String [(Text, TestResults)]) 204 | runTestFile conf k tf = do 205 | let gatherResults t@Test {..} = (testName testCase,) <$> withTestHandle_ conf k t 206 | parsed <- parseTestFile tf 207 | case parsed of 208 | Left err -> pure (Left err) 209 | Right ts -> Right <$> traverse gatherResults ts 210 | 211 | 212 | 213 | 214 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/PDP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | module Language.Avaleryar.PDP where 11 | 12 | import Control.DeepSeq (NFData) 13 | import Control.Exception (Exception) 14 | import Control.Monad.Except 15 | import Control.Monad.Reader 16 | import Control.Monad.State 17 | import Data.Bifunctor (first) 18 | import Data.Coerce 19 | import Data.List (stripPrefix) 20 | import Data.Map (Map) 21 | import Data.Text (Text, pack) 22 | import qualified Data.Text as T 23 | import Data.Typeable (Typeable) 24 | import GHC.Generics (Generic) 25 | import System.FilePath (stripExtension) 26 | import Text.PrettyPrint.Leijen.Text (Pretty(..), putDoc, squotes) 27 | 28 | import Language.Avaleryar.ModeCheck (ModeError, modeCheck) 29 | import Language.Avaleryar.Parser (parseFile, parseText, qry) 30 | import Language.Avaleryar.PrettyPrinter () 31 | import Language.Avaleryar.Semantics 32 | import Language.Avaleryar.Syntax 33 | 34 | 35 | data PDPConfig = PDPConfig 36 | { systemAssertion :: Map Pred (Lit EVar -> Avaleryar ()) -- ^ can't change system assertion at runtime 37 | , nativeAssertions :: NativeDb -- ^ Needs to be in the reader so changes induce a new mode-check on rules 38 | , submitQuery :: Maybe Query -- ^ for authorizing assertion submissions 39 | , maxDepth :: Int 40 | , maxAnswers :: Int 41 | } deriving Generic 42 | 43 | instance NFData PDPConfig 44 | 45 | newtype PDP a = PDP { unPDP :: ReaderT PDPConfig (ExceptT PDPError (StateT RulesDb IO)) a } 46 | deriving (Functor, Applicative, Monad, MonadIO, MonadError PDPError) 47 | 48 | data PDPError 49 | = ModeError ModeError 50 | | VarInQueryResults TextVar 51 | | ParseError String 52 | | SubmitError SubmitError 53 | deriving (Eq, Ord, Read, Show, Typeable) 54 | 55 | instance Exception PDPError 56 | 57 | instance Pretty PDPError where 58 | pretty (ModeError e) = pretty e 59 | pretty (VarInQueryResults v) = "got variable " <> squotes (pretty v) <> " in query results" 60 | pretty (ParseError e) = pretty e 61 | pretty (SubmitError e) = pretty e 62 | 63 | data SubmitError 64 | = SubmissionDisabled 65 | | SubmissionDenied 66 | deriving (Eq, Ord, Read, Show) 67 | 68 | instance Pretty SubmitError where 69 | pretty SubmissionDisabled = "submission disabled" 70 | pretty SubmissionDenied = "submission denied" 71 | 72 | runPDP :: PDP a -> PDPConfig -> IO (Either PDPError a) 73 | runPDP (PDP ma) = flip evalStateT mempty . runExceptT . runReaderT ma 74 | 75 | runPDP' :: PDP a -> PDPConfig -> IO a 76 | runPDP' pdp conf = runPDP pdp conf >>= either (error . show) pure 77 | 78 | runAva :: Avaleryar a -> PDP (AvaResults a) 79 | runAva = runAvaWith id 80 | 81 | -- | Run an 'Avaleryar' computation inside a 'PDP', configured according to the latter's 82 | -- 'PDPConfig'. The caller is given an opportunity to muck with the 'RulesDb' with which the 83 | -- subcomputation is run. This is used by 'runQuery' to add the @application@ assertion from the 84 | -- query just before executation. 85 | -- 86 | -- NB: The system assertion from the config is added to the the rule database after the caller's 87 | -- mucking function has done its business to ensure that the caller can't sneakily override the 88 | -- @system@ assertion with their own. 89 | runAvaWith :: (RulesDb -> RulesDb) -> Avaleryar a -> PDP (AvaResults a) 90 | runAvaWith f ma = avaResults <$> runDetailedWith f ma 91 | 92 | runDetailedWith :: (RulesDb -> RulesDb) -> Avaleryar a -> PDP (DetailedResults a) 93 | runDetailedWith f ma = do 94 | PDPConfig {..} <- askConfig 95 | -- do 'f' *before* inserting the system assertion, to make sure the caller can't override it! 96 | rdb <- insertRuleAssertion "system" systemAssertion . f <$> getRulesDb 97 | liftIO $ runAvaleryar' maxDepth maxAnswers (Db (f rdb) nativeAssertions) ma 98 | -- is this exactly what I just said not to do ^ ? 99 | 100 | checkRules :: [Rule RawVar] -> PDP () 101 | checkRules rules = do 102 | nm <- asksConfig (fmap (fmap nativeSig) . unNativeDb . nativeAssertions) -- TODO: Suck less 103 | either (throwError . ModeError) pure $ modeCheck nm rules 104 | 105 | checkSubmit :: [Fact] -> PDP () 106 | checkSubmit facts = asksConfig submitQuery >>= \case 107 | Nothing -> throwError $ SubmitError SubmissionDisabled 108 | Just q -> do 109 | answers <- runQuery' facts q 110 | when (null answers) $ throwError (SubmitError SubmissionDenied) 111 | 112 | submitAssertion :: Text -> [Rule RawVar] -> [Fact] -> PDP () 113 | submitAssertion assn rules facts = checkSubmit facts >> unsafeSubmitAssertion assn rules 114 | 115 | submitText :: Text -> Text -> [Fact] -> PDP () 116 | submitText assn text facts = checkSubmit facts >> unsafeSubmitText assn text 117 | 118 | submitFile :: Maybe String -> FilePath -> [Fact] -> PDP () 119 | submitFile assn path facts = checkSubmit facts >> unsafeSubmitFile assn path 120 | 121 | -- | unsafe because there's no authz on the submission 122 | unsafeSubmitAssertion :: Text -> [Rule RawVar] -> PDP () 123 | unsafeSubmitAssertion assn rules = do 124 | checkRules rules 125 | modifyRulesDb $ insertRuleAssertion assn (compileRules assn $ fmap (fmap unRawVar) rules) 126 | 127 | 128 | -- | TODO: ergonomics, protect "system", etc. 129 | unsafeSubmitFile :: Maybe String -> FilePath -> PDP () 130 | unsafeSubmitFile assn path = do 131 | rules <- liftIO $ parseFile path 132 | unsafeSubmitAssertion (pack $ maybe (stripDotAva path) id assn) =<< either (throwError . ParseError) (pure . coerce) rules 133 | 134 | unsafeSubmitText :: Text -> Text -> PDP () 135 | unsafeSubmitText assn text = unsafeSubmitAssertion assn =<< either (throwError . ParseError) (pure . coerce) rules 136 | where rules = parseText assn text 137 | 138 | retractAssertion :: Text -> PDP () 139 | retractAssertion = modifyRulesDb . retractRuleAssertion 140 | 141 | runDetailedQuery :: [Fact] -> Text -> [Term TextVar] -> PDP DetailedQueryResults 142 | runDetailedQuery facts p args = do 143 | answers <- runDetailedWith (insertApplicationAssertion facts) $ compileQuery "system" p args 144 | flip traverse answers $ \l -> do 145 | traverse (throwError . VarInQueryResults . unEVar) l 146 | 147 | runQuery :: [Fact] -> Text -> [Term TextVar] -> PDP QueryResults 148 | runQuery facts p args = do 149 | answers <- runAvaWith (insertApplicationAssertion facts) $ compileQuery "system" p args 150 | flip traverse answers $ \l -> do 151 | traverse (throwError . VarInQueryResults . unEVar) l 152 | 153 | runQuery' :: [Fact] -> Query -> PDP QueryResults 154 | runQuery' facts (Lit (Pred p _) as) = runQuery facts p as 155 | 156 | queryPretty :: [Fact] -> Text -> [Term TextVar] -> PDP () 157 | queryPretty facts p args = do 158 | answers <- runQuery facts p args 159 | liftIO $ mapM_ (putDoc . pretty . factToRule @TextVar) answers 160 | 161 | testQuery :: [Fact] -> Query -> PDP () 162 | testQuery facts (Lit (Pred p _) as) = queryPretty facts p as 163 | 164 | -- | Insert an @application@ assertion into a 'RulesDb' providing the given facts. 165 | insertApplicationAssertion :: [Fact] -> RulesDb -> RulesDb 166 | insertApplicationAssertion = insertRuleAssertion "application" . compileRules "application" . fmap factToRule 167 | 168 | nativeModes :: NativeDb -> Map Text (Map Pred ModedLit) 169 | nativeModes = fmap (fmap nativeSig) . unNativeDb 170 | 171 | stripDotAva :: FilePath -> FilePath 172 | stripDotAva path = maybe path id $ stripExtension "ava" path 173 | 174 | stripPathPrefix :: String -> FilePath -> FilePath 175 | stripPathPrefix pfx path = maybe path id $ stripPrefix pfx path 176 | 177 | -- NB: The given file is parsed as the @system@ assertion regardless of its filename, which is 178 | -- almost guaranteed to be what you want. 179 | pdpConfig :: NativeDb -> FilePath -> IO (Either PDPError PDPConfig) 180 | pdpConfig db fp = runExceptT $ do 181 | sys <- ExceptT . liftIO . fmap (first ParseError . coerce) $ parseFile fp 182 | ExceptT . pure . first ModeError $ modeCheck (nativeModes db) sys 183 | pure $ PDPConfig (compileRules "system" $ fmap (fmap unRawVar) sys) db Nothing 50 10 184 | 185 | pdpConfigText :: NativeDb -> Text -> Either PDPError PDPConfig 186 | pdpConfigText db text = do 187 | sys <- first ParseError . coerce $ parseText "system" text 188 | first ModeError $ modeCheck (nativeModes db) sys 189 | pure $ PDPConfig (compileRules "system" $ fmap (fmap unRawVar) sys) db Nothing 50 10 190 | 191 | pdpConfigRules :: NativeDb -> [Rule RawVar] -> Either PDPError PDPConfig 192 | pdpConfigRules db sys = do 193 | first ModeError $ modeCheck (nativeModes db) sys 194 | pure $ PDPConfig (compileRules "system" $ fmap (fmap unRawVar) sys) db Nothing 50 10 195 | 196 | 197 | demoNativeDb :: NativeDb 198 | demoNativeDb = mkNativeDb "base" preds 199 | where preds = [ mkNativePred "not=" $ (/=) @Value 200 | , mkNativePred "even" $ even @Int 201 | , mkNativePred "odd" $ odd @Int 202 | , mkNativePred "rev" $ Solely . T.reverse 203 | , mkNativePred "cat" $ fmap (Solely . pack) . readFile . T.unpack 204 | , mkNativePred "lines" $ fmap Solely . T.lines] 205 | 206 | demoConfig :: IO (Either PDPError PDPConfig) 207 | demoConfig = fmap addSubmit <$> pdpConfig demoNativeDb "system.ava" 208 | where addSubmit conf = conf { submitQuery = Just [qry| may(submit) |]} 209 | 210 | -- Everyone: Alec, why not just use lenses? 211 | -- Me: ... what's that over there!? ... ::smokebomb:: 212 | 213 | asksConfig :: (PDPConfig -> a) -> PDP a 214 | asksConfig f = PDP $ asks f 215 | 216 | askConfig :: PDP PDPConfig 217 | askConfig = asksConfig id 218 | 219 | getsRulesDb :: (RulesDb -> a) -> PDP a 220 | getsRulesDb f = PDP $ gets f 221 | 222 | getRulesDb :: PDP RulesDb 223 | getRulesDb = getsRulesDb id 224 | 225 | modifyRulesDb :: (RulesDb -> RulesDb) -> PDP () 226 | modifyRulesDb f = PDP $ modify f 227 | 228 | putRulesDb :: RulesDb -> PDP () 229 | putRulesDb ndb = modifyRulesDb (const ndb) 230 | 231 | withMaxDepth :: Int -> PDP a -> PDP a 232 | withMaxDepth n = PDP . local go . unPDP 233 | where go conf = conf {maxDepth = n} 234 | 235 | withMaxAnswers :: Int -> PDP a -> PDP a 236 | withMaxAnswers n = PDP . local go . unPDP 237 | where go conf = conf {maxAnswers = n} 238 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeSynonymInstances #-} 14 | 15 | {-| 16 | 17 | @ 18 | may(?access) :- 19 | application says key(?key), 20 | hr says user-key(?user, ?key), 21 | :ldap says user-group(?user, ?group), 22 | ?group says user-status(?user, active), 23 | known-access(?access). 24 | @ 25 | 26 | This code represents a 'Rule'. It shows a way in which the 'Lit'eral identified by the 'Pred'icate 27 | @may/2@ can be proven by satisfying every body literal in the rule. Each 'BodyLit' comes from an 28 | "assertion", which is a collection of rules. The assertion from which a rule comes is referenced by 29 | the 'ARef' which appears immediately to the left of @says@, as in @hr says user-key(?user, ?key)@. 30 | An assertion reference may be any 'Term' (a 'Value' or a variable), or it may be a "native" 31 | assertion, which is prefixed with a colon (as in @:ldap says user-group(?user, ?group)@). Because 32 | all rules exist in an assertion, the omitted @... says@ on the last line is implicitly understood to 33 | be @current-assertion says known-access(?access)@ (where @current-assertion@ stands for the actual 34 | name of the assertion in which @may\/1@ is defined). In brief: 35 | 36 | * @?user@: Variable (we're polymorphic in variables, there are several different kinds) 37 | * @active@: 'Value' 38 | * @user-status(?user, active)@: 'Lit' 39 | * @?group says@: 'ARef' 40 | * @?group says user-status(?user,active)@: 'BodyLit' 41 | * @user-status/2@: 'Pred' 42 | 43 | -} 44 | 45 | 46 | module Language.Avaleryar.Syntax where 47 | 48 | import Control.DeepSeq (NFData) 49 | import Data.Char (isSpace) 50 | import Data.Function (on) 51 | import Data.Functor.Const (Const(..)) 52 | import Data.Hashable (Hashable(hashWithSalt)) 53 | import Data.Map (Map) 54 | import Data.String 55 | import Data.Text (Text) 56 | import qualified Data.Text as T 57 | import Data.Void 58 | import GHC.Generics (Generic) 59 | import Text.Megaparsec (SourcePos(..), pos1, unPos) 60 | import Text.PrettyPrint.Leijen.Text 61 | (Doc, Pretty(..), brackets, colon, dot, empty, group, hsep, line, nest, parens, punctuate, space, vsep) 62 | 63 | data Value 64 | = I Int 65 | | T Text 66 | | B Bool 67 | deriving (Eq, Ord, Read, Show, Generic) 68 | 69 | instance NFData Value 70 | instance Hashable Value 71 | 72 | instance IsString Value where 73 | fromString = T . fromString 74 | 75 | instance Pretty Value where 76 | pretty (I n) = pretty n 77 | pretty (B b) = if b then "#t" else "#f" 78 | pretty (T t) = if T.any isSpace t 79 | then pretty (show t) -- want the quotes/escaping 80 | else pretty t -- display as a symbol 81 | 82 | -- | A predicate is identified by its name and arity (i.e., the predicate of the literal @foo(bar, ?baz)@ is @foo/2@) 83 | data Pred = Pred Text Int deriving (Eq, Ord, Read, Show, Generic) 84 | 85 | instance NFData Pred 86 | instance Hashable Pred 87 | 88 | instance Pretty Pred where 89 | pretty (Pred p n) = pretty p <> "/" <> pretty n 90 | 91 | -- | A term is either a 'Value' or a variable. Terms are polymorphic in the variable type to 92 | -- provide a bit of safety by keeping us from crossing various streams (e.g., separating runtime 93 | -- unification variables from raw variables straight out of the parser helps avoid a bit of unwanted 94 | -- variable capture). 95 | data Term v = Val Value | Var v deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) 96 | 97 | instance NFData v => NFData (Term v) 98 | instance Hashable v => Hashable (Term v) 99 | 100 | instance Pretty v => Pretty (Term v) where 101 | pretty (Var v) = "?" <> pretty v 102 | pretty (Val c) = pretty c 103 | 104 | -- | A literal is identified by a 'Pred' and a list of 'Term's, where the arity in the 'Pred' is the 105 | -- same as the length of the list of 'Term's in the argument list. 106 | data Lit v = Lit Pred [Term v] deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) 107 | 108 | instance NFData v => NFData (Lit v) 109 | instance Hashable v => Hashable (Lit v) 110 | 111 | instance Pretty v => Pretty (Lit v) where 112 | pretty (Lit (Pred p _) as) = pretty p <> parens (hsep . punctuate "," $ fmap pretty as) 113 | 114 | -- | Convenience constructor for 'Lit's. 115 | lit :: Text -> [Term v] -> Lit v 116 | lit pn as = Lit (Pred pn (length as)) as 117 | 118 | -- | A reference to an assertion may either statically denote a native assertion or appear as a 119 | -- 'Term'. 120 | data ARef v = ARNative Text | ARTerm (Term v) | ARCurrent deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) 121 | 122 | instance NFData v => NFData (ARef v) 123 | instance Hashable v => Hashable (ARef v) 124 | 125 | instance Pretty v => Pretty (ARef v) where 126 | pretty (ARTerm t) = pretty t 127 | pretty (ARNative n) = colon <> pretty n 128 | pretty ARCurrent = mempty 129 | 130 | prettyAssertion :: Value -> [Pred] -> Doc 131 | prettyAssertion assn ps = pretty assn 132 | <> ": " 133 | <> group (nest 2 (line <> (vsep . fmap pretty $ ps))) 134 | 135 | -- | A 'Lit'eral appearing in the body of a 'Rule' is always qualified by an 'ARef' to an assertion. 136 | -- When no assertion appears in the concrete syntax, the parser inserts a reference to the assertion 137 | -- currently being parsed. 138 | data BodyLit v = Says (ARef v) (Lit v) 139 | deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) 140 | 141 | instance NFData v => NFData (BodyLit v) 142 | instance Hashable v => Hashable (BodyLit v) 143 | 144 | instance Pretty v => Pretty (BodyLit v) where 145 | pretty (aref `Says` l) = pretty aref <> space <> "says" <> space <> pretty l 146 | 147 | -- | A rule has a head and a body made of 'BodyLit's. 148 | data Rule v = Rule (Lit v) [BodyLit v] 149 | deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) 150 | 151 | instance NFData v => NFData (Rule v) 152 | instance Hashable v => Hashable (Rule v) 153 | 154 | instance Pretty v => Pretty (Rule v) where 155 | pretty (Rule hd body) = pretty hd <> bodyDoc body <> dot <> line 156 | where bodyDoc [] = empty 157 | bodyDoc _ = space <> ":-" 158 | <> group (nest 2 (line <> (vsep . punctuate "," $ fmap pretty body))) 159 | 160 | -- | Facts can be thought of as rules with no variables in the head and no body. Instead, we 161 | -- represent them as 'Lit's with variables of type 'Void' to ensure they are facts by construction. 162 | type Fact = Lit Void 163 | 164 | -- | Convenience constructor for 'Fact's. Works directly on 'Valuable's because the whole point is 165 | -- that there aren't any variables amongst the arguments. 166 | fact :: Valuable v => Text -> [v] -> Fact 167 | fact pn = lit pn . fmap val 168 | 169 | -- | 'Fact's are vacuously 'Rule's. 170 | factToRule :: Fact -> Rule v 171 | factToRule fct = Rule (vacuous fct) [] 172 | 173 | -- | 'Directive's provide a side-channel for metadata to pass from assertion authors into an 174 | -- implementation. They're intended to be extracted at parse time, and are /never/ considered 175 | -- during evaluation. However, an intermediate processor might use information from a directive to 176 | -- manipulate code /before/ it's loaded into the system and evaluated. The motivating use cases for 177 | -- directives are to declare test-suites and (eventually) mode declarations. 178 | data Directive = Directive Fact [Fact] deriving (Eq, Ord, Show, Generic) 179 | 180 | instance NFData Directive 181 | instance Hashable Directive 182 | 183 | -- TODO: Pretty this up. 184 | instance Pretty Directive where 185 | pretty (Directive f fs) = ":- " <> pretty (vacuous @_ @TextVar f) 186 | <> group (nest 2 (line <> (vsep . fmap (pretty . vacuous @_ @TextVar) $ fs))) 187 | <> dot 188 | 189 | -- | To ensure freshness, tag runtime variables ('EVar's) with the current value of an 'Epoch' 190 | -- counter which we bump every time we allocate a new variable. 191 | newtype Epoch = Epoch { getEpoch :: Int } 192 | deriving (Eq, Ord, Read, Show, Num, Enum, Generic, NFData, Hashable) 193 | 194 | -- | TODO: This should probably become a newtype 195 | type TextVar = Text 196 | 197 | type Query = Lit TextVar 198 | 199 | -- | Convenience constructor for 'Query's. 200 | query :: Text -> [Term TextVar] -> Query 201 | query = lit 202 | 203 | -- | At runtime, we unify on variables tagged with an 'Epoch' to help avoid undesirable variable capture. 204 | data EVar = EVar Epoch TextVar deriving (Eq, Ord, Read, Show, Generic) 205 | 206 | instance NFData EVar 207 | instance Hashable EVar 208 | 209 | instance Pretty EVar where 210 | pretty (EVar (Epoch e) v) = pretty v <> brackets (pretty e) 211 | 212 | -- | Extract the 'TextVar' portion of an 'EVar'. 213 | unEVar :: EVar -> TextVar 214 | unEVar (EVar _ v) = v 215 | 216 | -- | Raw variables are produced by the parser. 217 | data RawVar = RawVar { unRawVar :: Text, rawLoc :: SourcePos } 218 | deriving (Read, Show, Generic) 219 | 220 | instance NFData RawVar 221 | 222 | instance Eq RawVar where 223 | (==) = (==) `on` unRawVar 224 | 225 | instance Ord RawVar where 226 | compare = compare `on` unRawVar 227 | 228 | instance IsString RawVar where 229 | fromString s = RawVar (T.pack s) (SourcePos "fromString" pos1 pos1) 230 | 231 | instance Pretty RawVar where 232 | pretty = pretty . unRawVar 233 | 234 | -- There's no 'Hashable' instance for 'SourcePos'. 235 | instance Hashable RawVar where 236 | hashWithSalt salt (RawVar v (SourcePos {..})) = 237 | salt 238 | `hashWithSalt` v 239 | `hashWithSalt` sourceName 240 | `hashWithSalt` unPos sourceLine 241 | `hashWithSalt` unPos sourceColumn 242 | 243 | 244 | -- | The runtime substitution. 245 | type Env = Map EVar (Term EVar) 246 | 247 | -- | When satisfying a predicate, a variable in its argument may be used in "input mode", meaning 248 | -- that the predicate expects it to be bound /before/ we attempt to satisfy it, or "output mode", 249 | -- where it is the responsibility of the predicate to bind the variable to a value if it succeeds. 250 | data Mode v = In v | Out v 251 | deriving (Eq, Ord, Read, Show, Generic) 252 | 253 | instance NFData v => NFData (Mode v) 254 | instance Hashable v => Hashable (Mode v) 255 | 256 | type ModedLit = Lit (Mode RawVar) 257 | 258 | -- | Some types may be interpreted as a 'Value'. 259 | class Valuable a where 260 | toValue :: a -> Value 261 | fromValue :: Value -> Maybe a 262 | 263 | instance Valuable Value where 264 | toValue = id 265 | fromValue = Just 266 | 267 | instance Valuable Text where 268 | toValue = T 269 | fromValue (T a) = Just a 270 | fromValue _ = Nothing 271 | 272 | instance Valuable Int where 273 | toValue = I 274 | fromValue (I a) = Just a 275 | fromValue _ = Nothing 276 | 277 | instance Valuable Bool where 278 | toValue = B 279 | fromValue (B a) = Just a 280 | fromValue _ = Nothing 281 | 282 | deriving instance Valuable a => Valuable (Const a (b :: k)) 283 | 284 | fromTerm :: Valuable a => Term v -> Maybe a 285 | fromTerm (Val x) = fromValue x 286 | fromTerm _ = Nothing 287 | 288 | -- | Construct a 'Term' from anything 'Valuable'. 289 | val :: Valuable a => a -> Term v 290 | val = Val . toValue 291 | 292 | -- | Some types may be interprected as a 'Fact'. 293 | class Factual a where 294 | toFact :: a -> Fact 295 | 296 | instance Factual Fact where 297 | toFact = id 298 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Avaleryar 2 | 3 | An implementation of [Soutei][soutei-paper]. 4 | 5 | Not yet fit for human consumption. 6 | 7 | > It's easier to ask forgiveness than it is to get permission. --Rear Admiral Grace Murray Hopper 8 | 9 | ## Overview 10 | 11 | Avaleryar is an implementation of [Pimlott and Kiselyov's Soutei][soutei-paper] trust-management 12 | system, comprising 13 | 14 | * A [Datalog](https://en.wikipedia.org/wiki/Datalog)-like rule language for describing authorization 15 | policies (including the evaluator, parser, and a pretty-printer). 16 | * Convenient library support for extending the policy language with application-specific predicates. 17 | * A REPL for exploring and debugging policies. 18 | * An integrated unit-testing system. (NB: It's pretty bad; we intend to improve it someday). 19 | 20 | We have more improvements planned for the future, which you can read about 21 | [below](#planned-improvements). 22 | 23 | ## A Quick Example 24 | 25 | Soutei is an extremely flexible system, capable of expressing various styles of authorization 26 | policies (RBAC, ABAC, other acronyms that end in -BAC). For this introductory example, we'll write 27 | a simple policy for a hypothetical blogging platform. When a user attempts to take an action, the 28 | platform will consult the policy to advise it whether or not to allow the operation to proceed. 29 | Here's an informal version of our policy, in English: 30 | 31 | * Anyone may read a post that's been published 32 | * Anyone who is allowed to edit a post may read it 33 | * The author of a post may edit and publish it 34 | * The owner of a blog may create new posts 35 | * A user may leave a comment on a post if they're permitted to read it, and are friends with the 36 | post's author. 37 | 38 | ```prolog 39 | ;; Anyone may read a post that's been published 40 | may(read) :- 41 | application says status(published). 42 | 43 | ;; Anyone who is allowed to edit a post may read it 44 | may(read) :- 45 | may(edit). 46 | 47 | ;; The author of a post may edit it... 48 | may(edit) :- 49 | application says user(?user), 50 | application says author(?user). 51 | 52 | ;; ...and publish it 53 | may(publish) :- 54 | application says user(?user), 55 | application says author(?user). 56 | 57 | ;; The owner of a blog may create new posts 58 | may(create) :- 59 | application says user(?user), 60 | application says blog-owner(?user). 61 | 62 | ;; A user may leave a comment on a post if they're permitted to read it, and are friends with the 63 | ;; post's author. 64 | may(comment) :- 65 | may(read), 66 | application says user(?user), 67 | application says author(?author), 68 | ?author says friend(?user). 69 | ``` 70 | 71 | What we have is a collection of _rules_ describing the circumstances under which a particular action 72 | should be permitted. When our blog application wants to know whether a request is authorized, it 73 | will ask Soutei. Soutei will then try to prove that the rules permit the access somehow, and let 74 | the application know if it succeeded. We'll discuss this syntax in detail below. Briefly, though, 75 | you can decode, say, the third rule (the author of a post may edit and publish it) like this: 76 | "`edit` is permitted when the application tells us there's a user (denoted by the _variable_ 77 | `?user`) associated with the request, and the application tells us that that user is identically the 78 | author of the post". Observe that `:-` (which I'll pronounce "when") is like an implication in 79 | logic. The second rule (if you're allowed to edit you're allowed to read) is just saying that 80 | `edit` implies `read` (or, since the implication goes right-to-left, perhaps "`read` is implied by 81 | `edit`" would be better). 82 | 83 | Don't worry if this is still confusing. The example demonstrates several different features of the 84 | system. Nonetheless, I hope you agree it's a relatively compact and clean description of a 85 | not-completely-trivial authorization policy. 86 | 87 | ## Using Soutei for Authorization 88 | 89 | Architecturally, Soutei provides support for implementing a so-called "policy decision point". Its 90 | job is to advise an application on whether it should permit a request by determining if it complies 91 | with its security policy. It does _not_ provide policy _enforcement_. This is to say, you ask 92 | whether to allow access, and you get an answer, but it's still up to you to send the 403 back to the 93 | client if that answer was "no". 94 | 95 | To make use of the policy engine, you formulate a query and send it along. For instance, when 96 | implementing the commenting system for your blog platform, you might ask Soutei `may(comment)` (this 97 | is concrete syntax, in practice you'll assemble the query using library functions). Of course, 98 | whether commenting is permitted depends on information that Soutei doesn't have. In our example, 99 | that's at least the identity of the commenting user and the author of the post, and probably some 100 | more information necessary to deduce the ability to read the post. Soutei only knows about the 101 | rules you've given it, so where do these extra facts about this particular commenting operation come 102 | from? The application provides them as a parameter to the query. So in our example, the 103 | application might ask "is commenting permitted? (and by the way, the post has been published, the 104 | current user is `bob`, the author of the post is `alice`, and `alice` says `bob` is her friend, in 105 | case that helps you make your decision)". 106 | 107 | This may be a rather different style of access control than you're used to, and it requires a bit of 108 | a shift in perspective. 109 | 110 | TODO: Say more here. 111 | 112 | ## Syntax and Semantics 113 | 114 | Here's a rule about activities: 115 | 116 | ```prolog 117 | can(?activity) :- 118 | want-to(?activity). 119 | ``` 120 | 121 | It says that an activity is permitted (`can(?activity)`) when we want to do that activity 122 | (`want-to(?activity)`). We can see several features of the syntax in this small example. Rules 123 | have two parts (a **head** and a **body**), separated by the symbol `:-` (which I tend to pronounce 124 | "when"), and terminated with a period. The head of the rule is `can(?activity)`, and the body of 125 | the rule is `want-to(?activity)`. They use a function-call like notation (called a **literal**) to 126 | describe logical **predicates** (i.e., `can` and `want-to`). Predicates are usually denoted with 127 | their arity, so rather than writing `can`, we'd write `can/1`. If we had a predicate describing 128 | friendship between two people (`friend(alice, bob)`), we'd refer to it as `friend/2`. We can also 129 | see that **variables** are written with a prefix question-mark (`?activity`). 130 | 131 | If this rule were our entire policy, it would never permit us to do anything, because it has no way 132 | to establish what we `want-to/1` do. In general, determining our psyche's innermost desires can be 133 | complicated, and we could write a bunch of complicated rules to define `want-to/1`. But let's just 134 | assume we're blessed with unusual self awareness, and add a special kind of rule, called a **fact**, 135 | that will express our yearning: 136 | 137 | ```prolog 138 | can(?activity) :- 139 | want-to(?activity). 140 | 141 | ;; we can dance if we want to 142 | want-to(dance). 143 | ``` 144 | 145 | We can see that a fact is a rule without a body. We can also see that comments are introduced with 146 | semicolons and extend to the end of the line. This policy will now permit a query of the form 147 | `can(dance)`. Let's look at how that deduction works. We ask Soutei `can(dance)`, and it reasons: "I 148 | can prove `can(dance)` if, when `?activity` is `dance`, I can prove `want-to(dance)`. Oh! and I can 149 | prove `want-to(dance)` because I know that for fact!". 150 | 151 | Notice that `dance` isn't a variable, it's just a symbol. We could have written `want-to("dance")`, 152 | using double-quotes to delimit the string, but it's unnecessary (and un-idiomatic) when the string 153 | doesn't contain spaces or commas. 154 | 155 | Now suppose we want to say that we can dance if we want to, act if we want to, but sing under any 156 | circumstances? (This whole example will probably make more sense with a bit more 157 | [context](https://www.youtube.com/watch?v=AjPau5QYtYs)): 158 | 159 | ```prolog 160 | can(?activity) :- 161 | want-to(?activity). 162 | 163 | can(sing). 164 | 165 | ;; we can dance if we want to 166 | want-to(dance). 167 | 168 | ;; we can act if we want to 169 | want-to(act). 170 | ``` 171 | 172 | What `can/1` we do now? Well, we `can(dance)`, we `can(dance)`, we `can(sing)`, and we `can(act)`. 173 | This shows that we're able to express different ways to conclude that an action is permitted by 174 | writing multiple rules for the same predicate (remember that facts are rules without bodies). Rule 175 | bodies aren't limited to a single literal. Let's add an example: 176 | 177 | ```prolog 178 | can(?activity) :- 179 | want-to(?activity). 180 | 181 | can(sing). 182 | 183 | ;; we can dance if we want to 184 | want-to(dance). 185 | 186 | ;; we can act if we want to 187 | want-to(act). 188 | 189 | ;; we only want to go when the night is young, and so am I 190 | want-to(go) :- 191 | time-of(night, young), 192 | age-of(me, young). 193 | ``` 194 | 195 | We require every predicate in the body of a rule to succeed in order for the rule to succeed. So 196 | `want-to(go)` needs both `time-of(night, young)` and `age-of(me, young)` to be proven in order for 197 | this rule to prove that `want-to(go)`. Of course, what we have so far isn't enough to prove 198 | `can(go)` yet, because `age-of/2` and `time-of/2` aren't actually defined anywhere. This isn't 199 | considered an error; it simply means that an attempt to prove `want-to(go)` will fail. (As a 200 | reminder, there's no special meaning attached to `night`, `young` or `me`---they're just symbols I'm 201 | using to demonstrate the syntax). 202 | 203 | It may be occurring to you by now that these rules don't actually depend on anything---the assertion 204 | we're developing (a collection of rules like this is called an **assertion**---an assertion is kind 205 | of like a module or a namespace) will always prove exactly the same things. A rule may consult 206 | predicates in _other_ assertions than the one in which it's written. Let's hypothesize two new 207 | assertions, `clock` and `bio`, that contain chronological and biographical rules, respectively: 208 | 209 | ```prolog 210 | can(?activity) :- 211 | want-to(?activity). 212 | 213 | can(sing). 214 | 215 | ;; we can dance if we want to 216 | want-to(dance). 217 | 218 | ;; we can act if we want to 219 | want-to(act). 220 | 221 | ;; we only want to go when the night is young, and so am and I 222 | want-to(go) :- 223 | clock says time-of(night, young), 224 | bio says age-of(me, young). 225 | ``` 226 | 227 | We've changed the body of our `want-to(go)` rule by adding `clock says time-of(night, young)` and 228 | `bio says age-of(me, young)`. This tells Soutei to try and resolve `time-of/2` in the assertion 229 | named `clock` and `age-of/2` in the assertion named `bio`. By "resolve a predicate in an 230 | assertion", I mean that Soutei will load all the rules in that assertion, and continue trying to 231 | satisfy the predicate using the rules in _that_ assertion. Of course, if any rule in this new 232 | assertion has a body literal of the form `assertion says pred(...)`, then Soutei will load 233 | the rules in `assertion` and resolve `pred` there. 234 | 235 | Other than a short discussion about variable binding and another on so-called "native predicates", 236 | we've now looked (albeit briefly) at the entirety of the semantics of the language. I point that 237 | out because in order to continue our Safety Dance, we'll need to introduce a convention that 238 | `avaleryar` (following the original paper) imposes: the `application` assertion. Semantically, the 239 | `application` assertion is no different than any other. However, when `avaleryar` runs a query, it 240 | accepts a collection of facts as, effectively, parameters that are made available to our rules 241 | through the `application` assertion. (NB: I'm doing my best to distinguish Soutei-the-language from 242 | `avaleryar`-the-implementation-of-Soutei-the-language, I hope this isn't too confusing). So to 243 | demonstrate, let's write a needlessly complicated rule determining whether the dancing we can do is, 244 | properly a Safety Dance. 245 | 246 | ```prolog 247 | can(?activity) :- 248 | want-to(?activity). 249 | 250 | can(sing). 251 | 252 | ;; we can dance if we want to 253 | want-to(dance). 254 | 255 | ;; we can act if we want to 256 | want-to(act). 257 | 258 | ;; we only want to go when the night is young, and so am and I 259 | want-to(go) :- 260 | clock says time-of(night, young), 261 | bio says age-of(me, young). 262 | 263 | ;; we can overextend the efficacy a questionable pop-culture reference 264 | safety(?activity) :- 265 | can(?activity), 266 | application says out-of(control, everything), 267 | application says doing-it(from, pole), 268 | application says doing-it(to, pole), 269 | application says looking-at(hands, ?somebody), 270 | ?somebody says taking(the-chance). 271 | ``` 272 | 273 | This (completely inane, it's getting pretty late as I write this---the examples section below won't 274 | be this silly) new rule uses a bunch of information provided by the application querying for 275 | authorization advice (`application says ...`) in addition to some locally written rules 276 | (`can(?activity)`). It also uses an assertion _determined by the query_ (`?somebody says 277 | taking(the-chance)`) to ultimately establish that indeed, `safety(dance)`. The ability to 278 | dynamically choose different assertions in which to reason is a powerfully expressive feature of 279 | Soutei. 280 | 281 | TODO: unification and native predicates. 282 | 283 | TODO: why encoding "'Cause your friends don't dance, and if they don't dance, then they're no 284 | friends of mine" isn't (naively) possible. 285 | 286 | TODO: mode checking. 287 | 288 | TODO: monotonicity. 289 | 290 | ## Examples and Advice 291 | 292 | ### Example: Unix File Permissions 293 | 294 | Here is a simplified version of file permissions on Unix. We assume that the application will tell 295 | us what the file is, that there's an assertion named after the file that knows what permissions are 296 | set on it, who owns it, and which group it's associated with, as well as that each group has an 297 | assertion named after it that can tell us whether a user is a member of that group. For example, we 298 | might have an assertion for some file that looked like: 299 | 300 | ```prolog 301 | ;; assertion for /path/to/some/file 302 | 303 | owner(mary). 304 | group(wheel). 305 | perm(user, read). 306 | perm(user, write). 307 | perm(user, execute). 308 | perm(group, read). 309 | perm(group, execute). 310 | perm(other, read). 311 | ``` 312 | 313 | This would represent a file owned by `mary`, with group `wheel`, with permissions `754` (as in, 314 | `chmod 754 /path/to/some/file`). 315 | 316 | ```prolog 317 | ;; allow ?access when the user is the owner and ?access is enabled for them. 318 | ;; NB: The word "user" appears with three different meanings in this rule. The application fact 319 | ;; 'user/1', which indicates the user accessing the file, the variable '?user', which has that 320 | ;; user bound to it, and the symbol 'user' in 'perm(user, ?access)', which refers to user 321 | ;; permissions on a file in the sense of 'chmod u+x $FILE'. 322 | may(?access) :- 323 | application says file(?file), 324 | application says user(?user), 325 | ?file says owner(?user), 326 | ?file says perm(user, ?access). 327 | 328 | ;; allow ?access when it's enabled on the file, the file is associated with a group ?group, 329 | ;; and the user is a member of ?group. 330 | may(?access) :- 331 | application says file(?file), 332 | application says user(?user), 333 | ?file says group(?group), 334 | ?group says member(?user), 335 | ?file says perm(group, ?access). 336 | 337 | ;; allow ?access if it's enabled for all users ("other" permissions) 338 | may(?access) :- 339 | application says file(?file), 340 | ?file says perm(other, ?access). 341 | ``` 342 | 343 | Unix permissions are more sophisticated than this---for instance, if you have `read` access to a 344 | directory, you are permitted to see the _names_ of the files in that directory, but not other 345 | metadata (roughly, you're allowed to see the output of `ls`, but not `ls -l`) unless you also have 346 | `execute` permission on the directory as well. A more nuanced version of this policy would need to 347 | know what metadata is being sought by the application, and probably require some native predicates 348 | to compute the directory part of a file path. 349 | 350 | ### Example: Role-Based Access Control (RBAC) 351 | 352 | In RBAC, we have a discrete set of primitive _permissions_, a collection of named _roles_ each of 353 | which is a subset of the permissions, and an assignment of users to (possibly multiple) roles. To 354 | determine if a user is permitted to take some action, we check that the user has been assigned some 355 | role that contains the appropriate permission. 356 | 357 | ```prolog 358 | ;; permissions 359 | 360 | perm(manage-users). 361 | perm(manage-computers). 362 | perm(access-lab). 363 | perm(run-experiment). 364 | perm(create-experiment). 365 | perm(approve-experiment). 366 | 367 | ;; roles 368 | 369 | ; grad students get to do all the work 370 | role(grad-student, access-lab). 371 | role(grad-student, run-experiment). 372 | 373 | ; professors have at least the permissions of grad students, plus they can 374 | ; create experiments. 375 | role(professor, ?perm) :- 376 | role(grad-student, ?perm). 377 | role(professor, create-experiment). 378 | 379 | ; poison control should probably be allowed into the lab, just in case 380 | role(poison-control, access-lab). 381 | 382 | ; the IT department needs to access the lab to manage its computers 383 | role(it-support, access-lab). 384 | role(it-support, manage-computers). 385 | 386 | ; the dean has nothing to do with the science, but they still sign the 387 | ; checks and assign personel 388 | role(dean, approve-experiment). 389 | role(dean, manage-users). 390 | 391 | ;; users 392 | 393 | has-role(bill, grad-student). 394 | has-role(clara, professor). 395 | has-role(dmitri, grad-student). 396 | has-role(dmitri, poison-control). ; dmitri is a volunteer EMT 397 | has-role(emily, it-support). 398 | has-role(fabian, dean). 399 | 400 | ;; RBAC 401 | 402 | may(?perm) :- 403 | application says user(?user), 404 | has-role(?user, ?role), 405 | role(?role, ?perm). 406 | ``` 407 | 408 | ### Example: Access Control Lists (ACLs) 409 | 410 | ### Advice: Don't use ACLs 411 | 412 | ## Using Avaleryar 413 | 414 | TODO: tutorial module. 415 | 416 | ## Glossary 417 | 418 | ## Planned Improvements 419 | 420 | * An interactive debugger 421 | * A better persistence story (to make dynamic rule submission usable) 422 | * Assertion signatures (enabling the use of variables for native assertions) 423 | * Some kind of [abduction](https://en.wikipedia.org/wiki/Abductive_logic_programming) (to offer 424 | explanations of query failure) 425 | 426 | 427 | [soutei-paper]: http://okmij.org/ftp/papers/Soutei.pdf "Soutei Paper" 428 | -------------------------------------------------------------------------------- /core/src/Language/Avaleryar/Semantics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TupleSections #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-| 16 | 17 | Evaluation proceeds pretty much like in the Soutei paper. Computations are performed in the 18 | 'Avaleryar' monad, which is built up from the paper's backtracking monad and maintains the 19 | runtime state ('RT'). The latter consists of the current variable substitution, an 'Epoch' counter 20 | for a supply of guaranteed-fresh variables, and a database of predicates 'Db'. 21 | 22 | To 'resolve' a 'Goal' (really just a 'BodyLit'), we load its associated assertion, look its 'Pred' 23 | up, and execute the rule (or native predicate) to which it's bound. Our "compiled" representation 24 | of rules amounts to fuctions from 'Lit's (the head of a rule) to 'Avaleryar' computations. 25 | 26 | The database distinguishes between 'Rule's and "native predicates". In the original implementation, 27 | all mode-restricted predicates were baked into the @application@ assertion. But we expect to have a 28 | larger number of built-in predicates (for example, to parse JWTs, manipulate dates and times, or 29 | consult a SQL database), so it seemed worthwhile to deviate from the paper to allow native 30 | predicates to come from assertions other than @application@. Because native predicates are likely 31 | to be mode restricted (one wouldn't want to backtrack through a signature-checking routine, 32 | attempting to enumerate new bitstrings until one just so happened to be a digest of your plaintext), 33 | we need some means of identifying them at load-time to mode-check them before attempting to call 34 | them. To simplify all this, we require that native predicates (the only mode-restricted predicates 35 | in the system) reside in "native assertions", which maintain enough information in their 36 | 'NativePred's to allow mode-checking for subsequent assertion submissions. 37 | 38 | Currently, native assertions are distinguished lexically from normal rule assertions by prefixing 39 | their name with a colon. Thus, @:ldap says user-group(?user, ?group)@ refers to the native 40 | predicate @user-group\/2@ within the native assertion named @ldap@. Variables may not currently 41 | denote native assertions, so there's no way to express something like: 42 | 43 | @ 44 | may(read) :- 45 | application says directory-service(?ds), 46 | application says user(?user), 47 | :?ds says valid-user(?user). 48 | @ 49 | 50 | With the syntax suggesting that the application might have sent @directory-service(ldap)@ along with 51 | its query. The colon syntax was selected to be evocative of possibly someday in the future having 52 | signatures for native assertions, so we might one day write: 53 | 54 | @ 55 | may(read) :- 56 | application says directory-service(?ds), 57 | application says user(?user), 58 | DS:?ds says valid-user(?user). 59 | @ 60 | 61 | and ensure well-modedness from the signature @DS@ of all directory service assertions. 62 | 63 | -} 64 | 65 | 66 | module Language.Avaleryar.Semantics where 67 | 68 | import Control.Applicative 69 | import Control.DeepSeq (NFData) 70 | import Control.Monad.Except 71 | import Control.Monad.State 72 | import Data.Foldable 73 | import Data.Map (Map) 74 | import qualified Data.Map as Map 75 | import Data.String 76 | import Data.Text (Text, pack) 77 | import Data.Void (vacuous) 78 | import GHC.Clock (getMonotonicTime) 79 | import GHC.Generics (Generic) 80 | import Text.PrettyPrint.Leijen.Text (Pretty(..), vsep) 81 | 82 | import Control.Monad.FBackTrackT 83 | 84 | import Language.Avaleryar.Syntax 85 | 86 | -- | A native predicate carries not just its evaluation function, but also its signature, so it may 87 | -- be consulted when new assertions are submitted in order to mode-check them. 88 | data NativePred = NativePred 89 | { nativePred :: Lit EVar -> Avaleryar () 90 | , nativeSig :: ModedLit 91 | } deriving Generic 92 | 93 | instance NFData NativePred 94 | 95 | -- | Regular 'Rule' assertions may be named by any 'Value'. 96 | newtype RulesDb = RulesDb { unRulesDb :: Map Value (Map Pred (Lit EVar -> Avaleryar ())) } 97 | deriving (Semigroup, Monoid, Generic) 98 | 99 | instance Pretty RulesDb where 100 | pretty (RulesDb as) = vsep . fmap go $ Map.toList as 101 | where go (assn, pm) = prettyAssertion assn $ Map.keys pm 102 | 103 | -- | Native predicates are lexically restricted, so 'NativeDb's are keyed on 'Text' rather than 104 | -- 'Value'. 105 | newtype NativeDb = NativeDb { unNativeDb :: Map Text (Map Pred NativePred) } 106 | deriving (Semigroup, Monoid, Generic) 107 | 108 | instance NFData NativeDb 109 | 110 | -- TODO: newtype harder (newtype RuleAssertion c = ..., newtype NativeAssertion c = ...) 111 | data Db = Db 112 | { rulesDb :: RulesDb 113 | , nativeDb :: NativeDb 114 | } deriving (Generic) 115 | 116 | instance Semigroup Db where 117 | Db rdb ndb <> Db rdb' ndb' = Db (rdb <> rdb') (ndb <> ndb') 118 | 119 | instance Monoid Db where 120 | mempty = Db mempty mempty 121 | mappend = (<>) 122 | 123 | -- | As 'Map.lookup', but fail into 'empty' instead of 'Nothing' when the key is missing. 124 | alookup :: (Alternative f, Ord k) => k -> Map k a -> f a 125 | alookup k m = maybe empty pure $ Map.lookup k m 126 | 127 | -- | Look up a the 'Pred' in the assertion denoted by the given 'Value', and return the code to 128 | -- execute it. 129 | loadRule :: Value -> Pred -> Avaleryar (Lit EVar -> Avaleryar ()) 130 | loadRule c p = getsRT (unRulesDb . rulesDb . db) >>= alookup c >>= alookup p 131 | 132 | -- | As 'loadRule' for native predicates. 133 | loadNative :: Text -> Pred -> Avaleryar (Lit EVar -> Avaleryar ()) 134 | loadNative n p = getsRT (unNativeDb . nativeDb . db) >>= alookup n >>= alookup p >>= pure . nativePred 135 | 136 | -- | Runtime state for 'Avaleryar' computations. 137 | data RT = RT 138 | { env :: Env -- ^ The accumulated substitution 139 | , epoch :: Epoch -- ^ A counter for generating fresh variables 140 | , db :: Db -- ^ The database of compiled predicates 141 | } deriving (Generic) 142 | 143 | -- | Allegedly more-detailed results from an 'Avaleryar' computation. A more ergonomic type is 144 | -- 'AvaResults', which you can build from 'DetailedResults' with 'avaResults'. 145 | data DetailedResults a = DetailedResults 146 | { initialDepth :: Int -- ^ The number of steps (fuel) with which the computation was run 147 | , initialBreadth :: Int -- ^ The maximum number of answers requested 148 | , remainingDepth :: Int -- ^ The remaining fuel at the end of the computation 149 | , remainingBreadth :: Int -- ^ Effectively @initialBreadth - length results@ 150 | , wallClockTime :: Double -- ^ The time (in seconds) elapsed running the computation 151 | , results :: [a] -- ^ The results of the computation 152 | } deriving (Eq, Ord, Read, Show, Foldable, Functor, Traversable, Generic) 153 | 154 | -- | The results of running an 'Avaleryar' computation. 155 | data AvaResults a 156 | = Failure -- ^ Produced no results 157 | | FuelExhausted -- ^ Ran out of fuel before producing any results 158 | | Success [a] -- ^ Produced some results; may or may not have run out of fuel 159 | deriving (Eq, Ord, Read, Show, Foldable, Functor, Traversable, Generic) 160 | 161 | avaResults :: DetailedResults a -> AvaResults a 162 | avaResults DetailedResults {..} = case (remainingDepth, results) of 163 | (0, []) -> FuelExhausted 164 | (_, []) -> Failure 165 | (_, rs) -> Success rs 166 | 167 | type QueryResults = AvaResults Fact 168 | type DetailedQueryResults = DetailedResults Fact 169 | 170 | -- | A fair, backtracking, terminating, stateful monad transformer that does all the work. This is 171 | -- 'StateT' over 'Stream', so state changes are undone on backtracking. This is important. 172 | newtype Avaleryar a = Avaleryar { unAvaleryar :: StateT RT (Stream IO) a } 173 | deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFail, MonadYield, MonadIO) 174 | 175 | -- | Run an 'Avaleryar' computation. The first argument is an upper limit on the number of 176 | -- backtracking steps the computation may take before terminating, the second is an upper limit on 177 | -- the number of values the computation may produce before terminating. Both could be made optional 178 | -- (unlimited depth, unlimited answers), but that doesn't seem like the point of what we're trying 179 | -- to do here. 180 | runAvaleryar :: Int -> Int -> Db -> Avaleryar a -> IO (AvaResults a) 181 | runAvaleryar d b db = fmap avaResults . runAvaleryar' d b db 182 | 183 | runAvaleryar' :: Int -> Int -> Db -> Avaleryar a -> IO (DetailedResults a) 184 | runAvaleryar' d b db ava = do 185 | start <- getMonotonicTime 186 | res <- runM' (Just d) (Just b) 187 | . flip evalStateT (RT mempty 0 db) 188 | . unAvaleryar $ ava 189 | end <- getMonotonicTime 190 | case res of 191 | (Just d', Just b', as) -> pure $ DetailedResults d b d' b' (end - start) as 192 | _ -> error "runM' gave back Nothings; shouldn't happen" 193 | 194 | getRT :: Avaleryar RT 195 | getRT = Avaleryar get 196 | 197 | getsRT :: (RT -> a) -> Avaleryar a 198 | getsRT = Avaleryar . gets 199 | 200 | putRT :: RT -> Avaleryar () 201 | putRT = Avaleryar . put 202 | 203 | -- | Try to find a binding for the given variable in the current substitution. 204 | -- 205 | -- NB: The resulting 'Term' may still be a variable. 206 | lookupEVar :: EVar -> Avaleryar (Term EVar) 207 | lookupEVar ev = do 208 | RT {..} <- getRT 209 | alookup ev env 210 | 211 | -- | As 'lookupEVar', using the current value of the 'Epoch' counter in the runtime state. 212 | lookupVar :: TextVar -> Avaleryar (Term EVar) 213 | lookupVar v = do 214 | ev <- EVar <$> getsRT epoch <*> pure v 215 | lookupEVar ev 216 | 217 | -- | Unifies two terms, updating the substitution in the state. 218 | unifyTerm :: Term EVar -> Term EVar -> Avaleryar () 219 | unifyTerm t t' = do 220 | ts <- subst t 221 | ts' <- subst t' 222 | unless (ts == ts') $ do 223 | rt@RT {..} <- getRT 224 | case (ts, ts') of 225 | (Var v, _) -> putRT rt {env = Map.insert v ts' env} 226 | (_, Var v) -> putRT rt {env = Map.insert v ts env} 227 | _ -> empty -- ts /= ts', both are values 228 | 229 | -- | Apply the current substitution on the given 'Term'. This function does path compression: if it 230 | -- finds a variable, it recurs. This function does not fail: if there is no binding for the given 231 | -- variable, it will give it right back. 232 | subst :: Term EVar -> Avaleryar (Term EVar) 233 | subst v@(Val _) = pure v 234 | subst var@(Var ev) = getsRT env >>= maybe (pure var) subst . Map.lookup ev 235 | 236 | type Goal = BodyLit EVar 237 | 238 | -- | Analyze the given assertion reference and look up the given predicate to find some code to 239 | -- execute. 240 | loadResolver :: ARef EVar -> Pred -> Avaleryar (Lit EVar -> Avaleryar ()) 241 | loadResolver (ARNative n) p = loadNative n p 242 | loadResolver (ARTerm t) p = do 243 | Val c <- subst t -- mode checking should assure that assertion references are ground by now 244 | loadRule c p 245 | loadResolver ARCurrent _ = error "found ARCurrent in loadResolver; shouldn't be possible" 246 | 247 | -- | Load the appropriate assertion, and execute the predicate in the goal. Eagerly substitutes, 248 | -- which I think might be inefficient, but I also think was tricky to not-do here way back when I 249 | -- wrote this. 250 | resolve :: Goal -> Avaleryar (Lit EVar) 251 | resolve (assn `Says` l@(Lit p as)) = do 252 | resolver <- yield' $ loadResolver assn p 253 | resolver l 254 | Lit p <$> traverse subst as 255 | 256 | 257 | -- | A slightly safer version of @'zipWithM_' 'unifyTerm'@ that ensures its argument lists are the 258 | -- same length. 259 | unifyArgs :: [Term EVar] -> [Term EVar] -> Avaleryar () 260 | unifyArgs [] [] = pure () 261 | unifyArgs (x:xs) (y:ys) = unifyTerm x y >> unifyArgs xs ys 262 | unifyArgs _ _ = empty 263 | 264 | -- | NB: 'compilePred' doesn't look at the 'Pred' for any of the given rules, it assumes it was 265 | -- given a query that applies, and that the rules it was handed are all for the same predicate. 266 | -- This is not the function you want. FIXME: Suck less 267 | compilePred :: [Rule TextVar] -> Lit EVar -> Avaleryar () 268 | compilePred rules (Lit _ qas) = do 269 | rt@RT {..} <- getRT 270 | putRT rt {epoch = succ epoch} 271 | let rules' = fmap (EVar epoch) <$> rules 272 | go (Rule (Lit _ has) body) = do 273 | unifyArgs has qas 274 | traverse_ resolve body 275 | msum $ go <$> rules' 276 | 277 | -- | Turn a list of 'Rule's into a map from their names to code that executes them. 278 | -- 279 | -- Substitutes the given assertion for references to 'ARCurrent' in the bodies of the rules. This 280 | -- is somewhat gross, and needs to be reexamined in the fullness of time. 281 | compileRules :: Text -> [Rule TextVar] -> Map Pred (Lit EVar -> Avaleryar ()) 282 | compileRules assn rules = 283 | fmap compilePred $ Map.fromListWith (++) [(p, [emplaceCurrentAssertion assn r]) 284 | | r@(Rule (Lit p _) _) <- rules] 285 | 286 | emplaceCurrentAssertion :: Text -> Rule v -> Rule v 287 | emplaceCurrentAssertion assn (Rule l b) = Rule l (go <$> b) 288 | where go (ARCurrent `Says` bl) = (ARTerm $ val assn) `Says` bl 289 | go bl = bl 290 | 291 | compileQuery :: String -> Text -> [Term TextVar] -> Avaleryar (Lit EVar) 292 | compileQuery assn p args = resolve $ assn' `Says` (Lit (Pred p (length args)) (fmap (fmap (EVar (-1))) args)) 293 | where assn' = case assn of 294 | (':':_) -> ARNative (pack assn) 295 | _ -> ARTerm . Val $ fromString assn 296 | 297 | -- | TODO: Suck less 298 | compileQuery' :: String -> Query -> Avaleryar (Lit EVar) 299 | compileQuery' assn (Lit (Pred p _) args) = compileQuery assn p args 300 | 301 | insertRuleAssertion :: Text -> Map Pred (Lit EVar -> Avaleryar ()) -> RulesDb -> RulesDb 302 | insertRuleAssertion assn rules = RulesDb . Map.insert (T assn) rules . unRulesDb 303 | 304 | retractRuleAssertion :: Text -> RulesDb -> RulesDb 305 | retractRuleAssertion assn = RulesDb . Map.delete (T assn) . unRulesDb 306 | 307 | --------------------- 308 | 309 | inMode :: Mode RawVar 310 | inMode = In "+" 311 | 312 | outMode :: Mode RawVar 313 | outMode = Out "-" 314 | 315 | -- | Typeclass machinery for easing the creation of native predicates. The idea is to do our best 316 | -- to translate regular Haskell functions into predicates callable from soutei code without needing 317 | -- to concern ourselves with the intricacies of the evaluator. 318 | class ToNative a where 319 | -- | Think of 'toNative' as describing how to unify the /result/ of a function with the complete 320 | -- list of 'Term's given. Usually, the list will only have one value in it, but it can have more 321 | -- or fewer in the case of e.g., tuples. Implementations /must/ ground-out every variable in the 322 | -- list, or the mode-checker will become unsound. 323 | toNative :: a -> [Term EVar] -> Avaleryar () 324 | 325 | -- | Probably this should be 'outMode' for each argument expected in the list of 'Term's in 326 | -- 'toNative'. 327 | inferMode :: [Mode RawVar] 328 | 329 | instance ToNative Value where 330 | toNative v args = unifyArgs [val v] args 331 | inferMode = [outMode] 332 | 333 | -- TODO: Figure out if there's a reason I didn't do: 334 | -- 335 | -- instance Valuable a => ToNative a where 336 | -- toNative v args = toNative (toValue a) args 337 | -- inferMode = [outMode] 338 | 339 | instance ToNative () where 340 | toNative () [] = pure () 341 | toNative () _ = empty 342 | inferMode = [] 343 | 344 | -- TODO: This is either slick or extremely hokey, figure out which. 345 | instance ToNative Bool where 346 | toNative b [] = guard b 347 | toNative _ _ = empty 348 | inferMode = [] 349 | 350 | -- TODO: This is also either slick or extremely hokey, figure out which. 351 | instance ToNative a => ToNative [a] where 352 | toNative as xs = msum [toNative a xs | a <- as] 353 | inferMode = inferMode @a 354 | 355 | instance ToNative a => ToNative (Maybe a) where 356 | toNative ma xs = toNative (toList ma) xs 357 | inferMode = inferMode @[a] 358 | 359 | -- | Pretty much just a 1-tuple, like @Only@ from @postgresql-simple@. 360 | newtype Solely a = Solely a 361 | 362 | instance Valuable a => ToNative (Solely a) where 363 | toNative (Solely a) args = unifyArgs [val a] args 364 | inferMode = [outMode] 365 | 366 | instance (Valuable a, Valuable b) => ToNative (a, b) where 367 | toNative (a, b) args = unifyArgs [val a, val b] args 368 | inferMode = [outMode, outMode] 369 | 370 | instance (Valuable a, Valuable b, Valuable c) => ToNative (a, b, c) where 371 | toNative (a, b, c) args = unifyArgs [val a, val b, val c] args 372 | inferMode = [outMode, outMode, outMode] 373 | 374 | instance (Valuable a, Valuable b, Valuable c, Valuable d) => ToNative (a, b, c, d) where 375 | toNative (a, b, c, d) args = unifyArgs [val a, val b, val c, val d] args 376 | inferMode = [outMode, outMode, outMode, outMode] 377 | 378 | instance (Valuable a, Valuable b, Valuable c, Valuable d, Valuable e) => ToNative (a, b, c, d, e) where 379 | toNative (a, b, c, d, e) args = unifyArgs [val a, val b, val c, val d, val e] args 380 | inferMode = [outMode, outMode, outMode, outMode, outMode] 381 | 382 | instance (Valuable a, Valuable b, Valuable c, Valuable d, Valuable e, Valuable f) => ToNative (a, b, c, d, e, f) where 383 | toNative (a, b, c, d, e, f) args = unifyArgs [val a, val b, val c, val d, val e, val f] args 384 | inferMode = [outMode, outMode, outMode, outMode, outMode, outMode] 385 | 386 | -- | This is where the magic happens. We require 'Valuable' (rather than 'ToNative') of the input 387 | -- so we can use 'fromValue' to pull the value back from Soutei into Haskell. We assign 'inMode' 388 | -- here to ensure that we actually get a value from the substitution so that 'fromValue' might 389 | -- conceivably work. 390 | instance (Valuable a, ToNative b) => ToNative (a -> b) where 391 | toNative f (x:xs) = do 392 | Val x' <- subst x -- mode checking should make this safe (because of the 'inMode' below) 393 | case fromValue x' of 394 | Just a -> toNative (f a) xs 395 | Nothing -> empty 396 | toNative _ _ = empty 397 | inferMode = inMode : inferMode @b 398 | 399 | -- | Executes the IO action and produces the result. 400 | -- 401 | -- TODO: This should possibly cache the result, but only once per query, probably. That would 402 | -- likely require infrastructure we lack at present. 403 | instance ToNative a => ToNative (IO a) where 404 | toNative ma xs = do 405 | a <- liftIO ma 406 | toNative a xs 407 | 408 | inferMode = inferMode @a 409 | 410 | -- | Create a native predicate from a 'ToNative' instance with the given name. 411 | mkNativePred :: forall a. (ToNative a) => Text -> a -> NativePred 412 | mkNativePred pn f = NativePred np moded 413 | where np (Lit _ args) = toNative f args 414 | modes = inferMode @a 415 | moded = Lit (Pred pn $ length modes) (Var <$> modes) 416 | 417 | -- TODO: Feels like I should be able to do this less manually, maybe? 418 | mkNativeFact :: (Factual a) => a -> NativePred 419 | mkNativeFact a = NativePred np $ fmap Out f 420 | where f@(Lit _ args) = vacuous $ toFact a 421 | np (Lit _ args') = unifyArgs args args' 422 | 423 | -- | Create a native database with the given assertion name from the given list of native 424 | -- predicates. 425 | mkNativeDb :: Text -> [NativePred] -> NativeDb 426 | mkNativeDb assn preds = NativeDb . Map.singleton assn $ Map.fromList [(p, np) | np@(NativePred _ (Lit p _)) <- preds] 427 | --------------------------------------------------------------------------------