├── Makefile ├── README ├── Soutei.cabal ├── Soutei ├── Assertions.hs ├── Check.hs ├── Client.hs ├── FBackTrack.hs ├── FBackTrackT.hs ├── GBBFS.hs ├── GBBFS1.hs ├── Lirs.hs ├── Logic.hs ├── Parsec.hs ├── Sexpr.hs ├── Soutei.hs └── Syntax.hs ├── demo ├── metcast-channels │ ├── Makefile │ ├── doc │ │ ├── 00.html │ │ ├── 01.html │ │ ├── 06.html │ │ ├── 07.html │ │ ├── 08.html │ │ ├── 09.html │ │ ├── 11.html │ │ ├── Makefile │ │ ├── index.html │ │ ├── notes │ │ ├── soutei.fig │ │ └── soutei.png │ ├── soutei-metcast-demo-init.txt │ └── soutei-metcast-tests.hs └── rbac │ ├── local │ ├── SOUTEI │ └── assertions │ │ ├── TPS-report-owner │ │ ├── app-owner │ │ ├── hr │ │ └── system │ ├── run-test.sh │ └── system ├── doc ├── Auth-transport.html ├── Auth-transport.scm ├── Auth-use-cases.html ├── Auth-use-cases.scm ├── Authorization.html ├── Authorization.scm ├── index.html └── soutei-sourceforge.scm ├── soutei-cli.hs ├── soutei-pipelined.hs └── soutei-server.hs /Makefile: -------------------------------------------------------------------------------- 1 | # Compiling Soutei library and sample applications 2 | 3 | GHC := ghc 4 | GHC_MAKE = $(GHC) --make 5 | GHC_OPTS := -O2 6 | GHC_INCLUDES = `$(GHC) --print-libdir`/include 7 | 8 | 9 | PROGS := soutei-server soutei-cli 10 | 11 | SOURCES := $(wildcard Soutei/*.hs) 12 | MODULES := $(subst /,.,$(patsubst %.hs,%,$(SOURCES))) 13 | OBJECTS := $(patsubst %.hs,$(BUILD_DIR)/objs/%.o,$(SOURCES)) 14 | HC_CMD := $(GHC_MAKE) $(GHC_OPTS) -I$(GHC_INCLUDES) 15 | 16 | all: $(PROGS) 17 | 18 | test: 19 | cd demo/metcast-channels/ && $(MAKE) test 20 | 21 | clean:: 22 | cd demo/metcast-channels/ && $(MAKE) clean 23 | 24 | 25 | %: %.hs 26 | $(HC_CMD) -o $@ $*.hs 27 | 28 | clean:: 29 | rm -f *.hi *.o $(PROGS) 30 | rm -f Soutei/*.hi 31 | rm -f Soutei/*.o 32 | 33 | soutei-pipelined: soutei-pipelined.hs 34 | ghc -O2 --make \ 35 | soutei-pipelined.hs -o $@ 36 | 37 | 38 | # The following targets require the FCGI library or Metcast 39 | # They are present for information only 40 | # 41 | # FCGIP=XXXSet-FGCI-library-here 42 | # soutei-fcgi: soutei-fcgi.hs 43 | # ghc -O2 --make -I$(FCGIP)/fcgi/include -i$(FCGIP) \ 44 | # $(FCGIP)/fcgi/fcgiapp.o $(FCGIP)/fcgi/os_unix.o \ 45 | # soutei-fcgi.hs -o $@ 46 | # 47 | # soutei-mux: soutei-mux.hs 48 | # ghc -O2 --make -i$(FCGIP) $(FCGIP)/System/sys_open.o \ 49 | # soutei-mux.hs -o $@ 50 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Soutei, a logic-based trust-management system 2 | Andrew Pimlott and Oleg Kiselyov 3 | 4 | Soutei is a trust-management system, a dialect of Binder, for access 5 | control in distributed systems. Soutei policies and credentials are 6 | written in a declarative logic-based security language and thus 7 | constitute distributed logic programs. Soutei policies are modular, 8 | concise, and readable. They support policy verification, and, despite 9 | the simplicity of the language, express role- and attribute-based 10 | access control lists, and conditional delegation. 11 | 12 | 13 | Documentation: 14 | - Andrew Pimlott and Oleg Kiselyov: 15 | Soutei, a logic-based trust-management system (system description) 16 | The paper presented at FLOPS 2006, 8th International Symposium on 17 | Functional and Logic Programming. Fuji-Susono, Japan, April 24-26, 2006. 18 | The paper is published in Springer's Lecture Notes in Computer Science 3945, 19 | pp. 130-145, 2006. 20 | http://dx.doi.org/10.1007/11737414 21 | http://okmij.org/ftp/papers/Soutei.pdf 22 | 23 | - Specification, use cases and design notes 24 | http://soutei.sf.net/doc/ 25 | 26 | 27 | The source code is under GPL 2 license. 28 | 29 | MANIFEST 30 | 31 | Soutei/ The Soutei library (The Soutei `package') 32 | 33 | Sample Soutei applications 34 | soutei-server.hs Soutei TCP server 35 | soutei-cli.hs A bare-bone client for the soutei-server 36 | (useful for testing) 37 | 38 | Demonstrations 39 | demo/rbac/ Modelling access control lists and role-based 40 | access control in Soutei 41 | See the Soutei paper, section `Soutei by example' 42 | demo/rbac/run-test.sh The file to run the tests 43 | demo/rbac/demo/rbac/system The system policy 44 | demo/rbac/demo/rbac/local/assertions/ Other policies (HR, app-owner, etc) 45 | 46 | 47 | demo/metcast-channels/ Extensive regression test suite for Soutei along 48 | the lines of an actual demonstration, 49 | given in June 2005. 50 | See Section `A real-life use case' in the Soutei 51 | paper. 52 | demo/metcast-channels/Makefile do make test 53 | demo/metcast-channels/doc/ The slides of the test and the presentation 54 | script 55 | -------------------------------------------------------------------------------- /Soutei.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >= 1.14 2 | Name: Soutei 3 | Version: 2.1 4 | Synopsis: a logic-based trust-management system 5 | Description: 6 | SOUTEI is a trust-management system, a dialect of Binder, for access 7 | control in distributed systems. Soutei policies and credentials are written 8 | in a declarative logic-based security language and thus constitute 9 | distributed logic programs. Soutei policies are modular, concise, and 10 | readable. They support policy verification, and, despite the simplicity of 11 | the language, express role- and attribute-based access control lists, and 12 | conditional delegation. 13 | http://soutei.sourceforge.net/ 14 | http://github.com/mstone/soutei 15 | License: GPLv2 16 | Author: Oleg Kiselyov , Andrew Pimlott 17 | Maintainer: Michael Stone 18 | Stability: experimental 19 | Build-Type: Simple 20 | 21 | Library 22 | Exposed-Modules: Soutei.Soutei 23 | Soutei.Assertions, 24 | Soutei.Check, 25 | Soutei.Client, 26 | Soutei.FBackTrack, 27 | Soutei.FBackTrackT, 28 | Soutei.GBBFS, 29 | Soutei.GBBFS1, 30 | Soutei.Lirs, 31 | Soutei.Logic, 32 | Soutei.Parsec, 33 | Soutei.Sexpr, 34 | Soutei.Syntax 35 | Build-Depends: base >= 4.0, 36 | containers -any, 37 | directory -any, 38 | mtl -any, 39 | network -any, 40 | old-locale -any, 41 | old-time -any, 42 | parallel -any, 43 | parsec -any, 44 | QuickCheck == 2.*, 45 | random -any 46 | GHC-Options: -Wall -funbox-strict-fields 47 | GHC-Prof-Options: -prof -auto-all 48 | Default-Language: Haskell2010 49 | 50 | Executable soutei-server 51 | Main-Is: soutei-server.hs 52 | Other-Modules: Soutei.Soutei 53 | Build-Depends: base >= 4.0, 54 | containers -any, 55 | directory -any, 56 | mtl -any, 57 | network -any, 58 | old-locale -any, 59 | old-time -any, 60 | parallel -any, 61 | parsec -any, 62 | QuickCheck == 2.*, 63 | random -any 64 | GHC-Options: -Wall -funbox-strict-fields -rtsopts -threaded 65 | GHC-Prof-Options: -prof -auto-all 66 | Default-Language: Haskell2010 67 | 68 | Executable soutei-cli 69 | Main-Is: soutei-server.hs 70 | Other-Modules: Soutei.Soutei 71 | Build-Depends: base >= 4.0, 72 | containers -any, 73 | directory -any, 74 | mtl -any, 75 | network -any, 76 | old-locale -any, 77 | old-time -any, 78 | parallel -any, 79 | parsec -any, 80 | QuickCheck == 2.*, 81 | random -any 82 | GHC-Options: -Wall -funbox-strict-fields -rtsopts -threaded 83 | GHC-Prof-Options: -prof -auto-all 84 | Default-Language: Haskell2010 85 | 86 | Test-Suite soutei-metcast-tests 87 | Type: exitcode-stdio-1.0 88 | Main-is: demo/metcast-channels/soutei-metcast-tests.hs 89 | Build-Depends: base >= 4.0, 90 | containers -any, 91 | directory -any, 92 | mtl -any, 93 | network -any, 94 | old-locale -any, 95 | old-time -any, 96 | parallel -any, 97 | parsec -any, 98 | QuickCheck == 2.*, 99 | random -any 100 | GHC-Options: -Wall -funbox-strict-fields -rtsopts -threaded 101 | Default-Language: Haskell2010 102 | -------------------------------------------------------------------------------- /Soutei/Assertions.hs: -------------------------------------------------------------------------------- 1 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/Assertions.hs $ 2 | -- $Id: Assertions.hs 2947 2012-09-14 08:26:08Z oleg.kiselyov $ 3 | -- svn propset svn:keywords "HeadURL Id" filename 4 | 5 | -- Routines for loading, storing, and running queries against assertions. 6 | -- Primary interface is imperative because the memory index must be kept in 7 | -- sync with the disk; functional alternatives end in F. 8 | 9 | module Soutei.Assertions ( 10 | Assertions, AssertionsF, 11 | fromDataDir, fromDataDirWithActions, 12 | loadSysCtx, putCtx, putCtxRules, query, queryResults, 13 | emptyF, loadSysCtxF, putCtxF, putCtxRulesF, queryF, queryResultsF 14 | ) where 15 | 16 | import Prelude hiding (lookup) 17 | import Control.Monad 18 | import Control.Monad.Identity 19 | import Control.Monad.Trans 20 | import Data.Char (ord, isAlphaNum) 21 | import Data.Map (Map, empty, lookup, insert, delete, union, fromList) 22 | import Data.Maybe (fromMaybe, fromJust) 23 | import Data.Version (Version(..), showVersion, parseVersion) 24 | import Numeric (showHex) 25 | import System.Directory 26 | import System.IO 27 | import System.IO.Error as IO 28 | import System.IO.Unsafe (unsafePerformIO) 29 | import Text.ParserCombinators.ReadP (readP_to_S, string) 30 | 31 | import Soutei.Check 32 | import Soutei.FBackTrackT (Stream, runM) 33 | import qualified Soutei.Lirs as Lirs 34 | import Soutei.Logic (Query, runQuery, false, 35 | CtxQuery, PredQuery, ArgsQuery, 36 | prove, proveResults, clausesQuery, funcQuery) 37 | import Soutei.Parsec (parseM) 38 | import Soutei.Soutei 39 | import Soutei.Syntax (top, assertionL) 40 | 41 | data Assertions = Assertions { 42 | put :: Const -> CtxIndex IO -> Maybe String -> IO (), 43 | get :: Const -> IO (CtxIndex IO), 44 | app :: AppPrims IO 45 | } 46 | data AssertionsF = AssertionsF { 47 | index :: Index, 48 | appF :: AppPrims Identity 49 | } 50 | type Index = Map Const (CtxIndex Identity) 51 | type CtxIndex m = Map Pred (ArgsQuery m) 52 | type AppPrims m = Map Pred (ArgsQuery m, [ArgMode]) 53 | 54 | fromDataDir :: (IOError -> IO a) -> FilePath -> IO Assertions 55 | fromDataDir err dataDir = do 56 | initDataDir dataDir 57 | let storage = Lirs.Storage (storeA dataDir) 58 | (\ctx -> do s <- loadA dataDir ctx 59 | rules <- parseA "data store" s 60 | uncheckedIndexRules rules 61 | `IO.catch` \e -> err e >> return empty) 62 | lirs <- Lirs.new storage 990 1000 63 | return (Assertions (Lirs.put lirs) (Lirs.get lirs) stdAppPrims) 64 | 65 | fromDataDirWithActions :: 66 | (IOError -> IO a) -> 67 | (Const -> IO (Maybe String)) -> -- read action 68 | (Const -> (Maybe String) -> IO ()) -> -- write action 69 | IO Assertions 70 | fromDataDirWithActions err readA writeA = do 71 | let storage = Lirs.Storage (writeA) 72 | (\ctx -> do s <- readA ctx 73 | rules <- parseA "data store" s 74 | uncheckedIndexRules rules 75 | `IO.catch` \e -> err e >> return empty) 76 | lirs <- Lirs.new storage 990 1000 77 | return (Assertions (Lirs.put lirs) (Lirs.get lirs) stdAppPrims) 78 | 79 | emptyF :: AssertionsF 80 | emptyF = AssertionsF empty stdAppPrims 81 | 82 | loadSysCtx :: FilePath -> Assertions -> IO () 83 | loadSysCtx initFile as = do 84 | s <- readInitFile initFile 85 | putCtx initFile sysCtx (Just s) as 86 | 87 | loadSysCtxF :: FilePath -> AssertionsF -> IO AssertionsF 88 | loadSysCtxF initFile as = do 89 | s <- readInitFile initFile 90 | putCtxF initFile sysCtx (Just s) as 91 | 92 | readInitFile :: FilePath -> IO String 93 | readInitFile initFile = 94 | doesFileExist initFile >>= \b -> if b 95 | then readFile initFile 96 | else fail ("system-assertion " ++ initFile ++ " not found") 97 | 98 | -- Parse and add (compile and store) an assertion for a context 99 | putCtx :: String -> Const -> Maybe String -> Assertions -> IO () 100 | putCtx source ctx s as = do rules <- parseA source s 101 | putCtx' ctx s rules as 102 | 103 | putCtxRules :: Const -> Maybe [SynRule] -> Assertions -> IO () 104 | putCtxRules ctx rules as = let s = liftM (concatMap show) rules 105 | in putCtx' ctx s (fromMaybe [] rules) as 106 | 107 | putCtx' :: Const -> Maybe String -> [SynRule] -> Assertions -> IO () 108 | putCtx' ctx s rules as = do 109 | ctxIndex <- indexRules (fmap snd (app as)) rules 110 | put as ctx ctxIndex s 111 | 112 | putCtxF :: Monad m => String -> Const -> (Maybe String) -> 113 | AssertionsF -> m AssertionsF 114 | putCtxF source ctx s as = do rules <- parseA source s 115 | putCtxF' ctx rules as 116 | 117 | putCtxRulesF :: Monad m => Const -> Maybe [SynRule] -> AssertionsF -> 118 | m AssertionsF 119 | putCtxRulesF ctx rules as = putCtxF' ctx (fromMaybe [] rules) as 120 | 121 | putCtxF' :: Monad m => Const -> [SynRule] -> AssertionsF -> m AssertionsF 122 | putCtxF' ctx [] as = return as{index=delete ctx (index as)} 123 | putCtxF' ctx rules as = do ctxIdx <- indexRules (fmap snd (appF as)) rules 124 | return as{index=insert ctx ctxIdx (index as)} 125 | 126 | parseA :: Monad m => String -> Maybe String -> m [SynRule] 127 | parseA source Nothing = return [] 128 | parseA source (Just s) = parseM (top assertionL) source s 129 | 130 | indexRules :: (Monad m, Monad m') => CtxModes -> [SynRule] -> m (CtxIndex m') 131 | indexRules appModes rules = liftM compilePreds (checkRules appModes rules) 132 | 133 | uncheckedIndexRules :: (Monad m, Monad m') => [SynRule] -> m (CtxIndex m') 134 | uncheckedIndexRules facts = liftM compilePreds (groupRules facts) 135 | 136 | compilePreds :: Monad m => Map Pred [SynRule] -> CtxIndex m 137 | compilePreds preds = ctxIdx where 138 | ctxIdx = fmap compile preds 139 | compile clauses = clausesQuery clauses predQuery 140 | predQuery pred = fromJust (lookup pred ctxIdx) 141 | 142 | query :: Maybe Int -> Assertions -> [Fact] -> SynHeadAtom -> IO Bool 143 | query t as facts goal = mkCtxQ as facts >>= query' t goal 144 | 145 | queryF :: Monad m => Maybe Int -> AssertionsF -> [Fact] -> SynHeadAtom -> m Bool 146 | queryF t as facts goal = liftM (runIdentity . query' t goal) (mkCtxQF as facts) 147 | 148 | queryResults :: Maybe Int -> Assertions -> [Fact] -> SynHeadAtom -> IO [Fact] 149 | queryResults t as facts goal = mkCtxQ as facts >>= queryResults' t goal 150 | 151 | queryResultsF :: Monad m => Maybe Int -> AssertionsF -> [Fact] -> SynHeadAtom -> 152 | m [Fact] 153 | queryResultsF t as facts goal = liftM (runIdentity . queryResults' t goal) 154 | (mkCtxQF as facts) 155 | 156 | query' :: Monad m => Maybe Int -> SynHeadAtom -> CtxQuery m -> m Bool 157 | query' t goal ctxQ = let q = prove sysCtx goal ctxQ 158 | in liftM (not . null) (runM t (Just 1) (runQuery q)) 159 | 160 | queryResults' :: Monad m => Maybe Int -> SynHeadAtom -> CtxQuery m -> m [Fact] 161 | queryResults' t goal ctxQ = let q = proveResults sysCtx goal ctxQ 162 | in liftM (map fst) (runM t Nothing (runQuery q)) 163 | 164 | mkCtxQ :: Monad m => Assertions -> [Fact] -> m (CtxQuery IO) 165 | mkCtxQ as facts = do appIdx <- mkAppIdx (fmap fst (app as)) facts 166 | return (asQuery as appIdx) 167 | 168 | mkCtxQF :: Monad m => AssertionsF -> [Fact] -> m (CtxQuery Identity) 169 | mkCtxQF as facts = do appIdx <- mkAppIdx (fmap fst (appF as)) facts 170 | return (idxQuery (insert appCtx appIdx (index as))) 171 | 172 | mkAppIdx :: (Monad m, Monad m') => CtxIndex m' -> [Fact] -> m (CtxIndex m') 173 | mkAppIdx appPrims facts = let rules = map (flip Rule [] . factToAtom) facts 174 | in liftM (union appPrims) (uncheckedIndexRules rules) 175 | 176 | asQuery :: Assertions -> CtxIndex IO -> CtxQuery IO 177 | asQuery as appIdx ctx pred args frame 178 | | ctx == appCtx = ctxIdxQ appIdx 179 | | otherwise = \s -> do ctxIdx <- liftIO (get as ctx) 180 | ctxIdxQ ctxIdx s 181 | where 182 | ctxIdxQ ctxIdx = case lookup pred ctxIdx of 183 | Just q -> q args (asQuery as appIdx) frame 184 | Nothing -> false 185 | 186 | idxQuery :: Index -> CtxQuery Identity 187 | idxQuery idx ctx pred args frame = fromMaybe false $ do 188 | ctxIdx <- lookup ctx idx 189 | q <- lookup pred ctxIdx 190 | return (q args (idxQuery idx) frame) 191 | 192 | -- primitives 193 | 194 | ipofQuery :: Monad m => (ArgsQuery m, [ArgMode]) 195 | ipofQuery = (funcQuery ipof', [R L, R S]) where 196 | ipof' [SIP4Addr addr, SIP4Net net] = ip4of addr net 197 | ipof' _ = False 198 | 199 | neqQuery :: Monad m => (ArgsQuery m, [ArgMode]) 200 | neqQuery = (funcQuery (\[x1, x2] -> x1 /= x2), [R S, R S]) 201 | 202 | stdAppPrims :: Monad m => AppPrims m 203 | stdAppPrims = fromList [(Pred "ip-of" 2, ipofQuery), 204 | (Pred "neq" 2, neqQuery)] 205 | 206 | -- storage 207 | 208 | initDataDir :: FilePath -> IO () 209 | initDataDir dataDir = let markerFile = markerFilename dataDir in 210 | doesDirectoryExist dataDir >>= \b -> if b 211 | then doesFileExist markerFile >>= \b -> if b 212 | then do marker <- readFile markerFile 213 | checkMarker dataDir marker 214 | return () 215 | else do ents <- getDirectoryContents dataDir 216 | if (null (filter (\ent -> ent /= "." && ent /= "..") ents)) 217 | then do writeFile markerFile marker 218 | createDirectory (assertionsDir dataDir) 219 | else fail (dataDir ++ " is not a Soutei data directory") 220 | else fail (dataDir ++ " is not a directory") 221 | 222 | storeA :: FilePath -> Const -> (Maybe String) -> IO () 223 | storeA dataDir ctx = store where 224 | store Nothing = do b <- doesFileExist ctxFile 225 | when b (removeFile ctxFile) 226 | store (Just s) = do writeFile tmpFile s 227 | renameFile tmpFile ctxFile 228 | tmpFile = tmpFilename dataDir 229 | ctxFile = ctxFilename dataDir ctx 230 | 231 | loadA :: FilePath -> Const -> IO (Maybe String) 232 | loadA dataDir ctx = let ctxFile = ctxFilename dataDir ctx in do 233 | b <- doesFileExist ctxFile 234 | if b 235 | then liftM Just (readFile ctxFile) 236 | else return Nothing 237 | 238 | marker = magic ++ showVersion dataDirVersion ++ "\n" 239 | checkMarker dataDir s = case readP_to_S p s of 240 | [(Version [major, minor] [], "")] -> 241 | if major > dataDirMajor 242 | then fail (dataDir ++ " is newer than Soutei") 243 | else return (major, minor) 244 | _ -> fail (dataDir ++ " is not a Soutei data directory (corrupt SOUTEI)") 245 | where 246 | p = do string magic 247 | v <- parseVersion 248 | string "\n" 249 | return v 250 | magic = "Soutei data directory, version " 251 | dataDirVersion = Version [dataDirMajor, dataDirMinor] [] 252 | dataDirMajor = 0 253 | dataDirMinor = 0 254 | 255 | markerFilename :: FilePath -> FilePath 256 | markerFilename dataDir = dataDir ++ "/SOUTEI" 257 | 258 | tmpFilename :: FilePath -> FilePath 259 | tmpFilename dataDir = dataDir ++ "/.tmp" 260 | 261 | ctxFilename :: FilePath -> Const -> FilePath 262 | ctxFilename dataDir ctx = assertionsDir dataDir ++ "/" ++ encode (show ctx) 263 | 264 | assertionsDir :: FilePath -> FilePath 265 | assertionsDir dataDir = dataDir ++ "/assertions" 266 | 267 | encode :: String -> String 268 | encode = concatMap encode' where 269 | encode' ch | isAlphaNum ch || ch `elem` "!#$&'()+,-.;=@_" = [ch] 270 | | otherwise = '%' : showHex (ord ch) ";" 271 | 272 | -------------------------------------------------------------------------------- /Soutei/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 2 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 3 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/Check.hs $ 4 | -- $Id: Check.hs 2947 2012-09-14 08:26:08Z oleg.kiselyov $ 5 | -- svn propset svn:keywords "HeadURL Id" filename 6 | 7 | module Soutei.Check ( 8 | ArgMode(..), TermMode(..), CtxModes, 9 | checkRules, groupRules 10 | ) where 11 | 12 | import Prelude hiding (lookup) 13 | import Control.Monad.Reader 14 | import Control.Monad.Writer 15 | import Data.List (transpose) 16 | import Data.Map (Map, empty, lookup, member, insert, insertWith, fromList) 17 | 18 | import Soutei.Parsec (uncheckedParse) 19 | import Soutei.Soutei 20 | import Soutei.Syntax 21 | 22 | type CtxModes = Map Pred [ArgMode] 23 | 24 | checkRules :: Monad m => CtxModes -> [SynRule] -> m (Map Pred [SynRule]) 25 | checkRules appModes rules = do (m, preds) <- checkErrs (groupRules' rules) 26 | checkErrs (checkUndefined m preds) 27 | checkErrs (modeCheck appModes preds) 28 | return m 29 | 30 | groupRules :: Monad m => [SynRule] -> m (Map Pred [SynRule]) 31 | groupRules rules = liftM fst (checkErrs (groupRules' rules)) 32 | 33 | groupRules' :: [SynRule] -> Check (Map Pred [SynRule], [(Pred, [SynRule])]) 34 | groupRules' rules = group (empty, []) rules where 35 | group a [] = return a 36 | group (m, preds) (rule@(Rule (Atom _ pred _) _) : rules) = do 37 | when (member pred m) 38 | (err ("multiple definitions of " ++ show pred)) 39 | groupPred (rule:) rules 40 | where 41 | groupPred l (rule@(Rule (Atom _ pred' _) _) : rules) 42 | | pred' == pred = groupPred (l . (rule:)) rules 43 | groupPred l rules = let clauses = l [] 44 | in group (insert pred clauses m, 45 | (pred, clauses):preds) rules 46 | 47 | checkUndefined :: Map Pred [SynRule] -> [(Pred, [SynRule])] -> Check () 48 | checkUndefined m preds = mapEnterClauseM_ (mapEnterM_ checkRule) preds where 49 | checkRule (Rule h b) = mapEnterM_ checkAtom b 50 | checkAtom (Atom NothingCtx pred _) = 51 | when (not (member pred m)) 52 | (errPos ("undefined predicate " ++ show pred)) 53 | checkAtom _ = return () 54 | 55 | -- mode checker 56 | 57 | data ArgMode = R TermMode | P TermMode deriving Eq 58 | data TermMode = L | S deriving (Eq, Ord) 59 | 60 | instance Ord ArgMode where 61 | R m `compare` R m' = m' `compare` m 62 | R _ `compare` P _ = LT 63 | P _ `compare` R _ = GT 64 | P m `compare` P m' = m `compare` m' 65 | 66 | instance Show TermMode where 67 | showsPrec _ L = ("range limited"++) 68 | showsPrec _ S = ("statically range limited"++) 69 | 70 | type ModeEnv = Map SynVar TermMode 71 | 72 | {- 73 | At the top level, we pass in a data structure that maps built-in predicates onto their 74 | argument modes; this never changes. 75 | 76 | For each predicate: 77 | First, mode-check each clause: 78 | For each body atom: 79 | Look at the context for the atom: 80 | * If it's "application", then either the predicate is 81 | built-in (so we look up its argument modes) or it's not (so 82 | we assign all arguments the mode (P S): we're saying that in 83 | the application namespace, all predicates force their 84 | arguments to be statically limited.) 85 | * If the context is something that's not "application", then 86 | we assign all arguments the mode (P L): in any namespaces other 87 | than "application", all predicates bind their arguments (but not 88 | necessarily to a statically-known value). 89 | * If there is no context, then as in the "application" rule, we 90 | look up the predicate in the data structure that tells us the modes 91 | for predicates in the current context; if it's found, then we know 92 | the argument modes, and if not, we assign all arguments (P L). 93 | 94 | Now that we have a mode for each argument, for each (arg, mode) pair, 95 | we do the following checks: 96 | * If arg is an anonymous variable, and the mode requires anything, 97 | we report an error because an anonymous variable can't have a mode. 98 | * If arg is a named variable and the mode is provided, then we 99 | insert (arg, mode) into the environment if mode is a refinement on 100 | whatever mode arg is already bound to in the environment. 101 | * If arg is a named variable and the mode is required, then we look 102 | up arg in the environment and check that the mode that's already in 103 | the environment contains at least as much information as mode does. 104 | 105 | Second, determine the modes for the head, using the information we just 106 | computed about the variables in the body. The goal is to ensure that 107 | every argument in the head provides some mode. 108 | We create a list of modes corresponding to each argument in the head: 109 | * If the argument is a constant, then the mode is (P S): that is, this 110 | rule provides a statically known value for that argument. 111 | * If the argument is an anonymous variable, then we report an error, 112 | because we can't have anonymous variables in the head: an anonymous 113 | variable can't provide a mode. 114 | * If the argument is a named variable, then look up its mode and indicate 115 | that it provides that mode. If the mode isn't found in the environment, 116 | then we report an error. 117 | 118 | Third, now that for each predicate, we have a mode list for each of the rules 119 | that combine it, we combine these lists together so that we have a single mode 120 | list for each predicate, by taking the lower bound of each element in the list 121 | over all of the defining rules. 122 | 123 | Now that we know the argument modes for each predicate, 124 | iterate with this new information, until none of the modes 125 | for any of the predicates change. 126 | 127 | -} 128 | 129 | modeCheck :: CtxModes -> [(Pred, [SynRule])] -> Check CtxModes 130 | modeCheck appModes preds = iter (iterEnterClause addPred preds) 131 | where 132 | iter :: (CtxModes -> Check CtxModes) -> Check CtxModes 133 | iter f = iter' empty where 134 | iter' m = let (m', errs) = runWriter (f m) 135 | in if m' == m then tell errs >> return m 136 | else iter' m' 137 | 138 | addPred :: (Pred, [SynRule]) -> CtxModes -> CheckPos PredPos CtxModes 139 | addPred (pred, clauses) m = liftM (addPredMode pred m) (checkPred m clauses) 140 | 141 | addPredMode :: Pred -> CtxModes -> Maybe [ArgMode] -> CtxModes 142 | addPredMode pred m (Just argModes) = insert pred argModes m 143 | addPredMode _ m Nothing = m 144 | 145 | checkPred :: CtxModes -> [SynRule] -> CheckPos PredPos (Maybe [ArgMode]) 146 | checkPred modes clauses = liftM lwb (mapEnterM checkRule clauses) 147 | where 148 | lwb :: [Maybe [ArgMode]] -> Maybe [ArgMode] 149 | lwb clauseModes = fmap (map minimum . transpose) (sequence clauseModes) 150 | 151 | checkRule :: SynRule -> CheckPos ClausePos (Maybe [ArgMode]) 152 | checkRule (Rule (Atom NoCtx _ args) b) = do 153 | e <- iterEnter checkAtom b empty 154 | liftM sequence (mapEnterM (checkArg e) args) 155 | where 156 | checkArg :: ModeEnv -> SynTerm -> CheckPos HeadArgPos (Maybe ArgMode) 157 | checkArg e t@(Val _) = return (Just (P S)) 158 | checkArg e t@(Var Anon) = noMode (show t ++ " in head") 159 | checkArg e t@(Var (Named v)) = case lookup v e of 160 | Just m -> return (Just (P m)) 161 | Nothing -> noMode ("Can not derive mode for head term " ++ show t) 162 | noMode msg = errPos msg >> return Nothing 163 | 164 | checkAtom :: SynBodyAtom -> ModeEnv -> CheckPos BodyPos ModeEnv 165 | checkAtom (Atom ctx pred args) e = 166 | let argModes = case ctx of 167 | JustCtx (Val (SString "application")) -> 168 | case lookup pred appModes of 169 | Just argModes -> argModes 170 | Nothing -> repeat (P S) 171 | NothingCtx -> 172 | case lookup pred modes of 173 | Just argModes -> argModes 174 | Nothing -> repeat (P L) 175 | _ -> repeat (P L) 176 | in case ctx of 177 | JustCtx ctx -> withReaderT enterBodyCtx (checkArg ctx (R L) e) 178 | NothingCtx -> return e 179 | >>= iterEnter' checkArg (zip args argModes) 180 | where 181 | checkArg :: Show pos => SynTerm -> ArgMode -> ModeEnv -> 182 | CheckPos pos ModeEnv 183 | checkArg t@(Val _) _ e = return e 184 | checkArg t@(Var Anon) (P _) e = return e 185 | checkArg t@(Var Anon) (R m) e = expected t Nothing m >> return e 186 | checkArg t@(Var (Named v)) (P m) e = return (insertWith max v m e) 187 | checkArg t@(Var (Named v)) (R m) e = case lookup v e of 188 | Just m' | m' >= m -> return e 189 | m' -> expected t m' m >> return e 190 | expected :: Show pos => SynTerm -> Maybe TermMode -> TermMode -> 191 | CheckPos pos () 192 | expected t m m' = errPos (show t ++ showMaybe m ++ " found where " ++ 193 | show m' ++ " expected") 194 | showMaybe Nothing = " (mode unknown)" 195 | showMaybe (Just x) = " (" ++ show x ++ ")" 196 | 197 | -- A monad that helps with error reporting. 198 | -- Position stuff is a mess. 199 | 200 | type Check a = Writer Errors a 201 | type CheckPos pos a = ReaderT pos (Writer Errors) a 202 | type Errors = [String] -> [String] 203 | 204 | data PredPos = PredPos Pred 205 | data ClausePos = ClausePos PredPos Int 206 | data HeadArgPos = HeadArgPos ClausePos Int 207 | data BodyPos = BodyPos ClausePos Int 208 | data BodyCtxPos = BodyCtxPos BodyPos 209 | data BodyArgPos = BodyArgPos BodyPos Int 210 | 211 | instance Show PredPos where 212 | showsPrec _ (PredPos pred) = shows pred 213 | instance Show ClausePos where 214 | showsPrec _ (ClausePos p n) = shows p . (", clause "++) . shows n 215 | instance Show HeadArgPos where 216 | showsPrec _ (HeadArgPos p n) = shows p . (", arg "++) . shows n 217 | instance Show BodyPos where 218 | showsPrec _ (BodyPos p n) = shows p . (", atom "++) . shows n 219 | instance Show BodyCtxPos where 220 | showsPrec _ (BodyCtxPos p) = shows p . (", context"++) 221 | instance Show BodyArgPos where 222 | showsPrec _ (BodyArgPos p n) = shows p . (", arg "++) . shows n 223 | 224 | class Enter pos pos' obj | pos' -> pos obj, pos obj -> pos' where 225 | enter :: pos -> Int -> pos' 226 | 227 | instance Enter PredPos ClausePos SynRule where enter = ClausePos 228 | instance Enter ClausePos HeadArgPos (SynTerm) where enter = HeadArgPos 229 | instance Enter ClausePos BodyPos (SynBodyAtom) where enter = BodyPos 230 | instance Enter BodyPos BodyArgPos (SynTerm) where enter = BodyArgPos 231 | 232 | enterPred = PredPos 233 | enterBodyCtx = BodyCtxPos 234 | 235 | mapEnter :: Enter pos pos' obj => (obj -> CheckPos pos' a) -> [obj] -> 236 | [CheckPos pos a] 237 | mapEnter f xs = zipWith body [1..] xs where 238 | body n x = withReaderT (\pos -> enter pos n) (f x) 239 | mapEnterM f xs = sequence (mapEnter f xs) 240 | mapEnterM_ f xs = sequence_ (mapEnter f xs) 241 | 242 | iterEnter :: Enter pos pos' obj => (obj -> a -> CheckPos pos' a) -> [obj] -> 243 | (a -> CheckPos pos a) 244 | iterEnter f xs = iter (zipWith body [1..] xs) where 245 | body n x z = withReaderT (\pos -> enter pos n) (f x z) 246 | 247 | iterEnter' :: Enter pos pos' obj => (obj -> b -> a -> CheckPos pos' a) -> 248 | [(obj, b)] -> (a -> CheckPos pos a) 249 | iterEnter' f xs = iter (zipWith body [1..] xs) where 250 | body n (x, y) z = withReaderT (\pos -> enter pos n) (f x y z) 251 | 252 | mapEnterClause :: ([SynRule] -> CheckPos PredPos a) -> 253 | [(Pred, [SynRule])] -> [Check a] 254 | mapEnterClause f preds = map body preds where 255 | body (pred, clauses) = runReaderT (f clauses) (enterPred pred) 256 | mapEnterClauseM f preds = sequence (mapEnterClause f preds) 257 | mapEnterClauseM_ f preds = sequence_ (mapEnterClause f preds) 258 | 259 | iterEnterClause :: ((Pred, [SynRule]) -> a -> CheckPos PredPos a) -> 260 | [(Pred, [SynRule])] -> a -> Check a 261 | iterEnterClause f preds = iter (map body preds) where 262 | body p@(pred, _) z = runReaderT (f p z) (enterPred pred) 263 | 264 | err :: String -> Check () 265 | err msg = tell (msg :) 266 | 267 | errPos :: Show pos => String -> CheckPos pos () 268 | errPos msg = ask >>= \pos -> tell ((show pos ++ ": " ++ msg) :) 269 | 270 | checkErrs :: Monad m => Check a -> m a 271 | checkErrs m = let (r, errs) = runWriter m in case errs [] of 272 | [] -> return r 273 | errs -> fail (foldr1 (\s1 s2 -> s1 ++ "\n" ++ s2) errs) 274 | 275 | iter :: Monad m => [a -> m a] -> (a -> m a) 276 | iter = foldr (\f g x -> f x >>= g) return 277 | 278 | -- tests 279 | 280 | undefT = (1, ["foo(a) :- bar(a)."]) 281 | anonHeadT = (1, ["foo(?)."]) 282 | unusedHeadT = (1, ["foo(?a)."]) 283 | rsT = (1, ["foo(1) :- application says rs(?a)."]) 284 | rsT' = (2, ["foo(?a) :- application says rs(?a)."]) 285 | rsAnonT = (1, ["foo(1) :- application says rs(?)."]) 286 | rlT = (1, ["foo(1) :- application says rl(?a)."]) 287 | rlT' = (2, ["foo(?a) :- application says rl(?a)."]) 288 | rlAnonT = (1, ["foo(1) :- application says rl(?)."]) 289 | saysT = (1, ["foo(1) :- ?a says foo(1)."]) 290 | saysAnonT = (1, ["foo(1) :- ? says foo(1)."]) 291 | saysOkT = (0, ["foo(1) :- someone says foo(?a),\ 292 | \?a says foo(1)."]) 293 | rsFactT = (0, ["foo(1).", 294 | "bar(?a) :- foo(?a), application says rs(?a)."]) 295 | rsAppFactT = (0, ["bar(?a) :- application says foo(?a),\ 296 | \application says rs(?a)."]) 297 | rlRuleT = (0, ["bar(?a) :- someone says foo(?a),\ 298 | \application says rl(?a)."]) 299 | rsRuleT = (1, ["bar(?a) :- someone says foo(?a),\ 300 | \application says rs(?a)."]) 301 | rsChainT = (0, ["foo(1).", 302 | "bar(?a) :- foo(?a).", 303 | "baz(?a) :- bar(?a), application says rs(?a)."]) 304 | multiT = (1, ["foo(1).", 305 | "foo(?x) :- foo(?x).", 306 | "bar(?a) :- foo(?a), application says rs(?a)."]) 307 | improveT = (0, ["foo(1).", 308 | "bar(?a) :- bar(?a), foo(?a).", 309 | "baz(?a) :- bar(?a), application says rs(?a)."]) 310 | deproveT = (0, ["foo(1).", 311 | "bar(?a) :- foo(?a), bar(?a).", 312 | "baz(?a) :- bar(?a), application says rs(?a)."]) 313 | 314 | test = do assertErrs anonHeadT 315 | assertErrs unusedHeadT 316 | assertErrs rsT 317 | assertErrs rsT' 318 | assertErrs rsAnonT 319 | assertErrs rlT 320 | assertErrs rlT' 321 | assertErrs rlAnonT 322 | assertErrs saysT 323 | assertErrs saysAnonT 324 | assertErrs saysOkT 325 | assertErrs rsFactT 326 | assertErrs rsAppFactT 327 | assertErrs rlRuleT 328 | assertErrs rsRuleT 329 | assertErrs rsChainT 330 | assertErrs multiT 331 | assertErrs improveT 332 | assertErrs deproveT 333 | 334 | assertErrs :: (Int, [String]) -> IO () 335 | assertErrs (n, ps) = assert (length (testCheck ps) == n) 336 | 337 | assert :: Bool -> IO () 338 | assert True = putStrLn "assertion passed" 339 | assert False = fail "assertion failed" 340 | 341 | testCheck :: [String] -> [String] 342 | testCheck s = let rules = uncheckedParse assertionL (concat s) 343 | appModes = fromList [(Pred "rs" 1, [R S]), 344 | (Pred "rl" 1, [R L])] 345 | (_, errs) = runWriter $ do (m, preds) <- groupRules' rules 346 | checkUndefined m preds 347 | modeCheck appModes preds 348 | in errs [] 349 | 350 | -------------------------------------------------------------------------------- /Soutei/Client.hs: -------------------------------------------------------------------------------- 1 | module Soutei.Client ( 2 | ServiceAddress(..), parseServiceAddress, 3 | queryRemote 4 | ) where 5 | 6 | import Control.Monad.Error () -- just for instance Monad Either 7 | import Data.Maybe (fromMaybe) 8 | import Network 9 | import System.IO 10 | 11 | import Soutei.Sexpr as Sexpr 12 | import Soutei.Soutei as Soutei 13 | import Soutei.Syntax 14 | 15 | data ServiceAddress = HostPort HostName PortID 16 | 17 | parseServiceAddress :: Monad m => String -> m ServiceAddress 18 | parseServiceAddress s = 19 | let (host, port) = break (== ':') s 20 | in case port of 21 | ':':port -> case reads port of 22 | [(port,"")] -> return (HostPort host (PortNumber (fromInteger port))) 23 | _ -> return (HostPort host (Service port)) 24 | _ -> fail "cannot parse host:port" 25 | 26 | instance Read ServiceAddress where 27 | readsPrec _ s = map (\r -> (r, "")) (eitherToList (parseServiceAddress s)) 28 | 29 | eitherToList :: Either String a -> [a] 30 | eitherToList (Left _) = [] 31 | eitherToList (Right x) = [x] 32 | 33 | queryRemote :: ServiceAddress -> String -> [Fact] -> Goal -> IO Bool 34 | queryRemote (HostPort host port) id facts goal = 35 | let q = Sexpr.fromList (Sexpr.Atom (Val (SString id)) : 36 | Sexpr.Atom (Val (SString "query")) : 37 | atomToSexpr goal : 38 | map (atomToSexpr . factToAtom) facts) 39 | in do h <- connectTo host port 40 | hPrint h q 41 | hFlush h 42 | r <- hGetContents h 43 | fromMaybe (fail "Unexpected reply from Soutei") 44 | (lookup r [("(" ++ id ++ " #t)\n", return True), 45 | ("(" ++ id ++ " #f)\n", return False)]) 46 | 47 | atomToSexpr :: HeadAtom v -> Sexpr.Sexpr (Term v) 48 | atomToSexpr (Soutei.Atom NoCtx (Pred pred arity) args) = 49 | Sexpr.fromAtomList (Val (SString pred):args) 50 | 51 | t = let facts = [Soutei.Atom NoCtx (Pred "foo" 1) [Val (SString "bar")]] 52 | goal = Soutei.Atom NoCtx (Pred "may" 1) [Val (SString "HTTP")] 53 | in queryRemote (read "localhost:1500") "test" facts goal 54 | -------------------------------------------------------------------------------- /Soutei/FBackTrack.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | -- Simple Fair back-tracking monad 4 | -- Based on the Scheme code book-si, `Stream implementation, with incomplete' 5 | -- as of Feb 18, 2005 6 | 7 | module Soutei.FBackTrack where 8 | 9 | import Control.Monad 10 | 11 | data Stream a = Nil | One a | Choice a (Stream a) | Incomplete (Stream a) 12 | | IncompleteR (Stream a) 13 | deriving Show 14 | 15 | instance Monad Stream where 16 | return = One 17 | 18 | Nil >>= f = Nil 19 | One a >>= f = f a 20 | Choice a r >>= f = f a `mplus` (Incomplete (r >>= f)) 21 | {- 22 | Incomplete i >>= f = case i of 23 | Incomplete j -> Incomplete (j >>= f) 24 | _ -> i >>= f 25 | -} 26 | IncompleteR i >>= f = IncompleteR (i >>= f) 27 | Incomplete i >>= f = Incomplete (i >>= f) 28 | 29 | instance MonadPlus Stream where 30 | mzero = Nil 31 | 32 | mplus Nil r' = Incomplete r' 33 | mplus (One a) r' = Choice a r' 34 | mplus (Choice a r) r' = Choice a (mplus r' r) -- interleaving! 35 | --mplus (Incomplete i) r' = Incomplete (mplus i r') 36 | mplus r@(Incomplete i) r' = 37 | case r' of 38 | Nil -> r 39 | One b -> Choice b i 40 | Choice b r' -> Choice b (mplus i r') 41 | -- Choice _ _ -> Incomplete (mplus r' i) 42 | Incomplete j -> (Incomplete (mplus i j)) 43 | IncompleteR j -> IncompleteR (mplus i j) 44 | mplus r@(IncompleteR i) r' = IncompleteR (mplus r' i) 45 | 46 | -- run the Monad, to a specific depth 47 | runM :: Maybe Int -> Stream a -> [a] 48 | runM _ Nil = [] 49 | runM _ (One a) = [a] 50 | runM d (Choice a r) = a : (runM d r) 51 | runM (Just 0) (Incomplete r) = [] -- exhausted depth 52 | runM (Just 0) (IncompleteR r) = [] -- exhausted depth 53 | runM d (Incomplete r) = runM (liftM pred d) r 54 | runM d (IncompleteR r) = runM (liftM pred d) r 55 | 56 | -- Don't try the following with the regular List monad or List comprehension! 57 | -- That would diverge instantly: all `i', `j', and `k' are infinite 58 | -- streams 59 | 60 | pythagorean_triples :: MonadPlus m => m (Int,Int,Int) 61 | pythagorean_triples = 62 | let number = (return 0) `mplus` (number >>= (return . (+1))) in 63 | do 64 | i <- number 65 | guard $ i > 0 66 | j <- number 67 | guard $ j > 0 68 | k <- number 69 | guard $ k > 0 70 | guard $ i*i + j*j == k*k 71 | return (i,j,k) 72 | 73 | test = take 7 $ runM Nothing pythagorean_triples 74 | 75 | -- even more fun 76 | 77 | pythagorean_triples2 :: Stream (Int,Int,Int) 78 | pythagorean_triples2 = 79 | let number = (IncompleteR number >>= \n -> return (n+1)) `mplus` return 0 in 80 | do i <- number 81 | j <- number 82 | k <- number 83 | guard $ i*i + j*j == k*k 84 | return (i,j,k) 85 | 86 | test2 = take 7 $ filter (\(x,y,_) -> x*y/=0) $ runM Nothing pythagorean_triples2 87 | 88 | -- test different branching strategies 89 | -- note--ensure that structures aren't shared 90 | 91 | -- m = y (m + m + ... + m) 92 | t1 n = y (msum (map ($ n) (replicate n t1))) 93 | 94 | -- m = (y m + y m + ... + y m) 95 | t2 n = msum (map (y . ($ n)) (replicate n t2)) 96 | 97 | -- m = y (m + y (m + y (... + y m)...)) 98 | t3 n = y (foldr1 (\m m' -> mplus m (y m')) (map ($ n) (replicate n t3))) 99 | t3' n = foldr (\m m' -> y (mplus m m')) mzero (map ($ n) (replicate n t3')) 100 | 101 | -- m = y $ y $ ... $ y (m + m + ... + m) 102 | t4 n = foldr1 (.) (replicate n y) (msum (map ($ n) (replicate n t4))) 103 | 104 | -- m = y $ y $ ... $ y (m + m + ... + m) (~ ln n y's) 105 | t5 n = let n' = 1 + floor (log (fromIntegral n)) 106 | t n = foldr1 (.) (replicate n' y) (msum (map ($ n) (replicate n t))) 107 | in t n 108 | 109 | y = IncompleteR 110 | -------------------------------------------------------------------------------- /Soutei/FBackTrackT.hs: -------------------------------------------------------------------------------- 1 | {- Haskell98! -} 2 | 3 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/FBackTrackT.hs $ 4 | -- $Id: FBackTrackT.hs 2926 2012-09-07 04:43:30Z oleg.kiselyov $ 5 | -- svn propset svn:keywords "HeadURL Id" filename 6 | 7 | -- Simple Fair back-tracking monad TRANSFORMER 8 | -- Made by `transforming' the stand-alone monad from FBackTrack.hs, 9 | -- which, in turn, is based on the Scheme code book-si, 10 | -- `Stream implementation, with incomplete' as of Feb 18, 2005 11 | -- 12 | -- The transformatiion from a stand-alone Stream monad to a monad transformer 13 | -- is not at all similar to the trick described in Ralf Hinze's ICFP'00 paper, 14 | -- Deriving backtracking monad transformers. 15 | 16 | -- $Id: FBackTrackT.hs 2926 2012-09-07 04:43:30Z oleg.kiselyov $ 17 | 18 | module Soutei.FBackTrackT (Stream, yield, runM) where 19 | 20 | import Control.Monad 21 | import Control.Monad.Trans 22 | import Control.Monad.Identity 23 | 24 | data StreamE m a = Nil | One a | 25 | Choice a (Stream m a) | 26 | Incomplete (Stream m a) 27 | 28 | newtype Stream m a = Stream{unStream :: m (StreamE m a)} 29 | 30 | 31 | instance Monad m => Monad (Stream m) where 32 | return = Stream . return . One 33 | 34 | m >>= f = Stream (unStream m >>= bind) 35 | where 36 | bind Nil = return Nil 37 | bind (One a) = unStream $ f a 38 | bind (Choice a r) = unStream $ f a `mplus` (yield (r >>= f)) 39 | bind (Incomplete i) = return $ Incomplete (i >>= f) 40 | 41 | yield :: Monad m => Stream m a -> Stream m a 42 | yield = Stream . return . Incomplete 43 | 44 | instance Monad m => MonadPlus (Stream m) where 45 | mzero = Stream $ return Nil 46 | 47 | mplus m1 m2 = Stream (unStream m1 >>= mplus') 48 | where 49 | mplus' Nil = return $ Incomplete m2 50 | mplus' (One a) = return $ Choice a m2 51 | mplus' (Choice a r) = return $ Choice a (mplus m2 r) -- interleaving! 52 | --mplus' (Incomplete i) = return $ Incomplete (mplus i m2) 53 | mplus' r@(Incomplete i) = unStream m2 >>= \r' -> 54 | case r' of 55 | Nil -> return r 56 | One b -> return $ Choice b i 57 | Choice b r' -> return $ Choice b (mplus i r') 58 | -- Choice _ _ -> Incomplete (mplus r' i) 59 | Incomplete j -> return $ Incomplete $ Stream $ return $ Incomplete (mplus i j) 60 | 61 | 62 | instance MonadTrans Stream where 63 | lift m = Stream (m >>= return . One) 64 | 65 | instance MonadIO m => MonadIO (Stream m) where 66 | liftIO = lift . liftIO 67 | 68 | 69 | -- run the Monad, to a specific depth, and give at most 70 | -- specified number of answers. The monad `m' may be strict (like IO), 71 | -- so we can't count on the laziness of the `[a]' 72 | runM :: Monad m => Maybe Int -> Maybe Int -> Stream m a -> m [a] 73 | runM _ (Just 0) _ = return [] -- out of breadth 74 | runM d b m = unStream m >>= runM' d b 75 | runM' _ _ Nil = return [] 76 | runM' _ _ (One a) = return [a] 77 | runM' d b (Choice a r) = do t <- runM d (liftM pred b) r; return (a:t) 78 | runM' (Just 0) _ (Incomplete r) = return [] -- exhausted depth 79 | runM' d b (Incomplete r) = runM (liftM pred d) b r 80 | 81 | 82 | -- Don't try the following with the regular List monad or List comprehension! 83 | -- That would diverge instantly: all `i', `j', and `k' are infinite 84 | -- streams 85 | 86 | pythagorean_triples :: MonadPlus m => m (Int,Int,Int) 87 | pythagorean_triples = 88 | let number = (return 0) `mplus` (number >>= return . succ) in 89 | do 90 | i <- number 91 | guard $ i > 0 92 | j <- number 93 | guard $ j > 0 94 | k <- number 95 | guard $ k > 0 96 | guard $ i*i + j*j == k*k 97 | return (i,j,k) 98 | 99 | -- If you run this in GHCi, you can see that Indetity is a lazy monad 100 | -- and IO is strict: evaluating `test' prints the answers as they are computed. 101 | -- OTH, testio runs silently for a while and then prints all the answers 102 | -- at once 103 | test = runIdentity $ runM Nothing (Just 7) pythagorean_triples 104 | testio = runM Nothing (Just 7) pythagorean_triples >>= print 105 | 106 | 107 | -- The following code is not in general MonadPlus: it uses Incomplete 108 | -- explicitly. But it supports left recursion! Note that in OCaml, for example, 109 | -- we _must_ include that Incomplete data constructor to make 110 | -- the recursive definition well-formed. 111 | -- The code does *not* get stuck in the generation of primitive tuples 112 | -- like (0,1,1), (0,2,2), (0,3,3) etc. 113 | pythagorean_triples' :: Monad m => Stream m (Int,Int,Int) 114 | pythagorean_triples' = 115 | let number = (yield number >>= return . succ) `mplus` return 0 in 116 | do 117 | i <- number 118 | j <- number 119 | k <- number 120 | guard $ i*i + j*j == k*k 121 | return (i,j,k) 122 | 123 | test' = runIdentity $ runM Nothing (Just 27) pythagorean_triples' 124 | testio' = runM Nothing (Just 27) pythagorean_triples' >>= print 125 | 126 | pythagorean_triples'' :: Stream IO (Int,Int,Int) 127 | pythagorean_triples'' = 128 | let number = (yield number >>= return . succ) `mplus` return 0 in 129 | do 130 | i <- number 131 | j <- number 132 | k <- number 133 | liftIO $ print (i,j,k) 134 | guard $ i*i + j*j == k*k 135 | return (i,j,k) 136 | 137 | testio'' = runM Nothing (Just 7) pythagorean_triples'' >>= print 138 | 139 | -- a serious test of left recursion (due to Will Byrd) 140 | flaz x = yield (flaz x) `mplus` (yield (flaz x) `mplus` 141 | if x == 5 then return x else mzero) 142 | test_flaz = runIdentity $ runM Nothing (Just 15) (flaz 5) 143 | -------------------------------------------------------------------------------- /Soutei/GBBFS.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | -- A monad TRANSFORMER for BFS or DFS traversal 4 | -- The function dfs'or'bfs2 below determines which is which 5 | 6 | module Soutei.GBBFS (Stream, yield, runM) where 7 | 8 | import Control.Monad 9 | import Control.Monad.Trans 10 | import Control.Monad.Identity 11 | 12 | import Data.IORef -- for tests 13 | 14 | --import Debug.Trace -- for tests 15 | import System.IO.Unsafe -- because Debug.Trace.trace doesn't work after interr 16 | import System.Mem.StableName -- for tests 17 | trace str x = unsafePerformIO (putStrLn str) `seq` x 18 | 19 | 20 | -- The following two lines choose DFS or BFS traversal 21 | -- dfs'or'bfs2 r1 r2 = r1 ++ r2 22 | dfs'or'bfs2 r1 r2 = r2 ++ r1 23 | 24 | 25 | newtype Monad m => Stream m a = Stream{unStream :: m (StreamE m a)} 26 | type StreamE m a = (Maybe a, [Stream m a]) 27 | 28 | instance Monad m => Monad (Stream m) where 29 | return x = Stream (return (Just x, [])) 30 | 31 | m >>= f = Stream (unStream m >>= bind) 32 | where 33 | bind (ans, r) = return $ let q' = map (>>=f) r 34 | in (Nothing, maybe q' (\x -> f x : q') ans) 35 | 36 | 37 | instance Monad m => MonadPlus (Stream m) where 38 | mzero = Stream (return (Nothing, [])) 39 | 40 | mplus m1 m2 = Stream (unStream m1 >>= mplus') 41 | where 42 | mplus' (ans, r) = return $ (ans, m2:r) 43 | 44 | instance MonadTrans Stream where 45 | lift m = Stream (m >>= \x -> return (Just x, [])) 46 | 47 | instance MonadIO m => MonadIO (Stream m) where 48 | liftIO = lift . liftIO 49 | 50 | yield :: Monad m => Stream m a -> Stream m a 51 | yield = mplus mzero 52 | 53 | -- run the Monad, to a specific depth, and give at most 54 | -- specified number of answers. The monad `m' may be strict (like IO), 55 | -- so we can't count on the laziness of the `[a]' 56 | runM :: Monad m => Maybe Int -> Maybe Int -> Stream m a -> m [a] 57 | runM d b m = runM' d b [m] 58 | runM' d b m | trace ("Queue size " ++ show (length m)) False = undefined 59 | runM' _ (Just 0) _ = return [] -- out of breadth 60 | runM' _ _ [] = return [] -- finished 61 | runM' d b (m:r) = unStream m >>= runM'' d b r 62 | runM'' _ _ [] (Nothing,[]) = return [] 63 | runM'' _ _ [] (Just a, []) = return [a] 64 | runM'' d b r' (Just a, r) = 65 | do t <- runM' d (liftM pred b) (dfs'or'bfs2 r r'); return (a:t) 66 | runM'' (Just 0) _ _ (Nothing, r) = return [] -- exhausted depth 67 | runM'' d b r' (Nothing, r) = runM' (liftM pred d) b (dfs'or'bfs2 r r') 68 | 69 | ------------------------------------------------------------------------ 70 | -- Tests 71 | 72 | -- Testing that order solutions are generated 73 | 74 | nat :: MonadPlus m => m Int 75 | nat = return 0 `mplus` (nat >>= return . succ) 76 | 77 | testn0 = runIdentity $ runM Nothing (Just 10) nat 78 | testn1 = runIdentity $ runM Nothing (Just 32) 79 | (nat >>= \i -> nat >>= \j -> return (i,j)) 80 | 81 | {- For the true BFS, the solutions are generated in the order 82 | i+j=const 83 | *GBBFS> testn1 84 | [(0,0),(0,1),(1,0),(0,2),(1,1),(2,0),(0,3),(1,2),(2,1),(3,0), 85 | (0,4),(1,3),(2,2),(3,1),(4,0),(0,5),(1,4),(2,3),(3,2),(4,1),(5,0)] 86 | -} 87 | 88 | -- This test shows that effects associated with the solutions are 89 | -- NOT duplicated 90 | -- Compare with the corresponding test in FBIDFS.hs 91 | natio :: Stream IO Int 92 | natio = do n <- natio'; liftIO $ print n; return n 93 | where natio' = return 0 `mplus` (natio' >>= return . succ) 94 | 95 | testn2 = runM Nothing (Just 5) natio >>= print 96 | 97 | -- Don't try the following with the regular List monad or List comprehension! 98 | -- That would diverge instantly: all `i', `j', and `k' are infinite 99 | -- streams 100 | 101 | pythagorean_triples :: MonadPlus m => m (Int,Int,Int) 102 | pythagorean_triples = 103 | let number = (return 0) `mplus` (number >>= return . succ) in 104 | do 105 | i <- number 106 | guard $ i > 0 107 | j <- number 108 | guard $ j > 0 109 | k <- number 110 | guard $ k > 0 111 | guard $ i*i + j*j == k*k 112 | return (i,j,k) 113 | 114 | -- If you run this in GHCi, you can see that Indetity is a lazy monad 115 | -- and IO is strict: evaluating `test' prints the answers as they are computed. 116 | -- OTH, testio runs silently for a while and then prints all the answers 117 | -- at once 118 | test = runIdentity $ runM Nothing (Just 7) pythagorean_triples 119 | testio = runM Nothing (Just 7) pythagorean_triples >>= print 120 | 121 | 122 | -- The following code is not in general MonadPlus: it uses Incomplete 123 | -- explicitly. But it supports left recursion! Note that in OCaml, for example, 124 | -- we _must_ include that Incomplete data constructor to make 125 | -- the recursive definition well-formed. 126 | -- The code does *not* get stuck in the generation of primitive tuples 127 | -- like (0,1,1), (0,2,2), (0,3,3) etc. 128 | pythagorean_triples' :: Monad m => Stream m (Int,Int,Int) 129 | pythagorean_triples' = 130 | let number = (yield number >>= return . succ) `mplus` return 0 in 131 | do 132 | i <- number 133 | j <- number 134 | k <- number 135 | guard $ i*i + j*j == k*k 136 | return (i,j,k) 137 | 138 | test' = runIdentity $ runM Nothing (Just 27) pythagorean_triples' 139 | testio' = runM Nothing (Just 27) pythagorean_triples' >>= print 140 | 141 | pythagorean_triples'' :: Stream IO (Int,Int,Int) 142 | pythagorean_triples'' = 143 | let number = (yield number >>= return . succ) `mplus` return 0 in 144 | do 145 | i <- number 146 | j <- number 147 | k <- number 148 | liftIO $ print (i,j,k) 149 | guard $ i*i + j*j == k*k 150 | return (i,j,k) 151 | 152 | testio'' = runM Nothing (Just 7) pythagorean_triples'' >>= print 153 | 154 | -- a serious test of left recursion (due to Will Byrd) 155 | flaz x = yield (flaz x) `mplus` (yield (flaz x) `mplus` 156 | if x == 5 then return x else mzero) 157 | test_flaz = runIdentity $ runM Nothing (Just 15) (flaz 5) 158 | 159 | 160 | test_gt0 :: Stream IO Int 161 | test_gt0 = 162 | do 163 | g_count <- liftIO $ newIORef 0 164 | t_count <- liftIO $ newIORef 0 165 | let clear = (liftIO $ writeIORef g_count 0) >> 166 | (liftIO $ writeIORef t_count 0) 167 | let g = do 168 | liftIO $ modifyIORef g_count succ 169 | return 0 `mplus` (g >>= \y -> return $ 3*y + 1) 170 | t x = do 171 | -- liftIO $ print $ "t: " ++ (show x) 172 | liftIO $ modifyIORef t_count succ 173 | (if x == - 10 then return x else mzero) `mplus` t (x-1) 174 | clear 175 | r <- g >>= t 176 | gc <- liftIO $ readIORef g_count 177 | tc <- liftIO $ readIORef t_count 178 | clear 179 | liftIO $ putStrLn $ "g_count: " ++ (show gc) ++ 180 | ", t_count: " ++ (show tc) 181 | return r 182 | 183 | -- runM Nothing (Just 2) test_gt0 >>= print 184 | 185 | test_gt1 :: Stream IO Int 186 | test_gt1 = 187 | do 188 | g_count <- liftIO $ newIORef 0 189 | t_count <- liftIO $ newIORef 0 190 | let clear = (liftIO $ writeIORef g_count 0) >> 191 | (liftIO $ writeIORef t_count 0) 192 | let g = do 193 | liftIO $ modifyIORef g_count succ 194 | (yield g >>= \y -> return $ 3*y + 1) `mplus` return 0 195 | t x = do 196 | -- liftIO $ print $ "t: " ++ (show x) 197 | liftIO $ modifyIORef t_count succ 198 | (yield $ t (x-1)) `mplus` 199 | (if x == - 10 then return x else mzero) 200 | clear 201 | r <- g >>= t 202 | gc <- liftIO $ readIORef g_count 203 | tc <- liftIO $ readIORef t_count 204 | clear 205 | liftIO $ putStrLn $ "g_count: " ++ (show gc) ++ 206 | ", t_count: " ++ (show tc) 207 | return r 208 | 209 | 210 | -- test for the scheduling order 211 | -- it seems like BFS... 212 | test_sched n = runM (Just n) Nothing (t "") 213 | where 214 | t l | trace l False = undefined 215 | t l = Stream(return (Nothing, [(mplus (t ('0':l)) (t ('1':l)))])) 216 | 217 | 218 | pythagorean_triplesi :: MonadPlus m => () -> m (Int,Int,Int) 219 | pythagorean_triplesi () = 220 | let number l = trace ("Label: " ++ l) 221 | (return 0) `mplus` (number ('R':l)>>= return . succ) in 222 | do 223 | i <- number "i" 224 | guard $ i > 0 225 | j <- number ("j" ++ (replicate i 'R')) 226 | guard $ j > 0 227 | k <- number ("k" ++ (replicate i 'R') ++ "," ++ (replicate j 'R')) 228 | guard $ k > 0 229 | guard $ i*i + j*j == k*k 230 | return (i,j,k) 231 | 232 | testi n = runM (Just n) Nothing (pythagorean_triplesi ()) 233 | -------------------------------------------------------------------------------- /Soutei/GBBFS1.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | -- A monad TRANSFORMER for BFS or DFS traversal 4 | -- The function dfs'or'bfs2 below determines which is which 5 | 6 | module Soutei.GBBFS1 (Stream, yield, runM) where 7 | 8 | import Control.Monad 9 | import Control.Monad.Trans 10 | import Control.Monad.Identity 11 | 12 | import Data.IORef -- for tests 13 | 14 | --import Debug.Trace -- for tests 15 | import System.IO.Unsafe -- because Debug.Trace.trace doesn't work after interr 16 | import System.Mem.StableName -- for tests 17 | trace str x = unsafePerformIO (putStrLn str) `seq` x 18 | 19 | 20 | -- The following two lines choose DFS or BFS traversal 21 | -- dfs'or'bfs2 r1 r2 = r1 ++ r2 22 | dfs'or'bfs2 r1 r2 = r2 ++ r1 23 | 24 | 25 | newtype Monad m => Stream m a = Stream{unStream :: m (StreamE m a)} 26 | type StreamE m a = (Maybe a, [Stream m a]) 27 | 28 | instance Monad m => Monad (Stream m) where 29 | return x = Stream (return (Just x, [])) 30 | 31 | m >>= f = Stream (unStream m >>= bind) 32 | where 33 | -- the following was an absolutely critical update to reduce the 34 | -- queue size. Cf with the corresponding bind method of GBBFS.hs 35 | bind (Nothing, r) = return (Nothing, map (>>=f) r) 36 | bind (Just x, r) = let q' = map (>>=f) r 37 | in unStream (mplus (f x) 38 | (Stream (return (Nothing, q')))) 39 | 40 | 41 | instance Monad m => MonadPlus (Stream m) where 42 | mzero = Stream (return (Nothing, [])) 43 | 44 | mplus m1 m2 = Stream (unStream m1 >>= mplus') 45 | where 46 | mplus' (Nothing,r@(_:_)) = unStream m2 >>= mplus'' r 47 | mplus' (ans, r) = return $ (ans, m2:r) 48 | -- the following was critical for the fairness test_shed 49 | mplus'' r (ans,r') = return $ (ans, r ++ r') 50 | 51 | 52 | 53 | instance MonadTrans Stream where 54 | lift m = Stream (m >>= \x -> return (Just x, [])) 55 | 56 | instance MonadIO m => MonadIO (Stream m) where 57 | liftIO = lift . liftIO 58 | 59 | yield :: Monad m => Stream m a -> Stream m a 60 | yield = mplus mzero 61 | 62 | -- run the Monad, to a specific depth, and give at most 63 | -- specified number of answers. The monad `m' may be strict (like IO), 64 | -- so we can't count on the laziness of the `[a]' 65 | runM :: Monad m => Maybe Int -> Maybe Int -> Stream m a -> m [a] 66 | runM d b m = runM' d b [m] 67 | -- runM' d b m | trace ("Queue size " ++ show (length m)) False = undefined 68 | runM' _ (Just 0) _ = return [] -- out of breadth 69 | runM' _ _ [] = return [] -- finished 70 | runM' d b (m:r) = unStream m >>= runM'' d b r 71 | runM'' _ _ [] (Nothing,[]) = return [] 72 | runM'' _ _ [] (Just a, []) = return [a] 73 | runM'' d b r' (Just a, r) = 74 | do t <- runM' d (liftM pred b) (dfs'or'bfs2 r r'); return (a:t) 75 | runM'' (Just 0) _ _ (Nothing, r) = return [] -- exhausted depth 76 | runM'' d b r' (Nothing, r) = runM' (liftM pred d) b (dfs'or'bfs2 r r') 77 | 78 | ------------------------------------------------------------------------ 79 | -- Tests 80 | 81 | -- Testing that order solutions are generated 82 | 83 | nat :: MonadPlus m => m Int 84 | nat = return 0 `mplus` (nat >>= return . succ) 85 | 86 | testn0 = runIdentity $ runM Nothing (Just 10) nat 87 | testn1 = runIdentity $ runM Nothing (Just 32) 88 | (nat >>= \i -> nat >>= \j -> return (i,j)) 89 | 90 | {- For the true BFS, the solutions are generated in the order 91 | i+j=const 92 | *GBBFS> testn1 93 | [(0,0),(0,1),(1,0),(0,2),(1,1),(2,0),(0,3),(1,2),(2,1),(3,0), 94 | (0,4),(1,3),(2,2),(3,1),(4,0),(0,5),(1,4),(2,3),(3,2),(4,1),(5,0)] 95 | -} 96 | 97 | -- This test shows that effects associated with the solutions are 98 | -- NOT duplicated 99 | -- Compare with the corresponding test in FBIDFS.hs 100 | natio :: Stream IO Int 101 | natio = do n <- natio'; liftIO $ print n; return n 102 | where natio' = return 0 `mplus` (natio' >>= return . succ) 103 | 104 | testn2 = runM Nothing (Just 5) natio >>= print 105 | 106 | -- Don't try the following with the regular List monad or List comprehension! 107 | -- That would diverge instantly: all `i', `j', and `k' are infinite 108 | -- streams 109 | 110 | pythagorean_triples :: MonadPlus m => m (Int,Int,Int) 111 | pythagorean_triples = 112 | let number = (return 0) `mplus` (number >>= return . succ) in 113 | do 114 | i <- number 115 | guard $ i > 0 116 | j <- number 117 | guard $ j > 0 118 | k <- number 119 | guard $ k > 0 120 | guard $ i*i + j*j == k*k 121 | return (i,j,k) 122 | 123 | -- If you run this in GHCi, you can see that Indetity is a lazy monad 124 | -- and IO is strict: evaluating `test' prints the answers as they are computed. 125 | -- OTH, testio runs silently for a while and then prints all the answers 126 | -- at once 127 | test = runIdentity $ runM Nothing (Just 7) pythagorean_triples 128 | testio = runM Nothing (Just 7) pythagorean_triples >>= print 129 | 130 | 131 | -- The following code is not in general MonadPlus: it uses Incomplete 132 | -- explicitly. But it supports left recursion! Note that in OCaml, for example, 133 | -- we _must_ include that Incomplete data constructor to make 134 | -- the recursive definition well-formed. 135 | -- The code does *not* get stuck in the generation of primitive tuples 136 | -- like (0,1,1), (0,2,2), (0,3,3) etc. 137 | pythagorean_triples' :: Monad m => Stream m (Int,Int,Int) 138 | pythagorean_triples' = 139 | let number = (yield number >>= return . succ) `mplus` return 0 in 140 | do 141 | i <- number 142 | j <- number 143 | k <- number 144 | guard $ i*i + j*j == k*k 145 | return (i,j,k) 146 | 147 | test' = runIdentity $ runM Nothing (Just 27) pythagorean_triples' 148 | testio' = runM Nothing (Just 27) pythagorean_triples' >>= print 149 | 150 | pythagorean_triples'' :: Stream IO (Int,Int,Int) 151 | pythagorean_triples'' = 152 | let number = (yield number >>= return . succ) `mplus` return 0 in 153 | do 154 | i <- number 155 | j <- number 156 | k <- number 157 | liftIO $ print (i,j,k) 158 | guard $ i*i + j*j == k*k 159 | return (i,j,k) 160 | 161 | testio'' = runM Nothing (Just 7) pythagorean_triples'' >>= print 162 | 163 | -- a serious test of left recursion (due to Will Byrd) 164 | flaz x = yield (flaz x) `mplus` (yield (flaz x) `mplus` 165 | if x == 5 then return x else mzero) 166 | test_flaz = runIdentity $ runM Nothing (Just 15) (flaz 5) 167 | 168 | 169 | test_gt0 :: Stream IO Int 170 | test_gt0 = 171 | do 172 | g_count <- liftIO $ newIORef 0 173 | t_count <- liftIO $ newIORef 0 174 | let clear = (liftIO $ writeIORef g_count 0) >> 175 | (liftIO $ writeIORef t_count 0) 176 | let g = do 177 | liftIO $ modifyIORef g_count succ 178 | return 0 `mplus` (g >>= \y -> return $ 3*y + 1) 179 | t x = do 180 | -- liftIO $ print $ "t: " ++ (show x) 181 | liftIO $ modifyIORef t_count succ 182 | (if x == - 10 then return x else mzero) `mplus` t (x-1) 183 | clear 184 | r <- g >>= t 185 | gc <- liftIO $ readIORef g_count 186 | tc <- liftIO $ readIORef t_count 187 | clear 188 | liftIO $ putStrLn $ "g_count: " ++ (show gc) ++ 189 | ", t_count: " ++ (show tc) 190 | return r 191 | 192 | -- runM Nothing (Just 2) test_gt0 >>= print 193 | 194 | test_gt1 :: Stream IO Int 195 | test_gt1 = 196 | do 197 | g_count <- liftIO $ newIORef 0 198 | t_count <- liftIO $ newIORef 0 199 | let clear = (liftIO $ writeIORef g_count 0) >> 200 | (liftIO $ writeIORef t_count 0) 201 | let g = do 202 | liftIO $ modifyIORef g_count succ 203 | (yield g >>= \y -> return $ 3*y + 1) `mplus` return 0 204 | t x = do 205 | -- liftIO $ print $ "t: " ++ (show x) 206 | liftIO $ modifyIORef t_count succ 207 | (yield $ t (x-1)) `mplus` 208 | (if x == - 10 then return x else mzero) 209 | clear 210 | r <- g >>= t 211 | gc <- liftIO $ readIORef g_count 212 | tc <- liftIO $ readIORef t_count 213 | clear 214 | liftIO $ putStrLn $ "g_count: " ++ (show gc) ++ 215 | ", t_count: " ++ (show tc) 216 | return r 217 | 218 | 219 | -- test for the scheduling order 220 | -- it seems like BFS... 221 | test_sched n = runM (Just n) Nothing (t "") 222 | where 223 | t l | trace l False = undefined 224 | t l = Stream(return (Nothing, [(mplus (t ('0':l)) (t ('1':l)))])) 225 | 226 | 227 | pythagorean_triplesi :: MonadPlus m => () -> m (Int,Int,Int) 228 | pythagorean_triplesi () = 229 | let number l = trace ("Label: " ++ l) 230 | (return 0) `mplus` (number ('R':l)>>= return . succ) in 231 | do 232 | i <- number "i" 233 | guard $ i > 0 234 | j <- number ("j" ++ (replicate i 'R')) 235 | guard $ j > 0 236 | k <- number ("k" ++ (replicate i 'R') ++ "," ++ (replicate j 'R')) 237 | guard $ k > 0 238 | guard $ i*i + j*j == k*k 239 | return (i,j,k) 240 | 241 | testi n = runM (Just n) Nothing (pythagorean_triplesi ()) 242 | -------------------------------------------------------------------------------- /Soutei/Lirs.hs: -------------------------------------------------------------------------------- 1 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/Lirs.hs $ 2 | -- $Id: Lirs.hs 2935 2012-09-12 00:42:48Z oleg.kiselyov $ 3 | -- svn propset svn:keywords "HeadURL Id" filename 4 | 5 | -- LIRS: http://parapet.ee.princeton.edu/~sigm2002/papers/p31-jiang.pdf 6 | -- Basic idea: Maintain an LRU list, marking some entries "hot", based on 7 | -- the distance between the last two accesses. Maintain a separate list of 8 | -- "cold" entries, from which we evict. 9 | 10 | module Soutei.Lirs ( 11 | Lirs, Storage(..), new, get, put 12 | ) where 13 | 14 | import Prelude hiding (last, lookup) 15 | import Control.Monad 16 | import Data.IORef 17 | import Data.Map (Map, empty, lookup, insert, delete, elems, size) 18 | import Data.Maybe (fromMaybe) 19 | import System.Random (randomRIO) 20 | 21 | data Lirs k v sv = Lirs { 22 | cache :: IORef (Map k (Entry k v)), 23 | lru :: List (Entry k v), 24 | cold :: List (Entry k v), 25 | storage :: Storage k v sv, 26 | maxHot, maxSize :: Int 27 | -- TODO: limit the number of entries, ie size of lru 28 | } 29 | data Storage k v sv = Storage { 30 | store :: k -> sv -> IO (), 31 | load :: k -> IO v 32 | } 33 | data Entry k v = Entry { 34 | key :: k, 35 | status :: IORef (Status k v) 36 | } 37 | data Status k v = Hot (LruElem k v) v 38 | | Cold (Maybe (LruElem k v)) (ColdElem k v) v 39 | | Out (LruElem k v) 40 | type LirsElem k v = Elem (Entry k v) 41 | type LruElem k v = LirsElem k v 42 | type ColdElem k v = LirsElem k v 43 | 44 | printLirs lirs = do 45 | m <- readIORef (cache lirs) 46 | mapM (\e -> liftM ((,) (key e)) (readIORef (status e))) (elems m) >>= print 47 | toHList (lru lirs) >>= print . map key 48 | toHList (cold lirs) >>= print . map key 49 | 50 | instance Show (Status k v) where 51 | showsPrec _ (Hot _ _) = ("hot" ++) 52 | showsPrec _ (Cold _ _ _) = ("cold" ++) 53 | showsPrec _ (Out _) = ("out" ++) 54 | 55 | new :: Storage k v sv -> Int -> Int -> IO (Lirs k v sv) 56 | new s maxHot maxSize = do when (maxHot < 1 || maxSize < 1 || maxSize < maxHot) 57 | (fail "bad sizes") 58 | cache <- newIORef empty 59 | lruList <- newList 60 | coldList <- newList 61 | return (Lirs cache lruList coldList s maxHot maxSize) 62 | 63 | -- This doesn't count as a hit, but keep if the cache is not yet full. 64 | put :: Ord k => Lirs k v sv -> k -> v -> sv -> IO () 65 | put lirs k v sv = do 66 | (store (storage lirs)) k sv 67 | m <- readIORef (cache lirs) 68 | case lookup k m of 69 | Just entry -> modifyIORef (status entry) (setVal v) 70 | Nothing -> if size m < maxHot lirs 71 | then newHot lirs k v append 72 | else if size m < maxSize lirs 73 | then newCold lirs k v Nothing append 74 | else return () 75 | where 76 | setVal v (Hot lruElem _) = Hot lruElem v 77 | setVal v (Cold lruElem coldElem _) = Cold lruElem coldElem v 78 | setVal v s@(Out _) = s 79 | 80 | get :: Ord k => Lirs k v sv -> k -> IO v 81 | get lirs k = liftM fst (get' lirs k) 82 | 83 | get' lirs k = do 84 | m <- readIORef (cache lirs) 85 | case lookup k m of 86 | Just entry -> do 87 | lruElem' <- prepend (lru lirs) entry 88 | readIORef (status entry) >>= \s -> case s of 89 | Hot lruElem v -> do 90 | remove (lru lirs) lruElem 91 | writeIORef (status entry) (Hot lruElem' v) 92 | prune lirs 93 | return (v, True) 94 | Cold (Just lruElem) coldElem v -> do 95 | remove (lru lirs) lruElem 96 | remove (cold lirs) coldElem 97 | writeIORef (status entry) (Hot lruElem' v) 98 | demoteHot lirs 99 | return (v, True) 100 | Cold Nothing coldElem v -> do 101 | remove (cold lirs) coldElem 102 | coldElem' <- prepend (cold lirs) entry 103 | writeIORef (status entry) (Cold (Just lruElem') coldElem' v) 104 | return (v, True) 105 | Out lruElem -> do 106 | v <- load (storage lirs) k 107 | remove (lru lirs) lruElem 108 | writeIORef (status entry) (Hot lruElem' v) 109 | demoteHot lirs 110 | evictCold lirs 111 | return (v, False) 112 | Nothing -> do v <- load (storage lirs) k 113 | if size m < maxHot lirs 114 | then newHot lirs k v prepend 115 | else if size m < maxSize lirs 116 | then newCold lirs k v (Just prepend) prepend 117 | else do newCold lirs k v (Just prepend) prepend 118 | evictCold lirs 119 | return (v, False) 120 | 121 | newHot lirs k v lruIns = do 122 | status <- newIORef undefined 123 | let entry = Entry k status 124 | lruElem <- lruIns (lru lirs) entry 125 | writeIORef status (Hot lruElem v) 126 | modifyIORef (cache lirs) (insert k entry) 127 | 128 | newCold lirs k v lruIns coldIns = do 129 | status <- newIORef undefined 130 | let entry = Entry k status 131 | lruElem <- case lruIns of 132 | Just ins -> liftM Just (ins (lru lirs) entry) 133 | Nothing -> return Nothing 134 | coldElem <- coldIns (cold lirs) entry 135 | writeIORef status (Cold lruElem coldElem v) 136 | modifyIORef (cache lirs) (insert k entry) 137 | 138 | forget lirs k = modifyIORef (cache lirs) (delete k) 139 | 140 | demoteHot lirs = do 141 | Just lruElem@Elem{elemData = entry} <- readIORef (last (lru lirs)) 142 | remove (lru lirs) lruElem 143 | coldElem <- prepend (cold lirs) entry 144 | modifyIORef (status entry) (\(Hot _ v) -> Cold Nothing coldElem v) 145 | prune lirs 146 | 147 | evictCold lirs = do 148 | Just coldElem@Elem{elemData = entry} <- readIORef (last (cold lirs)) 149 | remove (cold lirs) coldElem 150 | readIORef (status entry) >>= \s -> case s of 151 | Cold (Just lruElem) _ v -> writeIORef (status entry) (Out lruElem) 152 | Cold Nothing _ _ -> forget lirs (key entry) 153 | 154 | prune lirs = do 155 | Just lruElem@Elem{elemData = entry} <- readIORef (last (lru lirs)) 156 | readIORef (status entry) >>= \s -> case s of 157 | Hot _ _ -> return () 158 | Cold _ coldElem v -> do remove (lru lirs) lruElem 159 | writeIORef (status entry) (Cold Nothing coldElem v) 160 | prune lirs 161 | Out _ -> do remove (lru lirs) lruElem 162 | forget lirs (key entry) 163 | prune lirs 164 | 165 | -- mutable doubly-linked list 166 | 167 | data Elem a = Elem { 168 | elemData :: a, 169 | prev, next :: IORef (Maybe (Elem a)) 170 | } 171 | data List a = List { first, last :: (IORef (Maybe (Elem a))) } 172 | 173 | newList :: IO (List a) 174 | newList = liftM2 List (newIORef Nothing) (newIORef Nothing) 175 | 176 | toHList :: List a -> IO [a] 177 | toHList l = walk (first l) where 178 | walk p = readIORef p >>= \e -> case e of 179 | Just e -> liftM (elemData e :) (walk (next e)) 180 | Nothing -> return [] 181 | 182 | remove :: List a -> Elem a -> IO () 183 | remove l e = do 184 | p <- readIORef (prev e) 185 | n <- readIORef (next e) 186 | case p of 187 | Just p -> writeIORef (next p) n 188 | Nothing -> writeIORef (first l) n 189 | case n of 190 | Just n -> writeIORef (prev n) p 191 | Nothing -> writeIORef (last l) p 192 | 193 | prepend :: List a -> a -> IO (Elem a) 194 | prepend l x = do 195 | firstElem <- readIORef (first l) 196 | elem <- liftM2 (Elem x) (newIORef Nothing) (newIORef firstElem) 197 | case firstElem of 198 | Just f -> writeIORef (prev f) (Just elem) 199 | Nothing -> writeIORef (last l) (Just elem) 200 | writeIORef (first l) (Just elem) 201 | return elem 202 | 203 | append :: List a -> a -> IO (Elem a) 204 | append l x = do 205 | lastElem <- readIORef (last l) 206 | elem <- liftM2 (Elem x) (newIORef lastElem) (newIORef Nothing) 207 | case lastElem of 208 | Just l -> writeIORef (next l) (Just elem) 209 | Nothing -> writeIORef (first l) (Just elem) 210 | writeIORef (last l) (Just elem) 211 | return elem 212 | 213 | -- tests 214 | 215 | testStorage = Storage (\k v -> return ()) (\k -> return ()) 216 | testLirs = new testStorage 217 | 218 | testPaper = do 219 | lirs <- testLirs 2 3 220 | let g n = get lirs n >> printLirs lirs 221 | g 1 -- [(1,hot)] [1] [] 222 | g 4 -- [(1,hot),(4,hot)] [4,1] [] 223 | g 2 -- [(1,hot),(2,cold),(4,hot)] [2,4,1] [2] 224 | g 3 -- [(1,hot),(2,out),(3,cold),(4,hot)] [3,2,4,1] [3] 225 | g 2 -- [(1,cold),(2,hot),(3,out),(4,hot)] [2,3,4] [1] 226 | g 1 -- [(1,cold),(2,hot),(3,out),(4,hot)] [1,2,3,4] [1] 227 | g 4 -- [(1,cold),(2,hot),(4,hot)] [4,1,2] [1] 228 | g 1 -- [(1,hot),(2,cold),(4,hot)] [1,4] [2] 229 | g 5 -- [(1,hot),(4,hot),(5,cold)] [5,1,4] [5] 230 | 231 | testCyclic workingSize maxHot maxSize reps = do 232 | lirs <- testLirs maxHot maxSize 233 | let g n = liftM snd (get' lirs n) 234 | mapM (\i -> g i) [1..workingSize] 235 | flip mapM_ [1..reps] $ \n -> do 236 | mapM_ (\i -> assert (show i) (g i)) [1..maxHot] 237 | mapM_ (\i -> assertNot (show i) (g i)) [maxHot+1..workingSize] 238 | print n 239 | tc = testCyclic 10001 9900 10000 100 240 | 241 | assert :: String -> IO Bool -> IO () 242 | assert msg io = io >>= \r -> when (not r) (fail ("assertion failed: " ++ msg)) 243 | assertNot msg io = assert msg (liftM not io) 244 | 245 | testRandom workingSize maxHot maxSize num = do 246 | lirs <- testLirs maxHot maxSize 247 | replicateM_ num $ do 248 | i <- randomRIO (1::Int, workingSize) 249 | get lirs i 250 | tr = testRandom 10000 9900 10000 100000000 251 | -------------------------------------------------------------------------------- /Soutei/Parsec.hs: -------------------------------------------------------------------------------- 1 | -- helpers for Parsec 2 | 3 | module Soutei.Parsec where 4 | 5 | import Text.ParserCombinators.Parsec 6 | import Control.Monad.Identity 7 | 8 | junk p = p >> return () 9 | 10 | parseM :: Monad m => Parser a -> FilePath -> String -> m a 11 | parseM p f s = handleM (parse p f s) 12 | 13 | parseFromFileM :: Parser a -> FilePath -> IO a 14 | parseFromFileM p f = parseFromFile p f >>= handleM 15 | 16 | handleM (Left e) = fail (show e) 17 | handleM (Right x) = return x 18 | 19 | uncheckedParse :: Parser a -> String -> a 20 | uncheckedParse p s = runIdentity (parseM p "string" s) 21 | -------------------------------------------------------------------------------- /Soutei/Sexpr.hs: -------------------------------------------------------------------------------- 1 | module Soutei.Sexpr ( 2 | Sexpr(..), 3 | sexpr, cons, whiteSpace, 4 | toList, toAtomList, fromList, fromAtomList 5 | ) where 6 | 7 | import Control.Monad 8 | import Text.ParserCombinators.Parsec hiding (newline) 9 | 10 | data Sexpr a = Atom a 11 | | Cons (Sexpr a) (Sexpr a) 12 | | Nil 13 | deriving (Eq) 14 | 15 | instance Show a => Show (Sexpr a) where 16 | showsPrec _ (Atom x) = shows x 17 | showsPrec _ l@(Cons x y) = showParen True (shows x . showsTail y) where 18 | showsTail (Atom x) = (" . "++) . shows x 19 | showsTail (Cons x y) = (' ':) . shows x . showsTail y 20 | showsTail Nil = id 21 | showsPrec _ Nil = ("()"++) 22 | 23 | -- do not eat trailing whitespace, because we want to process a request from 24 | -- a lazy stream (eg socket) as soon as we see the closing paren. 25 | sexpr :: Parser a -> Parser (Sexpr a) 26 | sexpr p = liftM Atom p 27 | <|> cons p 28 | sexprL p = lexeme (sexpr p) 29 | 30 | cons :: Parser a -> Parser (Sexpr a) 31 | cons p = between (lexeme (string "(")) (string ")") tailL where 32 | tailL = do dotL 33 | sexprL p 34 | -- require a space between consecutive atoms 35 | <|> liftM2 Cons (liftM Atom p) 36 | ( (whiteSpace1 >> tailL) 37 | <|> liftM2 Cons (consL p) tailL 38 | <|> return Nil) 39 | <|> liftM2 Cons (consL p) tailL 40 | <|> return Nil 41 | consL p = lexeme (cons p) 42 | 43 | lexeme p = do r <- p 44 | whiteSpace 45 | return r 46 | whiteSpace = many space 47 | whiteSpace1 = many1 space 48 | dotL = lexeme (string ".") 49 | 50 | toList :: Monad m => Sexpr a -> m [Sexpr a] 51 | toList Nil = return [] 52 | toList (Cons x xs) = liftM (x:) (toList xs) 53 | toList (Atom x) = fail "toList: not a pure list" 54 | 55 | toAtomList :: Monad m => Sexpr a -> m [a] 56 | toAtomList s = toList s >>= mapM toAtom where 57 | toAtom (Atom x) = return x 58 | toAtom _ = fail "toAtomList: element is not an atom" 59 | 60 | fromList :: [Sexpr a] -> Sexpr a 61 | fromList = foldr Cons Nil 62 | 63 | fromAtomList :: [a] -> Sexpr a 64 | fromAtomList = fromList . map Atom 65 | -------------------------------------------------------------------------------- /Soutei/Soutei.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | 3 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/Soutei.hs $ 4 | -- $Id: Soutei.hs 2929 2012-09-11 03:42:25Z oleg.kiselyov $ 5 | -- svn propset svn:keywords "HeadURL Id" filename 6 | 7 | module Soutei.Soutei where 8 | 9 | import Control.Monad 10 | import Data.Bits 11 | import Data.Word 12 | import Test.QuickCheck (Arbitrary(..), choose, oneof, sized, Property, forAll) 13 | 14 | -- The Soutei language 15 | 16 | data Const = SString String 17 | | SNumber !Integer 18 | | SIP4Addr !IP4Addr 19 | | SIP4Net !IP4Net 20 | deriving (Eq, Ord) 21 | newtype ConstC v = ConstC Const 22 | data IP4Addr = IP4Addr !Word32 23 | deriving (Eq, Ord) 24 | data IP4Net = IP4Net !IP4Addr !Int 25 | deriving (Eq, Ord) 26 | data Pred = Pred String !Int 27 | deriving (Eq, Ord) 28 | newtype SynVar = SynVar String 29 | deriving (Eq, Ord) 30 | data Var v = Anon 31 | | Named v 32 | deriving Eq 33 | -- No data constructor--used to guarantee a fact has no variables 34 | data NoVar 35 | data Term v = Var v 36 | | Val Const 37 | deriving Eq 38 | -- c is the container type constructor of context (NoCtx or MaybeCtx) 39 | data Atom c v = Atom { 40 | ctx :: c (Term v), 41 | pred :: Pred, 42 | args :: [Term v] } 43 | type HeadAtom v = Atom NoCtx v 44 | type BodyAtom v = Atom MaybeCtx v 45 | data NoCtx a = NoCtx 46 | data MaybeCtx a = JustCtx a 47 | | NothingCtx 48 | data Rule v = Rule (HeadAtom v) [BodyAtom v] 49 | type Fact = Atom NoCtx NoVar 50 | type SynTerm = Term (Var SynVar) 51 | type SynAtom c = Atom c (Var SynVar) 52 | type SynHeadAtom = HeadAtom (Var SynVar) 53 | type SynBodyAtom = BodyAtom (Var SynVar) 54 | type SynRule = Rule (Var SynVar) 55 | type Goal = SynHeadAtom 56 | 57 | atomToFact :: Monad m => Atom NoCtx v -> m Fact 58 | atomToFact atom = fmapM (\_ -> fail "facts may not have variables") atom 59 | 60 | factToAtom :: Fact -> Atom NoCtx v 61 | factToAtom fact = fmap undefined fact 62 | 63 | class FunctorM f where 64 | fmapM :: Monad m => (a -> m b) -> f a -> m (f b) 65 | 66 | instance FunctorM Maybe where 67 | fmapM f Nothing = return Nothing 68 | fmapM f (Just x) = f x >>= return . Just 69 | 70 | instance Functor Term where 71 | fmap f (Var v) = Var (f v) 72 | fmap f (Val x) = Val x 73 | instance FunctorM Term where 74 | fmapM f (Var v) = liftM Var (f v) 75 | fmapM f (Val x) = return (Val x) 76 | 77 | instance Functor c => Functor (Atom c) where 78 | fmap f (Atom ctx pred args) = Atom (fmap (fmap f) ctx) 79 | pred 80 | (map (fmap f) args) 81 | instance FunctorM c => FunctorM (Atom c) where 82 | fmapM f (Atom ctx pred args) = do 83 | ctx' <- fmapM (fmapM f) ctx 84 | args' <- mapM (fmapM f) args 85 | return (Atom ctx' pred args') 86 | 87 | instance Functor Rule where 88 | fmap f (Rule h b) = Rule (fmap f h) (map (fmap f) b) 89 | instance FunctorM Rule where 90 | fmapM f (Rule h b) = liftM2 Rule (fmapM f h) (mapM (fmapM f) b) 91 | 92 | instance Functor NoCtx where 93 | fmap f NoCtx = NoCtx 94 | instance FunctorM NoCtx where 95 | fmapM f NoCtx = return NoCtx 96 | 97 | instance Functor MaybeCtx where 98 | fmap f (JustCtx x) = JustCtx (f x) 99 | fmap f NothingCtx = NothingCtx 100 | instance FunctorM MaybeCtx where 101 | fmapM f (JustCtx x) = liftM JustCtx (f x) 102 | fmapM f NothingCtx = return NothingCtx 103 | 104 | sysCtx = SString "system" 105 | appCtx = SString "application" 106 | 107 | fact :: String -> [Const] -> Atom NoCtx v 108 | fact pred args = Atom NoCtx (Pred pred (length args)) (map Val args) 109 | 110 | goal :: String -> [Const] -> Goal 111 | goal pred args = Atom NoCtx (Pred pred (length args)) (map Val args) 112 | 113 | -- IPAddr/IPNet 114 | 115 | bytesToIP4Addr :: [Word8] -> IP4Addr 116 | bytesToIP4Addr = IP4Addr . bytesToBits 4 117 | 118 | ip4AddrToBytes :: IP4Addr -> [Word8] 119 | ip4AddrToBytes (IP4Addr addr) = bitsToBytes 4 addr 120 | 121 | bytesToBits :: Bits a => Int -> [Word8] -> a 122 | bytesToBits = toBits 0 where 123 | toBits acc 0 [] = acc 124 | toBits acc n (b:bs) = toBits (shiftL acc 8 .|. fromIntegral b) (n-1) bs 125 | 126 | bitsToBytes :: (Bits a, Integral a) => Int -> a -> [Word8] 127 | bitsToBytes n x = [fromIntegral (shiftR x ((n-i)*8) .&. 255) | i <- [1..n]] 128 | 129 | ip4of :: IP4Addr -> IP4Net -> Bool 130 | ip4of (IP4Addr addr) (IP4Net (IP4Addr netAddr) netBits) = 131 | let mask = complement (shiftL 1 (32 - netBits) - 1) 132 | in addr .&. mask == netAddr .&. mask 133 | 134 | -- QuickCheck 135 | 136 | -- only generate strings for simplicity 137 | instance Arbitrary Const where 138 | arbitrary = liftM SString (logSized (\n -> liftM show (choose (0, n)))) 139 | 140 | instance Arbitrary v => Arbitrary (Var v) where 141 | arbitrary = oneof [return Anon, liftM Named arbitrary] 142 | 143 | instance Arbitrary v => Arbitrary (Term v) where 144 | arbitrary = oneof [liftM Var arbitrary, liftM Val arbitrary] 145 | 146 | logSized f = sized (\n -> f (floor (log (fromIntegral (n+1)) / log 2) :: Int)) 147 | 148 | prop_ip4of :: Word32 -> Property 149 | prop_ip4of addr = forAll (choose (0,32)) $ \netBits -> 150 | forAll (choose (0,31)) $ \flipBit -> 151 | ip4of (IP4Addr (addr `complementBit` flipBit)) 152 | (IP4Net (IP4Addr addr) netBits) == 153 | (netBits + flipBit < 32) 154 | 155 | -------------------------------------------------------------------------------- /Soutei/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | -- $HeadURL: https://svn.metnet.navy.mil/svn/metcast/Mserver/trunk/soutei/haskell/Soutei/Syntax.hs $ 4 | -- $Id: Syntax.hs 2947 2012-09-14 08:26:08Z oleg.kiselyov $ 5 | -- svn propset svn:keywords "HeadURL Id" filename 6 | 7 | module Soutei.Syntax ( 8 | top, assertionL, headL, term, const 9 | ) where 10 | 11 | import Prelude hiding (head, const) 12 | import Control.Monad 13 | import Data.Bits 14 | import Data.Monoid (mconcat) 15 | import Text.ParserCombinators.Parsec hiding (newline) 16 | 17 | import Soutei.Parsec 18 | import Soutei.Soutei 19 | 20 | -- show 21 | 22 | instance Show Const where 23 | -- if it can be parsed as a symbol, show it as a symbol (cosmetic) 24 | showsPrec _ (SString s) = case parseM symbol "" s of 25 | Just s' | s' == s -> (s++) 26 | _ -> shows s 27 | showsPrec _ (SNumber n) = shows n 28 | showsPrec _ (SIP4Addr a) = ("#p"++) . shows a 29 | showsPrec _ (SIP4Net n) = ("#n"++) . shows n 30 | 31 | instance Show (ConstC v) where 32 | showsPrec _ (ConstC x) = shows x 33 | 34 | instance Show IP4Addr where 35 | showsPrec _ addr = ip4AddrToBytes addr `showsSep` "." 36 | 37 | instance Show IP4Net where 38 | showsPrec _ (IP4Net addr bits) = shows addr . ('/':) . shows bits 39 | 40 | instance Show Pred where 41 | showsPrec _ (Pred pred arity) = (pred++) . ('/':) . shows arity 42 | 43 | instance Show SynVar where 44 | showsPrec _ (SynVar v) = (v++) 45 | 46 | instance Show v => Show (Var v) where 47 | showsPrec _ Anon = ('?':) 48 | showsPrec _ (Named v) = ('?':) . shows v 49 | 50 | instance Show v => Show (Term v) where 51 | showsPrec _ (Val x) = shows x 52 | showsPrec _ (Var v) = shows v 53 | 54 | instance (Show (c (Term v)), Show v) => Show (Atom c v) where 55 | showsPrec _ (Atom ctx (Pred pred arity) args) = 56 | shows ctx . (pred++) . showParen True (args `showsSep` ", ") 57 | 58 | instance Show v => Show (Rule v) where 59 | showsPrec _ (Rule a []) = shows a . (".\n"++) 60 | showsPrec _ (Rule a as) = shows a . (" :-\n "++) . 61 | (as `showsSep` ",\n ") . (".\n"++) 62 | showList rules = mconcat (map shows rules) 63 | 64 | instance Show (NoCtx a) where 65 | showsPrec _ NoCtx = id 66 | 67 | instance Show a => Show (MaybeCtx a) where 68 | showsPrec _ (JustCtx a) = shows a . (" says "++) 69 | showsPrec _ (NothingCtx)= id 70 | 71 | showsSep :: Show a => [a] -> String -> ShowS 72 | showsSep [x] _ = shows x 73 | showsSep (x:xs) s = shows x . (s++) . showsSep xs s 74 | 75 | -- parser 76 | 77 | -- L suffix means a lexeme parser (eats trailing space); sort of annoying, 78 | -- but I prefer to be explicit, because the distinction sometimes matters. 79 | 80 | assertionL :: Parser [SynRule] 81 | assertionL = many statementL 82 | statementL :: Parser SynRule 83 | statementL = do h <- headL 84 | b <- do inCaseL 85 | bodyL 86 | <|> 87 | return [] 88 | stopL 89 | return (Rule h b) 90 | headL :: Parser SynHeadAtom 91 | headL = predAtomL NoCtx 92 | bodyL :: Parser [SynBodyAtom] 93 | bodyL = atomL `sepBy` commaL 94 | predAtomL :: c SynTerm -> Parser (SynAtom c) 95 | predAtomL ctx = do pred <- symbolL 96 | args <- parensL (termL `sepBy` commaL) 97 | return (Atom ctx (Pred pred (length args)) args) 98 | ctxAtomL :: Parser SynBodyAtom 99 | ctxAtomL = do ctx <- term 100 | whiteSpace1 101 | says 102 | whiteSpace1 103 | predAtomL (JustCtx ctx) 104 | atomL :: Parser SynBodyAtom 105 | atomL = try (predAtomL NothingCtx) 106 | <|> ctxAtomL 107 | termL :: Parser SynTerm 108 | termL = lexeme term 109 | term :: Parser SynTerm 110 | term = liftM Var var 111 | <|> liftM Val const 112 | 113 | -- lexemes 114 | 115 | top p = between whiteSpace eof p 116 | lexeme p = do r <- p 117 | whiteSpace 118 | return r 119 | space' = junk space <|> junk comment 120 | whiteSpace = many space' 121 | whiteSpace1 = many1 space' 122 | comment = do char ';' 123 | manyTill anyChar (newline <|> eof) 124 | "comment" 125 | newline = junk (char '\n') 126 | <|> junk (try (string "\r\n")) 127 | <|> junk (char '\r') 128 | 129 | stopL = lexeme (string ".") 130 | inCaseL = lexeme (string ":-") 131 | commaL = lexeme (string ",") 132 | parensL p = between (lexeme (string "(")) (lexeme (string ")")) p 133 | says = string "says" 134 | 135 | var = do char '?' 136 | liftM (Named . SynVar) symbol <|> return Anon 137 | symbolL = lexeme symbol 138 | symbol = do c <- symbolStart 139 | s <- many symbolChar 140 | return (c:s) 141 | "symbol" 142 | -- based on Scheme, except disallow leading '?', and allow '@" 143 | symbolStart = letter <|> oneOf "!$%&*/:<=>@~_^" 144 | symbolChar = symbolStart <|> digit <|> oneOf ".+-?" 145 | "symbol character" 146 | const = liftM SString qString 147 | <|> liftM SString symbol 148 | <|> liftM SNumber number 149 | <|> liftM SIP4Addr ip4Addr 150 | <|> liftM SIP4Net ip4Net 151 | "constant" 152 | qString = do char '"' 153 | manyTill ch (char '"') where 154 | ch = do char '\\' 155 | c <- anyChar 156 | case c of 157 | 'n' -> return '\n' 158 | '"' -> return '"' 159 | '\\' -> return '\\' 160 | otherwise -> fail "bad escape sequence" 161 | <|> anyChar 162 | number = natural 163 | ip4Addr = do try (string "#p") 164 | ip4Addr' 165 | ip4Net = do try (string "#n") 166 | addr <- ip4Addr' 167 | char '/' 168 | bits <- ip4NetBits 169 | return (IP4Net addr bits) 170 | ip4Addr' = liftM bytesToIP4Addr (ip4AddrByte `sepBy4` char '.') 171 | ip4AddrByte = liftM fromIntegral (naturalBet 0 255 "ip address octet") 172 | ip4NetBits = liftM fromIntegral (naturalBet 1 32 "ip address range bits") 173 | natural :: Parser Integer 174 | natural = liftM read (many1 digit) 175 | naturalBet n1 n2 what = do n <- natural 176 | when (n < n1 || n > n2) 177 | (fail ("bad " ++ what ++ " " ++ show n ++ 178 | ", not between " ++ show n1 ++ " and " 179 | ++ show n2)) 180 | return n 181 | 182 | sepByN :: Int -> Parser a -> Parser b -> Parser [a] 183 | sepByN n p sep = sb n where 184 | sb n = liftM2 (:) p (sb' (n-1)) 185 | sb' 0 = return [] 186 | sb' n = sep >> sb n 187 | sepBy4 = sepByN 4 188 | 189 | -- tests 190 | 191 | testParser :: String -> IO () 192 | testParser s = do a' <- parseM assertionL "test" s 193 | let s' = show a' 194 | if (s == s') 195 | then putStrLn "parsed" 196 | else fail ("parse error: " ++ show s ++ " -> " ++ show s') 197 | 198 | testParserError :: String -> IO () 199 | testParserError s = case parse assertionL "test" s of 200 | Left e -> putStrLn "parse error" 201 | Right x -> fail ("should not have parsed: " ++ s) 202 | 203 | -- most tests cribbed from binder-parse.scm 204 | test = do testParser "" 205 | testParserError "may" 206 | testParserError "may(1)" 207 | testParser "may(1).\n" 208 | testParserError "may(\")" 209 | testParserError "may(?, ?, ?)" 210 | testParser "may(?, ?, ?).\n" 211 | testParser "may(?, _, ?_).\n" 212 | testParser "may(?x, \"ok x\", ?zZ).\n" 213 | testParser ("may(?x, ?Y, ?) :-\n" ++ 214 | " application says ip(?ip).\n") 215 | testParser ("may(2, ?Y, ?) :-\n" ++ 216 | " ?Y says ip(?ip, #p10.0.0.1),\n" ++ 217 | " ok(?ip).\n") 218 | -------------------------------------------------------------------------------- /demo/metcast-channels/Makefile: -------------------------------------------------------------------------------- 1 | # Run the regression test suite for Soutei or for the 2 | # Metcast Channels + Soutei combo 3 | 4 | # The Soutei engine root 5 | ROOT=../../ 6 | 7 | GHC := ghc 8 | GHC_MAKE = $(GHC) --make 9 | GHC_OPTS := -O2 10 | GHC_INCLUDES = `$(GHC) --print-libdir`/include 11 | 12 | HC_CMD := $(GHC_MAKE) $(GHC_OPTS) -I$(GHC_INCLUDES) -i$(ROOT) 13 | 14 | test: soutei-metcast-tests 15 | ./soutei-metcast-tests 10 10 16 | 17 | soutei-metcast-tests: soutei-metcast-tests.hs 18 | $(HC_CMD) $^ -o $@ 19 | 20 | clean:: 21 | rm -f soutei-metcast-tests 22 | 23 | 24 | clean:: 25 | rm -f *.hi *.o $(PROGS) 26 | rm -f Soutei/*.hi 27 | rm -f Soutei/*.o 28 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/00.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | Introduction to Soutei 5 | 6 | 7 |

Introduction to Soutei

8 | 9 |

Soutei is Policy Decision Point (PDP). It offers advice 10 | about what actions are permitted, according to a policy. Enforcement of 11 | policy is left to a Policy Enforcement Point (PEP).

12 | 13 |

Design goals: 14 | 15 |

    16 |
  • Universal policy language and authorization service 17 |
  • Delegated and decentralized policies 18 |
  • High-assurance (Common Criteria Evaluation Assurance 19 | Level 6) 20 |
21 |

22 | 23 |

This demonstration was first given in June 2005 by 24 | Andrew Pimlott. 25 | 26 |

next

27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/01.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | Demo Scenario 5 | 6 | 7 |

Demo Scenario

8 | 9 |

We demonstrate Soutei integrated with Navy Enterprise Single Sign-On 10 | (NESSO) and Metcast Channels. We include examples of 11 | delegation and Risk Adaptable Access Control 12 | (RAdAC).

13 | 14 | communication diagram 15 | 16 |

Our initial policy states that: 17 | 18 |

    19 |
  • sam.sysadmin may delegate permission to create channels. 20 |
  • The creator of a channel may delegate access to his channel. 21 |
  • All access is delegated to the emergency policy. 22 |
23 |

24 | 25 |

next

26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/06.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | sam.sysadmin Policy 5 | 6 | 7 |

sam.sysadmin Policy

8 | 9 |

sam.sysadmin grants cam.create permission to create channels.

10 | 11 |

next

12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/07.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | cam.create Creates a Channel 5 | 6 | 7 |

cam.create Creates a Channel

8 | 9 |

cam.create creates the DustSensorData channel and grants himself full 10 | access to the channel. He also allows don.delegate to grant read 11 | permission to US citizens.

12 | 13 |

next

14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/08.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | don.delegate Delegates the Channel 5 | 6 | 7 |

don.delegate Delegates the Channel

8 | 9 |

don.delegate attempts to grant access to DustSensorData to everyone. 10 | He can now see the channel, because he is a US citizen.

11 | 12 |

next

13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/09.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | joe.canada Cannot See the Channel 5 | 6 | 7 |

joe.canada Cannot See the Channel

8 | 9 |

joe.canada cannot see the channel, even though don.delegate's policy 10 | attempted to let him, because the delegation only applies to US 11 | citizens.

12 | 13 |

next

14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/11.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Soutei-Channels Demonstration: 4 | ed.emergency Declares an Emergency 5 | 6 | 7 |

ed.emergency Declares an Emergency

8 | 9 |

ed.emergency is trusted to widen access in an emergency. He gives 10 | everyone permission to read from any channel. Now, even joe.canada can 11 | see the DustSensorData channel. But when ed.emergency withdraws his 12 | assertion, joe.canada's access ends. 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/Makefile: -------------------------------------------------------------------------------- 1 | all: soutei.png 2 | 3 | soutei.png: soutei.fig 4 | fig2dev -L png -S 4 < $< > $@ 5 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/index.html: -------------------------------------------------------------------------------- 1 | 00.html -------------------------------------------------------------------------------- /demo/metcast-channels/doc/notes: -------------------------------------------------------------------------------- 1 | cleanup 2 | - zero all assertions (4) 3 | - delete all channels (1) 4 | 5 | pre 6 | - log in as the following users 7 | - Administrator 8 | - cam.create 9 | - don.delegate 10 | - ed.emergency 11 | - joe.canuck 12 | - sam.sysadmin 13 | - close and reopen every browser (slide should open as start page) 14 | - increase font size twice 15 | 16 | Script follows. Notes and actions are intermixed. 17 | 18 | start logged in as Administrator 19 | 20 | slide 00 21 | - Authz: who can access what resources? 22 | - central to information assurance/NCES 23 | - Soutei is designed to be 24 | - unified authorization service for all applications 25 | - decentralized 26 | - high assurance (prove you can't break it) 27 | - NESSO is a GFE (government furnished equipment)--we could use anything. 28 | - delegation and RAdAC show distributed, non-monolithic, flexible policy. 29 | - doesn't assume anything about the policy, nothing built in--it's 30 | deny all (even from sysadmin) without an initial assertion to the 31 | contrary. 32 | - channel owners can't even see own channels (example of how we can "lock 33 | things down", secure by default) 34 | - base policy is encoded in a hard-coded soutei language assertion. 35 | - Soutei policy is a computer program. 36 | - note we will see examples of the Soutei language later (but you don't have 37 | to understand it because we're using a UI) 38 | 39 | switch to sam.sysadmin 40 | 41 | slide 06 42 | - Note that before, nobody could create channels. 43 | - Channel-specific authorization policy UI. 44 | - note that this is a subset of Soutei; Soutei is more powerful than this 45 | - emphasize that 46 | - every user has an assertion 47 | - just because every user has an assertion, it doesn't mean every user is 48 | trusted (partially decentralized) 49 | - user assertions are combined with the base assertion to form the policy 50 | - rules 51 | - "allow cam.create to create channels" 52 | - privileges "create" 53 | - "user name" "cam.create" 54 | - insist that pre this rule, cam couldn't create 55 | - read it back in english! 56 | 57 | switch to cam.create 58 | 59 | slide 07 60 | - Create channel DustSensorData 61 | - name, dscription, and max entries are required fields 62 | - Observe that we can't see the channel we created, until we authorize 63 | ourselves. 64 | - remind that we were delegated this ability by the default policy 65 | - rules 66 | - "give myself full access" 67 | - privileges "all client" 68 | - "channel name" "DustSensorData" 69 | - "user name" "cam.create" 70 | - note AND 71 | - "let don.delegate control US read access" 72 | - explain this very carefully!!! belabor!!! 73 | - privileges "read" 74 | - "channel name" "DustSensorData" 75 | - "user citizenship" "US" 76 | - "delegate" "don.delegate" 77 | - note OR 78 | - we can see the channel 79 | 80 | switch to don.delegate 81 | 82 | slide 08 83 | - Don can't see it at first. 84 | - Don delegates too much, either through carelessness or malice. 85 | Fortunately, his delegation is controlled. 86 | - rules 87 | - "read access to DustSensorData" 88 | - privileges "read" 89 | - "channel name" "DustSensorData" 90 | - He can see it--it "worked" 91 | - length 2 delegation chain 92 | 93 | switch to joe.canuck 94 | 95 | slide 09 96 | - No luck. 97 | - we delegated without compromising a static guarantee 98 | 99 | switch to ed.emergency 100 | 101 | slide 11 102 | - the initial policy allowed ed.emergency to grant any access 103 | - ed.emergency is really just a placeholder--could be an automatic 104 | submission based on some conditions 105 | - emergency policy is really just delegation (perhaps don't mention so it 106 | looks like a separate feature and not a hack?) 107 | - rules 108 | - "all may read" 109 | - privileges "read" 110 | - switch to joe.canuck 111 | - joe.canuck can see all channels 112 | - switch to ed.emergency 113 | - rules 114 | - switch to joe.canuck 115 | - no luck 116 | 117 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/soutei.fig: -------------------------------------------------------------------------------- 1 | #FIG 3.2 Produced by xfig version 3.2.5-alpha5 2 | Landscape 3 | Center 4 | Metric 5 | A4 6 | 100.00 7 | Single 8 | -2 9 | 1200 2 10 | 0 32 #8e8e8e 11 | 0 33 #868286 12 | 0 34 #e7e3e7 13 | 0 35 #808080 14 | 0 36 #c0c0c0 15 | 0 37 #e0e0e0 16 | 0 38 #8e8f8e 17 | 0 39 #444444 18 | 0 40 #868686 19 | 0 41 #c7c7c7 20 | 0 42 #e7e7e7 21 | 0 43 #f7f7f7 22 | 0 44 #9e9e9e 23 | 0 45 #717571 24 | 0 46 #414541 25 | 0 47 #757575 26 | 0 48 #c7c3c7 27 | 0 49 #414141 28 | 0 50 #c7c3c7 29 | 0 51 #effbff 30 | 0 52 #404040 31 | 0 53 #f3f3f3 32 | 0 54 #aaaaaa 33 | 0 55 #555555 34 | 0 56 #d7d3d7 35 | 0 57 #aeaaae 36 | 0 58 #c2c2c2 37 | 0 59 #303030 38 | 0 60 #515551 39 | 0 61 #f7f3f7 40 | 0 62 #666666 41 | 0 63 #717171 42 | 0 64 #c6b797 43 | 0 65 #eff8ff 44 | 0 66 #dccba6 45 | 0 67 #565151 46 | 0 68 #e2e2ee 47 | 0 69 #94949a 48 | 0 70 #dbdbdb 49 | 0 71 #a1a1b7 50 | 0 72 #9c0000 51 | 0 73 #ededed 52 | 0 74 #86acff 53 | 0 75 #7070ff 54 | 0 76 #bebebe 55 | 0 77 #515151 56 | 0 78 #d7d7d7 57 | 0 79 #85807d 58 | 0 80 #d2d2d2 59 | 0 81 #3a3a3a 60 | 0 82 #4573aa 61 | 0 83 #000000 62 | 0 84 #000049 63 | 0 85 #797979 64 | 0 86 #303430 65 | 0 87 #c7b696 66 | 0 88 #aeaeae 67 | 0 89 #d6d7d6 68 | 0 90 #7b79a5 69 | 0 91 #73758c 70 | 0 92 #635dce 71 | 0 93 #8c8c8c 72 | 0 94 #424242 73 | 0 95 #8c8c8c 74 | 0 96 #424242 75 | 0 97 #8c8c8c 76 | 0 98 #424242 77 | 0 99 #8c8c8c 78 | 0 100 #424242 79 | 0 101 #8c8c8c 80 | 0 102 #424242 81 | 0 103 #8c8c8c 82 | 0 104 #424242 83 | 0 105 #6e6e6e 84 | 0 106 #333333 85 | 0 107 #949395 86 | 0 108 #747075 87 | 0 109 #b3b3b3 88 | 0 110 #c3c3c3 89 | 0 111 #6d6d6d 90 | 0 112 #454545 91 | 6 7650 5850 9450 7200 92 | 2 2 0 2 0 6 50 -1 20 0.000 0 0 7 0 0 5 93 | 7875 6075 9225 6075 9225 6975 7875 6975 7875 6075 94 | 4 1 0 50 -1 18 12 0.0000 4 150 600 8550 6525 Soutei\001 95 | 4 1 0 50 -1 18 12 0.0000 4 180 525 8550 6780 (PDP)\001 96 | -6 97 | 6 7425 3150 9675 4725 98 | 2 2 0 2 0 11 50 -1 20 0.000 0 0 7 0 0 5 99 | 7650 3375 9450 3375 9450 4500 7650 4500 7650 3375 100 | 4 1 0 50 -1 18 12 0.0000 4 135 870 8550 3825 Channels\001 101 | 4 1 0 50 -1 18 12 0.0000 4 180 525 8550 4080 (PEP)\001 102 | -6 103 | # Array of disks 104 | 6 11025 3375 12150 4725 105 | 6 11075 3925 11646 4568 106 | 5 1 0 1 0 7 50 -1 -1 4.000 0 1 0 0 11360.500 4136.486 11146 4425 11360 4496 11575 4425 107 | 1 2 0 1 0 7 50 -1 20 0.000 1 0.0000 11360 4067 214 71 11146 4067 11575 4067 108 | 1 2 0 1 7 7 53 -1 20 0.000 1 0.0000 11360 4425 214 71 11146 4425 11575 4425 109 | 2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 110 | 11146 4067 11146 4425 111 | 2 1 0 1 0 7 50 -1 -1 4.000 0 0 -1 0 0 2 112 | 11575 4067 11575 4425 113 | 2 2 0 1 7 7 55 -1 20 0.000 0 0 -1 0 0 5 114 | 11146 4067 11575 4067 11575 4425 11146 4425 11146 4067 115 | -6 116 | 6 11217 3782 11789 4425 117 | 5 1 0 1 0 7 60 -1 -1 0.000 0 1 0 0 11503.000 3994.993 11289 4282 11503 4353 11717 4282 118 | 1 2 0 1 0 7 60 -1 20 0.000 1 0.0000 11503 3925 214 71 11289 3925 11717 3925 119 | 1 2 0 1 7 7 63 -1 20 0.000 1 0.0000 11503 4282 214 71 11289 4282 11717 4282 120 | 2 1 0 1 0 7 60 -1 -1 0.000 0 0 -1 0 0 2 121 | 11289 3925 11289 4282 122 | 2 1 0 1 0 7 60 -1 -1 0.000 0 0 -1 0 0 2 123 | 11717 3925 11717 4282 124 | 2 2 0 1 7 7 65 -1 20 0.000 0 0 -1 0 0 5 125 | 11289 3925 11717 3925 11717 4282 11289 4282 11289 3925 126 | -6 127 | 6 11360 3639 11932 4282 128 | 5 1 0 1 0 7 70 -1 -1 0.000 0 1 0 0 11646.000 3851.993 11432 4139 11646 4210 11860 4139 129 | 1 2 0 1 0 7 70 -1 20 0.000 1 0.0000 11646 3782 214 71 11432 3782 11860 3782 130 | 1 2 0 1 7 7 73 -1 20 0.000 1 0.0000 11646 4139 214 71 11432 4139 11860 4139 131 | 2 1 0 1 0 7 70 -1 -1 0.000 0 0 -1 0 0 2 132 | 11432 3782 11432 4139 133 | 2 1 0 1 0 7 70 -1 -1 0.000 0 0 -1 0 0 2 134 | 11860 3782 11860 4139 135 | 2 2 0 1 7 7 75 -1 20 0.000 0 0 -1 0 0 5 136 | 11432 3782 11860 3782 11860 4139 11432 4139 11432 3782 137 | -6 138 | 6 11503 3496 12075 4139 139 | 5 1 0 1 0 7 80 -1 -1 0.000 0 1 0 0 11789.000 3708.993 11575 3996 11789 4067 12003 3996 140 | 1 2 0 1 0 7 80 -1 20 0.000 1 0.0000 11789 3639 214 71 11575 3639 12003 3639 141 | 1 2 0 1 7 7 83 -1 20 0.000 1 0.0000 11789 3996 214 71 11575 3996 12003 3996 142 | 2 1 0 1 0 7 80 -1 -1 0.000 0 0 -1 0 0 2 143 | 11575 3639 11575 3996 144 | 2 1 0 1 0 7 80 -1 -1 0.000 0 0 -1 0 0 2 145 | 12003 3639 12003 3996 146 | 2 2 0 1 7 7 85 -1 20 0.000 0 0 -1 0 0 5 147 | 11575 3639 12003 3639 12003 3996 11575 3996 11575 3639 148 | -6 149 | -6 150 | 6 1755 3555 2295 4500 151 | 1 3 0 2 0 7 50 -1 -1 0.000 1 0.0000 2025 3825 225 225 2025 3825 2250 3825 152 | 4 1 0 50 -1 18 12 0.0000 4 150 540 2025 4500 Client\001 153 | -6 154 | 6 4230 6030 5670 7020 155 | 2 2 0 2 0 29 50 -1 20 0.000 0 0 -1 0 0 5 156 | 4275 6075 5625 6075 5625 6975 4275 6975 4275 6075 157 | 4 1 0 50 -1 18 12 0.0000 4 135 690 4950 6525 NESSO\001 158 | 4 1 0 50 -1 18 12 0.0000 4 180 450 4950 6780 (I&A)\001 159 | -6 160 | 6 4005 3330 5895 4770 161 | 2 2 0 2 0 14 50 -1 20 0.000 0 0 7 0 0 5 162 | 4050 3375 5850 3375 5850 4050 4050 4050 4050 3375 163 | 2 2 0 2 0 29 50 -1 20 0.000 0 0 7 0 0 5 164 | 4050 4050 5850 4050 5850 4725 4050 4725 4050 4050 165 | 4 1 0 50 -1 18 12 0.0000 4 180 1305 4950 4500 Nesso Plug-In\001 166 | 4 1 0 50 -1 18 12 0.0000 4 135 630 4950 3825 HTTPd\001 167 | -6 168 | 2 1 0 2 0 14 50 -1 20 0.000 0 0 7 1 1 2 169 | 2 1 2.00 120.00 180.00 170 | 2 1 2.00 120.00 180.00 171 | 4950 4950 4950 5850 172 | 2 1 0 2 0 14 50 -1 20 0.000 0 0 7 1 1 2 173 | 2 1 2.00 120.00 180.00 174 | 2 1 2.00 120.00 180.00 175 | 8550 4725 8550 5850 176 | 2 1 0 2 0 14 50 -1 20 0.000 0 0 7 1 1 2 177 | 2 1 2.00 120.00 180.00 178 | 2 1 2.00 120.00 180.00 179 | 9675 3825 11025 3825 180 | 2 1 0 2 0 14 50 -1 20 0.000 0 0 7 1 1 2 181 | 2 1 2.00 120.00 180.00 182 | 2 1 2.00 120.00 180.00 183 | 6075 3825 7425 3825 184 | 2 1 0 2 0 14 50 -1 20 0.000 0 0 7 1 1 2 185 | 2 1 2.00 120.00 180.00 186 | 2 1 2.00 120.00 180.00 187 | 2475 3825 3825 3825 188 | -------------------------------------------------------------------------------- /demo/metcast-channels/doc/soutei.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mstone/soutei/4d00e12180361561dab948f211bbcf9e75bfb1de/demo/metcast-channels/doc/soutei.png -------------------------------------------------------------------------------- /demo/metcast-channels/soutei-metcast-demo-init.txt: -------------------------------------------------------------------------------- 1 | ; The initial assertion for the demo June 2005 2 | ; Can also be used for common Metcast channels 3 | ; 4 | ; When actually running the demo, replace ed.emergency@HOST, 5 | ; sam.sysadmin@HOST, etc. with real identities in use at the 6 | ; demo system. 7 | 8 | ; (re-)create, drop channel, change its attributes, etc. 9 | may-admin(channel,?access) :- 10 | sam.sysadmin@HOST says may-admin(?access). 11 | 12 | ; emergency policies. Delegate to the emergency role 13 | may-admin(channel,?access) :- 14 | ed.emergency@HOST says may-admin(?access). 15 | 16 | ; Move from Step 1 to init state as it makes demo easier to follow 17 | ; SYSADM permits himself everything 18 | may-admin(channel, ?access) :- 19 | system says access-right(?access), 20 | application says this-user(sam.sysadmin@HOST). 21 | 22 | ; Move from Step 1 to init state as it makes demo easier to follow 23 | ; the owner of the channel can delete the channel and update 24 | ; its attributes 25 | may-admin(channel, ?access) :- 26 | system says access-right(?access), 27 | application says this-channel-owner(?channel,?owner), 28 | application says this-user(?owner). 29 | 30 | ; read or write from the channels 31 | may(channel,?access) :- 32 | application says this-channel-owner(?channel,?owner), 33 | ?owner says may(channel,?access). 34 | 35 | ; Only sam.sysadmin@HOST may read the audit records 36 | may(channel, read) :- 37 | application says this-channel-owner(ADMH,?), 38 | application says this-user(sam.sysadmin@HOST). 39 | 40 | 41 | ; For the demo, permit anyone to write to the ADM channel 42 | may(channel, write) :- 43 | application says this-channel-owner(ADM,?). 44 | 45 | ; For the demo, permit anyone to read from the ADM channel 46 | ;may(channel, read) :- 47 | ; application says this-channel-owner(ADM,?). 48 | 49 | ; emergency policies. Delegate to the emergency role 50 | may(channel,?access) :- 51 | ed.emergency@HOST says may(channel,?access). 52 | 53 | 54 | ; ``Standard channels'' with the public access 55 | may(channel,?access) :- 56 | access-right(?access), 57 | application says this-channel-owner(?channel,?), 58 | standard-channel(?channel). 59 | 60 | access-right(read). 61 | access-right(write). 62 | access-right(create). 63 | access-right(recreate). 64 | access-right(delete). 65 | 66 | standard-channel("DemoFiles"). 67 | standard-channel("SATIMG"). 68 | standard-channel("TESTIMG"). 69 | standard-channel("TextFiles"). 70 | 71 | -------------------------------------------------------------------------------- /demo/metcast-channels/soutei-metcast-tests.hs: -------------------------------------------------------------------------------- 1 | -- The regression test suite for Soutei along the lines of a real 2 | -- demo (given in June 2005). 3 | -- The main entry point runs the tests using the linked-in 4 | -- Soutei engine. 5 | -- The alternative entry point runs the tests against the Metcast server 6 | -- configured to communicate with a Soutei server for 7 | -- authorization decisions. The alternative entry point emulates the 8 | -- demonstration on June 2005. 9 | 10 | module Main where 11 | 12 | import Control.Monad 13 | import Data.IORef 14 | import Data.List 15 | import Data.Maybe 16 | import Network.Socket 17 | import System.Environment 18 | import System.IO 19 | import System.IO.Error as IO 20 | 21 | import Soutei.Assertions (Assertions, emptyF, loadSysCtxF, putCtxF, queryF) 22 | import Soutei.Soutei 23 | 24 | -- The main entry point 25 | -- The two arguments are the repetition counts (to test the performamce) 26 | -- For regression tests, pass 1 as the two arguments 27 | main = do 28 | getArgs >>= main' 29 | where 30 | main' [reps, queryReps, input] = do 31 | putStrLn $ "Soutei Regression tests" 32 | runLocalN (read reps) (read queryReps) input souteiDemo 33 | main' _ = do 34 | putStrLn $ "Running with default settings:\n" 35 | ++ " reps = 10\n" 36 | ++ " queryReps = 10\n" 37 | ++ " input = demo/metcast-channels/soutei-metcast-demo-init.txt\n" 38 | main' ["10", "10", "demo/metcast-channels/soutei-metcast-demo-init.txt"] 39 | 40 | 41 | -- The alternative entry point: run the metcast demo 42 | main_metcast = do 43 | putStrLn "Ruinning Metcast Channels demo" 44 | metcastDemoPrep 45 | metcastDemo 46 | 47 | -- Testing Soutei running as a separate server on a specified port 48 | maio = getArgs >>= main' 49 | where main' [port, reps] = 50 | replicateM_ (read reps) 51 | (runRemote (fromIntegral (read port :: Int)) souteiDemo) 52 | main' _ = putStrLn $ 53 | "Two arguments are required\n" ++ 54 | "port to communicate with Soutei at localhost\n" ++ 55 | "repetition count for load testing, for example, 1\n\n" 56 | 57 | 58 | samSysadminAssertion = unlines [ 59 | "may-admin(create) :- ", 60 | " application says this-user(cam.create@HOST). ", 61 | "may-admin(create) :- ", 62 | " application says this-user(cari.create@HOST). ", 63 | ""] 64 | 65 | camCreateAssertion = unlines [ 66 | "; grants himself every access right ", 67 | "may(channel, ?access) :- ", 68 | " system says access-right(?access), ", 69 | " application says this-user(cam.create@HOST). ", 70 | "; Delegate the conditional read permission to don.delegate ", 71 | "may(channel, read) :- ", 72 | " application says this-user(?U), ", 73 | " application says user-citizenship(US), ", 74 | " don.delegate@HOST says may(channel, read). ", 75 | ""] 76 | 77 | donDelegateAssertion = unlines [ 78 | "; permits everything to everybody ", 79 | "may(channel, read). ", 80 | ""] 81 | 82 | edEmergencyAssertion = unlines [ 83 | "may-admin(create). ", 84 | "may(channel, read). ", 85 | ""] 86 | 87 | -- This follows the demo scenario, with some additional checks along the 88 | -- way. 89 | 90 | souteiDemo :: Soutei -> IO () 91 | souteiDemo (Soutei query newAssertion) = do 92 | -- We only have the initial assertion 93 | 94 | -- cam.create can't create channels 95 | let goal = "may-admin channel create" 96 | facts = ["this-user cam.create@HOST"] 97 | assertNot (query "req-init-1" goal facts) 98 | 99 | -- only sam.sysadmin can read logs 100 | let goal = "may channel read" 101 | facts = ["this-channel-owner ADMH sys", 102 | "this-user sam.sysadmin@HOST"] 103 | assert (query "req-init-2" goal facts) 104 | 105 | let goal = "may channel read" 106 | facts = ["this-channel-owner ADMH sys", 107 | "this-user *"] 108 | assertNot (query "req-init-3" goal facts) 109 | 110 | -- some standard channels are public 111 | let goal = "may channel write" 112 | facts = ["this-channel-owner TESTIMG sys", 113 | "this-user *"] 114 | assert (query "req-init-4" goal facts) 115 | 116 | let goal = "may channel read" 117 | facts = ["this-channel-owner TESTIMG sys", 118 | "this-user *"] 119 | assert (query "req-init-5" goal facts) 120 | 121 | -- sam.sysadmin sends his policy 122 | 123 | newAssertion "req-sam-sysadmin-0" "sam.sysadmin@HOST" samSysadminAssertion 124 | 125 | -- cam.create creates DustSensorData, but sets no policy. 126 | 127 | -- cam.create is allowed to create new channels 128 | let goal = "may-admin channel create" 129 | facts = ["this-user cam.create@HOST"] 130 | assert (query "req-dust-init-1" goal facts) 131 | 132 | -- nobody can access his channel 133 | let goal = "may channel write" 134 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 135 | "this-user sam.sysadmin@HOST"] 136 | assertNot (query "req-dust-init-2" goal facts) 137 | 138 | -- even himself 139 | let goal = "may channel write" 140 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 141 | "this-user cam.create@HOST"] 142 | assertNot (query "req-dust-init-3" goal facts) 143 | 144 | -- cam.create sends his policy 145 | 146 | newAssertion "req-push-cam-create" "cam.create@HOST" camCreateAssertion 147 | 148 | -- cam.create can see his channel 149 | let goal = "may channel write" 150 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 151 | "this-user cam.create@HOST"] 152 | assert (query "req-dust-cam-create-1" goal facts) 153 | 154 | let goal = "may channel read" 155 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 156 | "this-user cam.create@HOST"] 157 | assert (query "req-dust-cam-create-2" goal facts) 158 | 159 | -- don.delegate can't see 160 | let goal = "may channel read" 161 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 162 | "this-user don.delegate@HOST"] 163 | assertNot (query "req-dust-cam-create-3" goal facts) 164 | 165 | -- don.delegate sends his policy 166 | 167 | newAssertion "req-push-don-delegate" "don.delegate@HOST" donDelegateAssertion 168 | 169 | -- don.delegate can read but not write 170 | let goal = "may channel read" 171 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 172 | "this-user don.delegate@HOST", 173 | "user-citizenship US"] 174 | assert (query "req-dust-don-delegate-1" goal facts) 175 | 176 | let goal = "may channel write" 177 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 178 | "this-user don.delegate@HOST", 179 | "user-citizenship US"] 180 | assertNot (query "req-dust-don-delegate-2" goal facts) 181 | 182 | -- joe.canuck is a Canadian, so can't read 183 | let goal = "may channel read" 184 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 185 | "this-user joe.canuck@HOST", 186 | "user-citizenship CA"] 187 | assertNot (query "req-dust-don-delegate-3" goal facts) 188 | 189 | -- Emergency policy 190 | 191 | newAssertion "req-push-ed-emergency" "ed.emergency@HOST" edEmergencyAssertion 192 | 193 | -- Anyone can create a channel 194 | let goal = "may-admin channel create" 195 | facts = ["this-user joe.canuck@HOST", 196 | "user-citizenship US"] 197 | assert (query "req-ed-emergency-1" goal facts) 198 | 199 | -- joe.canuck can now see cam.create's channels 200 | let goal = "may channel read" 201 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 202 | "this-user joe.canuck@HOST", 203 | "user-citizenship CA"] 204 | assert (query "req-dust-ed-emergency-2" goal facts) 205 | 206 | -- Emergency over 207 | 208 | newAssertion "req-push-ed-emergency" "ed.emergency@HOST" "" 209 | 210 | -- joe.canuck can no longer read cam.create's channel 211 | let goal = "may channel read" 212 | facts = ["this-channel-owner DustSensorData cam.create@HOST", 213 | "this-user joe.canuck@HOST", 214 | "user-citizenship CA"] 215 | assertNot (query "req-dust-don-delegate-3" goal facts) 216 | 217 | putStrLn "Regression tests done\n" 218 | 219 | `finally` do 220 | newAssertion "req-drop-sam-sysadmin" "sam.sysadmin@HOST" "" 221 | newAssertion "req-drop-cam-create" "cam.create@HOST" "" 222 | newAssertion "req-drop-don-delegate" "don.delegate@HOST" "" 223 | newAssertion "req-drop-ed-emergency" "ed.emergency@HOST" "" 224 | 225 | -- The same demo, except talking to Metcast (configured to use Soutei) 226 | -- instead of Soutei. The users must be configured in Apache. 227 | 228 | metcastDemoPrep = do 229 | deleteChannel samSysadmin "TESTIMG" 230 | assertEq 201 (createChannel samSysadmin "TESTIMG") 231 | 232 | metcastDemo = do 233 | -- We only have the initial assertion 234 | 235 | -- nobody can admin channels 236 | assertEq 403 (createChannel camCreate "DustSensorData") 237 | 238 | -- only sam.sysadmin can read logs 239 | assertEq 200 (retrieve "req-init-2" samSysadmin "ADMH") 240 | assertEq 304 (retrieve "req-init-3" anon "ADMH") 241 | 242 | -- some standard channels are public 243 | assertEq 201 (shove anon "TESTIMG" "text/plain" "hello world") 244 | assertEq 200 (retrieve "req-init-5" anon "TESTIMG") 245 | 246 | -- sam.sysadmin sends his policy 247 | 248 | shoveAssertion samSysadmin samSysadminAssertion 249 | 250 | -- cam.create creates DustSensorData, but sets no policy. 251 | 252 | -- cam.create is allowed to create new channels 253 | assertEq 201 (createChannel camCreate "DustSensorData") 254 | 255 | -- nobody can access his channel 256 | assertEq 400 (shove samSysadmin "DustSensorData" "text/plain" "hello world") 257 | 258 | -- even himself 259 | assertEq 400 (shove camCreate "DustSensorData" "text/plain" "hello world") 260 | 261 | -- cam.create sends his policy 262 | 263 | shoveAssertion camCreate camCreateAssertion 264 | 265 | -- cam.create can see his channel 266 | assertEq 201 (shove camCreate "DustSensorData" "text/plain" "hello world") 267 | assertEq 200 (retrieve "req-dust-cam-create-1" camCreate "DustSensorData") 268 | 269 | -- don.delegate can't see it 270 | assertEq 304 (retrieve "req-dust-cam-create-3" donDelegate "DustSensorData") 271 | 272 | -- don.delegate sends his policy 273 | 274 | shoveAssertion donDelegate donDelegateAssertion 275 | 276 | -- don.delegate can read but not write 277 | assertEq 200 (retrieve "req-dust-don-delegate-1" donDelegate "DustSensorData") 278 | assertEq 400 (shove donDelegate "DustSensorData" "text/plain" "hello world") 279 | 280 | -- joe.canuck is a Canadian, so can't read 281 | assertEq 304 (retrieve "req-dust-don-delegate-3" joeCanuck "DustSensorData") 282 | 283 | -- Emergency policy 284 | 285 | shoveAssertion edEmergency edEmergencyAssertion 286 | 287 | -- Anyone can create a channel 288 | assertEq 201 (createChannel joeCanuck "HockeyScores") 289 | 290 | -- joe.canuck can now see cam.create's channel 291 | assertEq 200 (retrieve "req-dust-ed-emergency-2" joeCanuck "DustSensorData") 292 | 293 | -- Emergency over 294 | 295 | shoveAssertion edEmergency "" 296 | 297 | -- joe.canuck can no longer read cam.create's channel 298 | assertEq 304 (retrieve "req-dust-don-delegate-3" joeCanuck "DustSensorData") 299 | 300 | `finally` do 301 | deleteChannel samSysadmin "DustSensorData" 302 | deleteChannel samSysadmin "HockeyScores" 303 | shoveAssertion samSysadmin "" 304 | shoveAssertion camCreate "" 305 | shoveAssertion donDelegate "" 306 | shoveAssertion edEmergency "" 307 | 308 | -- Soutei helpers 309 | 310 | data Soutei = Soutei { 311 | query :: String -> String -> [String] -> IO Bool, 312 | newAssertion :: String -> String -> String -> IO () 313 | } 314 | 315 | runLocalN reps queryReps input m = do 316 | r <- newIORef emptyF 317 | modifyIORefIO r (loadSysCtxF input) 318 | replicateM_ reps (m (Soutei (queryLocal queryReps r) (newAssertionLocal r))) 319 | 320 | queryLocal reps r id goal facts = readIORef r >>= \idx -> do 321 | let goal' = mkAtom (words goal) 322 | facts' = map (mkAtom . words) facts 323 | ret <- queryF t idx facts' goal' 324 | replicateM_ (reps-1) (assert (liftM (ret ==) (queryF t idx facts' goal'))) 325 | return ret 326 | where 327 | mkAtom (pred:args) = let pred' = Pred pred (length args) 328 | args' = map (Val . SString) args 329 | in Atom NoCtx pred' args' 330 | t = Just 1000 331 | 332 | newAssertionLocal r id ctx s = 333 | let s' = case s of 334 | "" -> Nothing; 335 | _ -> Just s 336 | in modifyIORefIO r (putCtxF "test" (SString ctx) s') 337 | 338 | -- Soutei should be already running with just the initial assertions 339 | -- soutei-metcast-demo-init.txt 340 | runRemote port m = m (Soutei (queryRemote port) (newAssertionRemote port)) 341 | 342 | soutei port = sockReq (liftM (SockAddrInet port) (inet_addr "127.0.0.1")) 343 | 344 | queryRemote :: PortNumber -> String -> String -> [String] -> IO Bool 345 | queryRemote port id goal facts = do 346 | let req = ("(" ++ id ++ " query (" ++ goal ++ ")" ++ 347 | concatMap (\f -> " (" ++ f ++ ")") facts ++ ")\n") 348 | r <- soutei port req 349 | fromMaybe (fail "Unexpected reply from Soutei") 350 | (lookup r [("(" ++ id ++ " #t)\n", return True), 351 | ("(" ++ id ++ " #f)\n", return False)]) 352 | 353 | newAssertionRemote :: PortNumber -> String -> String -> String -> IO () 354 | newAssertionRemote port id ctx assertion = do 355 | let req = ("(" ++ id ++ " assertion " ++ q ctx ++ " " ++ 356 | q assertion ++ ")\n") 357 | r <- soutei port req 358 | fromMaybe (fail "Unexpected reply from Soutei") 359 | (lookup r [("(" ++ id ++ " #t)\n", return ())]) 360 | 361 | q :: String -> String 362 | q s = "\"" ++ concatMap q' s ++ "\"" where 363 | q' '"' = "\\\"" 364 | q' '\\' = "\\\\" 365 | q' c = [c] 366 | 367 | -- metcast helpers 368 | 369 | metcastAddr = liftM (SockAddrInet 80) (inet_addr "127.0.0.1") 370 | metcastURL = "/metcast" 371 | serverURL = metcastURL ++ "/metcast.cgi" 372 | takerURL = metcastURL ++ "/metcast.cgi" 373 | 374 | -- (base64 of "username:", citizenship) 375 | type User = (String, Maybe String) 376 | samSysadmin = ("c2FtLnN5c2FkbWluQEhPU1Q6", Just "US") 377 | edEmergency = ("ZWQuZW1lcmdlbmN5QEhPU1Q6", Just "US") 378 | camCreate = ("Y2FtLmNyZWF0ZUBIT1NUOg==", Just "US") 379 | cariCreate = ("Y2FyaS5jcmVhdGVASE9TVDo=", Just "US") 380 | donDelegate = ("ZG9uLmRlbGVnYXRlQEhPU1Q6", Just "US") 381 | joeCanuck = ("am9lLmNhbnVja0BIT1NUOg==", Just "CA") 382 | anon = ("Kjo=", Nothing) 383 | 384 | retrieve :: String -> User -> String -> IO Int 385 | retrieve id user channel = do 386 | let body = "(" ++ id ++ " (products (Channel " ++ channel ++ ")))" 387 | http "POST" serverURL user "text/x-mbl" body 388 | 389 | shoveAssertion :: User -> String -> IO () 390 | shoveAssertion user assertion = do 391 | let body = "" 392 | s <- shove user "ADM" "text/xml" body 393 | if (s == 201) then return () 394 | else fail ("Failed to shove assertion: " ++ show s) 395 | 396 | createChannel :: User -> String -> IO Int 397 | createChannel user channel = do 398 | let body = unlines [ 399 | "", 400 | "", 403 | " ", 404 | ""] 405 | shove user "ADM" "text/xml" body 406 | 407 | deleteChannel :: User -> String -> IO Int 408 | deleteChannel user channel = do 409 | let body = "" 410 | shove user "ADM" "text/xml" body 411 | 412 | shove :: User -> String -> String -> String -> IO Int 413 | shove user channel contentType body = do 414 | http "PUT" takerURL user (contentType ++ "; cid=" ++ channel) body 415 | 416 | http :: String -> String -> User -> String -> String -> IO Int 417 | http method url (auth, cit) contentType body = do 418 | r <- sockReq metcastAddr (unlinesCRLF [ 419 | method ++ " " ++ url ++ " HTTP/1.0", 420 | "User-Agent: SouteiMetcastTests", 421 | "Authorization: Basic " ++ auth, 422 | "SAML-Assertion: " ++ (case cit of 423 | Just c -> "" ++ c ++ "" 424 | Nothing -> ""), 425 | "Content-type: " ++ contentType, 426 | "Content-length: " ++ show (length body), 427 | ""] 428 | ++ body) 429 | let (http, ' ':r') = span (/= ' ') r 430 | (status', _) = span (/= ' ') r' 431 | status = read status' 432 | -- putStrLn r 433 | when (http /= "HTTP/1.1") (fail ("invalid HTTP reply: " ++ http)) 434 | when (status >= 500) (fail ("HTTP server error: " ++ status')) 435 | return status 436 | 437 | unlinesCRLF = concatMap (++ "\r\n") 438 | 439 | -- common helpers 440 | 441 | sockReq :: IO SockAddr -> String -> IO String 442 | sockReq addr msg = do s <- socket AF_INET Stream 0 443 | a <- addr 444 | connect s a 445 | send' s msg 446 | shutdown s ShutdownSend 447 | ret <- recv' s 448 | sClose s 449 | return ret 450 | where 451 | send' s "" = return () 452 | send' s msg = do c <- send s msg 453 | send' s (drop c msg) 454 | recv' s = do r <- IO.try (recv s (1024 * 8)) 455 | case r of 456 | Left err -> if isEOFError err then return "" 457 | else ioError err 458 | Right msg -> do msg' <- recv' s 459 | return (msg ++ msg') 460 | 461 | assert :: IO Bool -> IO () 462 | assert m = m >>= \r -> case r of 463 | True -> do --hPutStrLn stderr "assertion passed" 464 | return () 465 | False -> fail "assertion failed" 466 | 467 | assertNot :: IO Bool -> IO () 468 | assertNot = assert . liftM not 469 | 470 | assertEq :: (Eq a) => a -> IO a -> IO () 471 | assertEq x = assert . liftM (== x) 472 | 473 | finally :: IO a -> IO b -> IO a 474 | finally m cleanup = do r <- m `IO.catch` \e -> cleanup >> IO.ioError e 475 | cleanup 476 | return r 477 | 478 | modifyIORefIO :: IORef a -> (a -> IO a) -> IO () 479 | modifyIORefIO r f = readIORef r >>= f >>= writeIORef r 480 | -------------------------------------------------------------------------------- /demo/rbac/local/SOUTEI: -------------------------------------------------------------------------------- 1 | Soutei data directory, version 0.0 2 | -------------------------------------------------------------------------------- /demo/rbac/local/assertions/TPS-report-owner: -------------------------------------------------------------------------------- 1 | ; Modelling access control lists and role-based access control 2 | ; in Soutei 3 | ; See the Soutei paper, section `Soutei by example' 4 | ; This is the TPS-report-owner policy, listing the access rights 5 | ; of the roles for the particular resource, TPS-report-memo 6 | 7 | acl-may(read, TPS-report-memo, programmer). 8 | acl-may(read, TPS-report-memo, manager). 9 | acl-may(write, TPS-report-memo, manager). 10 | 11 | -------------------------------------------------------------------------------- /demo/rbac/local/assertions/app-owner: -------------------------------------------------------------------------------- 1 | ; Modelling access control lists and role-based access control 2 | ; in Soutei 3 | ; See the Soutei paper, section `Soutei by example' 4 | ; This is the app-owner policy, listing the roles of users. 5 | 6 | role-member(Peter, programmer). 7 | role-member(Bill, manager). 8 | 9 | -------------------------------------------------------------------------------- /demo/rbac/local/assertions/hr: -------------------------------------------------------------------------------- 1 | ; Modelling access control lists and role-based access control 2 | ; in Soutei 3 | ; See the Soutei paper, section `Soutei by example' 4 | ; This is the hr policy, listing users are their keys 5 | 6 | user-key(Peter, "rsa:Z2FuZ3N0YQ=="). 7 | user-key(Bill, "rsa:eWVhaCBoaQ=="). 8 | -------------------------------------------------------------------------------- /demo/rbac/local/assertions/system: -------------------------------------------------------------------------------- 1 | ; Modelling access control lists and role-based access control 2 | ; in Soutei 3 | ; See the Soutei paper, section `Soutei by example' 4 | ; This is the system policy 5 | 6 | may(?access) :- application says resource(?resource), 7 | application says resource-owner(?owner), 8 | application says public-key(?key), 9 | hr says user-key(?user, ?key), 10 | app-owner says role-member(?user, ?role), 11 | ?owner says acl-may(?access, ?resource, ?role). 12 | -------------------------------------------------------------------------------- /demo/rbac/run-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Modelling access control lists and role-based access control 4 | # in Soutei 5 | # See the Soutei paper, section `Soutei by example' 6 | 7 | SOUTEI_SERVER=../../soutei-server 8 | SOUTEI_CLI=../../soutei-cli # A sample client 9 | 10 | HOST=localhost 11 | PORT=1500 # Communication port with clients 12 | 13 | echo "Starting the soutei server" 14 | $SOUTEI_SERVER system local $PORT & 15 | 16 | echo "server started: $!" 17 | sleep 1 # Wait until it starts up 18 | 19 | echo "Running sample queries" 20 | 21 | # Peter, programmer, can read 22 | $SOUTEI_CLI $HOST:$PORT \ 23 | -- may read \ 24 | -- resource TPS-report-memo \ 25 | -- resource-owner TPS-report-owner \ 26 | -- public-key "rsa:Z2FuZ3N0YQ==" \ 27 | && echo granted 28 | 29 | # Only managers can write 30 | $SOUTEI_CLI $HOST:$PORT \ 31 | -- may write \ 32 | -- resource TPS-report-memo \ 33 | -- resource-owner TPS-report-owner \ 34 | -- public-key "rsa:Z2FuZ3N0YQ==" \ 35 | || echo denied 36 | 37 | # Bill is the manager 38 | $SOUTEI_CLI $HOST:$PORT \ 39 | -- may write \ 40 | -- resource TPS-report-memo \ 41 | -- resource-owner TPS-report-owner \ 42 | -- public-key "rsa:eWVhaCBoaQ==" \ 43 | && echo granted 44 | 45 | # The expected sequence is `granted, denied, granted' 46 | 47 | echo "Terminating the soutei server" 48 | killall soutei-server 49 | 50 | wait 51 | echo "Done" 52 | 53 | -------------------------------------------------------------------------------- /demo/rbac/system: -------------------------------------------------------------------------------- 1 | ; Modelling access control lists and role-based access control 2 | ; in Soutei 3 | ; See the Soutei paper, section `Soutei by example' 4 | ; This is the system policy 5 | 6 | may(?access) :- application says resource(?resource), 7 | application says resource-owner(?owner), 8 | application says public-key(?key), 9 | hr says user-key(?user, ?key), 10 | app-owner says role-member(?user, ?role), 11 | ?owner says acl-may(?access, ?resource, ?role). 12 | -------------------------------------------------------------------------------- /doc/Auth-transport.html: -------------------------------------------------------------------------------- 1 | 3 | 4 | Transport of Soutei assertions 6 | 7 |

previous   next   contents   top 8 |
9 |

Transport of Soutei assertions

10 | 11 |

This page discusses various ways of making Soutei assertions 12 | available to the decision engine: by reading a local configuration 13 | file, by querying trusted databases and LDAP servers, or by delivering 14 | the assertions in HTTP headers and in Public-key and Attribute X.509 15 | certificates.

16 |
17 |
  1. X.509 Certificates and Soutei 18 |
  2. HTTP headers and Soutei 19 |
  3. References 20 |
21 |
22 |
   23 |

X.509 Certificates and Soutei

24 | 25 |

Soutei assertions may be included in a public-key X.509 26 | certificate (PKC) [RFC3280] or in a X.509 attribute 27 | certificate [RFC3281].

28 | 29 |

There is a distinct advantage of including Soutei assertions in a 30 | public-key certificate intended for establishing a TLS 31 | (HTTPS, SSL) connection with the application server. In that case, we 32 | get certificate transport and validation ``for free'', performed as 33 | a part of the TLS handshake. In case of HTTPS, the web server should 34 | be configured to request a client certificate during the 35 | handshake. The web server will challenge the validity of the 36 | certificate, according to the TLS protocol. If the certificate is found 37 | valid and authentic, the web server establishes the TLS connection and 38 | accepts the HTTP request. The web server will give to the application 39 | server (i.e., the Metcast server) the certificate in the PEM-encoded 40 | format, as the content of the environment variable SSL_CLIENT_CERT. An option ExportCertData must be 41 | included in SSLOptions directive of the SSL engine 42 | portion of the Apache configuration file. The Soutei assertion should 43 | be placed, as an octet string, in the field authInfo of 44 | an Attribute structure SvceAuthInfo of a 45 | sequence SubjectDirectoryAttributes of the v3 certificate 46 | extensions field. A private v3 certificate extension may also be 47 | defined for the purpose of holding assertions. Because the assertion 48 | is a part of a signed and validated certificate, we can trust the 49 | assertion without any further checks.

50 | 51 |

Including Soutei assertions in a public-key certificate however 52 | can be problematic from the logistic point of view. Certificates 53 | issued to an end user (e.g., Common Access Card certificates) 54 | typically have restrictions on their usage: the bit cA is 55 | turned off and the certificates may be invalid for key 56 | encipherment. Therefore, an end user may not issue his own 57 | certificates to delegate his privileges to applications or other users 58 | via Soutei assertions. The user must ask a Certifying Authority (CA) 59 | to issue him a certificate with the appropriate Soutei assertions. The 60 | latter is quite an involved process. Furthermore, it is argued in [RFC3281] that CA are wrong entities to issue authorization 61 | statements.

62 | 63 |

The task of issuing authorization statements properly belongs 64 | to attribute authorities, as described in [RFC3281]. Authorization statements are placed into attribute X.509 65 | certificates. According to [RFC3281], an attribute 66 | certificate is a structure similar to public key certificates. Whereas 67 | the latter binds an identity of a subject and his public key, an 68 | attribute certificate serves to assign authorization attributes to the 69 | certificate holder. The attributes may include group membership, role, 70 | security clearance, etc.

71 | 72 |
Some people constantly confuse public-key certificates (PKC) and 73 | attribute certificates (AC). An analogy may make the distinction 74 | clear. A PKC can be considered to be like a passport: it identifies 75 | the holder, tends to last for a long time, and should not be trivial 76 | to obtain. An AC is more like an entry visa: it is typically issued 77 | by a different authority and does not last for as long a time. As 78 | acquiring an entry visa typically requires presenting a passport, 79 | getting a visa can be a simpler process [RFC3281].
80 | 81 |

Attribute certificates seem therefore appropriate vehicles for 82 | Soutei assertions. An end user may issue attribute certificates for 83 | his own applications. Attribute certificates are short-lived and ideal 84 | for such a delegation purpose. Furthermore, the profile in [RFC3281] explicitly states that an attribute certificate issuer 85 | must not be a CA: an attribute certificate issuer's public-key 86 | certificate must not contain a basicConstraints extension 87 | with the cA boolean set to TRUE. Not only 88 | end users may issue attribute certificates -- they are the only 89 | entities that may do so.

90 | 91 |

Before processing an assertion found in an attribute certificate, 92 | the server must validate the certificate as described in Section 5 of 93 | [RFC3281]. If the field Holder of the 94 | certificate identifies the holder by name or by a certificate 95 | reference, the identity of the holder must match the identity of the 96 | authenticated client; see Section 4.2.2 of RFC3281 for more detail. 97 | The holder of the certificate may also be an empty sequence. The assertion 98 | found in such a certificate is eligible for caching. Certificates with 99 | the empty holder name are employed for delegation.

100 | 101 |

A Soutei assertion is placed into one attribute of an attribute 102 | certificate. The certificate may include other attributes. It seems 103 | that the most appropriate attribute for Soutei assertions is 104 | SvceAuthInfo, described in Section 4.4.1 or RFC3281: 105 | ``This attribute provides information that can be presented by the AC 106 | verifier to be interpreted and authenticated by a separate application 107 | within the target system.''

108 | 
     id-aca                     OBJECT IDENTIFIER ::= { id-pkix 10 }
109 |      id-aca-authenticationInfo  OBJECT IDENTIFIER ::= { id-aca 1 }
110 |      SvceAuthInfo ::= SEQUENCE {
111 |            service   GeneralName,
112 |            ident     GeneralName,
113 |            authInfo  OCTET STRING OPTIONAL }
114 |
The Soutei verifier is such a separate application. The Soutei 115 | assertion should be placed into the field authInfo. The 116 | fields service and ident are currently 117 | unused and should be set to the empty value of the type directoryName. We should mention that a Group attribute (Section 118 | 4.4.4 of RFC3281) seems also an appropriate attribute to hold Soutei 119 | assertions. We may in the future register an attribute object identifier 120 | specifically for Soutei assertions. 121 |

When an attribute certificate is imported into Soutei, the subject 122 | identity of the issuer (taken from the field issuerName 123 | of the certificate) serves as a context identifier for the imported 124 | assertion. The subject identity is generally a SHA-1 hash computed 125 | from the name of the issuer or found in the SubjectKeyIdentifier extension of the public-key certificate of 126 | the issuer. The extension takes precedence, if it exists.

127 | 128 |

The problem with attribute certificates is transporting them from 129 | a client to the server. Can we still piggy-back on TLS for 130 | transporting and validating attribute certificates? It seems that 131 | OpenSSL might do that for us. This issue requires further 132 | investigation.

133 |
   134 |

HTTP headers and Soutei

135 | 136 |

Soutei assertions may also be delivered in HTTP headers. The 137 | headers take precedence over the TLS-based transport of 138 | certificates. We introduce two kinds of headers. Only one kind must be 139 | present in a HTTP session.

140 | 141 |

Attribute-assertion header: X-X509-AC. The contents of 142 | the header is an attribute certificate (described above), DER- and 143 | Base64- encoded.

144 | 145 |

Signed-assertion-header: X-BAssertion. The contents of 146 | the header is a cryptographically signed message [RFC3369] 147 | with the content-type text/x-bassertion. The signer of 148 | the message is considered to be the issuer of the assertion.

149 | 150 |

   151 |

References

152 | 153 |

[Binder] J. DeTreville. Binder, a logic-based security language. IEEE Security and Privacy, 2002. 154 |
<http://research.microsoft.com/research/pubs/view.aspx?tr_id=545>

155 | 156 |

[PKI-Tutorial] Peter Gutmann. Everything you never wanted to know about PKI but have been forced 157 | to find out. 158 |
<http://www.cs.auckland.ac.nz/~pgut001/pubs/pkitutorial.pdf>

159 | 160 |

[RFC3280] R. Housley, W. Polk, W. Ford, D. Solo. Internet X.509 Public Key Infrastructure Certificate and Certificate Revocation List (CRL) Profile. RFC 3280, Standards Track. April 2002. 161 |
<http://www.rfc-editor.org/rfc/rfc3280.txt>

162 | 163 |

[RFC3281] S. Farrell and R. Housley. An Internet Attribute Certificate Profile for Authorization. RFC 3281, Standards Track. April 2002. 164 |
<http://www.rfc-editor.org/rfc/rfc3281.txt>

165 | 166 |

[RFC3369] R. Housley. Cryptographic Message Syntax (CMS). RFC 3369. Standards Track. August 2002. 167 |
<http://www.rfc-editor.org/rfc/rfc3369.txt>

168 | 169 |

[NIST-PKI] NIST PKI Program 170 |
<http://csrc.nist.gov/pki/>

171 | 172 |

[ASN1-Guide] Burton S. Kaliski Jr. A Layman's Guide to a Subset of ASN.1, BER, and DER. An RSA Laboratories Technical Note. Revised November 1, 1993. 173 |
<http://citeseer.nj.nec.com/47302.html>

174 | 175 |

[X509-Style] Peter Gutmann. X.509 Style Guide. October 2000. 176 |
<http://www.cs.auckland.ac.nz/~pgut001/pubs/x509guide.txt>

177 | 178 |
179 |
180 |
181 | 182 |

Last updated July 23, 2004

183 | 184 |

This site's top page is http://soutei.sf.net/

185 | 186 |
187 |
oleg-at-pobox.com or oleg-at-okmij.org 188 |
Your comments, problem reports, questions are very welcome!
189 |
190 | 191 |

Converted from SXML by SXML->HTML

192 |

$Id: Auth-transport.scm,v 1.2 2004/10/15 02:46:02 oleg Exp oleg $

193 | -------------------------------------------------------------------------------- /doc/Auth-transport.scm: -------------------------------------------------------------------------------- 1 | (define Content 2 | '(html:begin 3 | (Header 4 | (title "Transport of Soutei assertions") 5 | (description "Discussion of various ways to bring assertions to 6 | the Soutei engine.") 7 | (Date-Revision-yyyymmdd "20040723") 8 | (Date-Creation-yyyymmdd "20040722") 9 | (keywords "Binder, Soutei, Keynote, X.509, Attribute certificate") 10 | (AuthorAddress "oleg-at-okmij.org") 11 | (Author "Oleg Kiselyov") 12 | (rcs-id "$Id: Auth-transport.scm,v 1.2 2004/10/15 02:46:02 oleg Exp oleg $") 13 | (long-title "Transport of Soutei assertions") 14 | (Links 15 | (start "Authorization.html" 16 | (title "Authorization and Role-Based Access control")) 17 | (contents "Authorization.html") 18 | (prev "Auth-use-cases.html") 19 | (next "Authorization.html") 20 | (top "index.html") 21 | (home "http://soutei.sf.net/"))) 22 | 23 | (body 24 | (navbar) 25 | (page-title) 26 | 27 | 28 | (p "This page discusses various ways of making Soutei assertions 29 | available to the decision engine: by reading a local configuration 30 | file, by querying trusted databases and LDAP servers, or by delivering 31 | the assertions in HTTP headers and in Public-key and Attribute X.509 32 | certificates.") 33 | 34 | (TOC) 35 | 36 | (Section 2 "X.509" " Certificates and Soutei") 37 | 38 | (p "Soutei assertions may be included in a public-key X.509 39 | certificate (PKC) " (cite "RFC3280") " or in a X.509 attribute 40 | certificate " (cite "RFC3281") ".") 41 | 42 | (p "There is a distinct advantage of including Soutei assertions in a 43 | public-key certificate intended for establishing a TLS 44 | \(HTTPS, SSL) connection with the application server. In that case, we 45 | get certificate transport and validation ``for free'', performed as 46 | a part of the TLS handshake. In case of HTTPS, the web server should 47 | be configured to request a client certificate during the 48 | handshake. The web server will challenge the validity of the 49 | certificate, according to the TLS protocol. If the certificate is found 50 | valid and authentic, the web server establishes the TLS connection and 51 | accepts the HTTP request. The web server will give to the application 52 | server (i.e., the Metcast server) the certificate in the PEM-encoded 53 | format, as the content of the environment variable " (code 54 | "SSL_CLIENT_CERT") ". An option " (code "ExportCertData") " must be 55 | included in " (code "SSLOptions") " directive of the SSL engine 56 | portion of the Apache configuration file. The Soutei assertion should 57 | be placed, as an octet string, in the field " (code "authInfo") " of 58 | an " (code "Attribute") " structure " (code "SvceAuthInfo") " of a 59 | sequence " (code "SubjectDirectoryAttributes") " of the v3 certificate 60 | extensions field. A private v3 certificate extension may also be 61 | defined for the purpose of holding assertions. Because the assertion 62 | is a part of a signed and validated certificate, we can trust the 63 | assertion without any further checks.") 64 | 65 | (p "Including Soutei assertions in a public-key certificate however 66 | can be problematic from the logistic point of view. Certificates 67 | issued to an end user (e.g., Common Access Card certificates) 68 | typically have restrictions on their usage: the bit " (code "cA") " is 69 | turned off and the certificates may be invalid for key 70 | encipherment. Therefore, an end user may not issue his own 71 | certificates to delegate his privileges to applications or other users 72 | via Soutei assertions. The user must ask a Certifying Authority (CA) 73 | to issue him a certificate with the appropriate Soutei assertions. The 74 | latter is quite an involved process. Furthermore, it is argued in " 75 | (cite "RFC3281") " that CA are wrong entities to issue authorization 76 | statements.") 77 | 78 | (p "The task of issuing authorization statements properly belongs 79 | to attribute authorities, as described in " (cite "RFC3281") 80 | ". Authorization statements are placed into attribute X.509 81 | certificates. According to " (cite "RFC3281") ", an attribute 82 | certificate is a structure similar to public key certificates. Whereas 83 | the latter binds an identity of a subject and his public key, an 84 | attribute certificate serves to assign authorization attributes to the 85 | certificate holder. The attributes may include group membership, role, 86 | security clearance, etc.") 87 | (blockquote 88 | "Some people constantly confuse public-key certificates (PKC) and 89 | attribute certificates (AC). An analogy may make the distinction 90 | clear. A PKC can be considered to be like a passport: it identifies 91 | the holder, tends to last for a long time, and should not be trivial 92 | to obtain. An AC is more like an entry visa: it is typically issued 93 | by a different authority and does not last for as long a time. As 94 | acquiring an entry visa typically requires presenting a passport, 95 | getting a visa can be a simpler process " (cite "RFC3281") ".") 96 | 97 | (p "Attribute certificates seem therefore appropriate vehicles for 98 | Soutei assertions. An end user may issue attribute certificates for 99 | his own applications. Attribute certificates are short-lived and ideal 100 | for such a delegation purpose. Furthermore, the profile in " (cite 101 | "RFC3281") " explicitly states that an attribute certificate issuer 102 | must not be a CA: an attribute certificate issuer's public-key 103 | certificate must not contain a " (code "basicConstraints") " extension 104 | with the " (code "cA") " boolean set to " (code "TRUE") ". Not only 105 | end users may issue attribute certificates -- they are the only 106 | entities that may do so.") 107 | 108 | (p "Before processing an assertion found in an attribute certificate, 109 | the server must validate the certificate as described in Section 5 of 110 | " (cite "RFC3281") ". If the field " (code "Holder") " of the 111 | certificate identifies the holder by name or by a certificate 112 | reference, the identity of the holder must match the identity of the 113 | authenticated client; see Section 4.2.2 of RFC3281 for more detail. 114 | The holder of the certificate may also be an empty sequence. The assertion 115 | found in such a certificate is eligible for caching. Certificates with 116 | the empty holder name are employed for delegation.") 117 | 118 | (p "A Soutei assertion is placed into one attribute of an attribute 119 | certificate. The certificate may include other attributes. It seems 120 | that the most appropriate attribute for Soutei assertions is 121 | " (code "SvceAuthInfo") ", described in Section 4.4.1 or RFC3281: 122 | ``This attribute provides information that can be presented by the AC 123 | verifier to be interpreted and authenticated by a separate application 124 | within the target system.''") 125 | 126 | (verbatim 127 | "id-aca OBJECT IDENTIFIER ::= { id-pkix 10 }" 128 | "id-aca-authenticationInfo OBJECT IDENTIFIER ::= { id-aca 1 }" 129 | "SvceAuthInfo ::= SEQUENCE {" 130 | " service GeneralName," 131 | " ident GeneralName," 132 | " authInfo OCTET STRING OPTIONAL }" 133 | ) 134 | 135 | "The Soutei verifier is such a separate application. The Soutei 136 | assertion should be placed into the field " (code "authInfo") ". The 137 | fields " (code "service") " and " (code "ident") " are currently 138 | unused and should be set to the empty value of the type " (code 139 | "directoryName") ". We should mention that a Group attribute (Section 140 | 4.4.4 of RFC3281) seems also an appropriate attribute to hold Soutei 141 | assertions. We may in the future register an attribute object identifier 142 | specifically for Soutei assertions." 143 | 144 | ; Place service into Soutei's application context as 'service_info'? 145 | 146 | (p 147 | "When an attribute certificate is imported into Soutei, the subject 148 | identity of the issuer (taken from the field " (code "issuerName") " 149 | of the certificate) serves as a context identifier for the imported 150 | assertion. The subject identity is generally a SHA-1 hash computed 151 | from the name of the issuer or found in the " (code 152 | "SubjectKeyIdentifier") " extension of the public-key certificate of 153 | the issuer. The extension takes precedence, if it exists.") 154 | 155 | (p "The problem with attribute certificates is transporting them from 156 | a client to the server. Can we still piggy-back on TLS for 157 | transporting and validating attribute certificates? It seems that 158 | OpenSSL might do that for us. This issue requires further 159 | investigation.") 160 | 161 | (Section 2 "HTTP" " headers and Soutei") 162 | 163 | (p "Soutei assertions may also be delivered in HTTP headers. The 164 | headers take precedence over the TLS-based transport of 165 | certificates. We introduce two kinds of headers. Only one kind must be 166 | present in a HTTP session.") 167 | 168 | (p "Attribute-assertion header: " (code "X-X509-AC") ". The contents of 169 | the header is an attribute certificate (described above), DER- and 170 | Base64- encoded.") 171 | 172 | (p "Signed-assertion-header: " (code "X-BAssertion") ". The contents of 173 | the header is a cryptographically signed message " (cite "RFC3369") " 174 | with the content-type " (code "text/x-bassertion") ". The signer of 175 | the message is considered to be the issuer of the assertion.") 176 | 177 | 178 | (hr) 179 | 180 | (Section 2 "References") 181 | 182 | (bibitem "Binder" "Binder" 183 | "J. DeTreville. Binder, a logic-based security language. " 184 | "IEEE Security and Privacy, 2002. " 185 | (URL "http://research.microsoft.com/research/pubs/view.aspx?tr_id=545")) 186 | 187 | 188 | (bibitem "PKI-Tutorial" "PKI-Tutorial" 189 | "Peter Gutmann. " 190 | "Everything you never wanted to know about PKI but have been forced 191 | to find out. " 192 | (URL "http://www.cs.auckland.ac.nz/~pgut001/pubs/pkitutorial.pdf")) 193 | 194 | 195 | (bibitem "RFC3280" "RFC3280" 196 | "R. Housley, W. Polk, W. Ford, D. Solo. " 197 | "Internet X.509 Public Key Infrastructure " 198 | "Certificate and Certificate Revocation List (CRL) Profile. " 199 | "RFC 3280, Standards Track. April 2002." 200 | (URL "http://www.rfc-editor.org/rfc/rfc3280.txt") 201 | ) 202 | 203 | (bibitem "RFC3281" "RFC3281" 204 | "S. Farrell and R. Housley. " 205 | "An Internet Attribute Certificate Profile for Authorization. " 206 | "RFC 3281, Standards Track. April 2002." 207 | (URL "http://www.rfc-editor.org/rfc/rfc3281.txt") 208 | ) 209 | 210 | (bibitem "RFC3369" "RFC3369" 211 | "R. Housley. " 212 | "Cryptographic Message Syntax (CMS). " 213 | "RFC 3369. Standards Track. August 2002. " 214 | (URL "http://www.rfc-editor.org/rfc/rfc3369.txt") 215 | ) 216 | 217 | (bibitem "NIST-PKI" "NIST-PKI" 218 | "NIST PKI Program" 219 | (URL "http://csrc.nist.gov/pki/") 220 | ) 221 | 222 | ; ASN.1 References 223 | 224 | (bibitem "ASN1-Guide" "ASN1-Guide" 225 | "Burton S. Kaliski Jr. " 226 | "A Layman's Guide to a Subset of ASN.1, BER, and DER. " 227 | "An RSA Laboratories Technical Note. " 228 | "Revised November 1, 1993. " 229 | (URL "http://citeseer.nj.nec.com/47302.html") 230 | ; http://luca.ntop.org/Teaching/Appunti/asn1.html 231 | ) 232 | 233 | ; ASN.1 Misuse, a paper by Carl M. Ellison 234 | ; Other ASN.1 papers 235 | ; http://www.oss.com/asn1/booksintro.html 236 | ; http://www.larmouth.demon.co.uk/tutorials/tagging/index.htm 237 | ; http://www.oss.com/ 238 | 239 | (bibitem "X509-Style" "X509-Style" 240 | "Peter Gutmann. " 241 | "X.509 Style Guide. " 242 | "October 2000. " 243 | (URL "http://www.cs.auckland.ac.nz/~pgut001/pubs/x509guide.txt")) 244 | 245 | 246 | (footer) 247 | 248 | ))) 249 | 250 | 251 | ;======================================================================== 252 | ; HTML generation 253 | 254 | (define common-rules-here 255 | (generic-web-rules Content 256 | `( 257 | ; A reference to a group of test cases 258 | ; (group-ref target . title) 259 | ; If title is given, generate a regular 260 | ; title 261 | ; Otherwise, use target as the title 262 | (group-ref 263 | . ,(lambda (tag target . title) 264 | (list "" (if (pair? title) title target) 265 | "" nl))) 266 | 267 | ; A category of use cases 268 | ; (Category key . title) 269 | (Category 270 | . ,(lambda (tag key . title) 271 | (list "
 

Category " 272 | (if (pair? title) title key) 273 | "

" nl))) 274 | 275 | ; A section of use cases 276 | ; (Section key title ((group) ...)) 277 | (Scenario 278 | *macro* 279 | . ,(lambda (tag key title . groups) 280 | `((a (@ (name ,key)) (n_)) 281 | (h3 "Scenario " ,key) 282 | ,title 283 | (ul ,(map (lambda (gr) `(li ,gr (br) (n_))) groups)) 284 | ;,groups 285 | ))) 286 | 287 | ; A group of test cases 288 | ; (group key title ((tc) ...) (check)) 289 | (group 290 | *preorder* 291 | . ,(lambda (tag key title test-cases check) 292 | (pre-post-order 293 | `((a (@ (name ,key)) (n_)) 294 | ,title 295 | (ul ,(map (lambda (tc) `(li ,tc)) test-cases)) 296 | ,check 297 | ) 298 | `( 299 | (tc ; a test case 300 | . ,(lambda (tag . txt) txt)) 301 | (check ; Expect the result 302 | . ,(lambda (tag . txt) 303 | (and (not (null? txt)) (not (equal? '("") txt)) 304 | (list "Expect: " txt)))) 305 | ,@common-rules-here)))) 306 | 307 | ; Grammatical terms 308 | (nonterm ; Non-terminal of a grammar 309 | *macro* 310 | . ,(lambda (tag term) 311 | (list "<" term ">"))) 312 | 313 | (term-lit ; terminal that is a Scheme id 314 | *macro* 315 | . ,(lambda (tag term) 316 | term)) 317 | 318 | (term-str ; terminal that is a Scheme string 319 | *macro* 320 | . ,(lambda (tag term) 321 | (list "\"" term "\""))) 322 | 323 | (term-lit ; a literal Scheme symbol 324 | *macro* 325 | . ,(lambda (tag term) 326 | `(em ,term))) 327 | 328 | (ebnf-opt ; An optional term 329 | . ,(lambda (tag term) 330 | (list term "?"))) 331 | 332 | (ebnf-* ; Zero or more repetitions 333 | . ,(lambda (tag term) 334 | (list term "*"))) 335 | 336 | (ebnf-+ ; One or more repetitions 337 | . ,(lambda (tag term) 338 | (list term "+"))) 339 | 340 | (ebnf-choice ; Choice of terms 341 | . ,(lambda (tag . terms) 342 | (list-intersperse terms " | "))) 343 | 344 | (ebnf-group ; Group of terms 345 | *macro* 346 | . ,(lambda (tag . terms) 347 | `((strong "(") " " ,(list-intersperse terms " ") " " 348 | (strong ")")))) 349 | 350 | (production 351 | *macro* 352 | . ,(lambda (tag number lhs rhs . comment) 353 | (define local-ss 354 | `((quote *preorder* 355 | . ,(lambda (tag elem) `(term-str ,elem))) 356 | (*default* . ,(lambda x x)) 357 | (*text* 358 | . ,(lambda (tag str) `(nonterm , str))))) 359 | (let ((lhs (pre-post-order lhs local-ss)) 360 | (rhs (pre-post-order rhs local-ss))) 361 | ;(cerr "lhs: " lhs nl "rhs: " rhs nl) 362 | `(tr (@ (valign top)) 363 | (td (@ (align right)) 364 | (a (@ (name ("prod-" ,number))) "[" ,number "]") (n_)) 365 | (td (@ (align right)) 366 | (code ,lhs)) 367 | (td (@ (align center)) 368 | (code " ::= ")) 369 | (td (@ (align left)) 370 | (code 371 | ,(if (and (pair? rhs) (pair? (car rhs))) 372 | (list-intersperse rhs " ") 373 | rhs)) 374 | " " ,comment))))) 375 | 376 | (productions 377 | *macro* 378 | . ,(lambda (tag . prods) 379 | `(table (@ (border 0) (bgcolor "#f5dcb3")) ,prods))) 380 | 381 | 382 | ))) 383 | 384 | ; Generating HTML 385 | 386 | 387 | (define (generate-HTML Content) 388 | (SRV:send-reply 389 | (pre-post-order Content common-rules-here))) 390 | 391 | (generate-HTML Content) 392 | 393 | 394 | ; LocalWords: Datalog KeyNote RTC SDSI SPKI PolicyMaker SAML 395 | ; LocalWords: Herbrand blockquote bibitem ebnf HTTPS SSL PKC TLS authInfo 396 | ; LocalWords: SubjectDirectoryAttributes SvceAuthInfo GeneralName issuerName 397 | ; LocalWords: directoryName SubjectKeyIdentifier OpenSSL issuer's IMG pubkey 398 | ; LocalWords: DeTreville's ExportCertData SSLOptions Soutei Binder's pAtom 399 | ; LocalWords: KANREN DeTreville 400 | -------------------------------------------------------------------------------- /doc/Auth-use-cases.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mstone/soutei/4d00e12180361561dab948f211bbcf9e75bfb1de/doc/Auth-use-cases.scm -------------------------------------------------------------------------------- /doc/Authorization.html: -------------------------------------------------------------------------------- 1 | 3 | 4 | Authorization and Role-Based Access control 6 | 7 |
previous   next   contents   top 8 |
9 |

Authorization and Role-Based Access control. Survey and notes.

10 |
11 |
  1. Trust-management systems 12 |
  2. KeyNote 13 | 14 |
    1. Keynote problems 15 |
  3. Binder system 16 |
  4. SAML 17 |
  5. RTC: Datalog with constraints 18 |
  6. Policy checking 19 |
  7. Datalog 20 |
21 |
22 |
   23 |

Trust-management systems

24 | 25 |

Most of the access control systems discussed below belong to a 26 | class of trust-management systems. RFC 2704 succinctly describes these 27 | systems as follows [RFC2704]:

28 | 29 |
30 |

A trust-management system provides standard, general-purpose 31 | mechanisms for specifying application security policies and 32 | credentials. Trust-management credentials describe a specific 33 | delegation of trust and subsume the role of public key certificates; 34 | unlike traditional certificates, which bind keys to names, credentials 35 | can bind keys directly to the authorization to perform specific 36 | tasks. 37 |
...

38 | 39 |

Trust management unifies the notions of security policy, 40 | credentials, access control, and authorization. An application that 41 | uses a trust-management system can simply ask the compliance checker 42 | whether a requested action should be allowed. Furthermore, policies 43 | and credentials are written in standard languages that are shared by 44 | all trust-managed applications; the security configuration mechanism 45 | for one application carries exactly the same syntactic and semantic 46 | structure as that of another, even when the semantics of the 47 | applications themselves are quite different.

48 | 49 |

Trust-management policies are easy to distribute across networks, 50 | helping to avoid the need for application-specific distributed policy 51 | configuration mechanisms, access control lists, and certificate 52 | parsers and interpreters.

53 |
54 |
   55 |

KeyNote

56 | 57 |

KeyNote [KeyNote] [RFC2704] is one particular 58 | framework and a language to build trust-management systems. In 59 | KeyNote, principals are identified by names, which can be 60 | cryptographic keys. Policies and credentials are called `assertions': 61 | typically cryptographically signed statements describing trusted 62 | actions and conditions that yield a policy compliance value. The 63 | latter is often a binary value (e.g., grant and deny); a range of restricted access permissions may also be 64 | specified. A principal may issue an assertion delegating authorization 65 | to perform (a subset) of actions to other principals. Top-level assertions 66 | are usually stored locally. Others are fetched from remote authorities 67 | or delivered by clients. In the latter cases, the assertions should be 68 | signed.

69 | 70 |

Particularly attractive properties of KeyNote are an ability of 71 | principals to delegate a subset of their privileges to other 72 | principals, and an ability to express authorization conditions as 73 | logical formulas. A condition is a logical proposition over attributes 74 | whose values can be strings, integers, and floating-point numbers. The 75 | values of the attributes are provided by an application that requests 76 | an authorization advice. The conditions can express, for example, that 77 | a particular file is accessible for reading only within a specific 78 | time window and only if the request is vouched for by at least two 79 | trusted administrators. Examples at the end of RFC2704 are quite 80 | illustrative.

81 | 82 |

KeyNote is a mature system. There is a reference implementation and 83 | several others. KeyNote is a part of a secure distributed file system 84 | [DisCFS] and of OpenBSD's IPSEC stack. Apache-SSL can also 85 | use KeyNote. The KeyNote page 86 | [KeyNote] lists other real-world applications of the 87 | system. Google search for KeyNote trust management yields 88 | quite a few links.

89 | 90 |

One of the important properties of the KeyNote system is its 91 | monotonicity: access permissions never decrease as more security 92 | assertions are made available to the system. That is, KeyNote will 93 | never authorize an action only because some crucial assertion was not 94 | delivered to the system in time. We should note however that the 95 | monotonicity property, however beneficial, precludes using KeyNote 96 | assertions for revocation. Revocation of privileges must be handled in 97 | some other way (e.g., through expiration of certificates).

98 | 99 |

The monotonicity property (adding certificates may only increase 100 | the trust value) seems to be sound: it is guaranteed by the fact that 101 | the Licensees: field of an assertion uses monotone 102 | operators (&&, || and k-of), 103 | and the Conditions: field cannot refer to other 104 | certificates.

105 | 106 |

The notion of an application scope provides some kind of scoping of 107 | attributes. The calling application is responsible for dereferencing 108 | attributes -- either by passing a dictionary or providing a look-up 109 | function (call-back). To the KeyNote system, the values of attributes 110 | and the bindings themselves are immutable. KeyNote provides for 111 | indirect references (e.g., $foo refers to an attribute 112 | whose name is in the attribute foo).

113 |
   114 |

Keynote problems

115 | 116 |

The KeyNote system is not without problems.

117 | 118 |
    119 |
  1. RFC2704 says, ``Attribute names may be given literally or 120 | calculated from string expressions and may be recursively 121 | dereferenced.'' It is not clear if self-references or cyclical 122 | references are expressible. If they are, a non-termination of a 123 | policy decision becomes an issue.
    2. 124 | 125 |
  2. Type conversion seems quite sloppy. Attribute values are 126 | strings; a user may request a conversion of a string to an integer or 127 | an IEEE floating-point number. If the conversion fails, no error is 128 | reported but the conversion result is assumed to be 0. Likewise, 129 | dereferencing an unbound attribute reports no error but yields the 130 | empty string instead.
    3. 131 | 132 |
  3. Local attributes (defined in an assertion itself) override 133 | application-supplied attributes. However, if the name of a local 134 | attribute is mis-spelled (or mis-cased -- names are case-sensitive), 135 | trouble ensues. No error is reported but the overriding fails. The 136 | error becomes especially insidious if a mis-spelled name is used as an 137 | indirect attribute name. The latter fact may cause a wrong value used 138 | in a condition formula, and consequently, authorizing an action that 139 | should have been denied.
    4. 140 | 141 |
  4. A design decision making a numeric conversion failure yield 0 is a 142 | security concern. Here's the example from RFC2704 itself:
         Conditions:
143 |        @user_id == 0 -> "full_access";             # clause (1)
144 |        @user_id < 1000 -> "user_access";           # clause (2)
145 |        @user_id < 10000 -> "guest_access";         # clause (3)
146 |        user_name == "root" -> "full_access";       # clause (4)
147 |
    Here @ is a string-to-integer conversion 148 | operator. Let us suppose that user_id was meant to be 149 | 65535 but by mistake was 65535-. The 150 | conversion fails, @user_id yields the value of 151 | zero, which triggers the answer full_access. A client 152 | would be given an authorization for the full access when no access 153 | should have been granted. This security concern becomes especially 154 | serious if the values of the attributes are accepted from clients, 155 | without exhaustive checking.
    5. 156 | 157 |
  5. It has been proven [RTC] that an analysis of all 158 | requests authorized by a set of assertions is undecidable. In fact, 159 | we cannot in generally tell if a policy with a single assertion 160 | authorizes any request at all. It is therefore impossible in general 161 | to analyze the effect of security assertions, e.g., to verify global 162 | policy constraints.
    6. 163 |
164 | 165 |

   166 |

Binder system

167 | 168 |

Binder is a logic-based security language: an extension of 169 | Datalog. Binder was introduced in a paper [Binder]. Google 170 | search for ``Binder security language'' offers many links to that 171 | paper -- but no real applications or implementations. In that respect, 172 | KeyNote is more developed. On the other hand, Binder is developed by 173 | an experienced security researcher, has a clean design and sound 174 | logical foundations [Logic-AC].

175 | 176 |

A security statement in Binder is a logical program written in a 177 | subset of Prolog without function symbols (i.e., Datalog). Binder 178 | extends Datalog [Datalog] with the notion of a context and 179 | a distinguished relation says. A statement in Binder can 180 | be a simple fact, e.g., can(john_smith,read,resource_r) 181 | or a rule, e.g., can(X,read,resource_r) :- 182 | employee(X,bigco). One rule like that replaces a great number 183 | of conventional access control list items. Security statements in Binder 184 | are therefore concise. Binder can easily express role-based access 185 | control, delegation, and quite complex security policies, for example 186 | [Binder]:

187 | 
     can(X, read, resource_r) :-
188 |         employee(X, bigco),
189 |         boss(Y, X),
190 |         approves(Y, X, read, resource_r).
191 |      employee(john_smith, bigco).
192 |      boss(fred_jones, john_smith).
193 |      approves(fred_jones, john_smith, read, resource_r).
194 |
The first statement in the above certificate is a rule stating that 195 | any employee of a BigCo may read resource_r provided such an 196 | action is approved by his boss. The other three statements are facts 197 | about employees of BigCo and the approval action. More examples along 198 | with their detailed descriptions can be found in the Binder paper [Binder]. 199 |

Granting access to a resource in Binder is deriving 200 | an atom that asserts such a permission, e.g., an atom can(john_smith,read,resource_r) in the example. The 201 | derivation constitutes a logical proof of the 202 | permission. The proof can be generated by a service, in polynomial 203 | time. Alternatively, a client can generate a proof and submit it with 204 | the request. The service needs merely to check the proof. The latter 205 | approach distributes the load of authorization computations and helps 206 | prevent denial-of-service attacks.

207 | 208 |

Binder programs do not contain negation. Therefore, Binder is 209 | monotonic: adding more statements can only make more atoms 210 | provable. In other words, we cannot cause elevated access permissions 211 | by withholding statements.

212 | 213 |

Binder is specifically designed for a distributed computing 214 | environment. Each authorization service has its own Binder context. A 215 | context with a set of facts and rules can be exported into a signed 216 | certificate and transmitted to another service. Statements in an 217 | exported context are marked with the identity of the exporting service 218 | using the quotation form says. A service can import a 219 | context and use the context's statements in local proofs if the local 220 | service trusts the remote one. The trust relationship is itself 221 | expressed as a set of Binder statements.

222 | 223 |

Identities of Binder principals -- for instance, identities of the 224 | exporting services -- are represented by cryptographic keys. The latter 225 | may be encoded in the format described in [RFC2792]. One may 226 | bind a local name to a cryptographic key for easy reference, e.g., 227 | [Binder]:

228 | 
     employee(X, bigco, full_time) :-
229 |        Y says employee(X, bigco, full_time),
230 |        bound(bigco_hr, Y).
231 |      bound(bigco_hr, rsa:3:c1ebab5d).
232 |
The local context with its name bigco_hr can be exported 233 | in turn. This feature lets Binder simulate the linked name spaces of 234 | SDSI/SPKI, but without built-in language support. 235 |

The paper [Binder] states the following distinguished 236 | features of the system:

237 | 238 |
    239 |
  1. A statement in Binder can be translated into a declarative, 240 | stand-alone English sentence.
    2. 241 | 242 |
  2. Binder programs can explicitly define new, application-specific 243 | predicates, which can act as lemmas in proofs. Predicates can be 244 | defined recursively. Rich proofs are allowed.
    3. 245 | 246 |
  3. Certificates may contain arbitrary facts and rules, over local, 247 | application-specific -- or remote and quoted predicates. Certificates 248 | can be safely interpreted outside their exporting context.
    4. 249 | 250 |
  4. Binder statements can appear in certificates, in policies, in 251 | ACLs, and elsewhere, and these statements can inter-operate freely.
    5. 252 | 253 |
  5. Binder queries are decidable in polynomial time.
    6. 254 |
255 | 256 |

Section 7 of the paper [Binder] compares Binder with 257 | X.509 Certificates, SDSI and SPKI, PolicyMaker, KeyNote, SD3 and 258 | similar logic-based security languages, and digital rights management 259 | languages. The paper shows that none of those systems possesses all five 260 | key Binder properties.

261 | 262 |

   263 |

SAML

264 | 265 |

SAML is a Security Assertion Markup Language [SAML]. 266 | SAML seems to be more a certificate format and a certificate transport 267 | format than a trust management language.

268 | 269 |

It seems that DecisionType of a SAML assertion only specifies 270 | Permit, Deny and Indeterminate. KeyNote provides for far more variety 271 | of decisions. The conditions on the assertion are also far less 272 | expressive: NotBefore, NotOnOrAfter, <AudienceRestrictionCondition>, 273 | <DoNotCacheCondition>.

274 |
   275 |

RTC: Datalog with constraints

276 | 277 |

Ninghui Li and John C. Mitchell have proposed a family of 278 | declarative trust-management languages based on Datalog with 279 | constraints [RTC].

280 |
   281 |

Policy checking

282 | 283 |

An access control system advises an application if an action 284 | requested by a particular principal is consistent with a security 285 | policy. We may also need to check if the security policy itself is 286 | consistent, that is, if it actually protects valuable resources. In a 287 | policy with many rules, the overall effect may be difficult to 288 | see. Unpleasant surprises do happen in practice:

289 | 290 |
Firewalls that rely on chained rule sets are vulnerable to 291 | cascade failures -- a change in one rule can have an effect on every 292 | rule that follows it. I've seen systems that relied on a firewall to 293 | block services that were only supposed to be available on the local 294 | network, but which were made available to the entire Internet due to 295 | the unforeseen results of a firewall rule change. [Firewalls] (p. 35)
296 | 297 |

The first quantitative study of firewall configuration errors 298 | [Firewall-errors] found the results dismal. ``Only one of the 299 | 37 firewalls exhibited just a single misconfiguration. All the others 300 | could have been easily penetrated by both unsophisticated attackers 301 | and mindless automatic worms.''

302 | 303 |

To prevent such unforeseen results we need to check policy's 304 | invariants and consistency. Unfortunately, many access control systems 305 | have quite low expressivity, which results in a large set of 306 | rules. For example, SELinux policy has around 50,000 statements. We 307 | need automated tools to verify policies. The tools must be built on 308 | firm logical foundations. Because the policy check is an off-line 309 | process (executed only when the policy is updated), the performance of 310 | the tools is not of prime importance.

311 | 312 |

Unfortunately, some of the access control systems such as KeyNote 313 | have not been designed with policy checking in mind: in general, 314 | policy checking in KeyNote is undecidable [RTC].

315 | 316 |

One real-life example of policy checking is testing that SELinux 317 | policies are consistent with the trusted computer base requirements: 318 | `Analyzing Integrity Protection in the SELinux Example Policy' by 319 | Trent Jaeger, Reiner Sailer, Xiaolan Zhang presented at USENIX 320 | Security Symposium 2003 [VALI]. The authors have developed 321 | a Gokyo policy analysis tool, which seems to rely on a human-aided 322 | exhaustive search. No inference seem to be present. In fact, the words 323 | `infer' and `formal' are not even mentioned, and the word `logic' 324 | occurs only in the title of two referenced papers. It is not clear how 325 | the tool itself was verified -- if it was at all. Perhaps the stress 326 | must be on rigor rather than on the development of visual tools.

327 | 328 |

   329 |

Datalog

330 | 331 |

Datalog seems to be the foundation for many logic-based access 332 | control languages and systems.

333 | 334 |

Introduction to datalog, top-down and bottom-up strategies, 335 | and Herbrand interpretation:

336 | 337 |
Computational Intelligence, a logical approach. D. Poole, 338 | A. Mackworth and R. Goebel.Oxford University Press, 1998. ISBN 339 | 0-19-510270-3. Chapter 2
340 | The handouts are available at 341 |
<http://www.cs.kuleuven.ac.be/~gerda/hb43/> 342 |

A more advanced comparison of top-down and bottom-up strategies:

343 | 344 |
Datalog Bottom-up is the Trend in the Deductive Database Evaluation 345 | Strategy. Yurek K. Hinz 346 |
<http://faculty.ed.umuc.edu/~meinkej/inss690/hinz.pdf>
347 | 348 |

Even more advanced, and more detailed papers:

349 | 350 |
Greedy Algorithms In Datalog. Sergio Greco and Carlo Zaniolo. 351 |
<http://www.cs.ucla.edu/~zaniolo/papers/tplp01.pdf>
352 | 353 |
Top-Down vs. Bottom-Up Revisited. Ramakrishnan, R., Srivastava, D., & Sudarshan, S. (2000). 354 |
<http://citeseer.nj.nec.com/374977.html>
355 | 356 |
Magic Sets and Other Strange Ways to Implement Logic Programs. Francois Bancilhon, David Maier, Yehoshua Sagiv, Jeffrey D. Ullman. PODS 1986: 1-16 357 |
<http://www.informatik.uni-trier.de/~ley/db/conf/pods/BancilhonMSU86.html>
358 | 359 |
Voronkov, A. (1999). Deductive Database. 360 | Computing Science Department Uppsala University, Uppsala, Sweden. 361 |
<http://www.csd.uu.se/~voronkov/ddb.htm>
362 | 363 |
364 |
Answer-set programming
365 | 366 |
367 |
<http://www.cs.utexas.edu/users/vl/tag/> 368 |
<http://www.cs.utexas.edu/users/tag/>
369 |
370 | 371 |
372 |
XSB: An efficient logical system with top-down and bottom-up 373 | strategies. XSB can evaluate according to Well-Founded Semantics 374 | through full SLG resolution.
375 | 376 |
377 |
<http://www.cs.sunysb.edu/~sbprolog/manual1/index.html>
378 |
379 | 380 |
Disjunctive Datalog
381 | 382 |

A disjunctive Datalog system DLV is the very first system 383 | supporting full disjunctive logic programming with answer set 384 | semantics. It supports answer set semantics for full disjunctive 385 | logic programs with negation, integrity constraints, queries, and 386 | arithmetic built-ins.

387 | 388 |
389 |
DLV Home page: 390 |
<http://www.dbai.tuwien.ac.at/proj/dlv/>
391 | 392 |
DLV Tutorial 393 |
<http://home.cern.ch/~chkoch/dlv/dlv_tutorial.html>
394 |
395 | 396 |

A graph coloring problem in the tutorial illustrates the 397 | advantages of DLV. The problem is to find out if a given map of 398 | countries can be colored with three colors. No two neighbor countries 399 | should have the same color. The map, of Mid-Western U.S. states in the 400 | example, as represented as a set of nodes and arcs. Arcs connect 401 | neighboring states.

402 | 
     node(minnesota). node(wisconsin). node(illinois). node(iowa). ...
403 |      arc(minnesota, wisconsin). arc(illinois, iowa).
404 |
405 |

The problem is solved by the following DLV program with only two 406 | statements:

407 | 
     % guess coloring
408 |      col(Country, red) v col(Country, green) v col(Country, blue) :- node(Country).
409 |      
410 |      % check coloring
411 |      :- arc(Country1, Country2), col(Country1, CommonColor), col(Country2, CommonColor).
412 |
The first statement is a disjunctive rule that guesses a 413 | coloring. The second statement expresses the strong constraint that 414 | deletes all those colorings that do not satisfy our requirements (that 415 | there may be no arc between two nodes of equal color). DLV solves the 416 | problem rather efficiently. 417 |

   418 |

References

419 | 420 |

[RFC2704] M. Blaze, J. Feigenbaum, J. Ioannidis, A. Keromytis. The KeyNote Trust-Management System Version 2. RFC 2704. September 1999. 421 |
<http://www.rfc-editor.org/rfc/rfc2704.txt>

422 | 423 |

[KeyNote] 424 |
<http://www.crypto.com/trustmgt/kn.html>

425 | 426 |

[RFC2792] M. Blaze, J. Ioannidis, A. Keromytis. DSA and RSA Key and Signature Encoding for the 427 | KeyNote Trust Management System.RFC 2792. March 2000. 428 |
<http://www.rfc-editor.org/rfc/rfc2792.txt>

429 | 430 |

[DisCFS] S. Miltchev, V. Prevelakis, S. Ioannidis, J. Ioannidis, 431 | A.D. Keromytis, J.M. Smith. Secure and Flexible Global File Sharing. Proc. USENIX 2003, FREENIX Track, pp. 165-178. 432 |
<http://www.usenix.org/events/usenix03/tech/freenix03/miltchev.html>

433 | 434 |

[Binder] J. DeTreville. Binder, a logic-based security language. IEEE Security and Privacy, 2002. 435 |
<http://research.microsoft.com/research/pubs/view.aspx?tr_id=545>

436 | 437 |

[RTC] Ninghui Li, J.C. Mitchell. Datalog with constraints: a foundation for trust management languages. Proc. PADL2003: Practical Aspects of Declarative Languages. LNCS 2562, pp. 58-73.

438 | 439 |

[Logic-AC] M. Abadi. Logic in Access Control. Proc. of the Eighteenth Annual IEEE Symposium on 440 | Logic in Computer Science (June 2003), 228-233. 441 |
<http://www.cse.ucsc.edu/~abadi/Papers/lics2003.pdf>

442 | 443 |

[SD3] T. Jim. SD3: A trust management system with certified evaluation. Proc. 2001 IEEE Symposium on Security and Privacy, pp. 106-115.

444 | 445 |

[SAML] Security Assertion Markup Language (SAML). Version 1.1. September 2003. 446 |
<http://xml.coverpages.org/saml.html> 447 |
<http://www.oasis-open.org/committees/tc_home.php?wg_abbrev=security>

448 | 449 |

[Firewalls] A. Singer, San Diego Supercomputing Center. Life without firewalls. USENIX ;login:, Dec 2003, v28, N6, pp. 34-41.

450 | 451 |

[Firewall-errors] Avishai Wool. A Quantitative Study of Firewall Configuration Errors. IEEE Computer, June 2004, pp. 62-67

452 | 453 |

[VALI] IBM T. J. Watson Research Center. Linux Security Analysis Tools. 454 |
<http://www.research.ibm.com/vali/>

455 | 456 |
457 |
458 |
459 | 460 |

Last updated July 23, 2004

461 | 462 |

This site's top page is http://soutei.sf.net/

463 | 464 |
465 |
oleg-at-pobox.com or oleg-at-okmij.org 466 |
Your comments, problem reports, questions are very welcome!
467 |
468 | 469 |

Converted from SXML by SXML->HTML

470 |

$Id: Authorization.scm,v 1.5 2004/07/24 01:38:54 oleg Exp oleg $

471 | -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 | Authorization.html -------------------------------------------------------------------------------- /doc/soutei-sourceforge.scm: -------------------------------------------------------------------------------- 1 | ; Evaluation of this file yields an HTML document 2 | ; $Id: soutei-sourceforge.scm,v 4.57 2009/03/11 04:12:37 oleg Exp $ 3 | 4 | (define Content 5 | '(html:begin 6 | (Header 7 | (title "Soutei: a logic-based trust-management system") 8 | (description "A distributed trust-management system") 9 | (Date-Revision-yyyymmdd "20100319") 10 | (Date-Creation-yyyymmdd "20100319") 11 | (keywords "Logic Programming, Keynote, Binder, authorization, access control, Haskell") 12 | (AuthorAddress "oleg-at-okmij.org") 13 | (long-title "Soutei: a logic-based trust-management system") 14 | ) 15 | 16 | (body 17 | (navbar 18 | ("Home" "http://soutei.sourceforge.net") 19 | ("Docs" "#Documentation") 20 | ; ("Sample" "#Sample") 21 | ("Availability" "#Availability") 22 | ("SVN" "http://soutei.svn.sourceforge.net/viewvc/soutei") 23 | ("Summary" "http://sourceforge.net/projects/soutei/") 24 | ;("Discussion" "http://sourceforge.net/mail/?group_id=99654") 25 | ;("News" "http://sourceforge.net/news/?group_id=99654") 26 | ;("Related" "#SOUTEI-related") 27 | ) 28 | 29 | 30 | 31 | (page-title) 32 | 33 | (a (@ (href "http://sourceforge.net/projects/soutei")) " " 34 | (img (@ (src 35 | "http://sflogo.sourceforge.net/sflogo.php?group_id=308653&type=3") 36 | (width "80") (height "15") (border "0") 37 | (alt "SourceForge.net")))) 38 | 39 | (p (em "SOUTEI") " is a trust-management system, a dialect of 40 | Binder, for access control in distributed systems. Soutei policies and 41 | credentials are written in a declarative logic-based security language 42 | and thus constitute distributed logic programs. Soutei policies are 43 | modular, concise, and readable. They support policy verification, and, 44 | despite the simplicity of the language, express role- and 45 | attribute-based access control lists, and conditional delegation.") 46 | (p 47 | (em "SOUTEI") " is designed to be an authorization decision 48 | system: it is meant to give " (em "advice") " whether a particular 49 | action should be permitted. A policy-enforcement point such as a web 50 | server, after receiving a request to fetch a web page, consults 51 | Soutei. Soutei receives the details of the request and replies 52 | with the `yes' or `no' answer, possibly qualified with attributes. It is 53 | up to the policy-enforcement point to follow the given advice. To 54 | reach a decision, Soutei consults the attributes of the request (such 55 | as the users and resources involved), information about the world, and 56 | policies.") 57 | (p 58 | (em "SOUTEI") " can be either embedded into applications or run 59 | as a stand-alone network service. In the latter case, Soutei can work with 60 | applications written in any language or running on any operating system. 61 | Originally, Soutei is a Haskell library. Soutei server is an application 62 | built on the top of the library.") 63 | 64 | (ul 65 | ; (li (local-ref "Sample")) 66 | ; (li (local-ref "mini")) 67 | (li (local-ref "Documentation")) 68 | (li (local-ref "Availability") 69 | (ul (li (local-ref "SVN")) 70 | (li (local-ref "Distributions")) 71 | )) 72 | ; (li (local-ref "Related") 73 | ; (li 74 | ; (a (@ (href "http://lists.sourceforge.net/lists/listinfo/ssax-sxml")) 75 | ; "SOUTEI Mailing list")) 76 | (li (a (@ (href "http://sourceforge.net/projects/soutei")) 77 | "SOUTEI project summary page at SourceForge")) 78 | ) 79 | 80 | ; Add the news section 81 | 82 | ;; (Section 3 "Sample" " applications") 83 | 84 | ;; (dl 85 | ;; (dt (cvs-ref "mini/type-inference.scm")) 86 | ;; (dd 87 | ;; "Hindley-Milner type inference " (em "relation") ", which 88 | ;; relates a term in a lambda-calculus with fixpoint, polymorphic let, 89 | ;; sums and products -- and its type. The relation can be used for type 90 | ;; inference (determining the type for a term), type checking (making 91 | ;; sure that a term is of the given type), and term 92 | ;; reconstruction (constructing a term that has the desired type). We may 93 | ;; also specify a part of the term and a part of the type, and ask the 94 | ;; system to fill in 95 | ;; the rest. In the latter applications, this code acts as a theorem 96 | ;; prover in intuitionistic logic.") 97 | 98 | ;; (dt (cvs-ref "benchmarks/")) 99 | ;; (dd "Standard Prolog benchmarks: nrev, query, qsort, queens, etc. -- 100 | ;; re-written for SOUTEI.") 101 | ;; ) 102 | 103 | (Section 3 "Documentation" " and design notes") 104 | 105 | (p (em "Soutei, a logic-based trust-management system (system description)") 106 | (br) 107 | "Andrew Pimlott and Oleg Kiselyov. Proceedings of FLOPS 2006, " 108 | "8th International Symposium on Functional and Logic Programming. " 109 | "Fuji-Susono, Japan, April 24-26, 2006." (br) 110 | "The paper is published in Springer's Lecture Notes in " 111 | "Computer Science 3945, pp. 130-145, 2006." (br) 112 | (URL "http://dx.doi.org/10.1007/11737414") (br) 113 | (URL "http://okmij.org/ftp/papers/Soutei.pdf")) 114 | 115 | (p 116 | (a (@ (href "doc/")) 117 | "Specification, use cases and design notes")) 118 | 119 | (Section 3 "Availability") 120 | (p "The current version of SOUTEI is 2.1. SOUTEI is OpenSource, 121 | distributed under the GPL 2 license.") 122 | (p 123 | "SOUTEI has been tested on the following Haskell systems:" 124 | (br) 125 | "GHC 6.10.4, The Haskell Platform, on Linux and FreeBSD. It is known 126 | to work on Microsoft Windows.") 127 | 128 | (Section 3 "Distributions") 129 | (p "SOUTEI download site at SourceForge:" 130 | (URL "http://sourceforge.net/projects/soutei/files")) 131 | 132 | (Section 3 "SVN" " Tree") 133 | (p (a (@ (href "http://soutei.svn.sourceforge.net/viewvc/soutei")) 134 | "The SVN Tree")) 135 | 136 | (footer) 137 | 138 | ))) 139 | 140 | ;(pp Content) 141 | 142 | ;======================================================================== 143 | ; HTML generation 144 | 145 | ; IMPORT 146 | ; SXML-to-HTML-ext.scm and all of its imports 147 | 148 | 149 | ; Generating HTML 150 | 151 | (define (generate-HTML Content) 152 | (SRV:send-reply 153 | (pre-post-order Content 154 | (generic-web-rules Content 155 | `((who *preorder* 156 | . ,(lambda (tag . elems) 157 | (pre-post-order `((br) . ,elems) universal-conversion-rules))) 158 | 159 | ; A reference to an anchor in the present file 160 | ; (local-ref target . title) 161 | ; If title is given, generate a regular 162 | ; title 163 | ; Otherwise, transform the content so that a 164 | ; construct that may generate an anchor 'target' (such 165 | ; as Section) is re-written to the 166 | ; title SXML. All other constructs re-write to 167 | ; nothing. 168 | (local-ref 169 | *preorder* 170 | . ,(lambda (tag target . title) 171 | (let 172 | ((title 173 | (if (pair? title) title ; it is given explicitly 174 | (pre-post-order Content 175 | `((*text* . ,(lambda (trigger str) '())) 176 | (*default* 177 | . ,(lambda (tag . elems) 178 | (let ((first-sign (signif-tail elems))) 179 | (if first-sign 180 | (let ((second-sign 181 | (signif-tail (cdr first-sign)))) 182 | (assert (not second-sign)) 183 | (car first-sign)) 184 | '())))) 185 | (Section 186 | *preorder* 187 | . ,(lambda (tag level key . elems) 188 | (if (equal? key target) 189 | (list key elems) 190 | '())))))))) 191 | (assert (pair? title) report: target) 192 | (cerr "title: " title nl) 193 | (post-order 194 | `(a (@ (href #\# ,target)) ,title) 195 | universal-conversion-rules)))) 196 | 197 | ; cvs-ref SOUTEI-relative path 198 | (cvs-ref 199 | *macro* 200 | . ,(lambda (tag path) 201 | `(a (@ (href 202 | "http://soutei.cvs.sourceforge.net/soutei/soutei/" 203 | ,path)) 204 | (code ,path)))) 205 | 206 | ; (navbar (title url) ...) 207 | (navbar 208 | *preorder* 209 | . ,(lambda (tag . elems) 210 | (post-order 211 | `(p (hr (@ (size 1) (noshade))) 212 | (div (@ (align "center")) 213 | ,(map 214 | (lambda (title-url) 215 | `((a (@ (href ,(cadr title-url))) ,(car title-url)) 216 | (n_) "|" (n_))) 217 | elems)) 218 | (hr (@ (size 1) (noshade))) (br)) 219 | universal-conversion-rules))) 220 | 221 | ))))) 222 | 223 | (generate-HTML Content) 224 | 225 | ; LocalWords: href cvs dd typecheck dt OpenSource Chez 226 | -------------------------------------------------------------------------------- /soutei-cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | module Main where 4 | 5 | import System.Environment 6 | import System.Exit 7 | import Network 8 | import System.IO 9 | import Control.Exception (bracket) 10 | import System.IO.Error 11 | import Control.Exception (evaluate,assert) 12 | 13 | docstrings = unlines [ 14 | "Simple Soutei Query interface", 15 | "", 16 | "This program accepts query parameters as arguments, queries", 17 | "the soutei application and indicates the success as its", 18 | "return code. The ExitSuccess code indicates that Soutei advises for", 19 | "the requested action. Any other code (including abort codes) mean", 20 | "disapproval", 21 | "", 22 | "Synopsis", 23 | " soutei-cli soutei-host-port -- key val1 ... -- key val1 ...", 24 | "", 25 | "where soutei-host-port is a string like localhost:1500", 26 | "The other arguments are passes as key val1 val2 tuples separated by --", 27 | "", 28 | "For example,", 29 | "./soutei-cli 127.0.0.1:1500 -- may channel read -- this-user SYSADM -- this-channel-owner ADMH system && echo ok" 30 | 31 | ] 32 | 33 | 34 | req'id = "sm-req-1.0" 35 | 36 | data QArgs = QArgs{ qa_host :: !String, 37 | qa_port :: !Int, 38 | qa_kv :: ![[String]] } deriving Show 39 | 40 | parse'args [] = error "No args" 41 | parse'args (host'port : argkvs) = 42 | QArgs host (parse_port port_str) (parse_kvs argkvs []) 43 | where 44 | (host,port_str) = break (==':') host'port 45 | parse_port (':':str) | [(n,"")] <- reads str = n 46 | parse_port str = error $ "Bad port number arg: " ++ str 47 | 48 | parse_kvs [] acc | not $ null acc = reverse acc 49 | parse_kvs ("--":args) acc = parse_kvs args' (kv:acc) 50 | where (kv,args') = break (=="--") args 51 | parse_kvs args _ = error $ "bad keyword args: " ++ (show args) 52 | 53 | parse_args args = error $ "bad args: " ++ (show args) 54 | 55 | 56 | make'req kvs = (showParen True $ showString req'id . showChar ' ' . 57 | showString "query" . showChar ' ' . skvs) "" 58 | where skvs = foldr (\e z -> showParen True ((unqwords e)++) . z) id kvs 59 | -- like unwords, but print the strings in double quotes, with escapes 60 | -- if needed. Except the first word! Soutei takes it 61 | unqwords (key:vals) = unwords (key : map show vals) 62 | 63 | -- The OK reply is of the form "(sm-req-1.0 #t)" (followed by newline, perhaps) 64 | check'reply rep | (_,'#':'t':_) <- break (=='#') rep = True 65 | check'reply _ = False 66 | 67 | 68 | soutei :: QArgs -> IO String 69 | soutei qa = do bracket 70 | (connectTo (qa_host qa) 71 | (PortNumber (fromIntegral (qa_port qa)))) 72 | (hClose) 73 | (\h -> do 74 | hPutStr h $ make'req (qa_kv qa) 75 | hFlush h 76 | -- shutdown s ShutdownSend 77 | hGetLine h) 78 | print'help str = do 79 | putStrLn str; putStrLn "" 80 | putStrLn docstrings 81 | exitWith (ExitFailure 4) 82 | 83 | main = do 84 | args <- getArgs 85 | if null args then print'help "no args" else return () 86 | rep <- soutei (parse'args args) 87 | exitWith (if check'reply rep then ExitSuccess 88 | else ExitFailure 2) 89 | -------------------------------------------------------------------------------- /soutei-pipelined.hs: -------------------------------------------------------------------------------- 1 | -- Soutei Policy Decision Service 2 | -- It is intended to communice with a pep-auth-filter, an authorization 3 | -- filter for a web server. 4 | -- 5 | -- The interface is straightforward, via stdin/stdout. The filter 6 | -- writes all attributes as name-value-pairs: 7 | -- name1 \n value1 \n name2 \n value2 \n ... 8 | -- Two \n in a row signify the end of input. 9 | -- All attribute names and values are opaque to us, except one. 10 | -- If there is an attribute named 'resource', the corresponding value 11 | -- must be a URL, such as http://host/a/b/c.d 12 | -- The http://host part is optional. We add a sequence of attributes: 13 | -- resource-below = http://host/a 14 | -- resource-below = http://host/a/b 15 | -- 16 | -- We reply with either T\n or F\n. We also have an option to close 17 | -- the connection and exit, or just die. 18 | -- We accept SIGUSR1 so to reload the policy database. See the usage 19 | -- message below. 20 | 21 | module Main (main) where 22 | 23 | import Soutei.Assertions (Assertions, fromDataDirWithActions,loadSysCtx, query) 24 | import Soutei.Syntax 25 | import Soutei.Soutei as Soutei 26 | 27 | import Control.Monad.Trans 28 | import Data.Char ( toLower, isSpace, isAlphaNum, ord ) 29 | import Data.List (scanl, init) 30 | import Numeric (showHex) 31 | 32 | import Data.IORef 33 | import System.IO (hSetBuffering,stderr,BufferMode(..), Handle, hGetLine, 34 | hPutStr, hPutChar, stdin, stdout, hPutStrLn, hFlush) 35 | import System.Posix.Signals as Signals 36 | 37 | import System.Time ( getClockTime ) 38 | import System.Environment (getArgs) 39 | import System.Directory as Dir 40 | import System.Exit 41 | import System.IO.Error as IO 42 | 43 | 44 | version = "$Id: soutei-pipelined.hs 1940 2008-02-14 05:26:56Z oleg.kiselyov $" 45 | 46 | usage = unlines ( 47 | ("Soutei-pipelined " ++ version) : 48 | "Usage: soutei-pipelined DATA-DIR": 49 | "Start the Soutei server.": 50 | " DATA-DIR a directory with policy": 51 | " The directory should be owned by a dedicated user (e.g., root)": 52 | " not being writable to this process, contain a read-only file": 53 | " named system (the root of the policy) and no file named": 54 | " application.": 55 | "Send SIGUSR1 to reload the data.": 56 | []) 57 | 58 | 59 | useError msg = do 60 | note [msg,"\n",usage] 61 | exitWith (ExitFailure 64) 62 | 63 | startError e = note ["Exception: ", show e] >> exitWith (ExitFailure 66) 64 | 65 | main = do 66 | -- setTimeZoneGMT 67 | hSetBuffering stderr LineBuffering 68 | noteDate ["===== Soutei Authorizer server: ", version, "\n\n"] 69 | -- Signals.installHandler Signals.sigPIPE Signals.Ignore Nothing 70 | getArgs >>= main' 71 | 72 | data Policy = Policy{policy_data :: Assertions, 73 | policy_reload :: IORef Bool, 74 | policy_load_action :: IO Assertions} 75 | 76 | main' [dataDir] = do 77 | let load_action = load_policy dataDir `catch` startError 78 | policy <- load_action 79 | reloadFlag <- newIORef False 80 | Signals.installHandler Signals.userDefinedSignal1 81 | (Signals.Catch $ writeIORef reloadFlag True) Nothing 82 | loop (Policy policy reloadFlag load_action) 83 | main' _ = useError "Exactly one arg is required." 84 | 85 | -- The main processing loop 86 | loop :: Policy -> IO () 87 | loop policy = do 88 | note ["Listening"] 89 | attrs <- getAttrs stdin 90 | logRequest attrs 91 | policy <- check_reload policy 92 | res <- authorizer (policy_data policy) attrs 93 | note ["Decision: ", show res] 94 | hPutStrLn stdout (if res then "T" else "F") 95 | hFlush stdout 96 | loop policy 97 | note ["\nSuccessful exit"] 98 | where 99 | check_reload policy = do 100 | reload <- readIORef (policy_reload policy) 101 | if reload then do 102 | p <- writeIORef (policy_reload policy) False >> 103 | policy_load_action policy 104 | return policy{policy_data = p} 105 | else return policy 106 | 107 | type RequestInfo = [(String,String)] 108 | 109 | -- Read the sequence of name-value pairs 110 | getAttrs :: Handle -> IO [(String,String)] 111 | getAttrs h = get [] 112 | where 113 | get acc = do 114 | name <- hGetLine h 115 | if name == "" then return acc 116 | else do 117 | value <- hGetLine h 118 | get ((name,value):acc) 119 | 120 | -- Log the received request. We do that early before starting the parsing, 121 | -- so we can display the (potentially erroneous) request data before 122 | -- we begin reporting errors about them. 123 | -- Note that the type of this function says EMonadIO m -- rather than 124 | -- any MonadCGI. That is, this function assuredly creates no CGI 125 | -- output! 126 | logRequest :: MonadIO m => RequestInfo -> m () 127 | logRequest req = 128 | noteDate ["---> New AuthRequest request\n", show req] 129 | 130 | 131 | -- The main authorizer module 132 | authorizer :: Assertions -> RequestInfo -> IO Bool 133 | authorizer policies req = do 134 | let auth_req = read_analyze_req req 135 | soutei_query policies auth_req 136 | 137 | data AuthRequest = AuthRequest {areq_verb :: String, 138 | areq_uri :: String, 139 | areq_atts :: [(String,String)]} 140 | 141 | -- Build the request for Soutei 142 | read_analyze_req :: RequestInfo -> AuthRequest 143 | read_analyze_req req = AuthRequest {areq_verb = "Access", 144 | areq_uri = "service", 145 | areq_atts = ext_req} 146 | where 147 | ext_req = maybe req add_to_req $ lookup "resource" req 148 | add_to_req uri = map (\v -> ("resource-below",v)) (split_uri uri) ++ req 149 | 150 | -- Split the URI at resource boundaries (as described in the commenst above) 151 | split_uri :: String -> [String] 152 | split_uri uri = check $ splitAll '/' uri 153 | where 154 | check (schema:"":host:components@(_:_)) = 155 | map ((schema++'/':'/':host)++) $ build components 156 | check (schema:"":host:[]) = [] 157 | check ("":components@(_:_)) = build components 158 | check components@(_:_) = build components 159 | check _ = [] 160 | build = tail . scanl (\z a -> z ++ '/':a) "" . init 161 | 162 | t_split_uri1 = map split_uri [ 163 | "", "http://localhost", "http://localhost/", 164 | "http://localhost/a", "http://localhost/a/b", "http://localhost/a/b/", 165 | "/", "/a/b/c", "a/b/c", "a", "a/", "a/b/c/"] 166 | {- 167 | [[],[],[], 168 | [],["http://localhost/a"],["http://localhost/a","http://localhost/a/b"], 169 | [],["/a","/a/b"],["/a","/a/b"],[],["/a"],["/a","/a/b","/a/b/c"]] 170 | -} 171 | 172 | 173 | -- | Split a list in many on a particular element: 174 | -- 175 | -- > splitAll 'm' "simply marvelous" == ["si", "ply ", "arvelous"] 176 | -- 177 | splitAll :: Eq a => a -> [a] -> [[a]] 178 | splitAll c s = case break (==c) s of 179 | ([], []) -> [] 180 | (x, []) -> [x] 181 | (x, [_]) -> [x, []] 182 | (x, _:y) -> x : splitAll c y 183 | 184 | 185 | soutei_query :: Assertions -> AuthRequest -> IO Bool 186 | soutei_query policy areq = do 187 | let goal = Soutei.goal "may" [SString $ areq_verb areq, 188 | SString $ areq_uri areq] 189 | facts <- mapM attr_to_fact $ areq_atts areq 190 | note ["Beginning the query; goal: ", show goal, "\n", 191 | "facts: ", show (areq_atts areq)] 192 | query runLimit policy facts goal 193 | 194 | runLimit = Just 10000 195 | 196 | attr_to_fact (key,val) = atomToFact $ Soutei.fact key [SString val] 197 | 198 | -- Loading the policies and checking them 199 | load_policy :: FilePath -> IO Assertions 200 | load_policy data_dir = do 201 | note ["Loading policies from directory ",data_dir] 202 | ifnotA (doesDirectoryExist data_dir) 203 | (fail "Data directory does not exist") 204 | ifnotA (getPermissions data_dir >>= \p -> return $ 205 | Dir.readable p && Dir.searchable p && (not $ Dir.writable p)) 206 | (fail "Data directory has wrong permissions") 207 | let sys_ctx_file = ctxFilename data_dir sysCtx 208 | ifnotA (getPermissions sys_ctx_file >>= \p -> return $ 209 | Dir.readable p && (not $ Dir.writable p)) 210 | (fail "System policy is writable: wrong") 211 | ifnotA (fmap not $ doesFileExist (ctxFilename data_dir appCtx)) 212 | (fail "application file should not exist") 213 | 214 | policies <- fromDataDirWithActions logErr readA writeA 215 | loadSysCtx sys_ctx_file policies 216 | return policies 217 | where 218 | writeA ctx content = return () 219 | readA ctx = let ctxFile = ctxFilename data_dir ctx in do 220 | b <- doesFileExist ctxFile 221 | if b 222 | then (return . Just) =<< readFile ctxFile 223 | else return Nothing 224 | logErr err = note [if isUserError err then ioeGetErrorString err 225 | else show err] 226 | 227 | ifnotA :: Monad m => m Bool -> m () -> m () 228 | ifnotA testA ac = do 229 | f <- testA 230 | if f then return () else ac 231 | 232 | ctxFilename :: FilePath -> Const -> FilePath 233 | ctxFilename dataDir ctx = dataDir ++ "/" ++ encode (show ctx) 234 | 235 | encode :: String -> String 236 | encode = concatMap encode' where 237 | encode' ch | isAlphaNum ch || ch `elem` "!#$&'()+,-.;=@_" = [ch] 238 | | otherwise = '%' : showHex (ord ch) ";" 239 | 240 | 241 | -- | Convenience function for logging, into stderr 242 | note :: MonadIO m => [String] -> m () 243 | note msgs = liftIO (mapM_ (hPutStr stderr) msgs >> hPutChar stderr '\n') 244 | 245 | -- The same but prints the date first 246 | noteDate :: MonadIO m => [String] -> m () 247 | noteDate msgs = do 248 | t <- liftIO getClockTime 249 | note $ show t : ": " : msgs 250 | -------------------------------------------------------------------------------- /soutei-server.hs: -------------------------------------------------------------------------------- 1 | -- Soutei server 2 | 3 | module Main where 4 | 5 | import Prelude hiding (log) 6 | import Control.Exception (bracket) 7 | import Control.Monad (liftM) 8 | import Network 9 | import System.Environment (getArgs) 10 | import System.Exit 11 | import System.IO 12 | import System.IO.Error as IO 13 | import System.IO.Unsafe (unsafeInterleaveIO) 14 | import System.Locale (defaultTimeLocale) 15 | import System.Time (getClockTime, toCalendarTime, formatCalendarTime) 16 | 17 | import Soutei.Assertions (Assertions, fromDataDir, loadSysCtx, putCtx, 18 | query, queryResults) 19 | import Soutei.Parsec (parseM) 20 | import Soutei.Sexpr (Sexpr) 21 | import Soutei.Sexpr as Sexpr 22 | import Soutei.Soutei as Soutei 23 | import Soutei.Syntax 24 | 25 | usage = unlines ( 26 | "Soutei $Id: soutei-server.hs 2155 2009-05-19 03:40:47Z oleg.kiselyov $": 27 | "Usage: server SYSTEM-ASSERTION DATA-DIR PORT": 28 | "Start the Soutei server.": 29 | " SYSTEM-ASSERTION a file containing the system assertion": 30 | " DATA-DIR a directory for storing persistent data": 31 | " PORT the TCP port on which to listen (number or service name)": 32 | "Requests take one of the forms:": 33 | " (REQ-ID query (REQ-PRED ARG1 ...) (FACT1-PRED ARG1 ...) ...)": 34 | " Try to derive the request from the policy, using the facts as the": 35 | " application assertion. Returns #t (allow) or #f (deny).": 36 | " (REQ-ID query-results (REQ-PRED ARG1 ...) (FACT1-PRED ARG1 ...) ...)": 37 | " Like query, but returns the list of derived facts.": 38 | " (REQ-ID assertion CONTEXT \"ASSERTION-TEXT\")": 39 | " Add or replace the assertion for the given context. Returns #f if there": 40 | " was a problem with the assertion, #t otherwise.": 41 | "Response has the form": 42 | " (REQ-ID RETURN)": 43 | "Log messages go to stderr, which can be redirected to a file.": 44 | []) 45 | 46 | useError msg = do hPutStrLn stderr msg 47 | hPutStr stderr usage 48 | exitWith (ExitFailure 64) 49 | 50 | startError err = let msg = if isUserError err then ioeGetErrorString err 51 | else show err 52 | in do hPutStrLn stderr msg 53 | exitWith (ExitFailure 66) 54 | 55 | main = do getArgs >>= \args -> case args of 56 | [initFile, dataDir, port] -> do 57 | let portID = case reads port of 58 | ((n, ""):_) -> PortNumber (fromIntegral n) 59 | _ -> Service port 60 | as <- fromDataDir logErr dataDir `IO.catch` startError 61 | loadSysCtx initFile as `IO.catch` startError 62 | bracket (listenOn portID `IO.catch` startError) sClose $ 63 | \s -> do logDate "Soutei $Id: soutei-server.hs 2155 2009-05-19 03:40:47Z oleg.kiselyov $ started" 64 | loop as s 65 | _ -> useError "Exactly three arguments required." 66 | 67 | loop :: Assertions -> Socket -> IO () 68 | loop as s = do 69 | logDate "Listening ..." 70 | bracket (accept s) 71 | (\(h,_,_) -> hClose h `IO.catch` logErr) $ \(h,_,_) -> do 72 | logDate "Connected" 73 | req <- hGetContents h 74 | se <- parseM (Sexpr.whiteSpace >> Sexpr.cons term) "request" req 75 | log ("--> " ++ show se) 76 | Sexpr.toList se >>= \l -> case l of 77 | Sexpr.Atom (Val reqId) : Sexpr.Atom (Val (SString cmd)) : rest -> do 78 | r <- serveRequest as cmd rest 79 | `IO.catch` \e -> logErr e >> return (boolToSexpr False) 80 | let rsp = show (Sexpr.Atom (Const' reqId) `Sexpr.Cons` r) 81 | log ("<-- " ++ rsp) 82 | hPutStrLn h rsp 83 | _ -> fail "malformed request" 84 | `IO.catch` logErr 85 | loop as s 86 | 87 | log msg = log' msg 88 | logDate msg = do t <- getClockTime >>= toCalendarTime 89 | log' ("[" ++ formatCalendarTime defaultTimeLocale 90 | "%Y-%m-%d %H:%M:%S" t ++ "] " 91 | ++ msg) 92 | logErr err = log' (if isUserError err then ioeGetErrorString err 93 | else show err) 94 | log' msg = hPutStrLn stderr msg `IO.catch` \e -> exitWith (ExitFailure 74) 95 | 96 | data Const' = Const' Const 97 | | Bool' Bool 98 | instance Show Const' where 99 | showsPrec _ (Const' x) = shows x 100 | showsPrec _ (Bool' False) = ("#f" ++) 101 | showsPrec _ (Bool' True) = ("#t" ++) 102 | 103 | serveRequest :: Assertions -> String -> [Sexpr SynTerm] -> IO (Sexpr Const') 104 | serveRequest as "query" l = liftM boolToSexpr (doQuery as l) 105 | serveRequest as "query-results" l = liftM factsToSexpr (doQueryResults as l) 106 | serveRequest as "assertion" l = liftM unitToSexpr (doAssertion as l) 107 | serveRequest _ cmd _ = fail ("unknown command: " ++ cmd) 108 | 109 | boolToSexpr b = Sexpr.fromAtomList [Bool' b] 110 | unitToSexpr _ = boolToSexpr True 111 | factsToSexpr fs = Sexpr.fromList (map factToSexpr fs) where 112 | factToSexpr (Soutei.Atom NoCtx (Pred p _) as) = 113 | Sexpr.fromAtomList (Const' (SString p) : map (\(Val x) -> Const' x) as) 114 | 115 | doQuery :: Assertions -> [Sexpr SynTerm] -> IO Bool 116 | doQuery as (goal:facts) = do 117 | goal' <- mkAtom goal 118 | facts' <- mapM mkFact facts 119 | query runLimit as facts' goal' 120 | doQuery _ _ = fail "query missing goal" 121 | 122 | doQueryResults :: Assertions -> [Sexpr SynTerm] -> IO [Fact] 123 | doQueryResults as (goal:facts) = do 124 | goal' <- mkAtom goal 125 | facts' <- mapM mkFact facts 126 | queryResults runLimit as facts' goal' 127 | 128 | runLimit = Just 10000 129 | 130 | mkAtom :: Sexpr (SynTerm) -> IO (SynHeadAtom) 131 | mkAtom l = Sexpr.toAtomList l >>= \l -> case l of 132 | (Val (SString pred):args@(_:_)) -> 133 | return (Soutei.Atom NoCtx (Pred pred (length args)) args) 134 | _ -> fail "malformed or missing predicate" 135 | 136 | mkFact :: Sexpr (SynTerm) -> IO Fact 137 | mkFact fact = mkAtom fact >>= atomToFact 138 | 139 | doAssertion :: Assertions -> [Sexpr (SynTerm)] -> IO () 140 | doAssertion as [Sexpr.Atom (Val ctx), Sexpr.Atom (Val (SString text))] 141 | | ctx == sysCtx = fail "may not replace system assertion" 142 | | ctx == appCtx = fail "may not add application assertion" 143 | | True = let s = case text of 144 | "" -> Nothing 145 | _ -> Just text 146 | in putCtx "assertion" ctx s as 147 | doAssertion _ _ = fail "malformed assertion request" 148 | 149 | --------------------------------------------------------------------------------