├── _CoqProject ├── mail-cli ├── Setup.hs ├── lib │ ├── Main.hs │ ├── CLI │ │ └── Stubs.hs │ └── FS │ │ ├── State.hs │ │ └── Ops.hs ├── stack.yaml ├── Extract.v ├── mail-cli.cabal └── fiximports.py ├── mail-test ├── Setup.hs ├── stack.yaml ├── lib │ ├── Support.hs │ ├── Main.hs │ ├── SMTP.hs │ └── POP3.hs ├── Extract.v ├── mail-test.cabal ├── stack.yaml.lock └── fiximports.py ├── concur-test ├── Setup.hs ├── stack.yaml ├── Extract.v ├── stack.yaml.lock ├── concur-test.cabal ├── lib │ ├── Main.hs │ └── Interpreter.hs └── fiximports.py ├── src ├── Spec │ ├── Equiv.v │ ├── ConcurProc.v │ ├── Equiv │ │ ├── Automation.v │ │ └── Atomic.v │ ├── Trace.v │ ├── Abstraction.v │ ├── CodeOpt.v │ └── ExecSemantics.v ├── .dir-locals.el ├── Helpers │ ├── ProofAutomation │ │ ├── Abstract.v │ │ ├── DependentEq.v │ │ ├── Misc.v │ │ ├── ExistentialVariants.v │ │ ├── Propositional.v │ │ └── SimplMatch.v │ ├── Learn.v │ ├── ProofAutomation.v │ ├── FunMap.v │ ├── RecordSet.v │ ├── Instances.v │ ├── ListStuff.v │ ├── Sets.v │ └── StringUtils.v ├── CSPEC.v ├── FS │ ├── MailServerAPI.v │ ├── FSImpl.v │ ├── LinkAPI.v │ ├── FSAPI.v │ └── MailServerProto.v └── Mail │ ├── MailServerLockAbsImpl.v │ ├── MailServerLockAbsAPI.v │ ├── MailServerComposedAPI.v │ ├── MailboxTmpAbsImpl.v │ ├── MailServerComposedImpl.v │ ├── MailboxTmpAbsAPI.v │ ├── LinkRetryImpl.v │ ├── MailFSPathImpl.v │ ├── TryDeliverAPI.v │ ├── MailServerAPI.v │ ├── MailboxAPI.v │ ├── MailFSPathAPI.v │ ├── MailFSAPI.v │ ├── MailFSStringAPI.v │ ├── TryDeliverImpl.v │ ├── DeliverAPI.v │ ├── MailFSStringAbsImpl.v │ ├── MailFSStringImpl.v │ ├── MailFSStringAbsAPI.v │ ├── MailFSImpl.v │ ├── DeliverListTidAPI.v │ └── MailFSPathAbsAPI.v ├── .github └── mailbot.json ├── scripts ├── mk-users.sh ├── add-preprocess.sh ├── run-mailserver.sh └── run-gomail.sh ├── .gitignore ├── README.md ├── research.txt ├── LICENSE ├── .travis.yml ├── Makefile ├── gomail ├── msrv │ └── msrv_test.go └── mclnt │ └── mclnt.go └── README.concur /_CoqProject: -------------------------------------------------------------------------------- 1 | -R build POCS 2 | -------------------------------------------------------------------------------- /mail-cli/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /mail-test/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /concur-test/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Spec/Equiv.v: -------------------------------------------------------------------------------- 1 | Require Export Spec.Equiv.TraceIncl. 2 | Require Export Spec.Equiv.Atomic. 3 | Require Export Spec.Equiv.UptoSteps. 4 | -------------------------------------------------------------------------------- /.github/mailbot.json: -------------------------------------------------------------------------------- 1 | { 2 | "commitEmailFormat": "html", 3 | "commitList": "tchajed@mit.edu,kaashoek@mit.edu,nickolai@csail.mit.edu,adamc@csail.mit.edu,gibsons@mit.edu" 4 | } 5 | -------------------------------------------------------------------------------- /mail-cli/lib/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF ./fiximports.py #-} 2 | module Main where 3 | 4 | import FS.State 5 | import MailCli 6 | 7 | main :: IO () 8 | main = runFS cli 9 | -------------------------------------------------------------------------------- /concur-test/stack.yaml: -------------------------------------------------------------------------------- 1 | # For advanced use and comprehensive documentation of the format, please see: 2 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # latest release for GHC 8.6.5 as of 2020-02-17 5 | # uses GHC 8.6.5 6 | resolver: lts-14.27 7 | -------------------------------------------------------------------------------- /mail-cli/stack.yaml: -------------------------------------------------------------------------------- 1 | # For advanced use and comprehensive documentation of the format, please see: 2 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # latest release as of 2018-08-01 5 | # uses GHC 8.4.3 6 | resolver: lts-12.4 7 | 8 | packages: 9 | - '.' 10 | -------------------------------------------------------------------------------- /concur-test/Extract.v: -------------------------------------------------------------------------------- 1 | Cd "concur-test/extract/". 2 | 3 | Require Import ExtrHaskellBasic. 4 | Require Import ExtrHaskellNatInteger. 5 | 6 | Extraction Language Haskell. 7 | 8 | Require Import Examples.LockedCounter. 9 | 10 | Separate Extraction compiled_threads. 11 | 12 | Cd "../../". 13 | -------------------------------------------------------------------------------- /src/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((coq-mode 5 | (company-coq-dir-local-symbols 6 | ("State" . ?Σ) ("state" . ?σ) ("state'" . (?σ (Br . Bl) ?')) 7 | ("world" . ?Ω) 8 | ("|=" . ?⊨) ("|->" . ?↦) 9 | ))) 10 | -------------------------------------------------------------------------------- /mail-cli/lib/CLI/Stubs.hs: -------------------------------------------------------------------------------- 1 | module CLI.Stubs (getMail) where 2 | 3 | import Control.Monad.Trans (liftIO) 4 | import FS.State 5 | import System.IO 6 | 7 | getMail :: Proc String 8 | getMail = do 9 | x <- liftIO $ do 10 | putStr "Enter text to send: " 11 | hFlush stdout 12 | getLine 13 | return $ x 14 | 15 | -------------------------------------------------------------------------------- /scripts/mk-users.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | NUSER=100 4 | 5 | rm -rf /tmp/mailtest 6 | ln -s /dev/shm/mailtest /tmp/mailtest 7 | 8 | echo "Create $NUSER mailboxes" 9 | for i in `seq 0 $NUSER`; 10 | do 11 | rm -rf /dev/shm/mailtest/u$i 12 | mkdir -p /dev/shm/mailtest/u$i/mail 13 | mkdir -p /dev/shm/mailtest/u$i/tmp 14 | done 15 | 16 | -------------------------------------------------------------------------------- /scripts/add-preprocess.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | # cross-platform sed (because OS X only has BSD sed): 5 | # see http://stackoverflow.com/questions/5694228/sed-in-place-flag-that-works-both-on-mac-bsd-and-linux 6 | 7 | for file in "$@"; do 8 | sed -i.bak $'1s|^|{-# OPTIONS_GHC -F -pgmF ./fiximports.py #-}\\\n|' "$file" 9 | rm "$file.bak" 10 | done 11 | -------------------------------------------------------------------------------- /mail-test/stack.yaml: -------------------------------------------------------------------------------- 1 | # For advanced use and comprehensive documentation of the format, please see: 2 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # latest release for GHC 8.6.5 as of 2020-02-17 5 | # uses GHC 8.6.5 6 | resolver: lts-14.27 7 | 8 | extra-deps: 9 | - flock-0.3.1.8 10 | - rdtsc-1.3.0.1@sha256:0a6e8dc715ba82ad72c7e2b1c2f468999559bec059d50540719a80b00dcc4e66 11 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/Abstract.v: -------------------------------------------------------------------------------- 1 | Local Lemma abstract_away_helper {A} (P: A -> Prop) (x y:A) : 2 | P y -> y = x -> P x. 3 | Proof. 4 | intros; subst; auto. 5 | Qed. 6 | 7 | Ltac abstract_term t := 8 | match goal with 9 | | |- ?g => let p := eval pattern t in g in 10 | match p with 11 | | ?P ?x => eapply (abstract_away_helper P) 12 | end 13 | end. 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /build 2 | /bin 3 | /doc 4 | /.lia.cache 5 | /*/.stack-work 6 | /*/extract 7 | /lab*-handin.tar.gz 8 | 9 | # emacs 10 | *.aux 11 | *.*~ 12 | 13 | # vim 14 | *.swp 15 | 16 | # CoqIDE files 17 | \#*# 18 | 19 | # Coq compiled files 20 | *.vo 21 | *.v.d 22 | *.glob 23 | 24 | # created by remap-nbd 25 | /disk.img 26 | 27 | # created by replicate-nbd 28 | /disk0.img 29 | /disk1.img 30 | 31 | # 32 | rabid.log 33 | postal.log 34 | -------------------------------------------------------------------------------- /scripts/run-mailserver.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" 6 | cd "$DIR/.." 7 | NPROC=$1 8 | NMSG=100000 9 | N=$((NMSG * NPROC)) 10 | TIMEFORMAT='real %R nuser %U sys %S (s)' 11 | echo "== mail-test $NPROC $NMSG $N $(date) == " 12 | for i in $(seq 1 "$NPROC") 13 | do 14 | echo "== mail-test $i $((N / i))" 15 | ./scripts/mk-users.sh; time ./bin/mail-test "$i" "$((N / i))" 1 1 16 | sleep 1 17 | done 18 | 19 | -------------------------------------------------------------------------------- /concur-test/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 524996 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml 11 | sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 12 | original: lts-14.27 13 | -------------------------------------------------------------------------------- /scripts/run-gomail.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" 6 | cd "$DIR/.." 7 | NPROC=$1 8 | NMSG=100000 9 | N=$((NMSG * NPROC)) 10 | TIMEFORMAT='real %R nuser %U sys %S (s)' 11 | echo "== gomail $NPROC $NMSG $N $(date) == " 12 | for i in $(seq 1 "$NPROC") 13 | do 14 | echo "== gomail $i $((N / i))" 15 | ./scripts/mk-users.sh; time ( cd ./gomail/msrv && GOMAIL_NPROC=$i GOMAIL_NITER=$((N / i)) go test -v ) 16 | sleep 1 17 | done 18 | 19 | -------------------------------------------------------------------------------- /mail-cli/lib/FS/State.hs: -------------------------------------------------------------------------------- 1 | module FS.State 2 | ( 3 | Proc 4 | , FSState(..) 5 | , runFS 6 | , (>>=) 7 | , return 8 | ) where 9 | 10 | import Control.Monad.State.Strict (StateT, evalStateT) 11 | import Data.Map.Strict 12 | import System.IO 13 | 14 | data FSState = 15 | FS { storeH :: (Data.Map.Strict.Map Integer Handle) 16 | , nextH :: Integer} 17 | 18 | type Proc = StateT FSState IO 19 | 20 | initialEnv :: FSState 21 | initialEnv = FS (Data.Map.Strict.empty) (0) 22 | 23 | runFS :: Proc a -> IO a 24 | runFS m = evalStateT m initialEnv 25 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/DependentEq.v: -------------------------------------------------------------------------------- 1 | Require Eqdep. 2 | Require Import ProofAutomation.Propositional. 3 | 4 | (** Helpers for dependent equalities, especially when generated by inversion or 5 | induction. *) 6 | 7 | Ltac sigT_eq := 8 | match goal with 9 | | [ H: existT ?P ?a _ = existT ?P ?a _ |- _ ] => 10 | apply Eqdep.EqdepTheory.inj_pair2 in H; subst 11 | end. 12 | 13 | Ltac induct H := 14 | induction H; repeat sigT_eq; propositional. 15 | Ltac invert H := 16 | inversion H; repeat sigT_eq; propositional; repeat sigT_eq. 17 | 18 | Ltac inv_clear H := invert H; clear H. 19 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/Misc.v: -------------------------------------------------------------------------------- 1 | (** ** Other proof automation helpers *) 2 | 3 | (** substitute variables that are let bindings (these can be created with [set 4 | (x:=value)] and appear in the context as [v := def]) *) 5 | Ltac subst_var := 6 | repeat match goal with 7 | | [ v := _ |- _ ] => subst v 8 | end. 9 | 10 | Create HintDb false. 11 | 12 | Ltac solve_false := 13 | solve [ exfalso; eauto with false ]. 14 | 15 | Ltac rename_by_type type name := 16 | match goal with | x : type |- _ => rename x into name end. 17 | 18 | Ltac is_one_goal := let n := numgoals in guard n = 1. 19 | -------------------------------------------------------------------------------- /src/Helpers/Learn.v: -------------------------------------------------------------------------------- 1 | Inductive Learnt {P:Prop} := 2 | | AlreadyLearnt (H:P). 3 | 4 | Ltac learn_fact H := 5 | let P := type of H in 6 | let P := eval simpl in P in 7 | lazymatch goal with 8 | (* matching the type of H with the Learnt hypotheses means the 9 | learning fails even when the proposition is known by a different 10 | but unifiable type term *) 11 | | [ Hlearnt: @Learnt P |- _ ] => 12 | fail 0 "already knew" P "through" Hlearnt 13 | | _ => pose proof (H:P); pose proof (@AlreadyLearnt P H) 14 | end. 15 | 16 | Tactic Notation "learn" "that" constr(H) := learn_fact H. 17 | -------------------------------------------------------------------------------- /mail-cli/Extract.v: -------------------------------------------------------------------------------- 1 | Cd "mail-cli/extract/". 2 | 3 | Require Import ExtrHaskellBasic. 4 | Require Import ExtrHaskellNatInteger. 5 | Require Import ExtrHaskellString. 6 | 7 | Extraction Language Haskell. 8 | 9 | Require Import FS.MailCli. 10 | 11 | Extract Inlined Constant PeanoNat.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". 12 | 13 | Separate Extraction cli. 14 | 15 | (* Force extraction of the [Helpers] library since the initial student 16 | * code does not use it, but the students may need to use it, and the 17 | * build file (statdb-cli.cabal) lists it as a dependency. 18 | *) 19 | Recursive Extraction Library Helpers. 20 | 21 | Cd "../../". 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CSPEC 2 | 3 | [![Build Status](https://travis-ci.com/mit-pdos/cspec.svg?branch=master)](https://travis-ci.com/mit-pdos/cspec) 4 | 5 | Framework for reasoning about concurrent code using abstraction, layers, and movers. 6 | 7 | ## Compiling 8 | 9 | You'll need Coq v8.9 or master, Go, and Haskell stack. 10 | 11 | To compile CSPEC, CMAIL, and GoMail, run `make`. A benchmarking binary for 12 | `CMAIL` is output to `bin/mail-test` and a GoMail binary that listens for SMTP 13 | and POP3 connections is output to `bin/gomail`. 14 | 15 | The stack initialization doesn't handle parallel builds correctly so a parallel build 16 | with a fresh `stack` install may not work, but re-running should fix any 17 | concurrency issues (isn't that ironic?). 18 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation.v: -------------------------------------------------------------------------------- 1 | (** * Proof automation. 2 | 3 | To help prove various theorems, we provide some basic automation. 4 | This automation takes the form of Ltac scripts that are designed 5 | to solve certain types of goals, or simplify the goal in some way. 6 | We also use hints (using various [Hint] statements), which is a 7 | way to tell Coq which theorems should be used by tactics like 8 | [auto], [eauto], [autorewrite], and so on. 9 | *) 10 | 11 | Require Export Helpers.ProofAutomation.Abstract. 12 | Require Export Helpers.ProofAutomation.DependentEq. 13 | Require Export Helpers.ProofAutomation.ExistentialVariants. 14 | Require Export Helpers.ProofAutomation.Misc. 15 | Require Export Helpers.ProofAutomation.Propositional. 16 | Require Export Helpers.ProofAutomation.SimplMatch. 17 | -------------------------------------------------------------------------------- /concur-test/concur-test.cabal: -------------------------------------------------------------------------------- 1 | name: concur-test 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable concur-test 7 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N 8 | hs-source-dirs: extract, lib 9 | main-is: Main.hs 10 | build-depends: base >= 4.7 && < 5 11 | , ghc-prim 12 | , mtl 13 | , bytestring 14 | , atomic-primops 15 | other-modules: Interpreter 16 | , Compile 17 | , CompileLoop 18 | , ConcurProc 19 | , List 20 | , Datatypes 21 | , LockedCounter 22 | , Nat 23 | default-language: Haskell2010 24 | -------------------------------------------------------------------------------- /mail-test/lib/Support.hs: -------------------------------------------------------------------------------- 1 | module Support 2 | ( 3 | encode_tid_fn 4 | , decode_tid_fn 5 | , POP3Conn(..) 6 | , SMTPConn(..) 7 | ) where 8 | 9 | import Data.List 10 | import Data.IORef 11 | import System.IO 12 | import qualified Data.ByteString as BS 13 | import qualified Data.ByteString.Char8 as BSC8 14 | 15 | parse_number :: BS.ByteString -> Integer 16 | parse_number = read . BSC8.unpack 17 | 18 | encode_tid_fn :: Integer -> Integer -> BS.ByteString 19 | encode_tid_fn tid fn = BS.concat [BSC8.pack (show tid), ".", BSC8.pack (show fn)] 20 | 21 | decode_tid_fn :: BS.ByteString -> (Integer, Integer) 22 | decode_tid_fn fn = 23 | case BSC8.findIndex (=='.') fn of 24 | Nothing -> (0, 0) 25 | Just i -> let (tidstr, fnstr) = BS.splitAt i fn in 26 | (parse_number tidstr, parse_number (BS.tail fnstr)) 27 | 28 | data POP3Conn = 29 | POP3Conn Handle 30 | 31 | data SMTPConn = 32 | SMTPConn Handle 33 | -------------------------------------------------------------------------------- /concur-test/lib/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF ./fiximports.py #-} 2 | module Main where 3 | 4 | -- Haskell libraries 5 | import Control.Concurrent 6 | 7 | -- Our library code 8 | import Interpreter 9 | 10 | -- Extracted code 11 | import ConcurProc 12 | import LockedCounter 13 | 14 | 15 | run_thread :: State -> Coq_maybe_proc (TSOOp__Coq_xOp a) -> IO () 16 | run_thread _ NoProc = return () 17 | run_thread s (Proc p) = do 18 | tid <- myThreadId 19 | putStrLn $ "Running " ++ (show tid) 20 | run_proc s p 21 | return () 22 | 23 | spawn_thread :: State -> Coq_maybe_proc (TSOOp__Coq_xOp a) -> IO () 24 | spawn_thread s p = do 25 | putStrLn $ "Spawning.." 26 | tid <- forkIO (run_thread s p) 27 | putStrLn $ "Spawned " ++ (show tid) 28 | return () 29 | 30 | main :: IO () 31 | main = do 32 | s <- mkState 33 | mapM_ (spawn_thread s) compiled_threads 34 | putStrLn "Started all threads" 35 | threadDelay $ 60 * 1000000 36 | -------------------------------------------------------------------------------- /src/CSPEC.v: -------------------------------------------------------------------------------- 1 | (** This file exports the entire CSPEC framework as one import. *) 2 | 3 | (* TODO: we could probably export a lot less from each of these files, to 4 | clarify what the framework provides vs internal proofs. *) 5 | 6 | Require Export List. 7 | Require Export Omega. 8 | 9 | Require Export Helpers.ProofAutomation. 10 | Require Export Helpers.Instances. 11 | Require Export Helpers.ListStuff. 12 | Require Export Helpers.Sets. 13 | Require Export Helpers.Maps. 14 | Require Export Helpers.Ordering. 15 | Require Export Helpers.StringUtils. 16 | Require Export Helpers.RecordSet. 17 | 18 | Require Export Spec.ConcurExec. 19 | Require Export Spec.Compile. 20 | Require Export Spec.Abstraction. 21 | Require Export Spec.Patterns. 22 | Require Export Spec.Movers. 23 | Require Export Spec.Protocol. 24 | Require Export Spec.CompileLoop. 25 | Require Export Spec.Horizontal. 26 | Require Export Spec.Equiv. 27 | Require Export Spec.CodeOpt. 28 | -------------------------------------------------------------------------------- /src/Spec/ConcurProc.v: -------------------------------------------------------------------------------- 1 | Set Implicit Arguments. 2 | 3 | Section Proc. 4 | Variable Op : Type -> Type. 5 | 6 | Inductive proc : Type -> Type := 7 | | Call : forall T (op : Op T), proc T 8 | | Ret : forall T (v : T), proc T 9 | | Bind : forall T (T1 : Type) (p1 : proc T1) (p2 : T1 -> proc T), proc T 10 | | Until : forall T (c : T -> bool) (p : option T -> proc T) (v : option T), proc T 11 | | Atomic : forall T (p : proc T), proc T 12 | | Spawn : forall T (p: proc T), proc unit 13 | . 14 | 15 | Inductive maybe_proc := 16 | | Proc : forall T, proc T -> maybe_proc 17 | | NoProc. 18 | End Proc. 19 | 20 | Arguments Call {Op T}. 21 | Arguments Ret {Op T}. 22 | Arguments Bind {Op T T1}. 23 | Arguments Until {Op T}. 24 | Arguments Atomic {Op T}. 25 | Arguments Spawn {Op T}. 26 | 27 | Arguments Proc {Op T}. 28 | Arguments NoProc {Op}. 29 | 30 | Notation "x <- p1 ; p2" := (Bind p1 (fun x => p2)) 31 | (at level 60, right associativity). 32 | -------------------------------------------------------------------------------- /mail-test/Extract.v: -------------------------------------------------------------------------------- 1 | Require Import ExtrHaskellBasic. 2 | Require Import ExtrHaskellNatInteger. 3 | 4 | Extraction Language Haskell. 5 | 6 | Require Import Mail.MailServer. 7 | Require Import Mail.MailFSStringAbsAPI. 8 | Require Import Mail.MailServerAPI. 9 | 10 | Extract Inlined Constant encode_tid_fn => "Support.encode_tid_fn". 11 | Extract Inlined Constant decode_tid_fn => "Support.decode_tid_fn". 12 | Extract Inlined Constant smtpconn => "Support.SMTPConn". 13 | Extract Inlined Constant pop3conn => "Support.POP3Conn". 14 | 15 | Extract Inlined Constant abstract_string => "BS.ByteString". 16 | Extract Inlined Constant abstract_string_length => "(\s -> Prelude.fromIntegral (BS.length s))". 17 | Extract Inlined Constant tmp_string => """tmp""". 18 | Extract Inlined Constant mail_string => """mail""". 19 | Extract Inlined Constant nouser_string => """fake_user""". 20 | Extract Inlined Constant bench_msg => """Hello world.""". 21 | 22 | Cd "mail-test/extract/". 23 | Separate Extraction ms_bottom ms_bottom_opt ms_bottom_server ms_bottom_server_opt. 24 | Cd "../../". 25 | -------------------------------------------------------------------------------- /research.txt: -------------------------------------------------------------------------------- 1 | Possible projects 2 | 3 | - Code gen 4 | generate Go code for unfolded mailserver program 5 | compare to our hand-written Go implementation (gomail) 6 | Go instead of C, so we don't have to deal with low-level memory management 7 | 8 | - Less clunky horizontal composition 9 | Maybe use objects + separation logic 10 | Use it to have several locks 11 | 12 | - Crashes and concurrency 13 | Modify exec to support crashes 14 | Do layered recovery a la POCS 15 | Have top-level crash-safety theorem for mail server 16 | 17 | - Lock-free data structures with TSO 18 | look-free cache 19 | 20 | - Concurrent POSIX spec 21 | Model open() isn't atomic 22 | Slide fd layer under current bottom layer 23 | Proof atomicity of pathname lookups in context of mail server 24 | readdir 25 | 26 | Maybe a good base for scalable commutativity 27 | proof implementation scales 28 | Need memory model 29 | 30 | - Adopt for distributed systems 31 | Maybe can generalize horizon composition 32 | 33 | - Mail server security 34 | Use sfscq infrastructure for mail server 35 | -------------------------------------------------------------------------------- /mail-cli/mail-cli.cabal: -------------------------------------------------------------------------------- 1 | name: mail-cli 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable mail-cli 7 | hs-source-dirs: extract, lib 8 | main-is: Main.hs 9 | build-depends: base >= 4.7 && < 5 10 | , ghc-prim 11 | , mtl 12 | , bytestring 13 | , unix 14 | , containers 15 | , directory 16 | , filepath 17 | other-modules: Abstraction 18 | , Bool 19 | , CLI.Stubs 20 | , Datatypes 21 | , Helpers 22 | , Logic 23 | , Proc 24 | , MailServerAPI 25 | , MailCli 26 | , FS.State 27 | , FS.Ops 28 | , FSAPI 29 | , FSImpl 30 | , Def 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /mail-test/mail-test.cabal: -------------------------------------------------------------------------------- 1 | name: mail-test 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable mail-test 7 | ghc-options: -O2 -rtsopts 8 | default-extensions: OverloadedStrings 9 | hs-source-dirs: extract, lib 10 | main-is: Main.hs 11 | build-depends: base >= 4.7 && < 5 12 | , ghc-prim 13 | , mtl 14 | , bytestring 15 | , atomic-primops 16 | , unix 17 | , unix-bytestring 18 | , directory 19 | , random 20 | , rdtsc 21 | , flock 22 | , network 23 | , deepseq 24 | , split 25 | other-modules: Interpreter 26 | , Compile 27 | , ConcurProc 28 | , List 29 | , Datatypes 30 | , MailServer 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | CSPEC 2 | 3 | Copyright (c) 2017, Massachusetts Institute of Technology 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /mail-test/lib/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF ./fiximports.py #-} 2 | module Main where 3 | 4 | -- Haskell libraries 5 | import System.Environment 6 | 7 | -- Our library code 8 | import Interpreter 9 | import SMTP 10 | import POP3 11 | 12 | -- Extracted code 13 | import ConcurProc 14 | import MailFSMergedAPI 15 | import MailServer 16 | 17 | 18 | runThread :: State -> Coq_maybe_proc (MailFSMergedOp__Coq_xOp a) -> IO () 19 | runThread _ NoProc = return () 20 | runThread s (Proc p) = do 21 | _ <- run_proc s p 22 | return () 23 | 24 | main :: IO () 25 | main = do 26 | args <- getArgs 27 | mainArgs args 28 | 29 | mainArgs :: [String] -> IO () 30 | mainArgs [nprocs, niter, nsmtpiter, npop3iter] = do 31 | smtp <- smtpListen 2525 32 | pop3 <- pop3Listen 2110 33 | s <- mkState smtp pop3 34 | mapM_ (runThread s) 35 | -- (ms_bottom (read nprocs) (read niter) (read nsmtpiter) (read npop3iter)) 36 | (ms_bottom_opt (read nprocs) (read niter) (read nsmtpiter) (read npop3iter)) 37 | putStrLn "Waiting for child processes..." 38 | waitForChildren s 39 | 40 | mainArgs _ = do 41 | exec <- getProgName 42 | putStrLn $ "Usage: " ++ exec ++ " nsmtp npop3" 43 | -------------------------------------------------------------------------------- /mail-test/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: flock-0.3.1.8@sha256:27dd27853a2d1cd5e073a09b13d19315a1f06c73426fc4504ec384c6d4df58a6,1066 9 | pantry-tree: 10 | size: 349 11 | sha256: 58630cbb75d1b3c337ca395e6b8a43092282b076046ca324db65b590a46181a4 12 | original: 13 | hackage: flock-0.3.1.8 14 | - completed: 15 | hackage: rdtsc-1.3.0.1@sha256:0a6e8dc715ba82ad72c7e2b1c2f468999559bec059d50540719a80b00dcc4e66,1557 16 | pantry-tree: 17 | size: 644 18 | sha256: 6967a000a944b8b4744a36c76f5d0b11bb6bb2ca9c775cf29844be49139b205d 19 | original: 20 | hackage: rdtsc-1.3.0.1@sha256:0a6e8dc715ba82ad72c7e2b1c2f468999559bec059d50540719a80b00dcc4e66 21 | snapshots: 22 | - completed: 23 | size: 524996 24 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml 25 | sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 26 | original: lts-14.27 27 | -------------------------------------------------------------------------------- /src/Spec/Equiv/Automation.v: -------------------------------------------------------------------------------- 1 | Require Export Spec.ThreadsState. 2 | Require Export Spec.ConcurExec. 3 | 4 | Ltac thread_upd_ind p := 5 | let ind H := induction H; intros; subst; eauto; NoProc_upd in 6 | match goal with 7 | | H : exec _ _ (thread_upd ?ts ?tid (Proc ?pp)) _ |- _ => 8 | remember (thread_upd ts tid (Proc pp)); 9 | generalize dependent ts; 10 | generalize dependent p; 11 | ind H 12 | | H : exec_till _ _ _ (thread_upd ?ts ?tid (Proc ?pp)) _ |- _ => 13 | remember (thread_upd ts tid (Proc pp)); 14 | generalize dependent ts; 15 | generalize dependent p; 16 | ind H 17 | end. 18 | 19 | Ltac guess_ExecPrefix := 20 | match goal with 21 | | [ H: thread_get _ ?tid' = NoProc |- context[prepend ?tid _ _] ] => 22 | ExecPrefix tid tid' 23 | end. 24 | 25 | Ltac solve_ExecEquiv := 26 | match goal with 27 | | [ H: context[thread_get (thread_upd _ ?tid _) ?tid'] |- _ ] => 28 | cmp_ts tid' tid; repeat maybe_proc_inv; 29 | exec_tid_simpl; 30 | remove_redundant_upds; 31 | try (solve [ eauto ] || 32 | solve [ guess_ExecPrefix ]) 33 | end. 34 | 35 | Ltac ExecEquiv p := 36 | thread_upd_ind p; 37 | [ solve_ExecEquiv | .. ]. 38 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/ExistentialVariants.v: -------------------------------------------------------------------------------- 1 | (** * Additional support for evar-creating versions of tactics *) 2 | 3 | (* safe version of repeat eexists (which will unfold definitions) *) 4 | Ltac descend := 5 | repeat match goal with 6 | | |- exists _, _ => eexists 7 | end. 8 | 9 | Ltac especialize H := 10 | match type of H with 11 | | forall (x:?T), _ => 12 | let x := fresh x in 13 | evar (x:T); 14 | specialize (H x); 15 | subst x 16 | end. 17 | 18 | Local Ltac _especialize H := 19 | lazymatch type of H with 20 | | forall (x:?T), _ => let x := fresh x in 21 | lazymatch type of T with 22 | | Prop => unshelve (evar (x:T); 23 | specialize (H x); 24 | subst x) 25 | | _ => evar (x:T); 26 | specialize (H x); 27 | subst x 28 | end 29 | end. 30 | 31 | Ltac epose_proof H := 32 | let H' := fresh in 33 | pose proof H as H'; 34 | repeat (_especialize H'). 35 | 36 | Ltac eexists_t t := 37 | match goal with 38 | | |- exists (_:?T), _ => 39 | eexists (ltac:(t) : T) 40 | | |- {_:?T | _} => 41 | eexists (ltac:(t) : T) 42 | end. 43 | 44 | Ltac exists_econstructor := eexists_t ltac:(econstructor); simpl. 45 | -------------------------------------------------------------------------------- /mail-test/fiximports.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | # preprocessor: add extra imports 4 | # preprocessor: ghc -F -pgmF 5 | 6 | import re 7 | import os, sys 8 | 9 | import_modules = { 10 | "import qualified Support": 11 | [ 12 | "MailFSStringImpl", 13 | "MailServerAPI", 14 | "MailServer", 15 | ], 16 | "import qualified Data.ByteString as BS": 17 | [ 18 | "MailServerAPI", 19 | ], 20 | } 21 | 22 | module_imports = {} 23 | for imp, modules in import_modules.items(): 24 | for module in modules: 25 | if module not in module_imports: 26 | module_imports[module] = "" 27 | module_imports[module] += imp + "\n" 28 | 29 | fs_filename = sys.argv[1] 30 | filename = sys.argv[2] 31 | out = open(sys.argv[3], "w") 32 | 33 | module_name = None 34 | 35 | MODULE_RE = re.compile("module (?P.*) where\n") 36 | 37 | out.write("{-# LINE 1 \"%s\" #-}\n" % (filename)) 38 | for n, line in enumerate(open(filename), 1): 39 | m = MODULE_RE.match(line) 40 | if m: 41 | module_name = m.group("module") 42 | if line.strip() == "import qualified Prelude": 43 | mod_imports = module_imports.get(module_name) 44 | if mod_imports: 45 | out.write(mod_imports) 46 | out.write("{-# LINE %d \"%s\" #-}\n" % (n, filename)) 47 | line = line.replace('__FILE__', '"%s"' % sys.argv[2]) 48 | line = line.replace('__LINE__', '%d' % n) 49 | out.write(line) 50 | out.close() 51 | -------------------------------------------------------------------------------- /src/FS/MailServerAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import Relations.Relation_Operators. 3 | Require Import RelationClasses. 4 | Require Import Morphisms. 5 | 6 | Import ListNotations. 7 | Require Import String. 8 | Require Import FSAPI. 9 | 10 | Definition message := string. 11 | 12 | Inductive mailOpT : Type -> Type := 13 | | Deliver (user : string) (m : message) : mailOpT (option unit) 14 | | Read (user : string) : mailOpT (option (list message)). 15 | 16 | Definition mailState := forall (user : string), FSet.t message. 17 | 18 | Definition upd (s : mailState) (u : string) v := 19 | fun u' => 20 | if string_dec u' u then v else s u'. 21 | 22 | 23 | Module MailServerAPI <: Layer. 24 | 25 | Definition Op := mailOpT. 26 | Definition State := mailState. 27 | 28 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> Prop := 29 | | StepDeliver : forall user msg msgs state tid, 30 | state user = msgs -> 31 | xstep (Deliver user msg) tid 32 | state 33 | (Some tt) 34 | (upd state user (FSet.add msg msgs)) 35 | | StepRead : forall user msgs state tid, 36 | state user = msgs -> 37 | xstep (Read user) tid 38 | state 39 | (Some (FSet.elements msgs)) 40 | state 41 | | StepFail : forall T (op : Op (option T)) state tid, 42 | xstep op tid 43 | state 44 | None 45 | state. 46 | 47 | Definition step := xstep. 48 | 49 | Definition initP (_ : State) := True. 50 | 51 | End MailServerAPI. 52 | -------------------------------------------------------------------------------- /src/Mail/MailServerLockAbsImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailServerLockAbsAPI. 4 | 5 | Module MailServerLockAbsImpl' <: 6 | HLayerImplAbsT MailServerOp 7 | MailServerLockAbsState MailServerLockAbsAPI 8 | MailServerState MailServerAPI. 9 | 10 | Import MailServerLockAbsState. 11 | 12 | Definition absR (s1 : MailServerLockAbsState.State) (s2 : MailServerState.State) := 13 | MailServerLockAbsState.maildir s1 = s2. 14 | 15 | Hint Extern 1 (MailServerAPI.step _ _ _ _ _ _) => econstructor. 16 | 17 | Theorem absR_ok : 18 | op_abs absR MailServerLockAbsAPI.step MailServerAPI.step. 19 | Proof. 20 | unfold op_abs; intros. 21 | unfold absR in *. 22 | inversion H0; clear H0; subst; repeat sigT_eq. 23 | all: eauto. 24 | Qed. 25 | 26 | Definition initP_map (s1: MailServerLockAbsState.State) : {s2:MailServerState.State | initP s1 -> absR s1 s2 /\ MailServerState.initP s2}. 27 | exists (maildir s1). 28 | unfold initP, absR, MailServerState.initP; eauto. 29 | Defined. 30 | 31 | End MailServerLockAbsImpl'. 32 | 33 | Module MailServerLockAbsImpl := 34 | HLayerImplAbs MailServerOp 35 | MailServerLockAbsState MailServerLockAbsAPI 36 | MailServerState MailServerAPI 37 | MailServerLockAbsImpl'. 38 | 39 | Module MailServerLockAbsImplH' := 40 | LayerImplAbsHT 41 | MailServerOp 42 | MailServerLockAbsState MailServerLockAbsAPI 43 | MailServerState MailServerAPI 44 | MailServerLockAbsImpl' 45 | UserIdx. 46 | 47 | Module MailServerLockAbsImplH := 48 | LayerImplAbs MailServerHOp 49 | MailServerLockAbsHState MailServerLockAbsHAPI 50 | MailServerHState MailServerHAPI 51 | MailServerLockAbsImplH'. 52 | -------------------------------------------------------------------------------- /concur-test/fiximports.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | # preprocessor: add extra imports 4 | # preprocessor: ghc -F -pgmF 5 | 6 | import re 7 | import os, sys 8 | 9 | import_modules = { 10 | "import qualified Data.ByteString": 11 | [ 12 | "Disk", 13 | ], 14 | 15 | "import qualified Variables.Ops": 16 | [ 17 | "VariablesImpl", 18 | "StatDbCli", 19 | ], 20 | 21 | "import qualified CLI.Stubs": 22 | [ 23 | "StatDbCli", 24 | ], 25 | 26 | "import Variables.State": 27 | [ 28 | "Interface", 29 | "VariablesImpl", 30 | "StatDbImpl", 31 | "StatDbCli", 32 | "Abstraction", 33 | ], 34 | } 35 | 36 | module_imports = {} 37 | for imp, modules in import_modules.items(): 38 | for module in modules: 39 | if module not in module_imports: 40 | module_imports[module] = "" 41 | module_imports[module] += imp + "\n" 42 | 43 | fs_filename = sys.argv[1] 44 | filename = sys.argv[2] 45 | out = open(sys.argv[3], "w") 46 | 47 | module_name = None 48 | 49 | MODULE_RE = re.compile("module (?P.*) where\n") 50 | 51 | out.write("{-# LINE 1 \"%s\" #-}\n" % (filename)) 52 | for n, line in enumerate(open(filename), 1): 53 | m = MODULE_RE.match(line) 54 | if m: 55 | module_name = m.group("module") 56 | if line.strip() == "import qualified Prelude": 57 | mod_imports = module_imports.get(module_name) 58 | if mod_imports: 59 | out.write(mod_imports) 60 | out.write("{-# LINE %d \"%s\" #-}\n" % (n, filename)) 61 | line = line.replace('__FILE__', '"%s"' % sys.argv[2]) 62 | line = line.replace('__LINE__', '%d' % n) 63 | out.write(line) 64 | out.close() 65 | -------------------------------------------------------------------------------- /mail-cli/fiximports.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | # preprocessor: add extra imports 4 | # preprocessor: ghc -F -pgmF 5 | 6 | import re 7 | import os, sys 8 | 9 | import_modules = { 10 | "import qualified Data.ByteString": 11 | [ 12 | "MailCli", 13 | "FSImpl", 14 | "FSAPI", 15 | ], 16 | 17 | "import qualified FS.Ops": 18 | [ 19 | "FSImpl", 20 | "MailCli", 21 | ], 22 | 23 | "import qualified CLI.Stubs": 24 | [ 25 | "MailCli", 26 | ], 27 | 28 | "import FS.State": 29 | [ 30 | "Interface", 31 | "FSImpl", 32 | "MailServerImpl", 33 | "MailCli", 34 | "Abstraction", 35 | ], 36 | 37 | 38 | } 39 | 40 | module_imports = {} 41 | for imp, modules in import_modules.items(): 42 | for module in modules: 43 | if module not in module_imports: 44 | module_imports[module] = "" 45 | module_imports[module] += imp + "\n" 46 | 47 | fs_filename = sys.argv[1] 48 | filename = sys.argv[2] 49 | out = open(sys.argv[3], "w") 50 | 51 | module_name = None 52 | 53 | MODULE_RE = re.compile("module (?P.*) where\n") 54 | 55 | out.write("{-# LINE 1 \"%s\" #-}\n" % (filename)) 56 | for n, line in enumerate(open(filename), 1): 57 | m = MODULE_RE.match(line) 58 | if m: 59 | module_name = m.group("module") 60 | if line.strip() == "import qualified Prelude": 61 | mod_imports = module_imports.get(module_name) 62 | if mod_imports: 63 | out.write(mod_imports) 64 | out.write("{-# LINE %d \"%s\" #-}\n" % (n, filename)) 65 | line = line.replace('__FILE__', '"%s"' % sys.argv[2]) 66 | line = line.replace('__LINE__', '%d' % n) 67 | out.write(line) 68 | out.close() 69 | -------------------------------------------------------------------------------- /src/Helpers/FunMap.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Import Helpers.Instances. 3 | 4 | Set Implicit Arguments. 5 | 6 | 7 | Section FunMap. 8 | 9 | Variable A : Type. 10 | Variable V : Type. 11 | Context {Aeq : EqualDec A}. 12 | 13 | Definition funmap := A -> V. 14 | 15 | Definition fupd (a : A) (v : V) (m : funmap) : funmap := 16 | fun a' => if a == a' then v else m a'. 17 | 18 | Theorem fupd_eq : forall a v m, 19 | fupd a v m a = v. 20 | Proof. 21 | unfold fupd; intros. 22 | destruct (a == a); congruence. 23 | Qed. 24 | 25 | Theorem fupd_ne : forall a a' v m, 26 | a <> a' -> 27 | fupd a v m a' = m a'. 28 | Proof. 29 | unfold fupd; intros. 30 | destruct (a == a'); congruence. 31 | Qed. 32 | 33 | Theorem fupd_fupd_eq : forall a v v' m, 34 | fupd a v (fupd a v' m) = fupd a v m. 35 | Proof. 36 | unfold fupd; intros. 37 | eapply functional_extensionality; intros. 38 | destruct (a == x); congruence. 39 | Qed. 40 | 41 | Theorem fupd_fupd_ne : forall a v a' v' m, 42 | a <> a' -> 43 | fupd a v (fupd a' v' m) = fupd a' v' (fupd a v m). 44 | Proof. 45 | unfold fupd; intros. 46 | eapply functional_extensionality; intros. 47 | destruct (a == x); destruct (a' == x); congruence. 48 | Qed. 49 | 50 | Theorem fupd_same : forall a v m, 51 | m a = v -> 52 | fupd a v m = m. 53 | Proof. 54 | intros. 55 | extensionality a'; subst. 56 | destruct (a == a'); subst. 57 | rewrite fupd_eq; auto. 58 | rewrite fupd_ne; auto. 59 | Qed. 60 | 61 | End FunMap. 62 | 63 | Hint Rewrite fupd_eq : fupd. 64 | Hint Rewrite fupd_ne using (congruence || solve [ auto ]) : fupd. 65 | Hint Rewrite fupd_fupd_eq : fupd. 66 | 67 | Identity Coercion funmap_apply : funmap >-> Funclass. 68 | -------------------------------------------------------------------------------- /mail-cli/lib/FS/Ops.hs: -------------------------------------------------------------------------------- 1 | module FS.Ops where 2 | 3 | import Control.Monad.State.Strict (gets, modify) 4 | import Control.Monad.Trans (liftIO) 5 | 6 | import FS.State 7 | import FSAPI 8 | import Abstraction 9 | 10 | import String 11 | import System.IO 12 | import System.Directory 13 | import System.FilePath.Posix 14 | 15 | import Data.Map.Strict 16 | 17 | verbose :: Bool 18 | verbose = True 19 | 20 | debugmsg :: String -> Proc () 21 | debugmsg s = 22 | liftIO $ do 23 | if verbose then 24 | do 25 | putStrLn s 26 | hFlush stdout 27 | else 28 | return () 29 | 30 | init :: Proc InitResult 31 | init = return Initialized 32 | 33 | create :: Coq_pathname -> String -> Proc Integer 34 | create cpn fn = do 35 | debugmsg $ "create: " ++ (show cpn) ++ " " ++ fn 36 | let pn = (joinPath cpn) 37 | _ <- liftIO $ do 38 | h <- openFile (pn++"/"++fn) WriteMode 39 | hClose h 40 | debugmsg $ "create done" 41 | return 0 42 | 43 | -- mkdir -p 44 | mkdir :: Coq_pathname -> String -> Proc Integer 45 | mkdir cpn fn = do 46 | debugmsg $ "mkdir: " ++ (show cpn) ++ " " ++ fn 47 | let pn = (concat cpn) 48 | h <- liftIO $ do 49 | createDirectoryIfMissing True (pn++"/"++fn) 50 | debugmsg $ "mkdir done" 51 | return 0 52 | 53 | write_logged :: Coq_pathname -> String -> Proc () 54 | write_logged cpn content = do 55 | debugmsg $ "write_logged: " ++ (show cpn) ++ " " ++ content 56 | let pn = (concat cpn) 57 | debugmsg $ "pn: " ++ pn 58 | h <- liftIO $ do 59 | writeFile pn content 60 | debugmsg $ "write done" 61 | return () 62 | 63 | 64 | debug :: String -> Proc () 65 | debug msg = do 66 | debugmsg $ "debug: " ++ msg 67 | 68 | 69 | -- XXX search 70 | find_available_name :: Coq_pathname -> Proc String 71 | find_available_name pn = return "xxx" 72 | 73 | -------------------------------------------------------------------------------- /src/Spec/Trace.v: -------------------------------------------------------------------------------- 1 | Require Import ProofAutomation.DependentEq. 2 | Require Import List. 3 | 4 | Definition TID := nat. 5 | 6 | Inductive event := 7 | | Event : forall T (v:T), event. 8 | Arguments Event {T} v. 9 | 10 | Definition trace := list (TID * event). 11 | 12 | Definition thread_tr tid (evs: list event) : trace := map (pair tid) evs. 13 | 14 | Theorem thread_tr_app : forall tid evs1 evs2, 15 | thread_tr tid evs1 ++ thread_tr tid evs2 = 16 | thread_tr tid (evs1 ++ evs2). 17 | Proof. 18 | unfold thread_tr; simpl; intros. 19 | rewrite map_app; auto. 20 | Qed. 21 | 22 | Theorem thread_tr_eq : forall tid evs1 evs2, 23 | thread_tr tid evs1 = thread_tr tid evs2 -> 24 | evs1 = evs2. 25 | Proof. 26 | induct evs1. 27 | - destruct evs2; simpl in *; congruence. 28 | - destruct evs2; simpl in *; try congruence. 29 | invert H; eauto. 30 | f_equal; auto. 31 | Qed. 32 | 33 | (* TODO: these are only for backwards compatibility, from when [trace] was an 34 | inductive definition. *) 35 | Definition TraceEmpty : trace := nil. 36 | 37 | Definition prepend tid (evs: list event) (tr: trace) : trace := 38 | thread_tr tid evs ++ tr. 39 | 40 | Theorem prepend_empty_eq : forall tid evs evs', 41 | prepend tid evs TraceEmpty = prepend tid evs' TraceEmpty -> 42 | evs = evs'. 43 | Proof. 44 | unfold prepend; simpl; intros. 45 | rewrite !app_nil_r in H. 46 | apply thread_tr_eq in H; auto. 47 | Qed. 48 | 49 | Theorem prepend_app : forall (evs1 : list event) evs2 tr tid, 50 | prepend tid (evs1 ++ evs2) tr = prepend tid evs1 (prepend tid evs2 tr). 51 | Proof. 52 | unfold prepend; simpl; intros. 53 | rewrite <- thread_tr_app. 54 | rewrite app_assoc; auto. 55 | Qed. 56 | 57 | Theorem prepend_nil : forall tid tr, 58 | prepend tid nil tr = tr. 59 | Proof. 60 | reflexivity. 61 | Qed. 62 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: bionic 2 | language: generic 3 | 4 | services: 5 | - docker 6 | 7 | cache: 8 | directories: 9 | - $HOME/.stack 10 | 11 | env: 12 | global: 13 | - NJOBS="2" 14 | matrix: 15 | - COQ_IMAGE="coqorg/coq:dev" 16 | - COQ_IMAGE="coqorg/coq:latest" 17 | - COQ_IMAGE="coqorg/coq:8.10" 18 | 19 | before_install: 20 | # Download and unpack the stack executable 21 | - mkdir -p ~/.local/bin 22 | - export PATH=$HOME/.local/bin:$PATH 23 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 24 | 25 | install: | 26 | # Prepare the COQ container 27 | docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/demo -w /home/coq/demo ${COQ_IMAGE} 28 | docker exec COQ /bin/bash --login -c " 29 | # This bash script is double-quoted to interpolate Travis CI env vars: 30 | echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" 31 | export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' 32 | set -ex # -e = exit on failure; -x = trace for debug 33 | #opam update -y 34 | opam config list 35 | opam repo list 36 | opam list 37 | " 38 | before_script: 39 | - | 40 | docker exec COQ /bin/bash --login -c " 41 | export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' 42 | sudo chown -R coq:coq /home/coq/demo 43 | " 44 | script: 45 | - echo -e "${ANSI_YELLOW}Building ${TRAVIS_REPO_SLUG}...${ANSI_RESET}" && echo -en 'travis_fold:start:build\\r' 46 | - | 47 | docker exec COQ /bin/bash --login -c " 48 | export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' 49 | set -ex 50 | make -j${NJOBS} -k coq mail-test/extract 51 | chmod -R a+rw . 52 | " 53 | - make bin/mclnt bin/gomail 54 | - cd mail-test 55 | - stack --allow-different-user build 56 | - echo -en 'travis_fold:end:build\\r' 57 | 58 | after_script: 59 | - docker stop COQ 60 | -------------------------------------------------------------------------------- /src/Mail/MailServerLockAbsAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | 4 | Module MailServerLockAbsState <: State. 5 | 6 | Definition dir_contents := FMap.t (nat*nat) string. 7 | 8 | Record state_rec := mk_state { 9 | maildir : MailServerState.dir_contents; 10 | locked : option nat; 11 | }. 12 | 13 | Definition State := state_rec. 14 | Definition initP (s : State) := locked s = None. 15 | 16 | End MailServerLockAbsState. 17 | Module MailServerLockAbsHState := HState MailServerLockAbsState UserIdx. 18 | 19 | Module MailServerLockAbsAPI <: Layer MailServerOp MailServerLockAbsState. 20 | 21 | Import MailServerOp. 22 | Import MailServerLockAbsState. 23 | 24 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 25 | | StepDeliverOK : forall m mbox fn tid lock, 26 | ~ FMap.In fn mbox -> 27 | xstep (Deliver m) tid 28 | (mk_state mbox lock) 29 | true 30 | (mk_state (FMap.add fn m mbox) lock) 31 | nil 32 | | StepDeliverErr : forall m mbox tid lock, 33 | xstep (Deliver m) tid 34 | (mk_state mbox lock) 35 | false 36 | (mk_state mbox lock) 37 | nil 38 | | StepPickup : forall mbox tid r lock, 39 | FMap.is_permutation_kv r mbox -> 40 | xstep Pickup tid 41 | (mk_state mbox lock) 42 | r 43 | (mk_state mbox lock) 44 | nil 45 | | StepDelete : forall mbox tid id lock, 46 | xstep (Delete id) tid 47 | (mk_state mbox lock) 48 | tt 49 | (mk_state (FMap.remove id mbox) lock) 50 | nil 51 | 52 | | StepExt : forall s tid `(extop : extopT T) r, 53 | xstep (Ext extop) tid 54 | s 55 | r 56 | s 57 | (Event (extop, r) :: nil) 58 | . 59 | 60 | Definition step := xstep. 61 | 62 | Definition initP := initP. 63 | 64 | End MailServerLockAbsAPI. 65 | Module MailServerLockAbsHAPI := HLayer MailServerOp MailServerLockAbsState MailServerLockAbsAPI UserIdx. 66 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ## Common library code 2 | CODE += $(wildcard src/Helpers/*.v) 3 | CODE += $(wildcard src/Helpers/*/*.v) 4 | CODE += $(wildcard src/Spec/*.v) 5 | CODE += $(wildcard src/Spec/*/*.v) 6 | CODE += $(wildcard src/*.v) 7 | CODE += $(wildcard src/Mail/*.v) 8 | CODE += $(wildcard src/Examples/*.v) 9 | 10 | # TODO: fix implicit core warnings 11 | COQRFLAGS := -R build POCS 12 | COQWFLAGS := -w -implicit-core-hint-db 13 | 14 | BINS := concur-test mail-test 15 | 16 | .PHONY: default 17 | default: $(patsubst %,bin/%,$(BINS)) docs bin/mclnt bin/gomail 18 | 19 | build/%.v: src/%.v 20 | @mkdir -p $(@D) 21 | @rm -f $@ 22 | @ln -s "$(shell pwd)"/$< $@ 23 | .PRECIOUS: build/%.v 24 | 25 | build/%.v.d: build/%.v $(patsubst src/%.v,build/%.v,$(CODE)) 26 | coqdep -c $(COQRFLAGS) $< > $@ 27 | .PRECIOUS: build/%.v.d 28 | 29 | -include $(patsubst src/%.v,build/%.v.d,$(CODE)) 30 | 31 | build/%.vo: build/%.v 32 | coqc -q $(COQRFLAGS) $(COQWFLAGS) $< 33 | .PRECIOUS: build/%.vo 34 | 35 | .PHONY: coq 36 | coq: $(patsubst src/%.v,build/%.vo,$(CODE)) 37 | 38 | .PHONY: docs 39 | docs: coq 40 | @mkdir -p doc 41 | coqdoc $(COQRFLAGS) -g --interpolate -d doc $(patsubst src/%.v,build/%.v,$(CODE)) 42 | 43 | .PHONY: %/extract 44 | %/extract: %/Extract.v %/fiximports.py 45 | @mkdir -p $@ 46 | coqtop $(COQRFLAGS) $(COQWFLAGS) -batch -load-vernac-source $< 47 | ./scripts/add-preprocess.sh $@/*.hs 48 | 49 | concur-test/extract: build/Examples/LockedCounter.vo 50 | mail-test/extract: build/Mail/MailServer.vo 51 | 52 | bin/%: %/extract %/lib/*.hs 53 | mkdir -p $(@D) 54 | cd $(patsubst %/extract,%,$<) && PATH="$(PATH):"$(shell pwd)"/bin" stack build --copy-bins --local-bin-path ../bin 55 | 56 | bin/mclnt: gomail/mclnt/mclnt.go 57 | go build -o bin/mclnt $< 58 | bin/gomail: gomail/msrv/msrv.go 59 | go build -o bin/gomail $< 60 | 61 | .PHONY: clean 62 | clean: 63 | rm -rf build 64 | rm -rf doc 65 | rm -rf $(foreach d,$(BINS),$(d)/extract) 66 | rm -rf $(foreach d,$(BINS),$(d)/.stack-work) 67 | rm -f $(foreach b,$(BINS),bin/$(b)) 68 | -------------------------------------------------------------------------------- /src/Mail/MailServerComposedAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import String. 3 | Require Import MailServerAPI. 4 | 5 | 6 | Module MailServerComposedOp <: Ops. 7 | 8 | Import MailServerOp. 9 | Definition user := validIndexT UserIdx.indexValid. 10 | 11 | Inductive xOp : Type -> Type := 12 | | Deliver : forall (u : user) (m : string), xOp bool 13 | | Pickup : forall (u : user), xOp (list ((nat*nat) * string)) 14 | | CheckUser : forall (u : string), xOp (CheckResult UserIdx.indexValid) 15 | | Delete : forall (u : user) (id : nat*nat), xOp unit 16 | | Ext : forall `(op : extopT T), xOp T 17 | . 18 | 19 | Definition Op := xOp. 20 | 21 | End MailServerComposedOp. 22 | 23 | 24 | Module MailServerComposedState := MailServerHState. 25 | 26 | 27 | Module MailServerComposedAPI <: Layer MailServerComposedOp MailServerComposedState. 28 | 29 | Import MailServerComposedOp. 30 | Import MailServerComposedState. 31 | 32 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 33 | | StepDeliverOK : forall m s u fn tid, 34 | ~ FMap.In fn (hget s u) -> 35 | xstep (Deliver u m) tid 36 | s 37 | true 38 | (hadd u (FMap.add fn m (hget s u)) s) 39 | nil 40 | | StepDeliverErr : forall m s u tid, 41 | xstep (Deliver u m) tid 42 | s 43 | false 44 | s 45 | nil 46 | | StepPickup : forall s tid r u, 47 | FMap.is_permutation_kv r (hget s u) -> 48 | xstep (Pickup u) tid 49 | s 50 | r 51 | s 52 | nil 53 | | StepDelete : forall s tid id u, 54 | xstep (Delete u id) tid 55 | s 56 | tt 57 | (hadd u (FMap.remove id (hget s u)) s) 58 | nil 59 | 60 | | StepCheckUser : forall s tid u r, 61 | sameSlice r u -> 62 | xstep (CheckUser u) tid 63 | s 64 | r 65 | s 66 | nil 67 | 68 | | StepExt : forall s tid `(extop : _ T) r, 69 | xstep (Ext extop) tid 70 | s 71 | r 72 | s 73 | (Event (extop, r) :: nil) 74 | . 75 | 76 | Definition step := xstep. 77 | 78 | Definition initP : MailServerComposedState.State -> Prop := horizInitP MailServerState.initP. 79 | 80 | End MailServerComposedAPI. 81 | -------------------------------------------------------------------------------- /src/Mail/MailboxTmpAbsImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxAPI. 4 | Require Import MailboxTmpAbsAPI. 5 | Require Import MailServerLockAbsAPI. 6 | 7 | 8 | Module MailboxTmpAbs' <: 9 | HLayerImplAbsT MailboxOp 10 | MailboxTmpAbsState MailboxTmpAbsAPI 11 | MailServerLockAbsState MailboxAPI. 12 | 13 | Import MailboxTmpAbsState. 14 | 15 | Definition absR (s1 : MailboxTmpAbsState.State) (s2 : MailServerLockAbsState.State) := 16 | MailboxTmpAbsState.maildir s1 = MailServerLockAbsState.maildir s2 /\ 17 | (MailboxTmpAbsState.locked s1 = false <-> MailServerLockAbsState.locked s2 = None). 18 | 19 | Hint Extern 1 (MailboxAPI.step _ _ _ _ _ _) => econstructor. 20 | 21 | Theorem absR_ok : 22 | op_abs absR MailboxTmpAbsAPI.step MailboxAPI.step. 23 | Proof. 24 | unfold op_abs, absR; intros. 25 | destruct s1. 26 | destruct s2. 27 | intuition idtac. 28 | simpl in *; subst. 29 | inversion H0; clear H0; subst; repeat sigT_eq. 30 | all: simpl. 31 | all: eexists; split; [ | eauto ]. 32 | all: simpl. 33 | all: try intuition congruence. 34 | all: try ( destruct locked1; try intuition congruence ). 35 | all: eauto. 36 | simpl. 37 | intuition congruence. 38 | Qed. 39 | 40 | Hint Resolve absR_ok. 41 | 42 | Definition initP_map (s1: MailboxTmpAbsState.State) : 43 | {s2:MailServerLockAbsState.State | 44 | initP s1 -> absR s1 s2 /\ 45 | MailServerLockAbsState.initP s2}. 46 | unfold initP, absR, MailServerLockAbsState.initP. 47 | exists_econstructor; intuition eauto. 48 | Defined. 49 | 50 | End MailboxTmpAbs'. 51 | 52 | Module MailboxTmpAbsImpl := 53 | HLayerImplAbs MailboxOp 54 | MailboxTmpAbsState MailboxTmpAbsAPI 55 | MailServerLockAbsState MailboxAPI 56 | MailboxTmpAbs'. 57 | 58 | Module MailboxTmpAbsH' := 59 | LayerImplAbsHT 60 | MailboxOp 61 | MailboxTmpAbsState MailboxTmpAbsAPI 62 | MailServerLockAbsState MailboxAPI 63 | MailboxTmpAbs' 64 | UserIdx. 65 | 66 | Module MailboxTmpAbsImplH := 67 | LayerImplAbs MailboxHOp 68 | MailboxTmpAbsHState MailboxTmpAbsHAPI 69 | MailServerLockAbsHState MailboxHAPI 70 | MailboxTmpAbsH'. 71 | -------------------------------------------------------------------------------- /gomail/msrv/msrv_test.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "fmt" 5 | "math/rand" 6 | "os" 7 | "strconv" 8 | "sync" 9 | "testing" 10 | "time" 11 | ) 12 | 13 | const ( 14 | NUSER = 100 15 | ) 16 | 17 | func do_bench_loop(tid int, msg string, niter int, nsmtpiter int, npopiter int) error { 18 | r := rand.New(rand.NewSource(time.Now().UnixNano())) 19 | for l := 0; l < niter; l++ { 20 | for i := 0; i < nsmtpiter; i++ { 21 | u := "u" + strconv.Itoa(r.Int()%NUSER) 22 | if validUser(u) { 23 | m := &Message{To: u, Data: []string{msg}} 24 | err := m.process_msg(tid) 25 | if err != nil { 26 | return err 27 | } 28 | } else { 29 | return fmt.Errorf("Invalid user %v", u) 30 | } 31 | } 32 | for i := 0; i < npopiter; i++ { 33 | u := "u" + strconv.Itoa(r.Int()%NUSER) 34 | if validUser(u) { 35 | mbox, err := mkMailbox(u) 36 | if err != nil { 37 | return err 38 | } 39 | for _, f := range mbox.files { 40 | _, err = mbox.retr(&f) 41 | if err != nil { 42 | return err 43 | } 44 | } 45 | 46 | mbox.unlock() 47 | 48 | for _, f := range mbox.files { 49 | err = mbox.dele(&f) 50 | if err != nil { 51 | // benchmark artifact; matches cmail/haskell 52 | // return err 53 | } 54 | } 55 | } else { 56 | return fmt.Errorf("Invalid user %v", u) 57 | } 58 | } 59 | } 60 | return nil 61 | } 62 | 63 | func TestMixedLoad(t *testing.T) { 64 | nprocEnv := os.Getenv("GOMAIL_NPROC") 65 | nproc64, err := strconv.ParseInt(nprocEnv, 10, 64) 66 | if err != nil { 67 | t.Fatal(err) 68 | } 69 | 70 | niterEnv := os.Getenv("GOMAIL_NITER") 71 | niter64, err := strconv.ParseInt(niterEnv, 10, 64) 72 | if err != nil { 73 | t.Fatal(err) 74 | } 75 | 76 | nproc := int(nproc64) 77 | niter := int(niter64) 78 | 79 | var wg sync.WaitGroup 80 | start := time.Now() 81 | wg.Add(nproc) 82 | for g := 0; g < nproc; g++ { 83 | go func(g int) { 84 | defer wg.Done() 85 | err := do_bench_loop(g, "Hello world.", niter, 1, 1) 86 | if err != nil { 87 | t.Fatal(err) 88 | } 89 | }(g) 90 | } 91 | wg.Wait() 92 | 93 | end := time.Now() 94 | elapsed := end.Sub(start) 95 | fmt.Printf("%d threads, %d iter, %v elapsed\n", nproc, niter, elapsed) 96 | } 97 | -------------------------------------------------------------------------------- /src/Spec/Abstraction.v: -------------------------------------------------------------------------------- 1 | Require Import ConcurExec. 2 | Require Import Morphisms. 3 | Require Import ProofAutomation. 4 | Require Import Helpers.ListStuff. 5 | Require Import List. 6 | Require Import Omega. 7 | 8 | Import ListNotations. 9 | 10 | Global Set Implicit Arguments. 11 | Global Generalizable All Variables. 12 | 13 | 14 | (** Inclusion of traces across state abstraction *) 15 | 16 | Section StateAbstraction. 17 | 18 | Variable OpLo : Type -> Type. 19 | 20 | Variable StateLo : Type. 21 | Variable StateHi : Type. 22 | Variable absR : StateLo -> StateHi -> Prop. 23 | 24 | Variable lo_step : OpSemantics OpLo StateLo. 25 | Variable hi_step : OpSemantics OpLo StateHi. 26 | 27 | Hint Constructors exec_tid. 28 | 29 | Definition op_abs := forall T (op : OpLo T) s1 s1' s2 tid r evs, 30 | absR s1 s2 -> 31 | lo_step op tid s1 r s1' evs -> 32 | exists s2', 33 | absR s1' s2' /\ 34 | hi_step op tid s2 r s2' evs. 35 | 36 | Variable op_abs_holds : op_abs. 37 | 38 | Theorem atomic_exec_abs : forall `(p : proc OpLo T) s1 s1' s2 tid r evs, 39 | absR s1 s2 -> 40 | atomic_exec lo_step p tid s1 r s1' evs -> 41 | exists s2', 42 | absR s1' s2' /\ 43 | atomic_exec hi_step p tid s2 r s2' evs. 44 | Proof. 45 | intros. 46 | generalize dependent s2. 47 | induct H0; eauto. 48 | - edestruct IHatomic_exec1; intuition eauto. 49 | edestruct IHatomic_exec2; intuition eauto. 50 | - eapply op_abs_holds in H; eauto; deex. 51 | eexists; eauto. 52 | - edestruct IHatomic_exec; intuition eauto. 53 | Qed. 54 | 55 | Theorem exec_tid_abs : forall `(p : proc OpLo T) s1 s1' s2 tid res spawned evs, 56 | absR s1 s2 -> 57 | exec_tid lo_step tid s1 p s1' res spawned evs -> 58 | exists s2', 59 | absR s1' s2' /\ 60 | exec_tid hi_step tid s2 p s2' res spawned evs. 61 | Proof. 62 | intros. 63 | induct H0; eauto. 64 | - eapply op_abs_holds in H0; eauto; deex. 65 | eexists; eauto. 66 | - eapply atomic_exec_abs in H0; eauto; deex. 67 | eexists; eauto. 68 | Qed. 69 | 70 | Theorem trace_incl_abs : 71 | forall s1 s2 (ts : threads_state OpLo) tr, 72 | absR s1 s2 -> 73 | exec lo_step s1 ts tr -> 74 | exec hi_step s2 ts tr. 75 | Proof. 76 | intros. 77 | generalize dependent s2. 78 | induct H0; eauto. 79 | - eapply exec_tid_abs in H3; propositional; eauto. 80 | Qed. 81 | 82 | End StateAbstraction. 83 | -------------------------------------------------------------------------------- /concur-test/lib/Interpreter.hs: -------------------------------------------------------------------------------- 1 | module Interpreter where 2 | 3 | -- Haskell libraries 4 | import Control.Concurrent 5 | import Data.Atomics 6 | import Data.IORef 7 | import Data.Maybe 8 | import GHC.Base 9 | 10 | -- Extracted code 11 | import ConcurProc 12 | import LockedCounter 13 | 14 | data State = 15 | S !(IORef Integer) !(IORef Integer) 16 | 17 | mkState :: IO State 18 | mkState = do 19 | val0 <- newIORef 0 20 | val1 <- newIORef 0 21 | return $ S val0 val1 22 | 23 | verbose :: Bool 24 | verbose = True 25 | 26 | debugmsg :: String -> IO () 27 | debugmsg s = 28 | if verbose then do 29 | tid <- myThreadId 30 | putStrLn $ "[" ++ (show tid) ++ "] " ++ s 31 | else 32 | return () 33 | 34 | run_proc :: State -> Coq_proc (TSOOp__Coq_xOp a) GHC.Base.Any -> IO a 35 | run_proc s (Ret v) = do 36 | -- debugmsg $ "Ret" 37 | return $ unsafeCoerce v 38 | run_proc s (Bind p1 p2) = do 39 | -- debugmsg $ "Bind" 40 | v1 <- run_proc s p1 41 | v2 <- run_proc s (p2 $ unsafeCoerce v1) 42 | return v2 43 | run_proc s (Atomic _) = do 44 | -- debugmsg $ "Atomic" 45 | error "Running atomic" 46 | run_proc s (Until c p v0) = do 47 | -- debugmsg $ "Until" 48 | v <- run_proc s (p v0) 49 | if (c $ unsafeCoerce v) then 50 | return v 51 | else 52 | run_proc s (Until c p (unsafeCoerce v)) 53 | run_proc (S val0 val1) (Call (TSOOp__Read TSOOp__Coq_addr0)) = do 54 | v <- readIORef val0 55 | return $ unsafeCoerce v 56 | run_proc (S val0 val1) (Call (TSOOp__Read TSOOp__Coq_addr1)) = do 57 | v <- readIORef val1 58 | return $ unsafeCoerce v 59 | run_proc (S val0 val1) (Call (TSOOp__Write TSOOp__Coq_addr0 v)) = do 60 | debugmsg $ "Write0 " ++ (show v) 61 | writeIORef val0 v 62 | return $ unsafeCoerce () 63 | run_proc (S val0 val1) (Call (TSOOp__Write TSOOp__Coq_addr1 v)) = do 64 | debugmsg $ "Write1 " ++ (show v) 65 | writeIORef val1 v 66 | return $ unsafeCoerce () 67 | run_proc (S val0 val1) (Call (TSOOp__TestAndSet TSOOp__Coq_addr0 v)) = do 68 | prev <- atomicModifyIORef val0 (\cur -> (v, cur)) 69 | if v == prev then yield else return () 70 | return $ unsafeCoerce prev 71 | run_proc (S val0 val1) (Call (TSOOp__TestAndSet TSOOp__Coq_addr1 v)) = do 72 | prev <- atomicModifyIORef val1 (\cur -> (v, cur)) 73 | if v == prev then yield else return () 74 | return $ unsafeCoerce prev 75 | run_proc _ (Call TSOOp__Fence) = do 76 | -- we don't actually have weak memory (in fact Haskell does not define a 77 | -- memory model for IORefs), but if we had intrinsics we would call MFENCE 78 | return $ unsafeCoerce () 79 | -------------------------------------------------------------------------------- /src/Mail/MailServerComposedImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailServerComposedAPI. 4 | 5 | Module MailServerComposedImpl' <: 6 | LayerImplMoversT 7 | MailServerComposedState 8 | MailServerHOp MailServerHAPI 9 | MailServerComposedOp MailServerComposedAPI. 10 | 11 | Import MailServerComposedOp. 12 | 13 | (* START CODE *) 14 | 15 | Definition compile_op T (op : MailServerComposedOp.Op T) : proc MailServerHOp.Op T := 16 | match op with 17 | | Deliver u m => Call (Slice u (MailServerOp.Deliver m)) 18 | | Pickup u => Call (Slice u (MailServerOp.Pickup)) 19 | | CheckUser u => Call (CheckSlice u) 20 | | Delete u id => Call (Slice u (MailServerOp.Delete id)) 21 | | Ext extop => Call (Slice nouser (MailServerOp.Ext extop)) 22 | end. 23 | 24 | (* END CODE *) 25 | 26 | Theorem compile_op_no_atomics : 27 | forall `(op : _ T), 28 | no_atomics (compile_op op). 29 | Proof. 30 | destruct op; simpl; eauto. 31 | Qed. 32 | 33 | Ltac step_inv := 34 | match goal with 35 | | H : MailServerHAPI.step _ _ _ _ _ _ |- _ => 36 | inversion H; clear H; subst; repeat sigT_eq 37 | | H : MailServerAPI.step _ _ _ _ _ _ |- _ => 38 | inversion H; clear H; subst; repeat sigT_eq 39 | end; intuition idtac. 40 | 41 | Hint Constructors MailServerComposedAPI.xstep. 42 | 43 | Theorem compile_correct : 44 | compile_correct compile_op MailServerHAPI.step MailServerComposedAPI.step. 45 | Proof. 46 | unfold compile_correct; intros. 47 | destruct op. 48 | all: atomic_exec_inv. 49 | all: repeat step_inv. 50 | all: unfold MailServerComposedAPI.step. 51 | all: unfold user in *. 52 | all: unfold UserIdx.indexT in *. 53 | all: repeat sigT_eq. 54 | all: try destruct_validIndex. 55 | all: try rewrite hadd_hget_eq. 56 | all: eauto. 57 | 58 | destruct nouser. 59 | rewrite hadd_hget_eq. 60 | eauto. 61 | Qed. 62 | 63 | Theorem ysa_movers : forall `(op : _ T), 64 | ysa_movers MailServerHAPI.step (compile_op op). 65 | Proof. 66 | destruct op; simpl; eauto. 67 | Qed. 68 | 69 | Definition initP_compat : forall s, MailServerHAPI.initP s -> 70 | MailServerComposedAPI.initP s := 71 | ltac:(auto). 72 | 73 | End MailServerComposedImpl'. 74 | 75 | Module MailServerComposedImpl := 76 | LayerImplMovers 77 | MailServerComposedState 78 | MailServerHOp MailServerHAPI 79 | MailServerComposedOp MailServerComposedAPI 80 | MailServerComposedImpl'. 81 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/Propositional.v: -------------------------------------------------------------------------------- 1 | (** ** Variants of intuition that do not split the goal. *) 2 | 3 | Ltac safe_intuition_then t := 4 | repeat match goal with 5 | | [ H: _ /\ _ |- _ ] => 6 | destruct H 7 | | [ H: ?P -> _ |- _ ] => 8 | lazymatch type of P with 9 | | Prop => specialize (H ltac:(t)) 10 | | _ => fail 11 | end 12 | | _ => progress t 13 | end. 14 | 15 | Tactic Notation "safe_intuition" := safe_intuition_then ltac:(auto). 16 | Tactic Notation "safe_intuition" tactic(t) := safe_intuition_then t. 17 | 18 | Ltac propositional := 19 | repeat match goal with 20 | | |- forall _, _ => intros 21 | | [ H: _ /\ _ |- _ ] => destruct H 22 | | [ H: _ <-> _ |- _ ] => destruct H 23 | | [ H: False |- _ ] => solve [ destruct H ] 24 | | [ H: True |- _ ] => clear H 25 | | [ H: ~?P |- _ ] => solve [ destruct (H ltac:(trivial)) ] 26 | | [ H: ?P -> _, H': ?P |- _ ] => 27 | match type of P with 28 | | Prop => specialize (H H') 29 | end 30 | | [ H: forall x, x = _ -> _ |- _ ] => 31 | specialize (H _ eq_refl) 32 | | [ H: forall x, _ = x -> _ |- _ ] => 33 | specialize (H _ eq_refl) 34 | | [ H: exists (varname : _), _ |- _ ] => 35 | let newvar := fresh varname in 36 | destruct H as [newvar ?] 37 | | [ H: ?P |- ?P ] => exact H 38 | | _ => progress subst 39 | end. 40 | 41 | (** prove_hyps on a hypothesis H of the form [P1 -> Pn -> Q] produces [P1] ... 42 | [Pn] as goals and changes [H] to [Q] *) 43 | Ltac prove_hyps H := 44 | match type of H with 45 | | ?P -> ?Q => let HP := fresh in 46 | assert P as HP; 47 | [ | specialize (H HP); clear HP; prove_hyps H ] 48 | | _ => idtac 49 | end. 50 | 51 | (** * Instantiate existentials (deex) *) 52 | 53 | Ltac destruct_ands := 54 | repeat match goal with 55 | | [ H: _ /\ _ |- _ ] => 56 | destruct H 57 | end. 58 | 59 | Ltac deex := 60 | match goal with 61 | | [ H : exists (varname : _), _ |- _ ] => 62 | let newvar := fresh varname in 63 | destruct H as [newvar ?]; destruct_ands; subst 64 | end. 65 | 66 | Module DeexTests. 67 | 68 | Theorem chooses_name : 69 | (exists (foo:unit), foo=foo) -> 70 | True. 71 | Proof. 72 | intros. 73 | deex. 74 | destruct foo. 75 | trivial. 76 | Qed. 77 | 78 | Theorem chooses_fresh_name : 79 | forall (foo:bool), 80 | (exists (foo:unit), foo=foo) -> True. 81 | Proof. 82 | intros. 83 | deex. 84 | (* fresh name for exists witness *) 85 | destruct foo0. 86 | trivial. 87 | Qed. 88 | 89 | End DeexTests. 90 | -------------------------------------------------------------------------------- /src/Mail/MailboxTmpAbsAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailboxAPI. 3 | Require Import MailServerAPI. 4 | 5 | Module MailboxTmpAbsState <: State. 6 | 7 | Record state_rec := mk_state { 8 | tmpdir : MailServerState.dir_contents; 9 | maildir : MailServerState.dir_contents; 10 | locked : bool; 11 | }. 12 | 13 | Definition State := state_rec. 14 | Definition initP (s : State) := locked s = false /\ 15 | tmpdir s = FMap.empty /\ 16 | maildir s = FMap.empty. 17 | 18 | End MailboxTmpAbsState. 19 | Module MailboxTmpAbsHState := HState MailboxTmpAbsState UserIdx. 20 | 21 | 22 | Module MailboxTmpAbsAPI <: Layer MailboxOp MailboxTmpAbsState. 23 | 24 | Import MailboxOp. 25 | Import MailboxTmpAbsState. 26 | 27 | 28 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 29 | | StepDeliverOK : forall m tmp tmp' mbox tid fn lock, 30 | ~ FMap.In fn mbox -> 31 | xstep (Deliver m) tid 32 | (mk_state tmp mbox lock) 33 | true 34 | (mk_state tmp' (FMap.add fn m mbox) lock) 35 | nil 36 | | StepDeliverErr : forall m tmp tmp' mbox tid lock, 37 | xstep (Deliver m) tid 38 | (mk_state tmp mbox lock) 39 | false 40 | (mk_state tmp' mbox lock) 41 | nil 42 | | StepList : forall tmp mbox tid r lock, 43 | FMap.is_permutation_key r mbox -> 44 | xstep List tid 45 | (mk_state tmp mbox lock) 46 | r 47 | (mk_state tmp mbox lock) 48 | nil 49 | | StepReadOK : forall fn tmp mbox tid m lock, 50 | FMap.MapsTo fn m mbox -> 51 | xstep (Read fn) tid 52 | (mk_state tmp mbox lock) 53 | (Some m) 54 | (mk_state tmp mbox lock) 55 | nil 56 | | StepReadNone : forall fn tmp mbox tid lock, 57 | ~ FMap.In fn mbox -> 58 | xstep (Read fn) tid 59 | (mk_state tmp mbox lock) 60 | None 61 | (mk_state tmp mbox lock) 62 | nil 63 | | StepDelete : forall fn tmp mbox tid lock, 64 | xstep (Delete fn) tid 65 | (mk_state tmp mbox lock) 66 | tt 67 | (mk_state tmp (FMap.remove fn mbox) lock) 68 | nil 69 | | StepLock : forall tmp mbox tid, 70 | xstep Lock tid 71 | (mk_state tmp mbox false) 72 | tt 73 | (mk_state tmp mbox true) 74 | nil 75 | | StepUnlock : forall tmp mbox tid lock, 76 | xstep Unlock tid 77 | (mk_state tmp mbox lock) 78 | tt 79 | (mk_state tmp mbox false) 80 | nil 81 | 82 | | StepExt : forall s tid `(extop : _ T) r, 83 | xstep (Ext extop) tid 84 | s 85 | r 86 | s 87 | (Event (extop, r) :: nil) 88 | . 89 | 90 | Definition step := xstep. 91 | 92 | Definition initP := initP. 93 | 94 | End MailboxTmpAbsAPI. 95 | Module MailboxTmpAbsHAPI := HLayer MailboxOp MailboxTmpAbsState MailboxTmpAbsAPI UserIdx. 96 | -------------------------------------------------------------------------------- /src/Mail/LinkRetryImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxAPI. 4 | Require Import MailboxTmpAbsAPI. 5 | Require Import DeliverAPI. 6 | Require Import TryDeliverAPI. 7 | 8 | 9 | Module LinkRetryImpl' <: 10 | LayerImplLoopT 11 | MailboxTmpAbsState 12 | TryDeliverOp TryDeliverAPI 13 | DeliverOp DeliverAPI. 14 | 15 | (* START CODE *) 16 | 17 | Definition retry_cond (r : bool) := r. 18 | Definition once_cond {T} (r : T) := true. 19 | 20 | Definition compile_op T (op : DeliverOp.Op T) : (option T -> TryDeliverOp.Op T) * (T -> bool) * option T := 21 | match op with 22 | | DeliverOp.CreateWriteTmp data => (fun _ => TryDeliverOp.CreateWriteTmp data, once_cond, None) 23 | | DeliverOp.LinkMail => (fun _ => TryDeliverOp.LinkMail, retry_cond, None) 24 | | DeliverOp.UnlinkTmp => (fun _ => TryDeliverOp.UnlinkTmp, once_cond, None) 25 | | DeliverOp.List => (fun _ => TryDeliverOp.List, once_cond, None) 26 | | DeliverOp.Read fn => (fun _ => TryDeliverOp.Read fn, once_cond, None) 27 | | DeliverOp.Delete fn => (fun _ => TryDeliverOp.Delete fn, once_cond, None) 28 | | DeliverOp.Lock => (fun _ => TryDeliverOp.Lock, once_cond, None) 29 | | DeliverOp.Unlock => (fun _ => TryDeliverOp.Unlock, once_cond, None) 30 | | DeliverOp.Ext extop => (fun _ => TryDeliverOp.Ext extop, once_cond, None) 31 | end. 32 | 33 | (* END CODE *) 34 | 35 | Ltac step_inv := 36 | match goal with 37 | | H : TryDeliverAPI.xstep _ _ _ _ _ _ |- _ => 38 | inversion H; clear H; subst; repeat sigT_eq 39 | | H : DeliverAPI.xstep _ _ _ _ _ _ |- _ => 40 | inversion H; clear H; subst; repeat sigT_eq 41 | end. 42 | 43 | Ltac pair_inv := 44 | match goal with 45 | | H : (_, _) = (_, _) |- _ => 46 | inversion H; clear H; subst; repeat sigT_eq 47 | end. 48 | 49 | Hint Constructors TryDeliverAPI.xstep. 50 | Hint Constructors DeliverAPI.xstep. 51 | 52 | Theorem noop_or_success : 53 | noop_or_success compile_op TryDeliverAPI.step DeliverAPI.step. 54 | Proof. 55 | unfold noop_or_success. 56 | unfold TryDeliverAPI.step, DeliverAPI.step. 57 | destruct opM; simpl; intros; pair_inv; step_inv; eauto. 58 | Qed. 59 | 60 | Definition initP_compat : forall s, TryDeliverAPI.initP s -> 61 | DeliverAPI.initP s := 62 | ltac:(auto). 63 | 64 | End LinkRetryImpl'. 65 | 66 | Module LinkRetryImpl := 67 | LayerImplLoop 68 | MailboxTmpAbsState 69 | TryDeliverOp TryDeliverAPI 70 | DeliverOp DeliverAPI 71 | LinkRetryImpl'. 72 | 73 | Module LinkRetryImplH' := 74 | LayerImplLoopHT 75 | MailboxTmpAbsState 76 | TryDeliverOp TryDeliverAPI 77 | DeliverOp DeliverAPI 78 | LinkRetryImpl' 79 | UserIdx. 80 | 81 | Module LinkRetryImplH := 82 | LayerImplLoop 83 | MailboxTmpAbsHState 84 | TryDeliverHOp TryDeliverHAPI 85 | DeliverHOp DeliverHAPI 86 | LinkRetryImplH'. 87 | -------------------------------------------------------------------------------- /src/FS/FSImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import FSAPI. 3 | Require Extraction. 4 | 5 | Import ListNotations. 6 | Require Import String. 7 | 8 | Extraction Language Haskell. 9 | 10 | Module FS <: FSAPI. 11 | 12 | Definition pathname := FSAPI.pathname. 13 | 14 | Axiom init : proc InitResult. 15 | Axiom create : pathname -> string -> proc nat. 16 | Axiom mkdir : pathname -> string -> proc nat. 17 | Axiom delete : pathname -> proc unit. 18 | Axiom rmdir : pathname -> proc unit. 19 | Axiom rename_file : pathname -> pathname -> string -> proc unit. 20 | Axiom read : pathname -> proc string. 21 | Axiom write_logged : pathname -> string -> proc unit. 22 | Axiom write_bypass : pathname -> string -> proc unit. 23 | Axiom stat : pathname -> string -> proc FSAPI.stat_result. 24 | Axiom readdir : pathname -> proc (list string). 25 | Axiom recover : proc unit. 26 | Axiom find_available_name : pathname -> proc string. 27 | Axiom debug: string -> proc unit. 28 | 29 | Axiom abstr : Abstraction State. 30 | 31 | Axiom init_ok : init_abstraction init recover abstr inited. 32 | Axiom create_ok : forall tid dir name, proc_spec (create_spec tid dir name) (create dir name) recover abstr. 33 | Axiom mkdir_ok : forall tid dir name, proc_spec (mkdir_spec tid dir name) (mkdir dir name) recover abstr. 34 | Axiom delete_ok : forall tid pn, proc_spec (delete_spec tid pn) (delete pn) recover abstr. 35 | Axiom rmdir_ok : forall tid pn, proc_spec (rmdir_spec tid pn) (rmdir pn) recover abstr. 36 | Axiom rename_file_ok : forall pn newdir newname, proc_spec (rename_file_spec pn newdir newname) (rename_file pn newdir newname) recover abstr. 37 | Axiom read_ok : forall pn, proc_spec (read_spec pn) (read pn) recover abstr. 38 | Axiom write_logged_ok : forall pn f, proc_spec (write_logged_spec pn f) (write_logged pn f) recover abstr. 39 | Axiom write_bypass_ok : forall pn f, proc_spec (write_bypass_spec pn f) (write_bypass pn f) recover abstr. 40 | Axiom stat_ok : forall pn n, proc_spec (stat_spec pn n) (stat pn n) recover abstr. 41 | Axiom readdir_ok : forall pn, proc_spec (readdir_spec pn) (readdir pn) recover abstr. 42 | Axiom recover_noop : rec_noop recover abstr no_crash. 43 | Axiom find_available_name_ok : forall tid dirpn, 44 | proc_spec (find_available_name_spec tid dirpn) (find_available_name dirpn) recover abstr. 45 | Axiom debug_ok : forall s, proc_spec (debug_spec) (debug s) recover abstr. 46 | 47 | 48 | End FS. 49 | 50 | Extract Constant FS.init => "FS.Ops.init". 51 | Extract Constant FS.create => "FS.Ops.create". 52 | Extract Constant FS.mkdir => "FS.Ops.mkdir". 53 | Extract Constant FS.write_logged => "FS.Ops.write_logged". 54 | Extract Constant FS.debug => "FS.Ops.debug". 55 | 56 | (* XXX should be split: it should call find_avaialbe_name, but we should check 57 | * in Gallina that the name returned is indeed available and proof the check 58 | * correct. For now completely trusted. *) 59 | Extract Constant FS.find_available_name => "FS.Ops.find_available_name". 60 | 61 | -------------------------------------------------------------------------------- /src/Helpers/RecordSet.v: -------------------------------------------------------------------------------- 1 | Set Implicit Arguments. 2 | 3 | (** Reader is the reader monad (or just the function monad). We only use 4 | Applicative here. *) 5 | Definition Reader E T := forall (e:E), T e. 6 | Arguments Reader : clear implicits. 7 | 8 | Definition pure {E T} (x:T) : Reader E (fun _ => T) := fun _ => x. 9 | 10 | Definition ap {E} 11 | {A: E -> Type} 12 | {B: forall (e:E), A e -> Type} 13 | (f: Reader E (fun e => forall (a:A e), B e a)) : 14 | forall (x: Reader E A), Reader E (fun e => B e (x e)) := 15 | fun x => fun e => f e (x e). 16 | Infix "<*>" := (ap) (at level 11, left associativity). 17 | 18 | (** Settable is a way of accessing a constructor for a record of type T. The 19 | syntactic form of this definition is important: it must be an eta-expanded 20 | version of T's constructor, written generically over the field accessors of T. 21 | The best way to do this for a record X := mkX { A; B; C} is [pure mkX <*> A <*> 22 | B <*> C]. *) 23 | Class Settable T := { mkT: Reader T (fun _ => T); 24 | mkT_ok: forall x, mkT x = x }. 25 | Arguments mkT T mk : clear implicits, rename. 26 | 27 | Local Ltac mkSettable e := 28 | refine {| mkT := e |}; 29 | (match goal with 30 | | |- forall x, _ = _ => solve [ destruct x; cbv; f_equal ] 31 | end). 32 | 33 | (** mkSettable creates an instance of Settable from an expression like [pure mkX 34 | <*> A <*> B <*> C] *) 35 | Notation mkSettable e := (ltac:(mkSettable e)) (only parsing). 36 | 37 | (** [setter] creates a setter based on an eta-expanded record constructor and a 38 | particular field projection proj *) 39 | Local Ltac setter etaT proj := 40 | let set := 41 | (match eval pattern proj in etaT with 42 | | ?setter ?proj => constr:(fun x => setter (pure x)) 43 | end) in 44 | let set := (eval cbv [pure ap] in set) in 45 | exact set. 46 | 47 | (* Combining the above, [getSetter'] looks up the eta-expanded version of T with 48 | the Settable typeclass, and calls [setter] to create a setter. *) 49 | Local Ltac get_setter T proj := 50 | match constr:(mkT T _) with 51 | | mkT _ ?updateable => 52 | let updateable := (eval hnf in updateable) in 53 | match updateable with 54 | | {| mkT := ?mk |} => 55 | setter mk proj 56 | end 57 | end. 58 | 59 | (* Setter provides a way to change a field given by a projection function, along 60 | with correctness conditions that require the projected field and only the 61 | projected field is modified. *) 62 | Class Setter {R T} (proj: R -> T) := 63 | { set: T -> R -> R; 64 | set_get: forall v r, proj (set v r) = v; 65 | set_eq: forall r, set (proj r) r = r; }. 66 | 67 | Arguments set {R T} proj {Setter}. 68 | 69 | Ltac SetInstance_t := 70 | match goal with 71 | | |- @Setter ?T _ ?A => unshelve eapply Build_Setter; 72 | [ get_setter T A | intros ? r; destruct r | intros r; destruct r ]; 73 | intros; reflexivity 74 | end. 75 | 76 | Hint Extern 1 (Setter _) => SetInstance_t : typeclass_instances. 77 | 78 | Module RecordSetNotations. 79 | Notation "x [ proj := v ]" := (set proj v x) 80 | (at level 12, left associativity, 81 | format "x [ proj := v ]"). 82 | End RecordSetNotations. 83 | -------------------------------------------------------------------------------- /src/Mail/MailFSPathImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailFSStringAPI. 4 | Require Import MailFSPathAbsAPI. 5 | Require Import MailFSPathAPI. 6 | 7 | 8 | Module MailFSPathImpl' <: 9 | LayerImplMoversT 10 | MailFSPathAbsState 11 | MailFSPathOp MailFSPathAPI 12 | MailFSStringOp MailFSPathAbsAPI. 13 | 14 | (* START CODE *) 15 | 16 | Definition compile_op T (op : MailFSStringOp.Op T) : proc _ T := 17 | match op with 18 | | MailFSStringOp.LinkMail tmpfn mailfn => Call (MailFSPathOp.Link (tmp_string, tmpfn) (mail_string, mailfn)) 19 | | MailFSStringOp.List => Call (MailFSPathOp.List mail_string) 20 | | MailFSStringOp.Read fn => Call (MailFSPathOp.Read (mail_string, fn)) 21 | | MailFSStringOp.Delete fn => Call (MailFSPathOp.Unlink (mail_string, fn)) 22 | | MailFSStringOp.CreateTmp tmpfn => Call (MailFSPathOp.Create (tmp_string, tmpfn)) 23 | | MailFSStringOp.WriteTmp tmpfn data => Call (MailFSPathOp.Write (tmp_string, tmpfn) data) 24 | | MailFSStringOp.UnlinkTmp tmpfn => Call (MailFSPathOp.Unlink (tmp_string, tmpfn)) 25 | | MailFSStringOp.Ext extop => Call (MailFSPathOp.Ext extop) 26 | | MailFSStringOp.Lock => Call (MailFSPathOp.Lock) 27 | | MailFSStringOp.Unlock => Call (MailFSPathOp.Unlock) 28 | | MailFSStringOp.GetTID => Call (MailFSPathOp.GetTID) 29 | | MailFSStringOp.Random => Call (MailFSPathOp.Random) 30 | end. 31 | 32 | (* END CODE *) 33 | 34 | Theorem compile_op_no_atomics : 35 | forall `(op : _ T), 36 | no_atomics (compile_op op). 37 | Proof. 38 | destruct op; compute; eauto. 39 | Qed. 40 | 41 | Ltac step_inv := 42 | match goal with 43 | | H : MailFSPathAbsAPI.step _ _ _ _ _ _ |- _ => 44 | inversion H; clear H; subst; repeat sigT_eq 45 | | H : MailFSPathAPI.step _ _ _ _ _ _ |- _ => 46 | inversion H; clear H; subst; repeat sigT_eq 47 | end; intuition idtac. 48 | 49 | Hint Extern 1 (MailFSPathAbsAPI.step _ _ _ _ _ _) => econstructor. 50 | Hint Extern 1 (MailFSPathAPI.step _ _ _ _ _ _) => econstructor. 51 | 52 | Theorem compile_correct : 53 | compile_correct compile_op MailFSPathAPI.step MailFSPathAbsAPI.step. 54 | Proof. 55 | unfold compile_correct; intros. 56 | destruct op. 57 | 58 | all: try solve [ repeat atomic_exec_inv; repeat step_inv; eauto ]. 59 | Qed. 60 | 61 | Theorem ysa_movers : forall `(op : _ T), 62 | ysa_movers MailFSPathAPI.step (compile_op op). 63 | Proof. 64 | destruct op; simpl; eauto 20. 65 | Qed. 66 | 67 | Definition initP_compat : forall s, MailFSPathAPI.initP s -> 68 | MailFSPathAbsAPI.initP s := 69 | ltac:(auto). 70 | 71 | 72 | End MailFSPathImpl'. 73 | 74 | 75 | Module MailFSPathImpl := 76 | LayerImplMovers 77 | MailFSPathAbsState 78 | MailFSPathOp MailFSPathAPI 79 | MailFSStringOp MailFSPathAbsAPI 80 | MailFSPathImpl'. 81 | 82 | Module MailFSPathImplH' := 83 | LayerImplMoversHT 84 | MailFSPathAbsState 85 | MailFSPathOp MailFSPathAPI 86 | MailFSStringOp MailFSPathAbsAPI 87 | MailFSPathImpl' 88 | UserIdx. 89 | 90 | Module MailFSPathImplH := 91 | LayerImplMovers 92 | MailFSPathAbsHState 93 | MailFSPathHOp MailFSPathHAPI 94 | MailFSStringHOp MailFSPathAbsHAPI 95 | MailFSPathImplH'. 96 | -------------------------------------------------------------------------------- /src/Helpers/Instances.v: -------------------------------------------------------------------------------- 1 | Require Export RelationClasses. 2 | Require Import Relation_Operators. 3 | Require Import Ordering. 4 | Require Import ProofIrrelevance. 5 | 6 | Require Import String. 7 | Require Import List. 8 | 9 | (** * Decidable equality. 10 | 11 | [EqualDec] defines a notion of decidable equality for things 12 | of type [A]. This means that there is a function, called 13 | [equal_dec], which, given two things of type [A], will return 14 | whether they are equal or not. 15 | *) 16 | 17 | Class EqualDec A := 18 | equal_dec : forall x y : A, { x = y } + { x <> y }. 19 | 20 | Ltac RelInstance_t := 21 | intros; 22 | let refl := try solve [ hnf; intros; reflexivity ] in 23 | let symm := try solve [ hnf; intros; try symmetry; eauto ] in 24 | let trans := try solve [ hnf; intros; etransitivity; eauto ] in 25 | try match goal with 26 | | |- EqualDec _ => 27 | hnf; decide equality 28 | | |- Reflexive _ => 29 | hnf; intros; refl 30 | | |- Symmetric _ => 31 | hnf; intros; symm 32 | | |- Transitive _ => 33 | hnf; intros; trans 34 | | |- PreOrder _ => 35 | constructor; hnf; intros; [ refl | trans ] 36 | | |- Equivalence _ => 37 | constructor; hnf; intros; [ refl | symm | trans ] 38 | end. 39 | 40 | Notation RelInstance := (ltac:(RelInstance_t)) (only parsing). 41 | 42 | (** 43 | We define the notation [x == y] to mean our decidable equality 44 | between [x] and [y]. 45 | *) 46 | 47 | Notation " x == y " := (equal_dec x y) (no associativity, at level 70). 48 | 49 | (* For units, an explicit definition has better computational behavior. 50 | Specifically it is syntactically a [left], so any matches on [u == u'] 51 | automatically reduce to the true case; [decide equality] would first destruct 52 | the arguments before producing [left]. *) 53 | Instance unit_equal_dec : EqualDec unit := 54 | fun x y => left (match x, y with 55 | | tt, tt => eq_refl 56 | end). 57 | 58 | Instance nat_equal_dec : EqualDec nat := RelInstance. 59 | Instance bool_equal_dec : EqualDec bool := RelInstance. 60 | 61 | Instance string_equal_dec : EqualDec string := string_dec. 62 | Instance list_equal_dec A `{dec:EqualDec A} : EqualDec (list A) := list_eq_dec dec. 63 | 64 | Instance pair_equal_dec A B `{ea:EqualDec A} `{eb:EqualDec B} : EqualDec (A*B) := 65 | RelInstance. 66 | 67 | Instance option_equal_dec A `{ea:EqualDec A} : EqualDec (option A) := RelInstance. 68 | 69 | Local Hint Constructors clos_refl_trans_1n. 70 | Instance clos_rt1n_pre A (R: A -> A -> Prop) : PreOrder (clos_refl_trans_1n A R). 71 | Proof. 72 | RelInstance_t. 73 | eauto. 74 | induction H; eauto. 75 | Qed. 76 | 77 | Instance comparison_eq_dec : EqualDec comparison := ltac:(hnf; decide equality). 78 | 79 | Instance ord_eq_dec A {o:Ordering A} : EqualDec A. 80 | Proof. 81 | hnf; intros. 82 | destruct (cmp x y == Eq). 83 | apply cmp_eq in e; auto. 84 | right; intro; subst. 85 | rewrite cmp_refl in n; congruence. 86 | Qed. 87 | 88 | Instance sigT_eq_dec A (P: A -> Prop) (dec:EqualDec A) : EqualDec (sig P). 89 | Proof. 90 | hnf; intros. 91 | destruct x as [x ?], y as [y ?]. 92 | destruct (x == y); subst; [ left | right ]. 93 | - f_equal. 94 | apply proof_irrelevance. 95 | - intro. 96 | inversion H; congruence. 97 | Qed. 98 | -------------------------------------------------------------------------------- /mail-test/lib/SMTP.hs: -------------------------------------------------------------------------------- 1 | module SMTP where 2 | 3 | -- Loosely based on https://github.com/agrafix/haskell-smtp-server/blob/master/Smtp.hs 4 | 5 | import Network 6 | import System.IO 7 | import Support 8 | import Data.List.Split 9 | 10 | data SMTPServer = 11 | SMTPServer Socket 12 | 13 | data Message = 14 | Message 15 | { mail_client :: [String] 16 | , mail_from :: [String] 17 | , mail_to :: String 18 | , mail_data :: ShowS 19 | } 20 | 21 | smtpListen :: Int -> IO SMTPServer 22 | smtpListen portnum = do 23 | sock <- listenOn (PortNumber $ fromIntegral portnum) 24 | return $ SMTPServer sock 25 | 26 | smtpAccept :: SMTPServer -> IO SMTPConn 27 | smtpAccept (SMTPServer sock) = do 28 | (conn, _, _) <- accept sock 29 | hSetBuffering conn LineBuffering 30 | return $ SMTPConn conn 31 | 32 | smtpRespond :: Handle -> Int -> String -> IO () 33 | smtpRespond h code text = 34 | hPutStrLn h $ (show code) ++ " " ++ text 35 | 36 | smtpRespondOK :: Handle -> IO () 37 | smtpRespondOK h = 38 | smtpRespond h 250 "OK" 39 | 40 | smtpClose :: Handle -> IO () 41 | smtpClose h = do 42 | smtpRespond h 221 "closing" 43 | hClose h 44 | 45 | process_to:: [String] -> String 46 | process_to rcpt = 47 | let u = splitOn ":" (rcpt !! 0) 48 | in filter (not . (`elem` ['<', '>'])) (u !! 1) 49 | 50 | 51 | -- process_to :: [String] -> String 52 | -- process_to words = 53 | -- if length words == 1 && (words !! 0) == "TO:" 54 | -- then filter (not . flip elem "<>") (words !! 1) 55 | -- else "still-unknown" 56 | 57 | smtpProcessCommands :: Handle -> Message -> IO (Maybe Message) 58 | smtpProcessCommands h msg = do 59 | line <- hGetLine h 60 | let cmd = words line 61 | case cmd of 62 | "HELO" : client -> do 63 | smtpRespondOK h 64 | smtpProcessCommands h $ msg { mail_client = client } 65 | "EHLO" : client -> do 66 | smtpRespondOK h 67 | smtpProcessCommands h $ msg { mail_client = client } 68 | "MAIL" : from -> do 69 | smtpRespondOK h 70 | smtpProcessCommands h $ msg { mail_from = from } 71 | "RCPT" : to -> do 72 | smtpRespondOK h 73 | smtpProcessCommands h $ msg { mail_to = process_to to } 74 | ["DATA"] -> do 75 | smtpRespond h 354 "proceed with data" 76 | smtpProcessData h msg 77 | ["QUIT"] -> do 78 | smtpClose h 79 | return Nothing 80 | _ -> do 81 | smtpRespond h 500 "unknown command" 82 | smtpClose h 83 | return Nothing 84 | 85 | smtpProcessData :: Handle -> Message -> IO (Maybe Message) 86 | smtpProcessData h msg = do 87 | line <- hGetLine h 88 | if line == ".\r" then 89 | return (Just msg) 90 | else do 91 | smtpProcessData h $ msg { mail_data = (mail_data msg) . showString (line ++ "\n") } 92 | 93 | smtpGetMessage :: SMTPConn -> IO (Maybe (String, String)) 94 | smtpGetMessage (SMTPConn h) = do 95 | smtpRespond h 220 "ready" 96 | maybemsg <- smtpProcessCommands h (Message [] [] "unknown" (showString "")) 97 | case maybemsg of 98 | Nothing -> return Nothing 99 | Just msg -> return $ Just (mail_to msg, mail_data msg "") 100 | 101 | smtpDone :: SMTPConn -> Bool -> IO () 102 | smtpDone (SMTPConn h) True = do 103 | smtpRespond h 250 "delivered" 104 | smtpClose h 105 | 106 | smtpDone (SMTPConn h) False = do 107 | smtpRespond h 452 "could not deliver" 108 | smtpClose h 109 | -------------------------------------------------------------------------------- /src/Helpers/ListStuff.v: -------------------------------------------------------------------------------- 1 | Require Import Omega. 2 | Require Import List. 3 | 4 | Import ListNotations. 5 | 6 | Global Set Implicit Arguments. 7 | Global Generalizable All Variables. 8 | 9 | Fixpoint pad `(l : list T) len val : list T := 10 | match len with 11 | | O => l 12 | | S len' => 13 | match l with 14 | | x :: l' => 15 | x :: pad l' len' val 16 | | nil => 17 | val :: pad nil len' val 18 | end 19 | end. 20 | 21 | Fixpoint list_upd `(l : list T) (idx : nat) (v : T) := 22 | match l with 23 | | nil => nil 24 | | x :: l' => 25 | match idx with 26 | | O => v :: l' 27 | | S idx' => x :: list_upd l' idx' v 28 | end 29 | end. 30 | 31 | Lemma pad_is_append : forall n `(l : list T) v, 32 | pad l n v = l ++ repeat v (n - length l). 33 | Proof. 34 | induction n; simpl; intros. 35 | - rewrite app_nil_r; eauto. 36 | - destruct l; simpl. 37 | + rewrite IHn; simpl. replace (n - 0) with n by omega. reflexivity. 38 | + rewrite IHn. eauto. 39 | Qed. 40 | 41 | Lemma repeat_app : forall n m `(x : T), 42 | repeat x (n + m) = repeat x n ++ repeat x m. 43 | Proof. 44 | induction n; simpl; eauto; intros. 45 | f_equal. eauto. 46 | Qed. 47 | 48 | Lemma repeat_tl : forall n `(x : T), 49 | repeat x (S n) = repeat x n ++ [x]. 50 | Proof. 51 | induction n; simpl; eauto; intros. 52 | f_equal. rewrite <- IHn. reflexivity. 53 | Qed. 54 | 55 | Lemma rev_repeat : forall n T (x : T), 56 | rev (repeat x n) = repeat x n. 57 | Proof. 58 | induction n; simpl; eauto; intros. 59 | rewrite IHn. 60 | rewrite <- repeat_tl. 61 | reflexivity. 62 | Qed. 63 | 64 | Lemma length_list_upd: forall `(l: list T) i d, 65 | Datatypes.length (list_upd l i d) = Datatypes.length l. 66 | Proof. 67 | induction l; intros; simpl. 68 | + auto. 69 | + destruct i. 70 | replace (d::l) with ([d]++l) by auto. 71 | apply app_length. 72 | replace (a :: (list_upd l i d)) with ([a] ++ (list_upd l i d)) by auto. 73 | rewrite app_length. simpl. 74 | rewrite IHl; auto. 75 | Qed. 76 | 77 | Lemma list_upd_commutes: forall `(l: list T) i0 i1 v0 v1, 78 | i0 <> i1 -> 79 | list_upd (list_upd l i0 v0) i1 v1 = list_upd (list_upd l i1 v1) i0 v0. 80 | Proof. 81 | induction l; intros; auto. 82 | simpl. 83 | destruct i0; subst; simpl. 84 | destruct i1; try congruence. 85 | simpl; reflexivity. 86 | destruct i1; simpl. 87 | reflexivity. 88 | rewrite IHl; auto. 89 | Qed. 90 | 91 | Lemma list_upd_app : forall `(l1 : list T) l2 i v, 92 | length l1 <= i -> 93 | list_upd (l1 ++ l2) i v = l1 ++ list_upd l2 (i - length l1) v. 94 | Proof. 95 | induction l1; simpl; intros. 96 | - replace (i - 0) with i by omega; auto. 97 | - destruct i; try omega. 98 | f_equal. 99 | simpl. 100 | eapply IHl1; omega. 101 | Qed. 102 | 103 | Theorem nth_error_list_upd_eq : 104 | forall `(l : list A) n v, 105 | n < length l -> 106 | nth_error (list_upd l n v) n = Some v. 107 | Proof. 108 | induction l; simpl; intros; try omega. 109 | destruct n; simpl; eauto. 110 | eapply IHl; omega. 111 | Qed. 112 | 113 | Theorem nth_error_list_upd_ne : 114 | forall `(l : list A) n n' v, 115 | n <> n' -> 116 | nth_error (list_upd l n v) n' = nth_error l n'. 117 | Proof. 118 | induction l; simpl; intros; eauto. 119 | destruct n; simpl; eauto. 120 | - destruct n'; eauto; omega. 121 | - destruct n'; eauto. 122 | Qed. 123 | -------------------------------------------------------------------------------- /src/Spec/Equiv/Atomic.v: -------------------------------------------------------------------------------- 1 | Require Import Spec.ConcurExec. 2 | Require Import Spec.Equiv.Execution. 3 | 4 | Require Import ProofAutomation. 5 | Require Import Helpers.Instances. 6 | Require Import Morphisms. 7 | Require Import List. 8 | 9 | Section OpSemantics. 10 | 11 | Context {Op:Type -> Type}. 12 | Context {State:Type}. 13 | Variable op_step: OpSemantics Op State. 14 | 15 | Local Obligation Tactic := try RelInstance_t. 16 | 17 | (** A strong notion of equivalence for programs inside atomic sections. 18 | Basically the same as above, but defined as an underlying [atomic_exec] 19 | rather than [exec]. *) 20 | 21 | Local Definition atomic_equiv `(p1 : proc Op T) p2 := 22 | forall (s s' : State) r tid evs, 23 | atomic_exec op_step p1 tid s r s' evs <-> 24 | atomic_exec op_step p2 tid s r s' evs. 25 | 26 | Global Program Instance atomic_equiv_equivalence : 27 | Equivalence (@atomic_equiv T). 28 | 29 | Global Instance atomic_equiv_proper : 30 | Proper (atomic_equiv ==> atomic_equiv ==> iff) (@atomic_equiv T). 31 | Proof. 32 | typeclasses eauto. 33 | Qed. 34 | 35 | Theorem atomic_equiv_ret_bind : forall `(v : T) `(p : T -> proc Op T'), 36 | atomic_equiv (Bind (Ret v) p) (p v). 37 | Proof. 38 | split; intros. 39 | - atomic_exec_inv. 40 | invert H9. 41 | - rewrite <- app_nil_l. 42 | eauto. 43 | Qed. 44 | 45 | (* unused *) 46 | Local Theorem atomic_equiv_bind_ret : forall `(p : proc Op T), 47 | atomic_equiv (Bind p Ret) p. 48 | Proof. 49 | split; intros. 50 | - atomic_exec_inv. 51 | invert H10. 52 | rewrite app_nil_r. 53 | eauto. 54 | - rewrite <- app_nil_r. 55 | eauto. 56 | Qed. 57 | 58 | Local Theorem atomic_equiv_bind_bind : forall `(p1 : proc Op T1) `(p2 : T1 -> proc Op T2) `(p3 : T2 -> proc Op T3), 59 | atomic_equiv (Bind (Bind p1 p2) p3) (Bind p1 (fun v => Bind (p2 v) p3)). 60 | Proof. 61 | split; intros. 62 | - atomic_exec_inv. 63 | invert H9. 64 | rewrite <- app_assoc. 65 | eauto. 66 | - atomic_exec_inv. 67 | invert H10. 68 | rewrite app_assoc. 69 | eauto. 70 | Qed. 71 | 72 | Local Theorem atomic_equiv_bind_congruence : forall T (p1 p2: proc Op T) T' (rx1 rx2: T -> proc Op T'), 73 | atomic_equiv p1 p2 -> 74 | (forall x, atomic_equiv (rx1 x) (rx2 x)) -> 75 | atomic_equiv (Bind p1 rx1) (Bind p2 rx2). 76 | Proof. 77 | split; intros; atomic_exec_inv. 78 | - apply H in H11. 79 | apply H0 in H12. 80 | eauto. 81 | - apply H in H11. 82 | apply H0 in H12. 83 | eauto. 84 | Qed. 85 | 86 | Global Instance Bind_proper_atomic_equiv : 87 | Proper (atomic_equiv ==> 88 | pointwise_relation T atomic_equiv ==> 89 | @atomic_equiv TR) Bind. 90 | Proof. 91 | unfold Proper, respectful, pointwise_relation; intros. 92 | apply atomic_equiv_bind_congruence; auto. 93 | Qed. 94 | 95 | Global Instance Atomic_proper_atomic_equiv : 96 | Proper (atomic_equiv ==> exec_equiv_rx op_step (T:=T)) Atomic. 97 | Proof. 98 | intros. 99 | intros p1 p2 H. 100 | eapply exec_equiv_rx_proof_helper; intros; 101 | repeat exec_tid_inv. 102 | - apply H in H9. 103 | ExecPrefix tid tid'. 104 | - apply H in H9. 105 | ExecPrefix tid tid'. 106 | Qed. 107 | 108 | End OpSemantics. 109 | -------------------------------------------------------------------------------- /gomail/mclnt/mclnt.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | // use: $ time go run mclnt.go 4 | 5 | import ( 6 | "bufio" 7 | "fmt" 8 | "log" 9 | "net" 10 | "net/smtp" 11 | "net/textproto" 12 | "os" 13 | "strconv" 14 | "strings" 15 | "sync" 16 | "time" 17 | ) 18 | 19 | const ( 20 | NGO = 1 21 | NUSER = 100 22 | NMSG = 1000 23 | ) 24 | 25 | func sendmail(u string) { 26 | c, err := smtp.Dial("localhost:2525") 27 | if err != nil { 28 | log.Fatal(err) 29 | } 30 | 31 | if err := c.Hello("localhost"); err != nil { 32 | log.Fatal(err) 33 | } 34 | 35 | if err := c.Rcpt(u); err != nil { 36 | log.Fatal(err) 37 | } 38 | 39 | wc, err := c.Data() 40 | if err != nil { 41 | log.Fatal(err) 42 | } 43 | _, err = fmt.Fprintf(wc, "This is the email body") 44 | if err != nil { 45 | log.Fatal(err) 46 | } 47 | err = wc.Close() 48 | if err != nil { 49 | log.Fatal(err) 50 | } 51 | 52 | err = c.Quit() 53 | if err != nil { 54 | log.Fatal(err) 55 | } 56 | } 57 | 58 | func read_ok(tr *textproto.Reader) { 59 | line, err := tr.ReadLine() 60 | if err != nil { 61 | log.Fatal(err) 62 | } 63 | // fmt.Printf("ok line %s\n", line) 64 | if strings.HasPrefix(line, "+OK") { 65 | return 66 | } 67 | log.Fatal("no +OK") 68 | } 69 | 70 | func read_lines(tr *textproto.Reader) []string { 71 | lines, err := tr.ReadDotLines() 72 | if err != nil { 73 | log.Fatal(err) 74 | } 75 | // fmt.Printf("lines: %v\n", lines) 76 | return lines 77 | } 78 | 79 | func pickup(u string) { 80 | // fmt.Printf("pickup %s\n", u) 81 | c, err := net.Dial("tcp", "localhost:2110") 82 | if err != nil { 83 | log.Fatal(err) 84 | } 85 | defer c.Close() 86 | 87 | reader := bufio.NewReader(c) 88 | writer := bufio.NewWriter(c) 89 | tr := textproto.NewReader(reader) 90 | tw := textproto.NewWriter(writer) 91 | 92 | read_ok(tr) 93 | 94 | tw.PrintfLine("USER %s", u) 95 | read_ok(tr) 96 | 97 | tw.PrintfLine("LIST") 98 | read_ok(tr) 99 | 100 | lines := read_lines(tr) 101 | // fmt.Printf("user %v lines %v\n", u, lines) 102 | for i := 0; i < len(lines); i++ { 103 | msg := strings.Fields(lines[i]) 104 | tw.PrintfLine("RETR %s", msg[0]) 105 | read_ok(tr) 106 | read_lines(tr) 107 | 108 | tw.PrintfLine("DELE %s", msg[0]) 109 | read_ok(tr) 110 | } 111 | 112 | tw.PrintfLine("QUIT") 113 | read_ok(tr) 114 | } 115 | 116 | func smtp_client(c int) { 117 | for i := 0; i < (NMSG*NUSER)/NGO; i++ { 118 | u := (i + c) % NUSER 119 | sendmail("u" + strconv.Itoa(u)) 120 | } 121 | } 122 | 123 | func pop_client(c int) { 124 | n := NUSER / NGO 125 | o := c * n 126 | for u := 0; u < n; u++ { 127 | pickup("u" + strconv.Itoa(u+o)) 128 | } 129 | } 130 | 131 | func measure(s string, f func(int)) { 132 | var wg sync.WaitGroup 133 | start := time.Now() 134 | wg.Add(NGO) 135 | for c := 0; c < NGO; c++ { 136 | go func(c int) { 137 | defer wg.Done() 138 | f(c) 139 | }(c) 140 | } 141 | wg.Wait() 142 | t := time.Now() 143 | elapsed := t.Sub(start) 144 | fmt.Printf("%s: time %v\n", s, elapsed) 145 | } 146 | 147 | func main() { 148 | if len(os.Args) != 3 { 149 | panic(" ") 150 | } 151 | var wg sync.WaitGroup 152 | wg.Add(2) 153 | go func() { 154 | defer wg.Done() 155 | if os.Args[1] == "1" { 156 | measure("smtp", smtp_client) 157 | } 158 | }() 159 | go func() { 160 | defer wg.Done() 161 | if os.Args[2] == "1" { 162 | measure("pop", pop_client) 163 | } 164 | }() 165 | wg.Wait() 166 | } 167 | -------------------------------------------------------------------------------- /src/FS/LinkAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import String. 3 | Require Import Equalities. 4 | Require Import MSets.MSetWeakList. 5 | Require Import Relations.Relation_Operators. 6 | Require Import RelationClasses. 7 | Require Import Morphisms. 8 | Require Import Sumbool. 9 | Require Import FSModel. 10 | 11 | Import ListNotations. 12 | Open Scope string. 13 | 14 | 15 | (** Opcodes *) 16 | 17 | Inductive linkOpT : Type -> Type := 18 | | LinkAdd (dir : nat) (name : string) (target : Node) : linkOpT bool 19 | | LinkAllocFile (dir : nat) (name : string) : linkOpT (option nat) 20 | | LinkAllocDir (dir : nat) (name : string) : linkOpT (option nat) 21 | | LinkDel (dir : nat) (name : string) (target : Node) : linkOpT bool 22 | | LinkLookup (dir : nat) (name : string) : linkOpT (option Node) 23 | | LinkList (dir : nat) : linkOpT (option (list string)) 24 | | LinkGetRoot : linkOpT nat 25 | | LinkFindUnusedName (dir : nat) (prefix : string) : linkOpT string 26 | | FileRead (f : nat) : linkOpT string 27 | | FileWrite (f : nat) (data : string) : linkOpT unit 28 | | GetTID : linkOpT nat. 29 | 30 | 31 | Inductive stat_result := 32 | | StatFile 33 | | StatDir. 34 | 35 | 36 | Module LinkAPI <: Layer. 37 | 38 | Definition Op := linkOpT. 39 | Definition State := FS. 40 | 41 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> Prop := 42 | | StepAdd : forall dir name target tid fs, 43 | xstep (LinkAdd dir name target) tid 44 | fs 45 | true 46 | (add_link dir target name fs) 47 | | StepAllocFile : forall dir name fid tid fs, 48 | file_handle_valid fs fid -> 49 | file_handle_unused fs fid -> 50 | xstep (LinkAllocFile dir name) tid 51 | fs 52 | (Some fid) 53 | (add_link dir (FileNode fid) name fs) 54 | | StepAllocDir : forall dir name did tid fs, 55 | (~ exists pn, path_eval_root fs pn (DirNode did)) -> 56 | xstep (LinkAllocDir dir name) tid 57 | fs 58 | (Some did) 59 | (add_link dir (DirNode did) name fs) 60 | | StepDel : forall dir name target tid fs, 61 | xstep (LinkDel dir name target) tid 62 | fs 63 | true 64 | (del_link dir target name fs) 65 | | StepLookupAbsent : forall dir name tid fs, 66 | (~ exists target, valid_link fs dir name target) -> 67 | xstep (LinkLookup dir name) tid 68 | fs 69 | None 70 | fs 71 | | StepLookupFound : forall dir name target tid fs, 72 | valid_link fs dir name target -> 73 | xstep (LinkLookup dir name) tid 74 | fs 75 | (Some target) 76 | fs 77 | | StepList : forall dir tid fs, 78 | xstep (LinkList dir) tid 79 | fs 80 | (Some (readdir_names fs dir)) 81 | fs 82 | | StepGetRoot : forall tid fs r, 83 | r = FSRoot fs -> 84 | xstep LinkGetRoot tid 85 | fs 86 | r 87 | fs 88 | | StepFindUnusedName : forall tid fs dir pfx name, 89 | prefix pfx name = true -> 90 | (~ exists target, valid_link fs dir name target) -> 91 | xstep (LinkFindUnusedName dir pfx) tid 92 | fs 93 | name 94 | fs 95 | | StepRead : forall f data tid fs, 96 | nth_error (FSFiles fs) f = Some data -> 97 | xstep (FileRead f) tid 98 | fs 99 | data 100 | fs 101 | | StepWrite : forall f data tid fs, 102 | xstep (FileWrite f data) tid 103 | fs 104 | tt 105 | (upd_file f data fs) 106 | | StepGetTID : forall tid fs, 107 | xstep GetTID tid 108 | fs 109 | tid 110 | fs. 111 | 112 | Definition step := xstep. 113 | 114 | Definition initP (_ : State) := True. 115 | 116 | End LinkAPI. 117 | -------------------------------------------------------------------------------- /src/Spec/CodeOpt.v: -------------------------------------------------------------------------------- 1 | (** 2 | * This file defines helper theorems and tactics to optimize 3 | * the code generated through Cspec, by evaluating the layer 4 | * compilations before extraction. 5 | *) 6 | 7 | Require Import Spec.ConcurProc. 8 | Require Import Spec.ExecSemantics. 9 | Require Import Spec.Equiv.Execution. 10 | Require Import Spec.Equiv. 11 | Require Import Spec.ThreadsState. 12 | Require Import Helpers.ProofAutomation. 13 | Require Import Helpers.ListStuff. 14 | Require Import List. 15 | Require Import Omega. 16 | Require Import Morphisms. 17 | 18 | 19 | Theorem exec_equiv_ts_thread_from_list' : 20 | forall Op State (step : OpSemantics Op State) tl1 tl2 tlbase, 21 | Forall2 (fun ep1 ep2 => 22 | exists T p1 p2, 23 | ep1 = existT _ T p1 /\ 24 | ep2 = existT _ T p2 /\ 25 | exec_equiv step p1 p2) tl1 tl2 -> 26 | exec_equiv_ts step (thread_from_list (tlbase ++ tl1)) 27 | (thread_from_list (tlbase ++ tl2)). 28 | Proof. 29 | induction tl1; destruct tl2; intros; inversion H; clear H. 30 | - reflexivity. 31 | - subst; repeat deex. 32 | specialize (IHtl1 tl2 (tlbase ++ (existT _ T p2 :: nil)) H5); clear H5. 33 | repeat rewrite <- app_assoc in IHtl1; simpl in *. 34 | etransitivity; eauto; clear IHtl1. 35 | match goal with 36 | | |- exec_equiv_ts _ ?ts _ => 37 | specialize (H1 ts (length tlbase)) 38 | end. 39 | repeat rewrite thread_upd_thread_from_list in H1 by 40 | ( rewrite app_length; simpl; omega ). 41 | repeat rewrite list_upd_app with (l1 := tlbase) in H1 by omega. 42 | replace (length tlbase - length tlbase) with 0 in * by omega. 43 | simpl in *. 44 | eauto. 45 | Qed. 46 | 47 | Theorem exec_equiv_ts_thread_from_list : 48 | forall Op State (step : OpSemantics Op State) tl1 tl2, 49 | Forall2 (fun ep1 ep2 => 50 | exists T p1 p2, 51 | ep1 = existT _ T p1 /\ 52 | ep2 = existT _ T p2 /\ 53 | exec_equiv step p1 p2) tl1 tl2 -> 54 | exec_equiv_ts step (thread_from_list tl1) (thread_from_list tl2). 55 | Proof. 56 | intros. 57 | apply exec_equiv_ts_thread_from_list' with (tlbase := nil). 58 | eauto. 59 | Qed. 60 | 61 | Theorem pointwise_unused : 62 | forall `(step : OpSemantics Op State) AT RT lhs rhs, 63 | exec_equiv_rx step lhs rhs -> 64 | pointwise_relation AT (@exec_equiv_rx _ _ step RT) 65 | (fun a => lhs) (fun _ => rhs). 66 | Proof. 67 | unfold pointwise_relation; eauto. 68 | Qed. 69 | 70 | Theorem pointwise_used : 71 | forall `(step : OpSemantics Op State) AT RT lhs rhs, 72 | (forall a, exec_equiv_rx step (lhs a) (rhs a)) -> 73 | pointwise_relation AT (@exec_equiv_rx _ _ step RT) lhs rhs. 74 | Proof. 75 | unfold pointwise_relation; eauto. 76 | Qed. 77 | 78 | Theorem exec_equiv_until_once : 79 | forall T Op State (step : OpSemantics Op State) (p : proc Op T), 80 | exec_equiv_rx 81 | step 82 | (Until (fun _ => true) (fun _ => p) None) 83 | p. 84 | Proof. 85 | intros. 86 | rewrite exec_equiv_until. 87 | unfold until1. 88 | unfold exec_equiv_rx. 89 | intros. 90 | rewrite exec_equiv_bind_bind. 91 | eapply exec_equiv_bind_a; intros. 92 | rewrite exec_equiv_ret_bind. 93 | reflexivity. 94 | Qed. 95 | 96 | Theorem exec_equiv_ts_thread_map_thread_map : 97 | forall Op1 Op2 Op3 State (step : OpSemantics Op3 State) 98 | (f : forall T, proc Op1 T -> proc Op2 T) 99 | (g : forall T, proc Op2 T -> proc Op3 T) 100 | lhs rhs, 101 | exec_equiv_ts step lhs 102 | (thread_map (fun T t => g T (f T t)) rhs) -> 103 | exec_equiv_ts step lhs 104 | (thread_map g 105 | (thread_map f 106 | rhs)). 107 | Proof. 108 | intros. 109 | autorewrite with t. 110 | eauto. 111 | Qed. 112 | -------------------------------------------------------------------------------- /src/FS/FSAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import String. 3 | Require Import Equalities. 4 | Require Import MSets.MSetWeakList. 5 | Require Import Relations.Relation_Operators. 6 | Require Import RelationClasses. 7 | Require Import Morphisms. 8 | Require Import Sumbool. 9 | Require Import FSModel. 10 | Require Import LinkAPI. 11 | 12 | Import ListNotations. 13 | Open Scope string. 14 | 15 | 16 | Notation "x Ret None | Some x => p2 end) 17 | (at level 60, right associativity). 18 | 19 | 20 | Fixpoint namei_spec (startnode : Node) (pn : Pathname) : proc _ (option Node) := 21 | match pn with 22 | | nil => 23 | Ret (Some startnode) 24 | | name :: pn' => 25 | match startnode with 26 | | DirNode startdir => 27 | r <- Call (LinkLookup startdir name); 28 | match r with 29 | | None => Ret None 30 | | Some n => 31 | namei_spec n pn' 32 | end 33 | | _ => Ret None 34 | end 35 | end. 36 | 37 | Definition namei_cwd (cwd : nat) (pn : Pathname) : proc _ (option Node) := 38 | namei_spec (DirNode cwd) pn. 39 | 40 | Definition namei_cwd_dir (cwd : nat) (pn : Pathname) : proc _ (option nat) := 41 | r Ret (Some dirnum) 44 | | _ => Ret None 45 | end. 46 | 47 | Definition namei_cwd_file (cwd : nat) (pn : Pathname) : proc _ (option nat) := 48 | r Ret (Some h) 51 | | _ => Ret None 52 | end. 53 | 54 | Definition create (cwd : nat) (dir : Pathname) (name : string) := 55 | dirnum Ret (Some StatFile) 73 | | DirNode _ => Ret (Some StatDir) 74 | end. 75 | 76 | Definition readdir (cwd : nat) (pn : Pathname) := 77 | dirnum 88 | match dstnodeopt with 89 | | None => 90 | _ <- Call (LinkAdd dstdirnum dstname srcnode); 91 | _ <- Call (LinkDel srcdirnum srcname srcnode); 92 | Ret (Some tt) 93 | | Some (FileNode dstfile) => 94 | _ <- Call (LinkAdd dstdirnum dstname srcnode); 95 | _ <- Call (LinkDel dstdirnum dstname (FileNode dstfile)); 96 | _ <- Call (LinkDel srcdirnum srcname srcnode); 97 | Ret (Some tt) 98 | | _ => 99 | Ret None 100 | end 101 | | _ => Ret None 102 | end. 103 | 104 | Definition find_available_name (cwd : nat) (pn : Pathname) (pfx : string) := 105 | dirnum Type := 11 | | CreateWriteTmp : forall (data : string), xOp bool 12 | | LinkMail : xOp bool 13 | | UnlinkTmp : xOp unit 14 | 15 | | List : xOp (list (nat * nat)) 16 | | Read : forall (fn : nat * nat), xOp (option string) 17 | | Delete : forall (fn : nat * nat), xOp unit 18 | | Lock : xOp unit 19 | | Unlock : xOp unit 20 | 21 | | Ext : forall `(op : extopT T), xOp T 22 | . 23 | 24 | Definition Op := xOp. 25 | 26 | End TryDeliverOp. 27 | Module TryDeliverHOp := HOps TryDeliverOp UserIdx. 28 | 29 | 30 | Module TryDeliverAPI <: Layer TryDeliverOp MailboxTmpAbsState. 31 | 32 | Import TryDeliverOp. 33 | Import MailboxTmpAbsState. 34 | 35 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 36 | | StepCreateWriteTmpOK : forall tmp mbox tid data lock, 37 | xstep (CreateWriteTmp data) tid 38 | (mk_state tmp mbox lock) 39 | true 40 | (mk_state (FMap.add (tid, 0) data tmp) mbox lock) 41 | nil 42 | | StepCreateWriteTmpErr1 : forall tmp mbox tid data lock, 43 | xstep (CreateWriteTmp data) tid 44 | (mk_state tmp mbox lock) 45 | false 46 | (mk_state tmp mbox lock) 47 | nil 48 | | StepCreateWriteTmpErr2 : forall tmp mbox tid data data' lock, 49 | xstep (CreateWriteTmp data) tid 50 | (mk_state tmp mbox lock) 51 | false 52 | (mk_state (FMap.add (tid, 0) data' tmp) mbox lock) 53 | nil 54 | | StepUnlinkTmp : forall tmp mbox tid lock, 55 | xstep (UnlinkTmp) tid 56 | (mk_state tmp mbox lock) 57 | tt 58 | (mk_state (FMap.remove (tid, 0) tmp) mbox lock) 59 | nil 60 | | StepLinkMailOK : forall tmp mbox tid mailfn data lock, 61 | FMap.MapsTo (tid, 0) data tmp -> 62 | ~ FMap.In (tid, mailfn) mbox -> 63 | xstep (LinkMail) tid 64 | (mk_state tmp mbox lock) 65 | true 66 | (mk_state tmp (FMap.add (tid, mailfn) data mbox) lock) 67 | nil 68 | | StepLinkMailRetry : forall tmp mbox tid lock, 69 | xstep (LinkMail) tid 70 | (mk_state tmp mbox lock) 71 | false 72 | (mk_state tmp mbox lock) 73 | nil 74 | 75 | | StepList : forall tmp mbox tid r lock, 76 | FMap.is_permutation_key r mbox -> 77 | xstep List tid 78 | (mk_state tmp mbox lock) 79 | r 80 | (mk_state tmp mbox lock) 81 | nil 82 | 83 | | StepReadOK : forall fn tmp mbox tid m lock, 84 | FMap.MapsTo fn m mbox -> 85 | xstep (Read fn) tid 86 | (mk_state tmp mbox lock) 87 | (Some m) 88 | (mk_state tmp mbox lock) 89 | nil 90 | | StepReadNone : forall fn tmp mbox tid lock, 91 | ~ FMap.In fn mbox -> 92 | xstep (Read fn) tid 93 | (mk_state tmp mbox lock) 94 | None 95 | (mk_state tmp mbox lock) 96 | nil 97 | 98 | | StepDelete : forall fn tmp mbox tid lock, 99 | xstep (Delete fn) tid 100 | (mk_state tmp mbox lock) 101 | tt 102 | (mk_state tmp (FMap.remove fn mbox) lock) 103 | nil 104 | 105 | | StepLock : forall tmp mbox tid, 106 | xstep Lock tid 107 | (mk_state tmp mbox false) 108 | tt 109 | (mk_state tmp mbox true) 110 | nil 111 | | StepUnlock : forall tmp mbox tid lock, 112 | xstep Unlock tid 113 | (mk_state tmp mbox lock) 114 | tt 115 | (mk_state tmp mbox false) 116 | nil 117 | 118 | | StepExt : forall s tid `(extop : extopT T) r, 119 | xstep (Ext extop) tid 120 | s 121 | r 122 | s 123 | (Event (extop, r) :: nil) 124 | . 125 | 126 | Definition step := xstep. 127 | 128 | Definition initP := initP. 129 | 130 | End TryDeliverAPI. 131 | Module TryDeliverHAPI := HLayer TryDeliverOp MailboxTmpAbsState TryDeliverAPI UserIdx. 132 | -------------------------------------------------------------------------------- /src/Mail/MailServerAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | 3 | 4 | Parameter smtpconn : Type. 5 | Parameter pop3conn : Type. 6 | Parameter abstract_string : Type. 7 | Definition string: Type := abstract_string. 8 | Parameter tmp_string : string. 9 | Parameter mail_string : string. 10 | Parameter nouser_string : string. 11 | Parameter bench_msg : string. 12 | Parameter empty_string : string. 13 | Parameter tmp_mail_ne : tmp_string <> mail_string. 14 | Parameter abstract_string_length : string -> nat. 15 | Definition string_length s := abstract_string_length s. 16 | 17 | Instance string_Ordering : Ordering string. 18 | Admitted. 19 | 20 | 21 | Module UserIdx <: HIndex. 22 | Definition indexT := string. 23 | Parameter validUsers : list indexT. 24 | Definition indexValid (s:string) := In s validUsers. 25 | Definition indexCmp := string_Ordering. 26 | End UserIdx. 27 | 28 | Axiom nouser_valid : UserIdx.indexValid nouser_string. 29 | Definition nouser := exist _ nouser_string nouser_valid. 30 | 31 | Module MailServerOp <: Ops. 32 | 33 | Inductive pop3req := 34 | | POP3Stat 35 | | POP3List 36 | | POP3Retr : nat -> pop3req 37 | | POP3Delete : nat -> pop3req 38 | | POP3Closed 39 | . 40 | 41 | Inductive extopT : Type -> Type := 42 | | AcceptSMTP : extopT smtpconn 43 | | SMTPGetMessage : smtpconn -> extopT (option (string * string)) 44 | | SMTPRespond : smtpconn -> bool -> extopT unit 45 | 46 | | AcceptPOP3 : extopT pop3conn 47 | | POP3Authenticate : pop3conn -> extopT (option string) 48 | | POP3RespondAuth : pop3conn -> bool -> extopT unit 49 | | POP3GetRequest : pop3conn -> extopT pop3req 50 | | POP3RespondStat : pop3conn -> nat -> nat -> extopT unit 51 | | POP3RespondList : pop3conn -> list nat -> extopT unit 52 | | POP3RespondRetr : pop3conn -> string -> extopT unit 53 | | POP3RespondDelete : pop3conn -> extopT unit 54 | 55 | (* For benchmarking *) 56 | | PickUser : extopT string 57 | . 58 | 59 | Inductive xOp : Type -> Type := 60 | | Deliver : forall (m : string), xOp bool 61 | | Pickup : xOp (list ((nat*nat) * string)) 62 | | Delete : forall (id : nat*nat), xOp unit 63 | | Ext : forall `(op : extopT T), xOp T 64 | . 65 | 66 | Definition Op := xOp. 67 | 68 | End MailServerOp. 69 | Module MailServerHOp := HOps MailServerOp UserIdx. 70 | 71 | 72 | Module MailServerState <: State. 73 | 74 | Definition dir_contents := FMap.t (nat*nat) string. 75 | 76 | Definition State := dir_contents. 77 | Definition initP (s : State) := True. 78 | 79 | End MailServerState. 80 | Module MailServerHState := HState MailServerState UserIdx. 81 | 82 | 83 | (* TCB: this is the top-level specification for the mail server. It specifies 84 | what each operation does, and the proof covers any sequence of these 85 | operations. *) 86 | Module MailServerAPI <: Layer MailServerOp MailServerState. 87 | 88 | Import MailServerOp. 89 | Import MailServerState. 90 | 91 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 92 | | StepDeliverOK : forall m mbox fn tid, 93 | ~ FMap.In fn mbox -> 94 | xstep (Deliver m) tid 95 | mbox 96 | true 97 | (FMap.add fn m mbox) 98 | nil 99 | | StepDeliverErr : forall m mbox tid, 100 | xstep (Deliver m) tid 101 | mbox 102 | false 103 | mbox 104 | nil 105 | | StepPickup : forall mbox tid r, 106 | FMap.is_permutation_kv r mbox -> 107 | xstep Pickup tid 108 | mbox 109 | r 110 | mbox 111 | nil 112 | | StepDelete : forall mbox tid id, 113 | xstep (Delete id) tid 114 | mbox 115 | tt 116 | (FMap.remove id mbox) 117 | nil 118 | 119 | | StepExt : forall s tid `(extop : extopT T) r, 120 | xstep (Ext extop) tid 121 | s 122 | r 123 | s 124 | (Event (extop, r) :: nil) 125 | . 126 | 127 | Definition step := xstep. 128 | 129 | Definition initP := initP. 130 | 131 | End MailServerAPI. 132 | Module MailServerHAPI := HLayer MailServerOp MailServerState MailServerAPI UserIdx. 133 | -------------------------------------------------------------------------------- /src/Spec/ExecSemantics.v: -------------------------------------------------------------------------------- 1 | Require Import Trace. 2 | Require Import ConcurProc. 3 | Require Import Spec.ThreadsState. 4 | 5 | Global Set Implicit Arguments. 6 | Global Generalizable All Variables. 7 | 8 | (* TCB: this file defines [exec], which specifies how operations interleave 9 | atomically. This is used both for modeling low-level execution and for 10 | specifying the behavior of a specification layer. *) 11 | 12 | Section Execution. 13 | 14 | Variable Op: Type -> Type. 15 | Variable State : Type. 16 | 17 | Definition OpSemantics := forall T, Op T -> nat -> State -> T -> State -> list event -> Prop. 18 | Variable op_step : OpSemantics. 19 | 20 | Definition until1 T (c : T -> bool) 21 | (p : option T -> proc Op T) 22 | (v : option T) := 23 | Bind (p v) (fun x => if c x then Ret x else Until c p (Some x)). 24 | 25 | Inductive atomic_exec : forall T, proc Op T -> nat -> State -> 26 | T -> State -> list event -> Prop := 27 | 28 | | AtomicRet : forall T tid (v : T) s, 29 | atomic_exec (Ret v) tid s v s nil 30 | 31 | | AtomicBind : forall T1 T2 tid (p1 : proc Op T1) (p2 : T1 -> proc Op T2) 32 | s0 s1 s2 ev1 ev2 (v1 : T1) (v2 : T2), 33 | atomic_exec p1 tid s0 v1 s1 ev1 -> 34 | atomic_exec (p2 v1) tid s1 v2 s2 ev2 -> 35 | atomic_exec (Bind p1 p2) tid s0 v2 s2 (ev1 ++ ev2) 36 | 37 | | AtomicOp : forall T tid (v : T) s s' op evs, 38 | op_step op tid s v s' evs -> 39 | atomic_exec (Call op) tid s v s' evs 40 | 41 | | AtomicUntil : forall T (p : option T -> proc Op T) (c : T -> bool) v tid s r s' ev', 42 | atomic_exec (until1 c p v) tid s r s' ev' -> 43 | atomic_exec (Until c p v) tid s r s' ev' 44 | . 45 | 46 | Inductive exec_tid : forall T (tid : nat), 47 | State -> proc Op T -> 48 | State -> T + proc Op T -> maybe_proc Op -> list event -> Prop := 49 | 50 | | ExecTidRet : forall tid T (v : T) s, 51 | exec_tid tid s (Ret v) 52 | s (inl v) 53 | NoProc nil 54 | 55 | | ExecTidOp : forall tid T (v : T) s s' op evs, 56 | op_step op tid s v s' evs -> 57 | exec_tid tid s (Call op) 58 | s' (inl v) 59 | NoProc evs 60 | 61 | | ExecTidAtomic : forall tid T (v : T) ap s s' evs, 62 | atomic_exec ap tid s v s' evs -> 63 | exec_tid tid s (Atomic ap) 64 | s' (inl v) 65 | NoProc evs 66 | 67 | | ExecTidBind : forall tid T1 (p1 : proc Op T1) T2 (p2 : T1 -> proc Op T2) s s' result spawned evs, 68 | exec_tid tid s p1 69 | s' result spawned evs -> 70 | exec_tid tid s (Bind p1 p2) 71 | s' (inr 72 | match result with 73 | | inl r => p2 r 74 | | inr p1' => Bind p1' p2 75 | end 76 | ) spawned evs 77 | 78 | | ExecTidUntil : forall tid T (p : option T -> proc Op T) (c : T -> bool) v s, 79 | exec_tid tid s (Until c p v) 80 | s (inr (until1 c p v)) 81 | NoProc nil 82 | 83 | | ExecTidSpawn : forall tid T (p: proc Op T) s, 84 | exec_tid tid s (Spawn p) 85 | s (inl tt) 86 | (Proc p) nil 87 | . 88 | 89 | 90 | Inductive exec : State -> threads_state Op -> trace -> Prop := 91 | 92 | | ExecOne : forall T tid tid' (ts : threads_state Op) trace p s s' evs result spawned, 93 | ts tid = @Proc Op T p -> 94 | ts tid' = NoProc -> 95 | exec_tid tid s p s' result spawned evs -> 96 | exec s' (thread_upd (thread_upd ts tid' spawned) tid 97 | match result with 98 | | inl _ => NoProc 99 | | inr p' => Proc p' 100 | end) trace -> 101 | exec s ts (prepend tid evs trace) 102 | 103 | | ExecStop : forall (ts : threads_state Op) s, 104 | exec s ts TraceEmpty. 105 | 106 | End Execution. 107 | 108 | Notation "ts [[ tid ]]" := (thread_get ts tid) 109 | (at level 12, left associativity). 110 | 111 | Notation "ts [[ tid := p ]]" := (thread_upd ts tid p) 112 | (at level 12, left associativity). 113 | -------------------------------------------------------------------------------- /src/Mail/MailboxAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailServerLockAbsAPI. 4 | 5 | Module MailboxOp <: Ops. 6 | 7 | Definition extopT := MailServerAPI.MailServerOp.extopT. 8 | 9 | Inductive xOp : Type -> Type := 10 | | Deliver : forall (m : string), xOp bool 11 | | List : xOp (list (nat*nat)) 12 | | Read : forall (fn : nat*nat), xOp (option string) 13 | | Delete : forall (fn : nat*nat), xOp unit 14 | | Lock : xOp unit 15 | | Unlock : xOp unit 16 | | Ext : forall `(op : extopT T), xOp T 17 | . 18 | 19 | Definition Op := xOp. 20 | 21 | End MailboxOp. 22 | Module MailboxHOp := HOps MailboxOp UserIdx. 23 | 24 | 25 | Module MailboxAPI <: Layer MailboxOp MailServerLockAbsState. 26 | 27 | Import MailboxOp. 28 | Import MailServerLockAbsState. 29 | 30 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 31 | | StepDeliverOK : forall m mbox tid fn lock, 32 | ~ FMap.In fn mbox -> 33 | xstep (Deliver m) tid 34 | (mk_state mbox lock) 35 | true 36 | (mk_state (FMap.add fn m mbox) lock) 37 | nil 38 | | StepDeliverErr : forall m mbox tid lock, 39 | xstep (Deliver m) tid 40 | (mk_state mbox lock) 41 | false 42 | (mk_state mbox lock) 43 | nil 44 | | StepList : forall mbox tid r lock, 45 | FMap.is_permutation_key r mbox -> 46 | xstep List tid 47 | (mk_state mbox lock) 48 | r 49 | (mk_state mbox lock) 50 | nil 51 | 52 | | StepReadOK : forall fn mbox tid m lock, 53 | FMap.MapsTo fn m mbox -> 54 | xstep (Read fn) tid 55 | (mk_state mbox lock) 56 | (Some m) 57 | (mk_state mbox lock) 58 | nil 59 | | StepReadNone : forall fn mbox tid lock, 60 | ~ FMap.In fn mbox -> 61 | xstep (Read fn) tid 62 | (mk_state mbox lock) 63 | None 64 | (mk_state mbox lock) 65 | nil 66 | 67 | | StepDelete : forall fn mbox tid lock, 68 | xstep (Delete fn) tid 69 | (mk_state mbox lock) 70 | tt 71 | (mk_state (FMap.remove fn mbox) lock) 72 | nil 73 | 74 | | StepLock : forall mbox tid, 75 | xstep Lock tid 76 | (mk_state mbox None) 77 | tt 78 | (mk_state mbox (Some tid)) 79 | nil 80 | | StepUnlock : forall mbox tid lock, 81 | xstep Unlock tid 82 | (mk_state mbox lock) 83 | tt 84 | (mk_state mbox None) 85 | nil 86 | 87 | | StepExt : forall s tid `(extop : extopT T) r, 88 | xstep (Ext extop) tid 89 | s 90 | r 91 | s 92 | (Event (extop, r) :: nil) 93 | . 94 | 95 | Definition step := xstep. 96 | 97 | Definition initP := initP. 98 | 99 | End MailboxAPI. 100 | Module MailboxHAPI := HLayer MailboxOp MailServerLockAbsState MailboxAPI UserIdx. 101 | 102 | 103 | Module MailboxProtocol <: Protocol MailboxOp MailServerLockAbsState. 104 | 105 | Import MailboxOp. 106 | Import MailServerLockAbsState. 107 | 108 | Inductive xstep_allow : forall T, Op T -> nat -> State -> Prop := 109 | | AllowDeliver : forall m tid s, 110 | xstep_allow (Deliver m) tid s 111 | | AllowList : forall tid s, 112 | xstep_allow List tid s 113 | | AllowRead : forall fn tid s, 114 | locked s = Some tid -> 115 | xstep_allow (Read fn) tid s 116 | | AllowDelete : forall fn tid s, 117 | locked s = Some tid -> 118 | xstep_allow (Delete fn) tid s 119 | | AllowLock : forall tid s, 120 | xstep_allow Lock tid s 121 | | AllowUnlock : forall tid s, 122 | locked s = Some tid -> 123 | xstep_allow Unlock tid s 124 | | AllowExt : forall tid s `(extop : _ T), 125 | xstep_allow (Ext extop) tid s 126 | . 127 | 128 | Definition step_allow := xstep_allow. 129 | 130 | End MailboxProtocol. 131 | Module MailboxHProtocol := HProtocol MailboxOp MailServerLockAbsState MailboxProtocol UserIdx. 132 | 133 | 134 | Module MailboxRestrictedAPI <: Layer MailboxOp MailServerLockAbsState. 135 | 136 | Definition step := 137 | restricted_step MailboxAPI.step MailboxProtocol.step_allow. 138 | 139 | Definition initP := MailboxAPI.initP. 140 | 141 | End MailboxRestrictedAPI. 142 | Module MailboxRestrictedHAPI := HLayer MailboxOp MailServerLockAbsState MailboxRestrictedAPI UserIdx. 143 | -------------------------------------------------------------------------------- /src/Mail/MailFSPathAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailFSPathAbsAPI. 4 | 5 | Module MailFSPathOp <: Ops. 6 | 7 | Definition extopT := MailServerAPI.MailServerOp.extopT. 8 | 9 | Inductive xOp : Type -> Type := 10 | | Create : forall (tmpfn : string * string), xOp bool 11 | | Write : forall (tmpfn : string * string) (data : string), xOp bool 12 | | Link : forall (tmpfn : string * string) (mboxfn : string * string), xOp bool 13 | | Unlink : forall (fn : string * string), xOp unit 14 | 15 | | GetTID : xOp nat 16 | | Random : xOp nat 17 | 18 | | List : forall (dir : string), xOp (list string) 19 | | Read : forall (fn : string * string), xOp (option string) 20 | 21 | | Lock : xOp unit 22 | | Unlock : xOp unit 23 | 24 | | Ext : forall `(op : extopT T), xOp T 25 | . 26 | 27 | Definition Op := xOp. 28 | 29 | End MailFSPathOp. 30 | Module MailFSPathHOp := HOps MailFSPathOp UserIdx. 31 | 32 | 33 | Module MailFSPathAPI <: Layer MailFSPathOp MailFSPathAbsState. 34 | 35 | Import MailFSPathOp. 36 | Import MailFSPathAbsState. 37 | Import MailFSPathAbsAPI. 38 | 39 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 40 | | StepCreateOK : forall fs tid tmpfn lock, 41 | xstep (Create tmpfn) tid 42 | (mk_state fs lock) 43 | true 44 | (mk_state (FMap.add tmpfn empty_string fs) lock) 45 | nil 46 | | StepCreateErr : forall fs tid tmpfn lock, 47 | xstep (Create tmpfn) tid 48 | (mk_state fs lock) 49 | false 50 | (mk_state fs lock) 51 | nil 52 | | StepWriteOK : forall fs tid tmpfn data lock, 53 | FMap.MapsTo tmpfn empty_string fs -> 54 | xstep (Write tmpfn data) tid 55 | (mk_state fs lock) 56 | true 57 | (mk_state (FMap.add tmpfn data fs) lock) 58 | nil 59 | | StepWriteErr1 : forall fs tid tmpfn data lock, 60 | xstep (Write tmpfn data) tid 61 | (mk_state fs lock) 62 | false 63 | (mk_state fs lock) 64 | nil 65 | | StepWriteErr2 : forall fs tid tmpfn data data' lock, 66 | FMap.MapsTo tmpfn empty_string fs -> 67 | xstep (Write tmpfn data) tid 68 | (mk_state fs lock) 69 | false 70 | (mk_state (FMap.add tmpfn data' fs) lock) 71 | nil 72 | | StepUnlink : forall fs tid fn lock, 73 | xstep (Unlink fn) tid 74 | (mk_state fs lock) 75 | tt 76 | (mk_state (FMap.remove fn fs) lock) 77 | nil 78 | | StepLinkOK : forall fs tid mailfn data tmpfn lock, 79 | FMap.MapsTo tmpfn data fs -> 80 | ~ FMap.In mailfn fs -> 81 | xstep (Link tmpfn mailfn) tid 82 | (mk_state fs lock) 83 | true 84 | (mk_state (FMap.add mailfn data fs) lock) 85 | nil 86 | | StepLinkErr : forall fs tid mailfn tmpfn lock, 87 | xstep (Link tmpfn mailfn) tid 88 | (mk_state fs lock) 89 | false 90 | (mk_state fs lock) 91 | nil 92 | 93 | | StepList : forall fs tid r dirname lock, 94 | FMap.is_permutation_key r (drop_dirname (filter_dir dirname fs)) -> 95 | xstep (List dirname) tid 96 | (mk_state fs lock) 97 | r 98 | (mk_state fs lock) 99 | nil 100 | 101 | | StepGetTID : forall s tid, 102 | xstep GetTID tid 103 | s 104 | tid 105 | s 106 | nil 107 | | StepRandom : forall s tid r, 108 | xstep Random tid 109 | s 110 | r 111 | s 112 | nil 113 | 114 | | StepReadOK : forall fn fs tid m lock, 115 | FMap.MapsTo fn m fs -> 116 | xstep (Read fn) tid 117 | (mk_state fs lock) 118 | (Some m) 119 | (mk_state fs lock) 120 | nil 121 | | StepReadNone : forall fn fs tid lock, 122 | ~ FMap.In fn fs -> 123 | xstep (Read fn) tid 124 | (mk_state fs lock) 125 | None 126 | (mk_state fs lock) 127 | nil 128 | 129 | | StepLock : forall fs tid, 130 | xstep Lock tid 131 | (mk_state fs false) 132 | tt 133 | (mk_state fs true) 134 | nil 135 | | StepUnlock : forall fs tid lock, 136 | xstep Unlock tid 137 | (mk_state fs lock) 138 | tt 139 | (mk_state fs false) 140 | nil 141 | 142 | | StepExt : forall s tid `(extop : extopT T) r, 143 | xstep (Ext extop) tid 144 | s 145 | r 146 | s 147 | (Event (extop, r) :: nil) 148 | . 149 | 150 | Definition step := xstep. 151 | 152 | Definition initP := initP. 153 | 154 | End MailFSPathAPI. 155 | Module MailFSPathHAPI := HLayer MailFSPathOp MailFSPathAbsState MailFSPathAPI UserIdx. 156 | -------------------------------------------------------------------------------- /README.concur: -------------------------------------------------------------------------------- 1 | Documentation of various plans we have tried: 2 | 3 | BEFORE CFSCQ 4 | 5 | 0. Concurrent separation logic. Discovered it doesn't allow for temporal 6 | reasoning (queue holds the things you put in there). 7 | 8 | 1. Separation logic with rely-guarantee (lrg). Hard to automate 9 | reasoning about separation logic across rely-guarantee relations 10 | (actions). Concretely, couldn't use [cancel] across rely actions. 11 | 12 | CFSCQ 13 | 14 | 2. In cfscq, build lock and unlock into semantics. Don't remember what 15 | went wrong. 16 | 17 | 3. No fine-grained concurrency in current cfscq. Seems like a good fit 18 | for its scope. 19 | 20 | POCS 21 | 22 | 4. Stable predicates. Discovered that specifying only a part of the state 23 | means the rest of the state can be corrupted arbitrarily. Need to talk about 24 | which threads modify which parts of the state. Need thread IDs in background 25 | steps. 26 | 27 | 5. Rely-guarantee. Specs talked about rely-guarantee relations in the base 28 | execution semantics. Discovered that it's not sound to reason about low-level 29 | "assembly" steps using high-level abstractions, because assembly steps might 30 | not produce a clean abstract state. 31 | 32 | 6. Commutative operations. Re-order operations to achieve atomicity. 33 | Add thread IDs because they seem necessary (see plan 4 above). 34 | Add "Atomic" to the [prog] type to indicate an atomic sequence of code. 35 | Still some kind of protocol in the low-level exec semantics, but might 36 | be OK (i.e., can get a clean abstract state) due to re-ordering. 37 | 38 | 7. Multiple languages. Every basic operation in a language is atomic. 39 | Ran into an issue: when moving up to a higher-level language, concurrent 40 | threads should not appear to modify the state in an incomplete fashion. 41 | Thus, even if the higher-level language has the same abstract state (e.g., 42 | per-thread counters), it is INCORRECT to have an identity abstraction 43 | relation. Instead, it seems like the lower-level state needs to have 44 | ghost a snapshot of each thread's counter, which is set when the thread 45 | starts running, and atomically committed when the thread finishes its 46 | operation. The abstraction relation then exposes the SNAPSHOT state 47 | instead of the real implementation state, if a snapshot exists. 48 | 49 | === 50 | 51 | Observations: 52 | 53 | Commuting or re-ordering of operations seems important for rely/guarantee 54 | or protocol-style reasoning about concurrent threads WITH abstraction. 55 | In particular, if operations are never re-ordered, then there may never 56 | be a state of the system that cleanly matches a high-level abstraction. 57 | 58 | === 59 | 60 | Our framework does not support non-atomic operations. Every API method 61 | is an opcode, and opcodes execute in a single atomic step. This may be 62 | a problem for non-linearizable interfaces (like namei). 63 | 64 | === 65 | 66 | TODO for trace-based concurrency: 67 | 68 | - Left mover problem: how can we move it if it never executes? 69 | 70 | Suppose we have two locks (A and B), two variables (X and Y) 71 | protected by the two locks respectively, and two threads (1 and 2). 72 | 73 | Non-atomic trace: 74 | 75 | 1:Acquire(A) 1:Acquire(B) 1:Write(X,2) 1:Write(Y,2) 1:Release(B) 2:Acquire(B) 2:Read(Y)->2 2:Release(B) 2:spin 2:spin 2:spin ... 76 | 77 | Goal atomic trace: 78 | 79 | 2:... 1:<> 2:... 80 | 81 | We cannot move 2's actions left of 1's, because the Acquire(B)+Read(Y)+Release(B) 82 | would get a different Read outcome. 83 | 84 | But we also cannot move 1's Release(A) left, because 1:Release(A) never appears 85 | in the original trace -- thread 2 just keeps doing something else forever! 86 | 87 | More generally, some left-mover operation like Release(A) might not be enabled yet, 88 | so we can't force it to execute; the semantics might not allow it. Appearing in 89 | the original trace is our proof that it is enabled (and then we can move it left), 90 | but what if it doesn't appear? 91 | 92 | POSSIBLE SOLUTION: prove equivalence to atomic brackets containing 93 | some prefix of the left-movers? 94 | 95 | in the case of Release left-movers, this might provide sufficient atomicity for 96 | the refinement proof, which is the main goal of atomicity brackets for us. 97 | 98 | More symbol-pushing-like things: 99 | 100 | - Coinductive definitions. 101 | 102 | - Nesting refinements. We should transform [proc opLoT opMidT T]'s into 103 | [proc opLoT opHiT T]'s so that we can keep nesting layers and preserving 104 | [opHiT] traces. This will also unify compile-based refinement and 105 | state-abstraction refinement. 106 | 107 | === 108 | 109 | File system concurrency spec relwk: 110 | 111 | https://pages.lip6.fr/Marc.Shapiro/papers/VMCAI-2018-filesys.pdf 112 | -------------------------------------------------------------------------------- /src/Mail/MailFSAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxTmpAbsAPI. 4 | Require Import DeliverAPI. 5 | 6 | Module MailFSOp <: Ops. 7 | 8 | Definition extopT := MailServerAPI.MailServerOp.extopT. 9 | 10 | Inductive xOp : Type -> Type := 11 | | CreateTmp : xOp bool 12 | | WriteTmp : forall (data : string), xOp bool 13 | | LinkMail : forall (mboxfn : nat), xOp bool 14 | | UnlinkTmp : xOp unit 15 | 16 | | GetTID : xOp nat 17 | | Random : xOp nat 18 | 19 | | List : xOp (list (nat * nat)) 20 | | Read : forall (fn : nat * nat), xOp (option string) 21 | | Delete : forall (fn : nat * nat), xOp unit 22 | | Lock : xOp unit 23 | | Unlock : xOp unit 24 | 25 | | Ext : forall `(op : extopT T), xOp T 26 | . 27 | 28 | Definition Op := xOp. 29 | 30 | End MailFSOp. 31 | Module MailFSHOp := HOps MailFSOp UserIdx. 32 | 33 | 34 | Module MailFSAPI <: Layer MailFSOp MailboxTmpAbsState. 35 | 36 | Import MailFSOp. 37 | Import MailboxTmpAbsState. 38 | 39 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 40 | | StepCreateTmpOk : forall tmp mbox tid lock, 41 | xstep (CreateTmp) tid 42 | (mk_state tmp mbox lock) 43 | true 44 | (mk_state (FMap.add (tid, 0) empty_string tmp) mbox lock) 45 | nil 46 | | StepCreateTmpErr : forall tmp mbox tid lock, 47 | xstep (CreateTmp) tid 48 | (mk_state tmp mbox lock) 49 | false 50 | (mk_state tmp mbox lock) 51 | nil 52 | | StepWriteTmpOk : forall tmp mbox tid data lock, 53 | FMap.MapsTo (tid, 0) empty_string tmp -> 54 | xstep (WriteTmp data) tid 55 | (mk_state tmp mbox lock) 56 | true 57 | (mk_state (FMap.add (tid, 0) data tmp) mbox lock) 58 | nil 59 | | StepWriteTmpErr1 : forall tmp mbox tid data lock, 60 | xstep (WriteTmp data) tid 61 | (mk_state tmp mbox lock) 62 | false 63 | (mk_state tmp mbox lock) 64 | nil 65 | | StepWriteTmpErr2 : forall tmp mbox tid data data' lock, 66 | FMap.MapsTo (tid, 0) empty_string tmp -> 67 | xstep (WriteTmp data) tid 68 | (mk_state tmp mbox lock) 69 | false 70 | (mk_state (FMap.add (tid, 0) data' tmp) mbox lock) 71 | nil 72 | | StepUnlinkTmp : forall tmp mbox tid lock, 73 | xstep (UnlinkTmp) tid 74 | (mk_state tmp mbox lock) 75 | tt 76 | (mk_state (FMap.remove (tid, 0) tmp) mbox lock) 77 | nil 78 | | StepLinkMailOK : forall tmp mbox tid mailfn data lock, 79 | FMap.MapsTo (tid, 0) data tmp -> 80 | ~ FMap.In (tid, mailfn) mbox -> 81 | xstep (LinkMail mailfn) tid 82 | (mk_state tmp mbox lock) 83 | true 84 | (mk_state tmp (FMap.add (tid, mailfn) data mbox) lock) 85 | nil 86 | | StepLinkMailErr : forall tmp mbox tid mailfn lock, 87 | xstep (LinkMail mailfn) tid 88 | (mk_state tmp mbox lock) 89 | false 90 | (mk_state tmp mbox lock) 91 | nil 92 | 93 | | StepList : forall tmp mbox tid r lock, 94 | FMap.is_permutation_key r mbox -> 95 | xstep List tid 96 | (mk_state tmp mbox lock) 97 | r 98 | (mk_state tmp mbox lock) 99 | nil 100 | 101 | | StepGetTID : forall tmp mbox tid lock, 102 | xstep GetTID tid 103 | (mk_state tmp mbox lock) 104 | tid 105 | (mk_state tmp mbox lock) 106 | nil 107 | | StepRandom : forall tmp mbox tid r lock, 108 | xstep Random tid 109 | (mk_state tmp mbox lock) 110 | r 111 | (mk_state tmp mbox lock) 112 | nil 113 | 114 | | StepReadOK : forall fn tmp mbox tid m lock, 115 | FMap.MapsTo fn m mbox -> 116 | xstep (Read fn) tid 117 | (mk_state tmp mbox lock) 118 | (Some m) 119 | (mk_state tmp mbox lock) 120 | nil 121 | 122 | | StepReadNone : forall fn tmp mbox tid lock, 123 | ~ FMap.In fn mbox -> 124 | xstep (Read fn) tid 125 | (mk_state tmp mbox lock) 126 | None 127 | (mk_state tmp mbox lock) 128 | nil 129 | 130 | | StepDelete : forall fn tmp mbox tid lock, 131 | xstep (Delete fn) tid 132 | (mk_state tmp mbox lock) 133 | tt 134 | (mk_state tmp (FMap.remove fn mbox) lock) 135 | nil 136 | 137 | | StepLock : forall tmp mbox tid, 138 | xstep Lock tid 139 | (mk_state tmp mbox false) 140 | tt 141 | (mk_state tmp mbox true) 142 | nil 143 | | StepUnlock : forall tmp mbox tid lock, 144 | xstep Unlock tid 145 | (mk_state tmp mbox lock) 146 | tt 147 | (mk_state tmp mbox false) 148 | nil 149 | 150 | | StepExt : forall s tid `(extop : extopT T) r, 151 | xstep (Ext extop) tid 152 | s 153 | r 154 | s 155 | (Event (extop, r) :: nil) 156 | . 157 | 158 | Definition step := xstep. 159 | 160 | Definition initP := initP. 161 | 162 | End MailFSAPI. 163 | Module MailFSHAPI := HLayer MailFSOp MailboxTmpAbsState MailFSAPI UserIdx. 164 | -------------------------------------------------------------------------------- /src/Helpers/ProofAutomation/SimplMatch.v: -------------------------------------------------------------------------------- 1 | (** ** Simplify matches when possible *) 2 | 3 | Ltac simpl_match := 4 | let repl_match_goal d d' := 5 | replace d with d'; 6 | lazymatch goal with 7 | | [ |- context[match d' with _ => _ end] ] => fail 8 | | _ => idtac 9 | end in 10 | let repl_match_hyp H d d' := 11 | replace d with d' in H; 12 | lazymatch type of H with 13 | | context[match d' with _ => _ end] => fail 14 | | _ => idtac 15 | end in 16 | match goal with 17 | | [ Heq: ?d = ?d' |- context[match ?d with _ => _ end] ] => 18 | repl_match_goal d d' 19 | | [ Heq: ?d' = ?d |- context[match ?d with _ => _ end] ] => 20 | repl_match_goal d d' 21 | | [ Heq: ?d = ?d', H: context[match ?d with _ => _ end] |- _ ] => 22 | repl_match_hyp H d d' 23 | | [ Heq: ?d' = ?d, H: context[match ?d with _ => _ end] |- _ ] => 24 | repl_match_hyp H d d' 25 | end. 26 | 27 | Module SimplMatchTests. 28 | 29 | (** test simpl_match failure when match does not go away *) 30 | Theorem fails_if_match_not_removed : 31 | forall (vd m: nat -> option nat) a, 32 | vd a = m a -> 33 | vd a = match (m a) with 34 | | Some v => Some v 35 | | None => None 36 | end. 37 | Proof. 38 | intros. 39 | (simpl_match; fail "should not work here") 40 | || idtac. 41 | rewrite H. 42 | destruct (m a); auto. 43 | Qed. 44 | 45 | Theorem removes_match : 46 | forall (vd m: nat -> option nat) a v v', 47 | vd a = Some v -> 48 | m a = Some v' -> 49 | vd a = match (m a) with 50 | | Some _ => Some v 51 | | None => None 52 | end. 53 | Proof. 54 | intros. 55 | simpl_match; now auto. 56 | Qed. 57 | 58 | (** hypothesis replacement should remove the match or fail *) 59 | Theorem fails_on_hyp_if_match_not_removed : 60 | forall (vd m: nat -> option nat) a, 61 | vd a = m a -> 62 | m a = match (m a) with 63 | | Some v => Some v 64 | | None => None 65 | end -> 66 | True. 67 | Proof. 68 | intros. 69 | (simpl_match; fail "should not work here") 70 | || idtac. 71 | trivial. 72 | Qed. 73 | 74 | End SimplMatchTests. 75 | 76 | (** ** Find and destruct matches *) 77 | 78 | Ltac destruct_matches_in e := 79 | lazymatch e with 80 | | context[match ?d with | _ => _ end] => 81 | destruct_matches_in d 82 | | _ => destruct e eqn:?; intros 83 | end. 84 | 85 | Ltac destruct_all_matches := 86 | repeat (try simpl_match; 87 | try match goal with 88 | | [ |- context[match ?d with | _ => _ end] ] => 89 | destruct_matches_in d 90 | | [ H: context[match ?d with | _ => _ end] |- _ ] => 91 | destruct_matches_in d 92 | end); 93 | subst; 94 | try congruence; 95 | auto. 96 | 97 | Ltac destruct_nongoal_matches := 98 | repeat (try simpl_match; 99 | try match goal with 100 | | [ H: context[match ?d with | _ => _ end] |- _ ] => 101 | destruct_matches_in d 102 | end); 103 | subst; 104 | try congruence; 105 | auto. 106 | 107 | Ltac destruct_goal_matches := 108 | repeat (try simpl_match; 109 | match goal with 110 | | [ |- context[match ?d with | _ => _ end] ] => 111 | destruct_matches_in d 112 | end); 113 | try congruence; 114 | auto. 115 | 116 | Module DestructMatchesTests. 117 | 118 | Theorem removes_absurdities : 119 | forall b1 b2, 120 | b1 = b2 -> 121 | match b1 with 122 | | true => match b2 with 123 | | true => True 124 | | false => False 125 | end 126 | | false => match b2 with 127 | | true => False 128 | | false => True 129 | end 130 | end. 131 | Proof. 132 | intros. 133 | destruct_all_matches. 134 | Qed. 135 | 136 | Theorem destructs_innermost_match : 137 | forall b1 b2, 138 | match (match b2 with 139 | | true => b1 140 | | false => false 141 | end) with 142 | | true => b1 = true 143 | | false => b1 = false \/ b2 = false 144 | end. 145 | Proof. 146 | intros. 147 | destruct_goal_matches. 148 | Qed. 149 | 150 | End DestructMatchesTests. 151 | 152 | Ltac destruct_tuple := 153 | match goal with 154 | | [ H: context[let '(a, b) := ?p in _] |- _ ] => 155 | let a := fresh a in 156 | let b := fresh b in 157 | destruct p as [a b] 158 | | [ |- context[let '(a, b) := ?p in _] ] => 159 | let a := fresh a in 160 | let b := fresh b in 161 | destruct p as [a b] 162 | end. 163 | 164 | Tactic Notation "destruct" "matches" "in" "*" := destruct_all_matches. 165 | Tactic Notation "destruct" "matches" "in" "*|-" := destruct_nongoal_matches. 166 | Tactic Notation "destruct" "matches" := destruct_goal_matches. 167 | -------------------------------------------------------------------------------- /mail-test/lib/POP3.hs: -------------------------------------------------------------------------------- 1 | module POP3 2 | ( POP3Server(..) 3 | , pop3Listen 4 | , pop3Accept 5 | , pop3ProcessAuth 6 | , pop3Authenticate 7 | , pop3RespondAuth 8 | , pop3ProcessCommands 9 | , pop3GetRequest 10 | , pop3RespondStat 11 | , pop3RespondList 12 | , pop3RespondRetr 13 | , pop3RespondDelete 14 | ) where 15 | 16 | -- Haskell libraries 17 | 18 | import Control.Monad 19 | import qualified Data.ByteString as BS 20 | import qualified Data.ByteString.Char8 as BSC8 21 | import Data.Char 22 | import Network 23 | import System.IO 24 | 25 | -- Extracted code 26 | 27 | import MailServerAPI 28 | 29 | -- Our libraries 30 | 31 | import Support 32 | 33 | -- POP3 implementation 34 | 35 | data POP3Server = 36 | POP3Server Socket 37 | 38 | pop3Listen :: Int -> IO POP3Server 39 | pop3Listen portnum = do 40 | sock <- listenOn (PortNumber $ fromIntegral portnum) 41 | return $ POP3Server sock 42 | 43 | pop3Accept :: POP3Server -> IO POP3Conn 44 | pop3Accept (POP3Server sock) = do 45 | (conn, _, _) <- accept sock 46 | hSetBuffering conn LineBuffering 47 | pop3RespondOK conn 48 | return $ POP3Conn conn 49 | 50 | hPutStrs :: Handle -> [BS.ByteString] -> IO () 51 | hPutStrs h = BS.hPutStr h . BS.concat 52 | 53 | intToStr :: Integer -> BS.ByteString 54 | intToStr = BSC8.pack . show 55 | 56 | pop3Respond :: Handle -> Bool -> BS.ByteString -> IO () 57 | pop3Respond h True text = 58 | hPutStrs h $ ["+OK ", text, "\r\n"] 59 | pop3Respond h False text = 60 | hPutStrs h $ ["-ERR ", text, "\r\n"] 61 | 62 | pop3RespondOK :: Handle -> IO () 63 | pop3RespondOK h = 64 | pop3Respond h True "" 65 | 66 | pop3ProcessAuth :: Handle -> IO (Maybe String) 67 | pop3ProcessAuth h = do 68 | line <- hGetLine h 69 | let cmdparts = words line 70 | case cmdparts of 71 | cmd : rest -> 72 | case (map toUpper cmd) : rest of 73 | ["USER", u] -> do 74 | return $ Just u 75 | "CAPA" : _ -> do 76 | pop3RespondOK h 77 | hPutStr h ".\r\n" 78 | pop3ProcessAuth h 79 | "QUIT" : _ -> do 80 | pop3RespondOK h 81 | hClose h 82 | return Nothing 83 | _ -> do 84 | pop3Respond h False "unrecognized command" 85 | pop3ProcessAuth h 86 | _ -> do 87 | pop3Respond h False "unrecognized command" 88 | pop3ProcessAuth h 89 | 90 | pop3Authenticate :: POP3Conn -> IO (Maybe String) 91 | pop3Authenticate (POP3Conn h) = do 92 | pop3ProcessAuth h 93 | 94 | pop3RespondAuth :: POP3Conn -> Bool -> IO () 95 | pop3RespondAuth (POP3Conn h) True = do 96 | pop3RespondOK h 97 | pop3RespondAuth (POP3Conn h) False = do 98 | pop3Respond h False "unknown user" 99 | hClose h 100 | 101 | pop3ProcessCommands :: Handle -> IO MailServerOp__Coq_pop3req 102 | pop3ProcessCommands h = do 103 | line <- hGetLine h 104 | let cmdparts = words line 105 | case cmdparts of 106 | cmd : rest -> 107 | case (map toUpper cmd) : rest of 108 | "APOP" : _ -> do 109 | pop3RespondOK h 110 | pop3ProcessCommands h 111 | "USER" : _ -> do 112 | pop3RespondOK h 113 | pop3ProcessCommands h 114 | "PASS" : _ -> do 115 | pop3RespondOK h 116 | pop3ProcessCommands h 117 | "CAPA" : _ -> do 118 | pop3RespondOK h 119 | hPutStr h ".\r\n" 120 | pop3ProcessCommands h 121 | "STAT" : _ -> do 122 | return $ MailServerOp__POP3Stat 123 | "LIST" : _ -> do 124 | return $ MailServerOp__POP3List 125 | ["RETR", id] -> do 126 | return $ MailServerOp__POP3Retr $ read id - 1 127 | ["DELE", id] -> do 128 | return $ MailServerOp__POP3Delete $ read id - 1 129 | "QUIT" : _ -> do 130 | pop3RespondOK h 131 | hClose h 132 | return MailServerOp__POP3Closed 133 | _ -> do 134 | pop3Respond h False "unrecognized command" 135 | pop3ProcessCommands h 136 | _ -> do 137 | pop3Respond h False "unrecognized command" 138 | pop3ProcessCommands h 139 | 140 | pop3GetRequest :: POP3Conn -> IO MailServerOp__Coq_pop3req 141 | pop3GetRequest (POP3Conn h) = do 142 | pop3ProcessCommands h 143 | 144 | pop3RespondStat :: POP3Conn -> Integer -> Integer -> IO () 145 | pop3RespondStat (POP3Conn h) count size = do 146 | pop3Respond h True $ BS.concat [intToStr count, " ", intToStr size] 147 | 148 | pop3RespondList :: POP3Conn -> [Integer] -> IO () 149 | pop3RespondList (POP3Conn h) msglens = do 150 | pop3RespondOK h 151 | foldM (\idx msglen -> do 152 | BS.hPutStr h $ BS.concat [intToStr idx, " ", intToStr msglen, "\r\n"] 153 | return $ idx + 1) 1 msglens 154 | BS.hPutStr h ".\r\n" 155 | 156 | pop3RespondRetr :: POP3Conn -> BS.ByteString -> IO () 157 | pop3RespondRetr (POP3Conn h) body = do 158 | pop3RespondOK h 159 | BS.hPutStr h body 160 | BS.hPutStr h ".\r\n" 161 | 162 | pop3RespondDelete :: POP3Conn -> IO () 163 | pop3RespondDelete (POP3Conn h) = do 164 | pop3RespondOK h 165 | -------------------------------------------------------------------------------- /src/Mail/MailFSStringAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailFSStringAbsAPI. 4 | Require Import MailFSAPI. 5 | 6 | Module MailFSStringOp <: Ops. 7 | 8 | Definition extopT := MailServerAPI.MailServerOp.extopT. 9 | 10 | Inductive xOp : Type -> Type := 11 | | CreateTmp : forall (tmpfn : string), xOp bool 12 | | WriteTmp : forall (tmpfn : string) (data : string), xOp bool 13 | | LinkMail : forall (tmpfn : string) (mboxfn : string), xOp bool 14 | | UnlinkTmp : forall (tmpfn : string), xOp unit 15 | 16 | | GetTID : xOp nat 17 | | Random : xOp nat 18 | 19 | | List : xOp (list string) 20 | | Read : forall (fn : string), xOp (option string) 21 | | Delete : forall (fn : string), xOp unit 22 | | Lock : xOp unit 23 | | Unlock : xOp unit 24 | 25 | | Ext : forall `(op : extopT T), xOp T 26 | . 27 | 28 | Definition Op := xOp. 29 | 30 | End MailFSStringOp. 31 | Module MailFSStringHOp := HOps MailFSStringOp UserIdx. 32 | 33 | 34 | Module MailFSStringAPI <: Layer MailFSStringOp MailFSStringAbsState. 35 | 36 | Import MailFSStringOp. 37 | Import MailFSStringAbsState. 38 | 39 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 40 | | StepCreateTmpOK : forall tmp mbox tid tmpfn lock, 41 | xstep (CreateTmp tmpfn) tid 42 | (mk_state tmp mbox lock) 43 | true 44 | (mk_state (FMap.add tmpfn empty_string tmp) mbox lock) 45 | nil 46 | | StepCreateTmpErr : forall tmp mbox tid tmpfn lock, 47 | xstep (CreateTmp tmpfn) tid 48 | (mk_state tmp mbox lock) 49 | false 50 | (mk_state tmp mbox lock) 51 | nil 52 | | StepWriteTmpOK : forall tmp mbox tid tmpfn data lock, 53 | FMap.MapsTo tmpfn empty_string tmp -> 54 | xstep (WriteTmp tmpfn data) tid 55 | (mk_state tmp mbox lock) 56 | true 57 | (mk_state (FMap.add tmpfn data tmp) mbox lock) 58 | nil 59 | | StepWriteTmpErr1 : forall tmp mbox tid tmpfn data lock, 60 | xstep (WriteTmp tmpfn data) tid 61 | (mk_state tmp mbox lock) 62 | false 63 | (mk_state tmp mbox lock) 64 | nil 65 | | StepWriteTmpErr2 : forall tmp mbox tid tmpfn data data' lock, 66 | FMap.MapsTo tmpfn empty_string tmp -> 67 | xstep (WriteTmp tmpfn data) tid 68 | (mk_state tmp mbox lock) 69 | false 70 | (mk_state (FMap.add tmpfn data' tmp) mbox lock) 71 | nil 72 | | StepUnlinkTmp : forall tmp mbox tid tmpfn lock, 73 | xstep (UnlinkTmp tmpfn) tid 74 | (mk_state tmp mbox lock) 75 | tt 76 | (mk_state (FMap.remove tmpfn tmp) mbox lock) 77 | nil 78 | | StepLinkMailOK : forall tmp mbox tid mailfn data tmpfn lock, 79 | FMap.MapsTo tmpfn data tmp -> 80 | ~ FMap.In mailfn mbox -> 81 | xstep (LinkMail tmpfn mailfn) tid 82 | (mk_state tmp mbox lock) 83 | true 84 | (mk_state tmp (FMap.add mailfn data mbox) lock) 85 | nil 86 | | StepLinkMailErr : forall tmp mbox tid mailfn tmpfn lock, 87 | xstep (LinkMail tmpfn mailfn) tid 88 | (mk_state tmp mbox lock) 89 | false 90 | (mk_state tmp mbox lock) 91 | nil 92 | 93 | | StepList : forall tmp mbox tid r lock, 94 | FMap.is_permutation_key r mbox -> 95 | xstep List tid 96 | (mk_state tmp mbox lock) 97 | r 98 | (mk_state tmp mbox lock) 99 | nil 100 | 101 | | StepGetTID : forall tmp mbox tid lock, 102 | xstep GetTID tid 103 | (mk_state tmp mbox lock) 104 | tid 105 | (mk_state tmp mbox lock) 106 | nil 107 | | StepRandom : forall tmp mbox tid r lock, 108 | xstep Random tid 109 | (mk_state tmp mbox lock) 110 | r 111 | (mk_state tmp mbox lock) 112 | nil 113 | 114 | | StepReadOK : forall fn tmp mbox tid m lock, 115 | FMap.MapsTo fn m mbox -> 116 | xstep (Read fn) tid 117 | (mk_state tmp mbox lock) 118 | (Some m) 119 | (mk_state tmp mbox lock) 120 | nil 121 | | StepReadNone : forall fn tmp mbox tid lock, 122 | ~ FMap.In fn mbox -> 123 | xstep (Read fn) tid 124 | (mk_state tmp mbox lock) 125 | None 126 | (mk_state tmp mbox lock) 127 | nil 128 | 129 | | StepDelete : forall fn tmp mbox tid lock, 130 | xstep (Delete fn) tid 131 | (mk_state tmp mbox lock) 132 | tt 133 | (mk_state tmp (FMap.remove fn mbox) lock) 134 | nil 135 | 136 | | StepLock : forall tmp mbox tid, 137 | xstep Lock tid 138 | (mk_state tmp mbox false) 139 | tt 140 | (mk_state tmp mbox true) 141 | nil 142 | | StepUnlock : forall tmp mbox tid lock, 143 | xstep Unlock tid 144 | (mk_state tmp mbox lock) 145 | tt 146 | (mk_state tmp mbox false) 147 | nil 148 | 149 | | StepExt : forall s tid `(extop : extopT T) r, 150 | xstep (Ext extop) tid 151 | s 152 | r 153 | s 154 | (Event (extop, r) :: nil) 155 | . 156 | 157 | Definition step := xstep. 158 | 159 | Definition initP := initP. 160 | 161 | End MailFSStringAPI. 162 | Module MailFSStringHAPI := HLayer MailFSStringOp MailFSStringAbsState MailFSStringAPI UserIdx. 163 | -------------------------------------------------------------------------------- /src/Mail/TryDeliverImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxAPI. 4 | Require Import TryDeliverAPI. 5 | Require Import MailFSAPI. 6 | Require Import MailboxTmpAbsAPI. 7 | 8 | 9 | Module TryDeliverImpl' <: 10 | LayerImplMoversT 11 | MailboxTmpAbsState 12 | MailFSOp MailFSAPI 13 | TryDeliverOp TryDeliverAPI. 14 | 15 | (* START CODE *) 16 | 17 | Definition linkmail_core := 18 | ts <- Call MailFSOp.Random; 19 | ok <- Call (MailFSOp.LinkMail ts); 20 | Ret ok. 21 | 22 | Definition createwrite_core data := 23 | ok1 <- Call (MailFSOp.CreateTmp); 24 | if (ok1 : bool) then Call (MailFSOp.WriteTmp data) else Ret ok1. 25 | 26 | Definition compile_op T (op : TryDeliverOp.Op T) : proc MailFSOp.Op T := 27 | match op with 28 | | TryDeliverOp.CreateWriteTmp data => createwrite_core data 29 | | TryDeliverOp.LinkMail => linkmail_core 30 | | TryDeliverOp.UnlinkTmp => Call (MailFSOp.UnlinkTmp) 31 | | TryDeliverOp.List => Call (MailFSOp.List) 32 | | TryDeliverOp.Read fn => Call (MailFSOp.Read fn) 33 | | TryDeliverOp.Delete fn => Call (MailFSOp.Delete fn) 34 | | TryDeliverOp.Lock => Call (MailFSOp.Lock) 35 | | TryDeliverOp.Unlock => Call (MailFSOp.Unlock) 36 | | TryDeliverOp.Ext extop => Call (MailFSOp.Ext extop) 37 | end. 38 | 39 | (* END CODE *) 40 | 41 | Theorem compile_op_no_atomics : 42 | forall `(op : _ T), 43 | no_atomics (compile_op op). 44 | Proof. 45 | destruct op; compute; eauto. 46 | 47 | constructor; eauto. 48 | destruct x; eauto. 49 | Qed. 50 | 51 | Ltac step_inv := 52 | match goal with 53 | | H : TryDeliverAPI.step _ _ _ _ _ _ |- _ => 54 | inversion H; clear H; subst; repeat sigT_eq 55 | | H : MailFSAPI.step _ _ _ _ _ _ |- _ => 56 | inversion H; clear H; subst; repeat sigT_eq 57 | end; intuition idtac. 58 | 59 | Hint Extern 1 (TryDeliverAPI.step _ _ _ _ _ _) => econstructor. 60 | Hint Extern 1 (MailFSAPI.step _ _ _ _ _ _) => econstructor. 61 | Hint Constructors MailFSAPI.xstep. 62 | 63 | Lemma random_right_mover : 64 | right_mover 65 | MailFSAPI.step 66 | (MailFSOp.Random). 67 | Proof. 68 | unfold right_mover; intros. 69 | repeat step_inv; eauto 10. 70 | 71 | eexists; split; econstructor; eauto. 72 | Qed. 73 | 74 | Hint Resolve random_right_mover. 75 | 76 | Theorem ysa_movers_linkmail_core : 77 | ysa_movers MailFSAPI.step linkmail_core. 78 | Proof. 79 | econstructor; eauto 20. 80 | Qed. 81 | 82 | Hint Resolve ysa_movers_linkmail_core. 83 | 84 | Lemma fmap_mapsto_tid_ne : 85 | forall (tid0 tid1 : nat) (x y : nat) TV (v v0 : TV) m, 86 | tid0 <> tid1 -> 87 | FMap.MapsTo (tid0, x) v0 (FMap.add (tid1, y) v m) -> 88 | FMap.MapsTo (tid0, x) v0 m. 89 | Proof. 90 | intros. 91 | eapply FMap.mapsto_add_ne; eauto. 92 | congruence. 93 | Qed. 94 | 95 | Hint Resolve fmap_mapsto_tid_ne. 96 | 97 | Lemma createtmp_right_mover : 98 | right_mover 99 | MailFSAPI.step 100 | (MailFSOp.CreateTmp). 101 | Proof. 102 | unfold right_mover; intros. 103 | repeat step_inv; eauto 10. 104 | 105 | all: unfold MailFSAPI.step. 106 | all: try solve [ rewrite FMap.add_add_ne by congruence; eauto 10 ]. 107 | 108 | rewrite FMap.add_add_ne by congruence. 109 | eexists. split. 2: eauto. eauto. 110 | 111 | rewrite <- FMap.add_remove_ne by congruence. 112 | eexists. split. 2: eauto. eauto. 113 | 114 | eexists. split. 2: eauto. eauto. 115 | Qed. 116 | 117 | Hint Resolve createtmp_right_mover. 118 | 119 | Theorem ysa_movers_createwrite_core: 120 | forall data, 121 | ysa_movers MailFSAPI.step (createwrite_core data). 122 | Proof. 123 | econstructor; eauto 20. 124 | destruct r; eauto 20. 125 | Qed. 126 | 127 | Hint Resolve ysa_movers_createwrite_core. 128 | 129 | Theorem ysa_movers : forall `(op : _ T), 130 | ysa_movers MailFSAPI.step (compile_op op). 131 | Proof. 132 | destruct op; simpl; eauto 20. 133 | Qed. 134 | 135 | Theorem compile_correct : 136 | compile_correct compile_op MailFSAPI.step TryDeliverAPI.step. 137 | Proof. 138 | unfold compile_correct; intros. 139 | destruct op. 140 | 141 | all: repeat atomic_exec_inv; repeat step_inv; eauto. 142 | all: rewrite FMap.add_add; eauto. 143 | Qed. 144 | 145 | Definition initP_compat : forall s, MailFSAPI.initP s -> 146 | TryDeliverAPI.initP s := 147 | ltac:(auto). 148 | 149 | End TryDeliverImpl'. 150 | 151 | 152 | Module TryDeliverImpl := 153 | LayerImplMovers 154 | MailboxTmpAbsState 155 | MailFSOp MailFSAPI 156 | TryDeliverOp TryDeliverAPI 157 | TryDeliverImpl'. 158 | 159 | Module TryDeliverImplH' := 160 | LayerImplMoversHT 161 | MailboxTmpAbsState 162 | MailFSOp MailFSAPI 163 | TryDeliverOp TryDeliverAPI 164 | TryDeliverImpl' 165 | UserIdx. 166 | 167 | Module TryDeliverImplH := 168 | LayerImplMovers 169 | MailboxTmpAbsHState 170 | MailFSHOp MailFSHAPI 171 | TryDeliverHOp TryDeliverHAPI 172 | TryDeliverImplH'. 173 | -------------------------------------------------------------------------------- /src/Mail/DeliverAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxTmpAbsAPI. 4 | 5 | Module DeliverOp <: Ops. 6 | 7 | Definition extopT := MailServerAPI.MailServerOp.extopT. 8 | 9 | Inductive xOp : Type -> Type := 10 | | CreateWriteTmp : forall (data : string), xOp bool 11 | | LinkMail : xOp bool 12 | | UnlinkTmp : xOp unit 13 | 14 | | List : xOp (list (nat * nat)) 15 | | Read : forall (fn : nat * nat), xOp (option string) 16 | | Delete : forall (fn : nat*nat), xOp unit 17 | | Lock : xOp unit 18 | | Unlock : xOp unit 19 | 20 | | Ext : forall `(op : extopT T), xOp T 21 | . 22 | 23 | Definition Op := xOp. 24 | 25 | End DeliverOp. 26 | Module DeliverHOp := HOps DeliverOp UserIdx. 27 | 28 | 29 | Module DeliverAPI <: Layer DeliverOp MailboxTmpAbsState. 30 | 31 | Import DeliverOp. 32 | Import MailboxTmpAbsState. 33 | 34 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 35 | | StepCreateWriteTmpOK : forall tmp mbox tid data lock, 36 | xstep (CreateWriteTmp data) tid 37 | (mk_state tmp mbox lock) 38 | true 39 | (mk_state (FMap.add (tid, 0) data tmp) mbox lock) 40 | nil 41 | 42 | | StepCreateWriteTmpErr1 : forall tmp mbox tid data lock, 43 | xstep (CreateWriteTmp data) tid 44 | (mk_state tmp mbox lock) 45 | false 46 | (mk_state tmp mbox lock) 47 | nil 48 | | StepCreateWriteTmpErr2 : forall tmp mbox tid data data' lock, 49 | xstep (CreateWriteTmp data) tid 50 | (mk_state tmp mbox lock) 51 | false 52 | (mk_state (FMap.add (tid, 0) data' tmp) mbox lock) 53 | nil 54 | 55 | | StepUnlinkTmp : forall tmp mbox tid lock, 56 | xstep (UnlinkTmp) tid 57 | (mk_state tmp mbox lock) 58 | tt 59 | (mk_state (FMap.remove (tid, 0) tmp) mbox lock) 60 | nil 61 | | StepLinkMailOK : forall tmp mbox tid mailfn data lock, 62 | FMap.MapsTo (tid, 0) data tmp -> 63 | ~ FMap.In (tid, mailfn) mbox -> 64 | xstep (LinkMail) tid 65 | (mk_state tmp mbox lock) 66 | true 67 | (mk_state tmp (FMap.add (tid, mailfn) data mbox) lock) 68 | nil 69 | | StepLinkMailErr : forall tmp mbox tid lock, 70 | xstep (LinkMail) tid 71 | (mk_state tmp mbox lock) 72 | false 73 | (mk_state tmp mbox lock) 74 | nil 75 | 76 | | StepList : forall tmp mbox tid r lock, 77 | FMap.is_permutation_key r mbox -> 78 | xstep List tid 79 | (mk_state tmp mbox lock) 80 | r 81 | (mk_state tmp mbox lock) 82 | nil 83 | 84 | | StepRead : forall fn tmp mbox tid m lock, 85 | FMap.MapsTo fn m mbox -> 86 | xstep (Read fn) tid 87 | (mk_state tmp mbox lock) 88 | (Some m) 89 | (mk_state tmp mbox lock) 90 | nil 91 | 92 | | StepReadNone : forall fn tmp mbox tid lock, 93 | ~ FMap.In fn mbox -> 94 | xstep (Read fn) tid 95 | (mk_state tmp mbox lock) 96 | None 97 | (mk_state tmp mbox lock) 98 | nil 99 | 100 | | StepDelete : forall fn tmp mbox tid lock, 101 | xstep (Delete fn) tid 102 | (mk_state tmp mbox lock) 103 | tt 104 | (mk_state tmp (FMap.remove fn mbox) lock) 105 | nil 106 | 107 | | StepLock : forall tmp mbox tid, 108 | xstep Lock tid 109 | (mk_state tmp mbox false) 110 | tt 111 | (mk_state tmp mbox true) 112 | nil 113 | | StepUnlock : forall tmp mbox tid lock, 114 | xstep Unlock tid 115 | (mk_state tmp mbox lock) 116 | tt 117 | (mk_state tmp mbox false) 118 | nil 119 | 120 | | StepExt : forall s tid `(extop : extopT T) r, 121 | xstep (Ext extop) tid 122 | s 123 | r 124 | s 125 | (Event (extop, r) :: nil) 126 | . 127 | 128 | Definition step := xstep. 129 | 130 | Definition initP := initP. 131 | 132 | End DeliverAPI. 133 | Module DeliverHAPI := HLayer DeliverOp MailboxTmpAbsState DeliverAPI UserIdx. 134 | 135 | 136 | Module DeliverProtocol <: Protocol DeliverOp MailboxTmpAbsState. 137 | 138 | Import DeliverOp. 139 | Import MailboxTmpAbsState. 140 | 141 | Inductive xstep_allow : forall T, Op T -> nat -> State -> Prop := 142 | | AllowCreateWriteTmp : forall tid tmp mbox data lock, 143 | xstep_allow (CreateWriteTmp data) tid (mk_state tmp mbox lock) 144 | | AllowLinkMail : forall tid tmp mbox lock, 145 | FMap.In (tid, 0) tmp -> 146 | xstep_allow (LinkMail) tid (mk_state tmp mbox lock) 147 | | AllowUnlinkTmp : forall tid s, 148 | xstep_allow (UnlinkTmp) tid s 149 | | AllowList : forall tid s, 150 | xstep_allow List tid s 151 | | AllowRead : forall tid s fn, 152 | xstep_allow (Read fn) tid s 153 | | AllowDelete : forall tid s fn, 154 | xstep_allow (Delete fn) tid s 155 | | AllowLock : forall tid s, 156 | xstep_allow Lock tid s 157 | | AllowUnlock : forall tid s, 158 | xstep_allow Unlock tid s 159 | | AllowExt : forall tid s `(extop : _ T), 160 | xstep_allow (Ext extop) tid s 161 | . 162 | 163 | Definition step_allow := xstep_allow. 164 | 165 | End DeliverProtocol. 166 | Module DeliverHProtocol := HProtocol DeliverOp MailboxTmpAbsState DeliverProtocol UserIdx. 167 | 168 | 169 | Module DeliverRestrictedAPI <: Layer DeliverOp MailboxTmpAbsState. 170 | 171 | Definition step := 172 | restricted_step DeliverAPI.step DeliverProtocol.step_allow. 173 | 174 | Definition initP := DeliverAPI.initP. 175 | 176 | End DeliverRestrictedAPI. 177 | Module DeliverRestrictedHAPI := HLayer DeliverOp MailboxTmpAbsState DeliverRestrictedAPI UserIdx. 178 | -------------------------------------------------------------------------------- /src/Mail/MailFSStringAbsImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailboxAPI. 3 | Require Import MailFSAPI. 4 | Require Import MailFSStringAbsAPI. 5 | Require Import MailServerAPI. 6 | Require Import MailboxTmpAbsAPI. 7 | 8 | 9 | Module MailFSStringAbsImpl' <: 10 | HLayerImplAbsT MailFSOp 11 | MailFSStringAbsState MailFSStringAbsAPI 12 | MailboxTmpAbsState MailFSAPI. 13 | 14 | Definition dirR (d1 : MailFSStringAbsState.dir_contents) 15 | (d2 : MailServerState.dir_contents) : Prop := 16 | d1 = FMap.map_keys (fun '(tid, fn) => encode_tid_fn tid fn) d2. 17 | 18 | Definition absR (s1 : MailFSStringAbsState.State) (s2 : MailboxTmpAbsState.State) := 19 | dirR (MailFSStringAbsState.maildir s1) (MailboxTmpAbsState.maildir s2) /\ 20 | dirR (MailFSStringAbsState.tmpdir s1) (MailboxTmpAbsState.tmpdir s2) /\ 21 | MailFSStringAbsState.locked s1 = MailboxTmpAbsState.locked s2. 22 | 23 | Hint Extern 1 (MailFSAPI.step _ _ _ _ _ _) => econstructor. 24 | 25 | Lemma dirR_empty : dirR FMap.empty FMap.empty. 26 | Proof. 27 | unfold dirR; intros. 28 | symmetry. 29 | apply FMap.mapsto_empty_def; intros. 30 | unfold not; intros. 31 | apply FMap.map_keys_mapsto' in H; propositional. 32 | Qed. 33 | 34 | Lemma dirR_mapsto : 35 | forall d1 d2 tid fn data, 36 | dirR d1 d2 -> 37 | FMap.MapsTo (encode_tid_fn tid fn) data d1 -> 38 | FMap.MapsTo (tid, fn) data d2. 39 | Proof. 40 | unfold dirR; intros; subst. 41 | eapply FMap.map_keys_mapsto' in H0; deex. 42 | destruct k'. 43 | apply encode_tid_eq in H0; inversion H0; clear H0; subst. 44 | eauto. 45 | Qed. 46 | 47 | Lemma dirR_mapsto' : 48 | forall d1 d2 tid fn data, 49 | dirR d1 d2 -> 50 | FMap.MapsTo (tid, fn) data d2 -> 51 | FMap.MapsTo (encode_tid_fn tid fn) data d1. 52 | Proof. 53 | unfold dirR; intros; subst. 54 | eapply FMap.map_keys_mapsto in H0. 55 | exact H0. 56 | eauto. 57 | Qed. 58 | 59 | Lemma dirR_fmap_in : 60 | forall d1 d2 tid fn, 61 | dirR d1 d2 -> 62 | FMap.In (encode_tid_fn tid fn) d1 -> 63 | FMap.In (tid, fn) d2. 64 | Proof. 65 | intros. 66 | eapply FMap.in_mapsto_exists in H0; destruct H0. 67 | eapply FMap.mapsto_in. 68 | eapply dirR_mapsto; eauto. 69 | Qed. 70 | 71 | Lemma dirR_fmap_in' : 72 | forall d1 d2 tid fn, 73 | dirR d1 d2 -> 74 | FMap.In (tid, fn) d2 -> 75 | FMap.In (encode_tid_fn tid fn) d1. 76 | Proof. 77 | intros. 78 | eapply FMap.in_mapsto_exists in H0; destruct H0. 79 | eapply FMap.mapsto_in. 80 | eapply dirR_mapsto'; eauto. 81 | Qed. 82 | 83 | Lemma dirR_add : 84 | forall d1 d2 tid fn data, 85 | dirR d1 d2 -> 86 | dirR (FMap.add (encode_tid_fn tid fn) data d1) 87 | (FMap.add (tid, fn) data d2). 88 | Proof. 89 | unfold dirR; intros; subst. 90 | rewrite FMap.map_keys_add; eauto. 91 | Qed. 92 | 93 | Lemma dirR_remove : 94 | forall d1 d2 tid fn, 95 | dirR d1 d2 -> 96 | dirR (FMap.remove (encode_tid_fn tid fn) d1) 97 | (FMap.remove (tid, fn) d2). 98 | Proof. 99 | unfold dirR; intros; subst. 100 | rewrite FMap.map_keys_remove; eauto. 101 | Qed. 102 | 103 | Lemma dirR_is_permutation_key : 104 | forall d1 d2 l, 105 | dirR d1 d2 -> 106 | FMap.is_permutation_key l d1 -> 107 | FMap.is_permutation_key (map decode_tid_fn l) d2. 108 | Proof. 109 | unfold dirR, FMap.is_permutation_key. 110 | split; subst; intros. 111 | - eapply in_map_iff in H; deex. 112 | eapply H0 in H1. 113 | eapply FMap.map_keys_in' in H1; deex. 114 | destruct k'. 115 | rewrite encode_decode_tid_fn; eauto. 116 | - destruct x. 117 | eapply FMap.map_keys_in in H. 118 | eapply H0 in H. 119 | eapply in_map_iff. 120 | eexists; split; eauto. 121 | rewrite encode_decode_tid_fn; eauto. 122 | Qed. 123 | 124 | Hint Resolve dirR_fmap_in. 125 | Hint Resolve dirR_fmap_in'. 126 | Hint Resolve dirR_mapsto. 127 | Hint Resolve dirR_add. 128 | Hint Resolve dirR_remove. 129 | Hint Resolve dirR_is_permutation_key. 130 | 131 | Theorem absR_ok : 132 | op_abs absR MailFSStringAbsAPI.step MailFSAPI.step. 133 | Proof. 134 | unfold op_abs, absR; intros. 135 | destruct s1; simpl in *; subst. 136 | destruct s2; simpl in *; subst. 137 | intuition idtac. 138 | inversion H0; clear H0; subst; repeat sigT_eq; simpl in *. 139 | all: 140 | solve [ eexists; split; [ split | econstructor ]; simpl; intuition eauto ]. 141 | Qed. 142 | 143 | Definition initP_map (s1: MailFSStringAbsState.State) : 144 | {s2:MailboxTmpAbsState.State | 145 | MailFSStringAbsState.initP s1 -> absR s1 s2 /\ MailboxTmpAbsState.initP s2}. 146 | Proof. 147 | unfold MailFSStringAbsState.initP, MailboxTmpAbsState.initP, absR. 148 | destruct s1; simpl. 149 | exists_econstructor; (intuition eauto); propositional. 150 | Qed. 151 | 152 | End MailFSStringAbsImpl'. 153 | 154 | Module MailFSStringAbsImpl := 155 | HLayerImplAbs MailFSOp 156 | MailFSStringAbsState MailFSStringAbsAPI 157 | MailboxTmpAbsState MailFSAPI 158 | MailFSStringAbsImpl'. 159 | 160 | Module MailFSStringAbsImplH' := 161 | LayerImplAbsHT 162 | MailFSOp 163 | MailFSStringAbsState MailFSStringAbsAPI 164 | MailboxTmpAbsState MailFSAPI 165 | MailFSStringAbsImpl' 166 | UserIdx. 167 | 168 | Module MailFSStringAbsImplH := 169 | LayerImplAbs MailFSHOp 170 | MailFSStringAbsHState MailFSStringAbsHAPI 171 | MailboxTmpAbsHState MailFSHAPI 172 | MailFSStringAbsImplH'. 173 | -------------------------------------------------------------------------------- /src/Mail/MailFSStringImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailFSAPI. 4 | Require Import MailFSStringAPI. 5 | Require Import MailFSStringAbsAPI. 6 | 7 | 8 | Module MailFSStringImpl' <: 9 | LayerImplMoversT 10 | MailFSStringAbsState 11 | MailFSStringOp MailFSStringAPI 12 | MailFSOp MailFSStringAbsAPI. 13 | 14 | (* START CODE *) 15 | 16 | Definition createtmp_core := 17 | tid <- Call (MailFSStringOp.GetTID); 18 | r <- Call (MailFSStringOp.CreateTmp (encode_tid_fn tid 0)); 19 | Ret r. 20 | 21 | Definition writetmp_core data := 22 | tid <- Call (MailFSStringOp.GetTID); 23 | r <- Call (MailFSStringOp.WriteTmp (encode_tid_fn tid 0) data); 24 | Ret r. 25 | 26 | Definition linkmail_core mboxfn := 27 | tid <- Call (MailFSStringOp.GetTID); 28 | v <- Call (MailFSStringOp.LinkMail (encode_tid_fn tid 0) (encode_tid_fn tid mboxfn)); 29 | Ret v. 30 | 31 | Definition unlinktmp_core := 32 | tid <- Call (MailFSStringOp.GetTID); 33 | r <- Call (MailFSStringOp.UnlinkTmp (encode_tid_fn tid 0)); 34 | Ret r. 35 | 36 | Definition list_core := 37 | l <- Call (MailFSStringOp.List); 38 | Ret (map decode_tid_fn l). 39 | 40 | Definition compile_op T (op : MailFSOp.Op T) : proc MailFSStringOp.Op T := 41 | match op with 42 | | MailFSOp.LinkMail m => linkmail_core m 43 | | MailFSOp.List => list_core 44 | | MailFSOp.Read fn => Call (MailFSStringOp.Read (encode_tid_fn (fst fn) (snd fn))) 45 | | MailFSOp.Delete fn => Call (MailFSStringOp.Delete (encode_tid_fn (fst fn) (snd fn))) 46 | | MailFSOp.CreateTmp => createtmp_core 47 | | MailFSOp.WriteTmp data => writetmp_core data 48 | | MailFSOp.UnlinkTmp => unlinktmp_core 49 | | MailFSOp.Ext extop => Call (MailFSStringOp.Ext extop) 50 | | MailFSOp.Lock => Call (MailFSStringOp.Lock) 51 | | MailFSOp.Unlock => Call (MailFSStringOp.Unlock) 52 | | MailFSOp.GetTID => Call (MailFSStringOp.GetTID) 53 | | MailFSOp.Random => Call (MailFSStringOp.Random) 54 | end. 55 | 56 | (* END CODE *) 57 | 58 | Theorem compile_op_no_atomics : 59 | forall `(op : _ T), 60 | no_atomics (compile_op op). 61 | Proof. 62 | destruct op; compute; eauto. 63 | Qed. 64 | 65 | Ltac step_inv := 66 | match goal with 67 | | H : MailFSStringAbsAPI.step _ _ _ _ _ _ |- _ => 68 | inversion H; clear H; subst; repeat sigT_eq 69 | | H : MailFSStringAPI.step _ _ _ _ _ _ |- _ => 70 | inversion H; clear H; subst; repeat sigT_eq 71 | end; intuition idtac. 72 | 73 | Hint Extern 1 (MailFSStringAbsAPI.step _ _ _ _ _ _) => econstructor. 74 | Hint Extern 1 (MailFSStringAPI.step _ _ _ _ _ _) => econstructor. 75 | 76 | Lemma gettid_right_mover : 77 | right_mover 78 | MailFSStringAPI.step 79 | (MailFSStringOp.GetTID). 80 | Proof. 81 | unfold right_mover; intros. 82 | repeat step_inv; eauto. 83 | 84 | eexists; split; econstructor; eauto. 85 | Qed. 86 | 87 | Hint Resolve gettid_right_mover. 88 | 89 | Theorem ysa_movers_linkmail_core: forall n, 90 | ysa_movers MailFSStringAPI.step (linkmail_core n). 91 | Proof. 92 | econstructor; eauto 20. 93 | Qed. 94 | 95 | Hint Resolve ysa_movers_linkmail_core. 96 | 97 | Theorem ysa_movers_list_core: 98 | ysa_movers MailFSStringAPI.step list_core. 99 | Proof. 100 | unfold list_core, ysa_movers. 101 | eauto 20. 102 | Qed. 103 | 104 | Hint Resolve ysa_movers_list_core. 105 | 106 | Theorem ysa_movers_createtmp_core: 107 | ysa_movers MailFSStringAPI.step (createtmp_core). 108 | Proof. 109 | econstructor; eauto 20. 110 | Qed. 111 | 112 | Hint Resolve ysa_movers_createtmp_core. 113 | 114 | Theorem ysa_movers_writetmp_core: forall s, 115 | ysa_movers MailFSStringAPI.step (writetmp_core s). 116 | Proof. 117 | econstructor; eauto 20. 118 | Qed. 119 | 120 | Hint Resolve ysa_movers_writetmp_core. 121 | 122 | Theorem ysa_movers_unlinktmp_core: 123 | ysa_movers MailFSStringAPI.step unlinktmp_core. 124 | Proof. 125 | econstructor; eauto 20. 126 | Qed. 127 | 128 | Hint Resolve ysa_movers_unlinktmp_core. 129 | 130 | Theorem ysa_movers : forall `(op : _ T), 131 | ysa_movers MailFSStringAPI.step (compile_op op). 132 | Proof. 133 | destruct op; simpl; eauto 20. 134 | Qed. 135 | 136 | Theorem compile_correct : 137 | compile_correct compile_op MailFSStringAPI.step MailFSStringAbsAPI.step. 138 | Proof. 139 | unfold compile_correct; intros. 140 | destruct op. 141 | 142 | all: try solve [ repeat atomic_exec_inv; repeat step_inv; eauto ]. 143 | 144 | repeat atomic_exec_inv. 145 | repeat step_inv; eauto. 146 | 147 | destruct fn; simpl in *. 148 | eauto. 149 | 150 | destruct fn; simpl in *. 151 | eauto. 152 | Qed. 153 | 154 | Definition initP_compat : forall s, MailFSStringAPI.initP s -> 155 | MailFSStringAbsAPI.initP s := 156 | ltac:(auto). 157 | 158 | End MailFSStringImpl'. 159 | 160 | Module MailFSStringImpl := 161 | LayerImplMovers 162 | MailFSStringAbsState 163 | MailFSStringOp MailFSStringAPI 164 | MailFSOp MailFSStringAbsAPI 165 | MailFSStringImpl'. 166 | 167 | Module MailFSStringImplH' := 168 | LayerImplMoversHT 169 | MailFSStringAbsState 170 | MailFSStringOp MailFSStringAPI 171 | MailFSOp MailFSStringAbsAPI 172 | MailFSStringImpl' 173 | UserIdx. 174 | 175 | Module MailFSStringImplH := 176 | LayerImplMovers 177 | MailFSStringAbsHState 178 | MailFSStringHOp MailFSStringHAPI 179 | MailFSHOp MailFSStringAbsHAPI 180 | MailFSStringImplH'. 181 | -------------------------------------------------------------------------------- /src/Helpers/Sets.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Maps. 3 | Require Import Ordering. 4 | 5 | Set Implicit Arguments. 6 | 7 | Theorem Forall_impl : forall A (P P': A -> Prop) l, 8 | (forall x, P x -> P' x) -> 9 | Forall P l -> 10 | Forall P' l. 11 | Proof. 12 | induction l; simpl; intuition eauto. 13 | inversion H0; eauto. 14 | Qed. 15 | 16 | Module FSet. 17 | 18 | Section Sets. 19 | 20 | Variable A:Type. 21 | Context {Acmp:Ordering A}. 22 | 23 | Definition t := FMap.t A unit. 24 | Definition empty : t := FMap.empty. 25 | 26 | Definition elements (s:t) : list A := 27 | FMap.keys s. 28 | 29 | Definition In x (s:t) := 30 | FMap.In x s. 31 | 32 | Hint Unfold empty In : set. 33 | 34 | Ltac unfold_set := 35 | intros; 36 | autounfold with set in *. 37 | 38 | Theorem _in_mapsto : forall x u s, 39 | FMap.MapsTo x u s -> 40 | In x s. 41 | Proof. 42 | unfold_set. 43 | apply FMap.mapsto_in in H; auto. 44 | Qed. 45 | 46 | Theorem _in_mapsto' : forall x s, 47 | FMap.In x s -> 48 | FMap.MapsTo x tt s. 49 | Proof. 50 | unfold_set. 51 | apply FMap.in_mapsto_exists in H. 52 | destruct H as [[] ?]; auto. 53 | Qed. 54 | 55 | Definition For_all (P:A -> Prop) (s:t) := 56 | FMap.For_all (fun '(k, _) => P k) s. 57 | 58 | Hint Unfold For_all : set. 59 | 60 | Theorem empty_Forall : forall P, 61 | For_all P empty. 62 | Proof. 63 | unfold_set. 64 | apply FMap.empty_Forall. 65 | Qed. 66 | 67 | Theorem For_all_in (P:A -> Prop) (s:t) : 68 | For_all P s -> 69 | forall x, In x s -> P x. 70 | Proof. 71 | unfold_set. 72 | eapply FMap.For_all_in in H; eauto. 73 | apply _in_mapsto'; auto. 74 | Qed. 75 | 76 | Theorem not_in_forall : forall x s, 77 | ~In x s -> 78 | For_all (fun y => x <> y) s. 79 | Proof. 80 | unfold_set. 81 | eapply FMap.not_in_forall in H. 82 | eapply Forall_impl; eauto. 83 | intros. 84 | destruct x0; simpl in *; auto. 85 | Qed. 86 | 87 | Definition In_dec x s : {In x s} + {~In x s}. 88 | apply FMap.In_dec. 89 | Defined. 90 | 91 | Definition add (x:A) (s:t) : t := 92 | FMap.add x tt s. 93 | 94 | Theorem add_forall : forall x P s, 95 | For_all P s -> 96 | P x -> 97 | For_all P (add x s). 98 | Proof. 99 | unfold_set. 100 | eapply FMap.add_forall; eauto. 101 | Qed. 102 | 103 | Theorem add_forall' : forall x P s, 104 | For_all P (add x s) -> 105 | For_all P s. 106 | Proof. 107 | unfold_set. 108 | destruct (FMap.In_dec x s). 109 | apply _in_mapsto' in i. 110 | assert (FMap.In x (add x s)). 111 | eapply FMap.add_in. 112 | apply _in_mapsto' in H0. 113 | assert (P x) by (eapply FMap.For_all_in in H; eauto). 114 | eapply FMap.add_forall'_in; eauto. 115 | eapply FMap.add_forall'; eauto. 116 | Qed. 117 | 118 | Theorem add_in : forall x s, 119 | In x (add x s). 120 | Proof. 121 | unfold_set. 122 | apply FMap.add_in. 123 | Qed. 124 | 125 | Theorem add_in' : forall x s y, 126 | In x (add y s) -> 127 | x = y \/ In x s. 128 | Proof. 129 | unfold_set. 130 | apply FMap.add_in' in H; auto. 131 | Qed. 132 | 133 | Theorem add_incr : forall x s y, 134 | In y s -> 135 | In y (add x s). 136 | Proof. 137 | unfold_set. 138 | apply FMap.add_incr; auto. 139 | Qed. 140 | 141 | Definition remove x (s:t) : t := 142 | FMap.remove x s. 143 | 144 | Hint Unfold remove : set. 145 | 146 | Theorem remove_not_in : forall x s, 147 | ~In x (remove x s). 148 | Proof. 149 | unfold_set. 150 | apply FMap.remove_not_in. 151 | Qed. 152 | 153 | Theorem remove_in : forall x s y, 154 | In y s -> 155 | x <> y -> 156 | In y (remove x s). 157 | Proof. 158 | unfold_set. 159 | apply FMap.remove_in; auto. 160 | Qed. 161 | 162 | Theorem remove_in' : forall x s y, 163 | In x (remove y s) -> 164 | In x s /\ x <> y. 165 | Proof. 166 | unfold_set. 167 | apply FMap.remove_in'; auto. 168 | Qed. 169 | 170 | Theorem set_extensionality : forall s1 s2, 171 | (forall x, In x s1 <-> In x s2) -> 172 | s1 = s2. 173 | Proof. 174 | unfold_set. 175 | apply FMap.mapsto_extensionality; intuition. 176 | - destruct v. 177 | apply _in_mapsto in H0. 178 | apply _in_mapsto'. 179 | apply H; auto. 180 | - destruct v. 181 | apply _in_mapsto in H0. 182 | apply _in_mapsto'. 183 | apply H; auto. 184 | Qed. 185 | 186 | Definition filter (P: A -> bool) (s:t) : t := 187 | FMap.filter P s. 188 | 189 | Theorem filter_in : forall P s x, 190 | In x (filter P s) -> 191 | In x s. 192 | Proof. 193 | unfold_set. 194 | eauto using FMap.filter_in. 195 | Qed. 196 | 197 | Theorem filter_spec : forall P s, 198 | For_all (fun y => P y = true) (filter P s). 199 | Proof. 200 | unfold_set. 201 | eauto using FMap.filter_spec. 202 | Qed. 203 | 204 | Theorem filter_complete : forall P s x, 205 | In x s -> 206 | P x = true -> 207 | In x (filter P s). 208 | Proof. 209 | unfold_set. 210 | eauto using FMap.filter_complete. 211 | Qed. 212 | 213 | Definition is_permutation (l : list A) (s : t) : Prop := 214 | forall x, List.In x l <-> In x s. 215 | 216 | End Sets. 217 | 218 | End FSet. 219 | 220 | Arguments FSet.t A {Acmp}. 221 | -------------------------------------------------------------------------------- /src/Mail/MailFSStringAbsAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxTmpAbsAPI. 4 | Require Import MailFSAPI. 5 | 6 | 7 | Parameter encode_tid_fn : nat -> nat -> string. 8 | Parameter decode_tid_fn : string -> (nat * nat). 9 | Axiom encode_decode_tid_fn : forall tid fn, 10 | decode_tid_fn (encode_tid_fn tid fn) = (tid, fn). 11 | 12 | Theorem encode_tid_eq : forall t1 t2 n1 n2, 13 | encode_tid_fn t1 n1 = encode_tid_fn t2 n2 -> 14 | (t1, n1) = (t2, n2). 15 | Proof. 16 | intros. 17 | rewrite <- encode_decode_tid_fn at 1. 18 | rewrite H. 19 | rewrite encode_decode_tid_fn. 20 | eauto. 21 | Qed. 22 | 23 | Theorem encode_tid_fn_injective : 24 | FMap.injective (fun '(tid, fn) => encode_tid_fn tid fn). 25 | Proof. 26 | unfold FMap.injective; intros. 27 | destruct k1; destruct k2. 28 | contradict H. 29 | eapply encode_tid_eq; eauto. 30 | Qed. 31 | 32 | Hint Resolve encode_tid_fn_injective. 33 | 34 | 35 | Module MailFSStringAbsState <: State. 36 | 37 | Definition dir_contents := FMap.t string string. 38 | 39 | Record state_rec := mk_state { 40 | tmpdir : dir_contents; 41 | maildir : dir_contents; 42 | locked : bool; 43 | }. 44 | 45 | Definition State := state_rec. 46 | Definition initP (s : State) := locked s = false /\ 47 | tmpdir s = FMap.empty /\ 48 | maildir s = FMap.empty. 49 | 50 | End MailFSStringAbsState. 51 | Module MailFSStringAbsHState := HState MailFSStringAbsState UserIdx. 52 | 53 | 54 | Module MailFSStringAbsAPI <: Layer MailFSOp MailFSStringAbsState. 55 | 56 | Import MailFSOp. 57 | Import MailFSStringAbsState. 58 | 59 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 60 | | StepCreateTmpOK : forall tmp mbox tid lock, 61 | xstep (CreateTmp) tid 62 | (mk_state tmp mbox lock) 63 | true 64 | (mk_state (FMap.add (encode_tid_fn tid 0) empty_string tmp) mbox lock) 65 | nil 66 | | StepCreateTmpErr : forall tmp mbox tid lock, 67 | xstep (CreateTmp) tid 68 | (mk_state tmp mbox lock) 69 | false 70 | (mk_state tmp mbox lock) 71 | nil 72 | | StepWriteTmpOK : forall tmp mbox tid data lock, 73 | FMap.MapsTo (encode_tid_fn tid 0) empty_string tmp -> 74 | xstep (WriteTmp data) tid 75 | (mk_state tmp mbox lock) 76 | true 77 | (mk_state (FMap.add (encode_tid_fn tid 0) data tmp) mbox lock) 78 | nil 79 | | StepWriteTmpErr1 : forall tmp mbox tid data lock, 80 | xstep (WriteTmp data) tid 81 | (mk_state tmp mbox lock) 82 | false 83 | (mk_state tmp mbox lock) 84 | nil 85 | | StepWriteTmpErr2 : forall tmp mbox tid data data' lock, 86 | FMap.MapsTo (encode_tid_fn tid 0) empty_string tmp -> 87 | xstep (WriteTmp data) tid 88 | (mk_state tmp mbox lock) 89 | false 90 | (mk_state (FMap.add (encode_tid_fn tid 0) data' tmp) mbox lock) 91 | nil 92 | | StepUnlinkTmp : forall tmp mbox tid lock, 93 | xstep (UnlinkTmp) tid 94 | (mk_state tmp mbox lock) 95 | tt 96 | (mk_state (FMap.remove (encode_tid_fn tid 0) tmp) mbox lock) 97 | nil 98 | | StepLinkMailOK : forall tmp mbox tid mailfn data lock, 99 | FMap.MapsTo (encode_tid_fn tid 0) data tmp -> 100 | ~ FMap.In (encode_tid_fn tid mailfn) mbox -> 101 | xstep (LinkMail mailfn) tid 102 | (mk_state tmp mbox lock) 103 | true 104 | (mk_state tmp (FMap.add (encode_tid_fn tid mailfn) data mbox) lock) 105 | nil 106 | | StepLinkMail : forall tmp mbox tid mailfn lock, 107 | xstep (LinkMail mailfn) tid 108 | (mk_state tmp mbox lock) 109 | false 110 | (mk_state tmp mbox lock) 111 | nil 112 | 113 | | StepList : forall tmp mbox tid r lock, 114 | FMap.is_permutation_key r mbox -> 115 | xstep List tid 116 | (mk_state tmp mbox lock) 117 | (map decode_tid_fn r) 118 | (mk_state tmp mbox lock) 119 | nil 120 | 121 | | StepGetTID : forall tmp mbox tid lock, 122 | xstep GetTID tid 123 | (mk_state tmp mbox lock) 124 | tid 125 | (mk_state tmp mbox lock) 126 | nil 127 | | StepRandom : forall tmp mbox tid r lock, 128 | xstep Random tid 129 | (mk_state tmp mbox lock) 130 | r 131 | (mk_state tmp mbox lock) 132 | nil 133 | 134 | | StepReadOK : forall fntid fn tmp mbox tid m lock, 135 | FMap.MapsTo (encode_tid_fn fntid fn) m mbox -> 136 | xstep (Read (fntid, fn)) tid 137 | (mk_state tmp mbox lock) 138 | (Some m) 139 | (mk_state tmp mbox lock) 140 | nil 141 | | StepReadNone : forall fntid fn tmp mbox tid lock, 142 | ~ FMap.In (encode_tid_fn fntid fn) mbox -> 143 | xstep (Read (fntid, fn)) tid 144 | (mk_state tmp mbox lock) 145 | None 146 | (mk_state tmp mbox lock) 147 | nil 148 | 149 | | StepDelete : forall fntid fn tmp mbox tid lock, 150 | xstep (Delete (fntid, fn)) tid 151 | (mk_state tmp mbox lock) 152 | tt 153 | (mk_state tmp (FMap.remove (encode_tid_fn fntid fn) mbox) lock) 154 | nil 155 | 156 | | StepLock : forall tmp mbox tid, 157 | xstep Lock tid 158 | (mk_state tmp mbox false) 159 | tt 160 | (mk_state tmp mbox true) 161 | nil 162 | | StepUnlock : forall tmp mbox tid lock, 163 | xstep Unlock tid 164 | (mk_state tmp mbox lock) 165 | tt 166 | (mk_state tmp mbox false) 167 | nil 168 | 169 | | StepExt : forall s tid `(extop : extopT T) r, 170 | xstep (Ext extop) tid 171 | s 172 | r 173 | s 174 | (Event (extop, r) :: nil) 175 | . 176 | 177 | Definition step := xstep. 178 | 179 | Definition initP := initP. 180 | 181 | End MailFSStringAbsAPI. 182 | Module MailFSStringAbsHAPI := HLayer MailFSOp MailFSStringAbsState MailFSStringAbsAPI UserIdx. 183 | -------------------------------------------------------------------------------- /src/Mail/MailFSImpl.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxTmpAbsAPI. 4 | Require Import DeliverListTidAPI. 5 | Require Import MailFSAPI. 6 | 7 | 8 | Module MailFSImpl' <: 9 | LayerImplMoversT 10 | MailboxTmpAbsState 11 | MailFSOp MailFSAPI 12 | DeliverListTidOp DeliverListTidAPI. 13 | 14 | (* START CODE *) 15 | 16 | Definition same_tid (tid : nat) (fn : nat * nat) : bool := 17 | if tid == fst fn then 18 | true 19 | else 20 | false. 21 | 22 | Definition listtid_core := 23 | tid <- Call (MailFSOp.GetTID); 24 | l <- Call (MailFSOp.List); 25 | Ret (map snd (filter (same_tid tid) l)). 26 | 27 | Definition createwrite_core data := 28 | ok1 <- Call (MailFSOp.CreateTmp); 29 | if (ok1 : bool) then Call (MailFSOp.WriteTmp data) else Ret ok1. 30 | 31 | Definition compile_op T (op : DeliverListTidOp.Op T) : proc _ T := 32 | match op with 33 | | DeliverListTidOp.LinkMail m => Call (MailFSOp.LinkMail m) 34 | | DeliverListTidOp.List => Call (MailFSOp.List) 35 | | DeliverListTidOp.ListTid => listtid_core 36 | | DeliverListTidOp.Read fn => Call (MailFSOp.Read fn) 37 | | DeliverListTidOp.Delete fn => Call (MailFSOp.Delete fn) 38 | | DeliverListTidOp.CreateWriteTmp data => createwrite_core data 39 | | DeliverListTidOp.UnlinkTmp => Call (MailFSOp.UnlinkTmp) 40 | | DeliverListTidOp.Lock => Call (MailFSOp.Lock) 41 | | DeliverListTidOp.Unlock => Call (MailFSOp.Unlock) 42 | | DeliverListTidOp.Ext extop => Call (MailFSOp.Ext extop) 43 | end. 44 | 45 | (* END CODE *) 46 | 47 | Theorem compile_op_no_atomics : 48 | forall `(op : _ T), 49 | no_atomics (compile_op op). 50 | Proof. 51 | destruct op; compute; eauto. 52 | 53 | constructor; eauto. 54 | destruct x; eauto. 55 | Qed. 56 | 57 | Ltac step_inv := 58 | match goal with 59 | | H : MailFSAPI.step _ _ _ _ _ _ |- _ => 60 | inversion H; clear H; subst; repeat sigT_eq 61 | | H : MailFSAPI.xstep _ _ _ _ _ _ |- _ => 62 | inversion H; clear H; subst; repeat sigT_eq 63 | | H : DeliverListTidAPI.step _ _ _ _ _ _ |- _ => 64 | inversion H; clear H; subst; repeat sigT_eq 65 | end; intuition idtac. 66 | 67 | Hint Extern 1 (MailFSAPI.step _ _ _ _ _ _) => econstructor. 68 | Hint Extern 1 (DeliverListTidAPI.step _ _ _ _ _ _) => econstructor. 69 | Hint Constructors MailFSAPI.xstep. 70 | 71 | Lemma gettid_right_mover : 72 | right_mover 73 | MailFSAPI.step 74 | (MailFSOp.GetTID). 75 | Proof. 76 | unfold right_mover; intros. 77 | repeat step_inv; eauto 10. 78 | 79 | eexists; split; econstructor; eauto. 80 | Qed. 81 | 82 | Hint Resolve gettid_right_mover. 83 | 84 | Lemma fmap_mapsto_tid_ne : 85 | forall (tid0 tid1 : nat) (x y : nat) TV (v v0 : TV) m, 86 | tid0 <> tid1 -> 87 | FMap.MapsTo (tid0, x) v0 (FMap.add (tid1, y) v m) -> 88 | FMap.MapsTo (tid0, x) v0 m. 89 | Proof. 90 | intros. 91 | eapply FMap.mapsto_add_ne; eauto. 92 | congruence. 93 | Qed. 94 | 95 | Hint Resolve fmap_mapsto_tid_ne. 96 | 97 | Lemma createtmp_right_mover : 98 | right_mover 99 | MailFSAPI.step 100 | (MailFSOp.CreateTmp). 101 | Proof. 102 | unfold right_mover; intros. 103 | repeat step_inv; eauto 10. 104 | 105 | all: unfold MailFSAPI.step. 106 | all: try solve [ rewrite FMap.add_add_ne by congruence; eauto 10 ]. 107 | 108 | rewrite FMap.add_add_ne by congruence. 109 | eexists. split. 2: eauto. eauto. 110 | 111 | rewrite <- FMap.add_remove_ne by congruence. 112 | eexists. split. 2: eauto. eauto. 113 | 114 | eexists. split. 2: eauto. eauto. 115 | Qed. 116 | 117 | Hint Resolve createtmp_right_mover. 118 | 119 | Theorem ysa_movers_listtid_core: 120 | ysa_movers MailFSAPI.step listtid_core. 121 | Proof. 122 | econstructor; eauto 20. 123 | Qed. 124 | 125 | Hint Resolve ysa_movers_listtid_core. 126 | 127 | Theorem ysa_movers_createwrite_core: 128 | forall data, 129 | ysa_movers MailFSAPI.step (createwrite_core data). 130 | Proof. 131 | econstructor; eauto 20. 132 | destruct r; eauto 20. 133 | Qed. 134 | 135 | Hint Resolve ysa_movers_createwrite_core. 136 | 137 | Theorem ysa_movers : forall `(op : _ T), 138 | ysa_movers MailFSAPI.step (compile_op op). 139 | Proof. 140 | destruct op; simpl; eauto 20. 141 | Qed. 142 | 143 | Theorem compile_correct : 144 | compile_correct compile_op MailFSAPI.step DeliverListTidAPI.step. 145 | Proof. 146 | unfold compile_correct; intros. 147 | destruct op. 148 | 149 | all: try solve [ repeat atomic_exec_inv; repeat step_inv; eauto ]. 150 | 151 | - repeat atomic_exec_inv; repeat step_inv; eauto. 152 | rewrite FMap.add_add; eauto. 153 | rewrite FMap.add_add; eauto. 154 | 155 | - repeat atomic_exec_inv. 156 | repeat step_inv; eauto. 157 | econstructor; intros. 158 | 159 | eapply in_map_iff. 160 | exists (v1, fn); intuition eauto. 161 | eapply filter_In; intuition eauto. 162 | eapply FMap.is_permutation_in'; eauto. 163 | unfold same_tid; simpl. 164 | destruct (v1 == v1); congruence. 165 | Qed. 166 | 167 | Definition initP_compat : forall s, MailFSAPI.initP s -> 168 | DeliverListTidAPI.initP s := 169 | ltac:(auto). 170 | 171 | End MailFSImpl'. 172 | 173 | Module MailFSImpl := 174 | LayerImplMovers 175 | MailboxTmpAbsState 176 | MailFSOp MailFSAPI 177 | DeliverListTidOp DeliverListTidAPI 178 | MailFSImpl'. 179 | 180 | Module MailFSImplH' := 181 | LayerImplMoversHT 182 | MailboxTmpAbsState 183 | MailFSOp MailFSAPI 184 | DeliverListTidOp DeliverListTidAPI 185 | MailFSImpl' 186 | UserIdx. 187 | 188 | Module MailFSImplH := 189 | LayerImplMovers 190 | MailboxTmpAbsHState 191 | MailFSHOp MailFSHAPI 192 | DeliverListTidHOp DeliverListTidHAPI 193 | MailFSImplH'. 194 | -------------------------------------------------------------------------------- /src/Helpers/StringUtils.v: -------------------------------------------------------------------------------- 1 | Require Import Ascii String Omega OrderedTypeEx. 2 | 3 | 4 | (**** String_as_OT borrowed from Fiat *) 5 | 6 | Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq. 7 | intros; apply Nat.compare_eq_iff; trivial. 8 | Qed. 9 | 10 | Hint Rewrite <- nat_compare_lt : nat_comp_hints. 11 | Hint Rewrite <- nat_compare_gt : nat_comp_hints. 12 | Hint Rewrite Nat.compare_eq_iff : nat_comp_hints. 13 | Hint Rewrite <- Nat.compare_eq_iff : nat_comp_hints. 14 | Hint Rewrite nat_compare_eq_refl : nat_comp_hints. 15 | 16 | Ltac autorewrite_nat_compare := 17 | autorewrite with nat_comp_hints in *. 18 | 19 | Lemma nat_compare_consistent : 20 | forall n0 n1, 21 | { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt } 22 | + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq } 23 | + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }. 24 | Proof. 25 | intros n0 n1; 26 | destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ]; 27 | [ constructor 1; constructor 1 | constructor 1; constructor 2 | constructor 2 ]; 28 | split; 29 | autorewrite_nat_compare; 30 | intuition. 31 | Defined. 32 | 33 | Module String_as_OT <: UsualOrderedType. 34 | Definition t := string. 35 | 36 | Fixpoint string_compare str1 str2 := 37 | match str1, str2 with 38 | | EmptyString, EmptyString => Eq 39 | | EmptyString, _ => Lt 40 | | _, EmptyString => Gt 41 | | String char1 tail1, String char2 tail2 => 42 | match Nat.compare (nat_of_ascii char1) (nat_of_ascii char2) with 43 | | Eq => string_compare tail1 tail2 44 | | Lt => Lt 45 | | Gt => Gt 46 | end 47 | end. 48 | 49 | Lemma string_compare_eq_refl : forall x, string_compare x x = Eq. 50 | intro x; 51 | induction x; 52 | simpl; trivial; 53 | autorewrite_nat_compare. 54 | trivial. 55 | Qed. 56 | 57 | Ltac comparisons_minicrush := 58 | autorewrite_nat_compare; 59 | match goal with 60 | | [ |- context [Nat.compare ?a ?b] ] => 61 | let H := fresh in 62 | first [ 63 | assert (Nat.compare a b = Eq) as H by (autorewrite_nat_compare; omega) | 64 | assert (Nat.compare a b = Lt) as H by (autorewrite_nat_compare; omega) | 65 | assert (Nat.compare a b = Gt) as H by (autorewrite_nat_compare; omega) 66 | ]; rewrite H; intuition 67 | end. 68 | 69 | Ltac destruct_comparisons := 70 | repeat match goal with 71 | | [ H: match ?pred ?a ?b with 72 | | Lt => _ | Gt => _ | Eq => _ end = _ 73 | |- _] => 74 | let H := fresh in 75 | destruct (pred a b) eqn:H; 76 | try discriminate 77 | end. 78 | 79 | Ltac exfalso_from_equalities := 80 | match goal with 81 | | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => assert (b = c) by congruence; discriminate 82 | end. 83 | 84 | Definition eq := @eq string. 85 | 86 | Hint Resolve string_compare_eq_refl. 87 | 88 | Lemma eq_Eq : forall x y, x = y -> string_compare x y = Eq. 89 | Proof. 90 | intros; subst; auto. 91 | Qed. 92 | 93 | Lemma nat_of_ascii_injective : 94 | forall a b, nat_of_ascii a = nat_of_ascii b <-> a = b. 95 | Proof. 96 | intros a b; split; intro H; 97 | [ apply (f_equal ascii_of_nat) in H; 98 | repeat rewrite ascii_nat_embedding in H 99 | | apply (f_equal nat_of_ascii) in H ]; trivial. 100 | Qed. 101 | 102 | Lemma Eq_eq : forall x y, string_compare x y = Eq -> x = y. 103 | Proof. 104 | induction x; 105 | destruct y; 106 | simpl; 107 | first [ discriminate 108 | | intros; 109 | f_equal; 110 | destruct_comparisons; 111 | autorewrite_nat_compare; 112 | rewrite nat_of_ascii_injective in * 113 | | idtac ]; 114 | intuition. 115 | Qed. 116 | 117 | Lemma Eq_eq_iff : forall x y, x = y <-> string_compare x y = Eq. 118 | Proof. 119 | intros; split; eauto using eq_Eq, Eq_eq. 120 | Qed. 121 | 122 | Definition eq_refl := @eq_refl string. 123 | 124 | Definition eq_sym := @eq_sym string. 125 | 126 | Definition eq_trans := @eq_trans string. 127 | 128 | Definition lt x y := 129 | string_compare x y = Lt. 130 | 131 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 132 | Proof. 133 | intros x y z; 134 | generalize x z; 135 | clear x z; 136 | 137 | induction y; 138 | destruct x; 139 | destruct z; 140 | intros; 141 | unfold lt in *; 142 | simpl in *; 143 | first [ discriminate 144 | | destruct_comparisons; comparisons_minicrush 145 | | trivial ]; intuition. 146 | Qed. 147 | 148 | Lemma lt_not_eq : forall x y, lt x y -> ~ eq x y. 149 | Proof. 150 | unfold lt, not in *; 151 | intros; 152 | rewrite Eq_eq_iff in *; 153 | exfalso_from_equalities. 154 | Qed. 155 | 156 | Lemma Lt_Gt : forall x y, string_compare x y = Gt <-> string_compare y x = Lt. 157 | Proof. 158 | intros x; 159 | induction x as [ | x0 x' Hind ]; 160 | intros y; 161 | destruct y as [ | y0 y' ]; 162 | 163 | simpl; 164 | split; 165 | first [ discriminate | trivial ]; 166 | 167 | destruct (nat_compare_consistent 168 | (nat_of_ascii x0) 169 | (nat_of_ascii y0)) 170 | as [ [ (H1, H2) | (H1, H2) ] | (H1, H2) ]; 171 | rewrite H1, H2; 172 | try rewrite Hind; 173 | auto. 174 | Qed. 175 | 176 | Definition compare x y : OrderedType.Compare lt eq x y. 177 | Proof. 178 | destruct (string_compare x y) eqn:comp; 179 | unfold lt; 180 | [ constructor 2; apply Eq_eq 181 | | constructor 1 182 | | constructor 3; apply Lt_Gt]; 183 | trivial. 184 | Defined. 185 | 186 | Definition eq_dec : forall (x y: string), { x = y } + { x <> y }. 187 | Proof. 188 | exact string_dec. 189 | Defined. 190 | 191 | End String_as_OT. 192 | -------------------------------------------------------------------------------- /src/Mail/DeliverListTidAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailboxTmpAbsAPI. 4 | Require Import DeliverAPI. 5 | 6 | Module DeliverListTidOp <: Ops. 7 | 8 | Definition extopT := MailServerAPI.MailServerOp.extopT. 9 | 10 | Inductive xOp : Type -> Type := 11 | | CreateWriteTmp : forall (data : string), xOp bool 12 | | LinkMail : forall (mboxfn : nat), xOp bool 13 | | UnlinkTmp : xOp unit 14 | 15 | | List : xOp (list (nat * nat)) 16 | | ListTid : xOp (list nat) 17 | | Read : forall (fn : nat * nat), xOp (option string) 18 | | Delete : forall (fn : nat * nat), xOp unit 19 | | Lock : xOp unit 20 | | Unlock : xOp unit 21 | 22 | | Ext : forall `(op : extopT T), xOp T 23 | . 24 | 25 | Definition Op := xOp. 26 | 27 | End DeliverListTidOp. 28 | Module DeliverListTidHOp := HOps DeliverListTidOp UserIdx. 29 | 30 | 31 | Module DeliverListTidAPI <: Layer DeliverListTidOp MailboxTmpAbsState. 32 | 33 | Import DeliverListTidOp. 34 | Import MailboxTmpAbsState. 35 | 36 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 37 | | StepCreateWriteTmp : forall tmp mbox tid data lock, 38 | xstep (CreateWriteTmp data) tid 39 | (mk_state tmp mbox lock) 40 | true 41 | (mk_state (FMap.add (tid, 0) data tmp) mbox lock) 42 | nil 43 | | StepCreateWriteTmpErr1 : forall tmp mbox tid data lock, 44 | xstep (CreateWriteTmp data) tid 45 | (mk_state tmp mbox lock) 46 | false 47 | (mk_state tmp mbox lock) 48 | nil 49 | | StepCreateWriteTmpErr2 : forall tmp mbox tid data data' lock, 50 | xstep (CreateWriteTmp data) tid 51 | (mk_state tmp mbox lock) 52 | false 53 | (mk_state (FMap.add (tid, 0) data' tmp) mbox lock) 54 | nil 55 | | StepUnlinkTmp : forall tmp mbox tid lock, 56 | xstep (UnlinkTmp) tid 57 | (mk_state tmp mbox lock) 58 | tt 59 | (mk_state (FMap.remove (tid, 0) tmp) mbox lock) 60 | nil 61 | | StepLinkMailOK : forall tmp mbox tid mailfn data lock, 62 | FMap.MapsTo (tid, 0) data tmp -> 63 | ~ FMap.In (tid, mailfn) mbox -> 64 | xstep (LinkMail mailfn) tid 65 | (mk_state tmp mbox lock) 66 | true 67 | (mk_state tmp (FMap.add (tid, mailfn) data mbox) lock) 68 | nil 69 | | StepLinkMailErr : forall tmp mbox tid mailfn lock, 70 | xstep (LinkMail mailfn) tid 71 | (mk_state tmp mbox lock) 72 | false 73 | (mk_state tmp mbox lock) 74 | nil 75 | 76 | | StepList : forall tmp mbox tid r lock, 77 | FMap.is_permutation_key r mbox -> 78 | xstep List tid 79 | (mk_state tmp mbox lock) 80 | r 81 | (mk_state tmp mbox lock) 82 | nil 83 | | StepListTid : forall tmp mbox tid r lock, 84 | (forall fn, FMap.In (tid, fn) mbox -> In fn r) -> 85 | xstep ListTid tid 86 | (mk_state tmp mbox lock) 87 | r 88 | (mk_state tmp mbox lock) 89 | nil 90 | 91 | | StepReadOK : forall fn tmp mbox tid m lock, 92 | FMap.MapsTo fn m mbox -> 93 | xstep (Read fn) tid 94 | (mk_state tmp mbox lock) 95 | (Some m) 96 | (mk_state tmp mbox lock) 97 | nil 98 | 99 | | StepReadNone : forall fn tmp mbox tid lock, 100 | ~ FMap.In fn mbox -> 101 | xstep (Read fn) tid 102 | (mk_state tmp mbox lock) 103 | None 104 | (mk_state tmp mbox lock) 105 | nil 106 | 107 | | StepDelete : forall fn tmp mbox tid lock, 108 | xstep (Delete fn) tid 109 | (mk_state tmp mbox lock) 110 | tt 111 | (mk_state tmp (FMap.remove fn mbox) lock) 112 | nil 113 | 114 | | StepLock : forall tmp mbox tid, 115 | xstep Lock tid 116 | (mk_state tmp mbox false) 117 | tt 118 | (mk_state tmp mbox true) 119 | nil 120 | | StepUnlock : forall tmp mbox tid lock, 121 | xstep Unlock tid 122 | (mk_state tmp mbox lock) 123 | tt 124 | (mk_state tmp mbox false) 125 | nil 126 | 127 | | StepExt : forall s tid `(extop : extopT T) r, 128 | xstep (Ext extop) tid 129 | s 130 | r 131 | s 132 | (Event (extop, r) :: nil) 133 | . 134 | 135 | Definition step := xstep. 136 | 137 | Definition initP := initP. 138 | 139 | End DeliverListTidAPI. 140 | Module DeliverListTidHAPI := HLayer DeliverListTidOp MailboxTmpAbsState DeliverListTidAPI UserIdx. 141 | 142 | 143 | Module DeliverListTidProtocol <: Protocol DeliverListTidOp MailboxTmpAbsState. 144 | 145 | Import DeliverListTidOp. 146 | Import MailboxTmpAbsState. 147 | 148 | Inductive xstep_allow : forall T, Op T -> nat -> State -> Prop := 149 | | AllowCreateWriteTmp : forall tid s data, 150 | xstep_allow (CreateWriteTmp data) tid s 151 | | AllowLinkMail : forall tid tmp mbox mailfn lock, 152 | ~ FMap.In (tid, mailfn) mbox -> 153 | xstep_allow (LinkMail mailfn) tid (mk_state tmp mbox lock) 154 | | AllowUnlinkTmp : forall tid s, 155 | xstep_allow (UnlinkTmp) tid s 156 | | AllowList : forall tid s, 157 | xstep_allow List tid s 158 | | AllowListTid : forall tid s, 159 | xstep_allow ListTid tid s 160 | | AllowRead : forall tid s fn, 161 | xstep_allow (Read fn) tid s 162 | | AllowDelete : forall tid s fn, 163 | xstep_allow (Delete fn) tid s 164 | | AllowLock : forall tid s, 165 | xstep_allow Lock tid s 166 | | AllowUnlock : forall tid s, 167 | xstep_allow Unlock tid s 168 | | AllowExt : forall tid s `(extop : _ T), 169 | xstep_allow (Ext extop) tid s 170 | . 171 | 172 | Definition step_allow := xstep_allow. 173 | 174 | Definition initP := MailboxTmpAbsState.initP. 175 | 176 | End DeliverListTidProtocol. 177 | Module DeliverListTidHProtocol := HProtocol DeliverListTidOp MailboxTmpAbsState DeliverListTidProtocol UserIdx. 178 | 179 | 180 | Module DeliverListTidRestrictedAPI <: Layer DeliverListTidOp MailboxTmpAbsState. 181 | 182 | Definition step := restricted_step DeliverListTidAPI.step DeliverListTidProtocol.step_allow. 183 | 184 | Definition initP := MailboxTmpAbsState.initP. 185 | 186 | End DeliverListTidRestrictedAPI. 187 | Module DeliverListTidRestrictedHAPI := HLayer DeliverListTidOp MailboxTmpAbsState DeliverListTidRestrictedAPI UserIdx. 188 | -------------------------------------------------------------------------------- /src/Mail/MailFSPathAbsAPI.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import MailServerAPI. 3 | Require Import MailFSStringAPI. 4 | 5 | Module MailFSPathAbsState <: State. 6 | 7 | Definition fs_contents := FMap.t (string * string) string. 8 | 9 | Record state_rec := mk_state { 10 | fs : fs_contents; 11 | locked : bool; 12 | }. 13 | 14 | Definition State := state_rec. 15 | Definition initP (s : State) := locked s = false /\ 16 | fs s = FMap.empty. 17 | 18 | End MailFSPathAbsState. 19 | Module MailFSPathAbsHState := HState MailFSPathAbsState UserIdx. 20 | 21 | 22 | Module MailFSPathAbsAPI <: Layer MailFSStringOp MailFSPathAbsState. 23 | 24 | Import MailFSStringOp. 25 | Import MailFSPathAbsState. 26 | 27 | Definition filter_dir (dirname : string) (fs : fs_contents) := 28 | FMap.filter (fun '(dn, fn) => if dn == dirname then true else false) fs. 29 | 30 | Definition drop_dirname (fs : fs_contents) := 31 | FMap.map_keys (fun '(dn, fn) => fn) fs. 32 | 33 | Lemma in_filter_dir_eq: forall dirname k s, 34 | FMap.In (dirname, k) s -> 35 | FMap.In (dirname, k) (filter_dir dirname s). 36 | Proof. 37 | intros. 38 | unfold filter_dir. 39 | apply FMap.filter_complete; auto. 40 | destruct (dirname == dirname); simpl in *; try congruence. 41 | Qed. 42 | 43 | Lemma filter_dir_in_eq: forall dirname k s, 44 | FMap.In (dirname, k) (filter_dir dirname s) -> 45 | FMap.In (dirname, k) s. 46 | Proof. 47 | intros. 48 | unfold filter_dir in *. 49 | eapply FMap.filter_in; eauto. 50 | Qed. 51 | 52 | Lemma in_drop_dirname_eq: forall dirname k s, 53 | FMap.In (dirname, k) (filter_dir dirname s) -> 54 | FMap.In k (drop_dirname (filter_dir dirname s)). 55 | Proof. 56 | intros. 57 | eapply FMap.map_keys_in in H. 58 | exact H. 59 | Qed. 60 | 61 | Lemma drop_dirname_in_eq: forall dirname k s, 62 | FMap.In k (drop_dirname (filter_dir dirname s)) -> 63 | FMap.In (dirname, k) (filter_dir dirname s). 64 | Proof. 65 | unfold drop_dirname, filter_dir. 66 | intros. 67 | eapply FMap.map_keys_in' in H; deex. 68 | destruct k'. 69 | eapply FMap.filter_holds in H as H'. 70 | destruct (s0 == dirname); congruence. 71 | Qed. 72 | 73 | Lemma drop_dirname_filter_dir: forall s dirname k, 74 | FMap.In k (drop_dirname (filter_dir dirname s)) -> 75 | FMap.In (dirname, k) s. 76 | Proof. 77 | intros. 78 | apply filter_dir_in_eq. 79 | apply drop_dirname_in_eq; auto. 80 | Qed. 81 | 82 | Lemma filter_dir_drop_dirname: forall s dirname k, 83 | FMap.In (dirname, k) s -> 84 | FMap.In k (drop_dirname (filter_dir dirname s)). 85 | Proof. 86 | intros. 87 | apply in_drop_dirname_eq. 88 | apply in_filter_dir_eq; auto. 89 | Qed. 90 | 91 | Inductive xstep : forall T, Op T -> nat -> State -> T -> State -> list event -> Prop := 92 | | StepCreateTmpOk : forall fs tid tmpfn lock, 93 | xstep (CreateTmp tmpfn) tid 94 | (mk_state fs lock) 95 | true 96 | (mk_state (FMap.add (tmp_string, tmpfn) empty_string fs) lock) 97 | nil 98 | 99 | | StepCreateTmpErr : forall fs tid tmpfn lock, 100 | xstep (CreateTmp tmpfn) tid 101 | (mk_state fs lock) 102 | false 103 | (mk_state fs lock) 104 | nil 105 | 106 | | StepWriteTmpOk : forall fs tid tmpfn data lock, 107 | FMap.MapsTo (tmp_string, tmpfn) empty_string fs -> 108 | xstep (WriteTmp tmpfn data) tid 109 | (mk_state fs lock) 110 | true 111 | (mk_state (FMap.add (tmp_string, tmpfn) data fs) lock) 112 | nil 113 | 114 | | StepWriteTmpErr1 : forall fs tid tmpfn data lock, 115 | xstep (WriteTmp tmpfn data) tid 116 | (mk_state fs lock) 117 | false 118 | (mk_state fs lock) 119 | nil 120 | | StepWriteTmpErr2 : forall fs tid tmpfn data data' lock, 121 | FMap.MapsTo (tmp_string, tmpfn) empty_string fs -> 122 | xstep (WriteTmp tmpfn data) tid 123 | (mk_state fs lock) 124 | false 125 | (mk_state (FMap.add (tmp_string, tmpfn) data' fs) lock) 126 | nil 127 | 128 | | StepUnlinkTmp : forall fs tid tmpfn lock, 129 | xstep (UnlinkTmp tmpfn) tid 130 | (mk_state fs lock) 131 | tt 132 | (mk_state (FMap.remove (tmp_string, tmpfn) fs) lock) 133 | nil 134 | | StepLinkMailOK : forall fs tid mailfn data tmpfn lock, 135 | FMap.MapsTo (tmp_string, tmpfn) data fs -> 136 | ~ FMap.In (mail_string, mailfn) fs -> 137 | xstep (LinkMail tmpfn mailfn) tid 138 | (mk_state fs lock) 139 | true 140 | (mk_state (FMap.add (mail_string, mailfn) data fs) lock) 141 | nil 142 | | StepLinkMailErr : forall fs tid mailfn tmpfn lock, 143 | xstep (LinkMail tmpfn mailfn) tid 144 | (mk_state fs lock) 145 | false 146 | (mk_state fs lock) 147 | nil 148 | 149 | | StepList : forall fs tid r lock, 150 | FMap.is_permutation_key r (drop_dirname (filter_dir mail_string fs)) -> 151 | xstep List tid 152 | (mk_state fs lock) 153 | r 154 | (mk_state fs lock) 155 | nil 156 | 157 | | StepGetTID : forall s tid, 158 | xstep GetTID tid 159 | s 160 | tid 161 | s 162 | nil 163 | | StepRandom : forall s tid r, 164 | xstep Random tid 165 | s 166 | r 167 | s 168 | nil 169 | 170 | | StepReadOK : forall fn fs tid m lock, 171 | FMap.MapsTo (mail_string, fn) m fs -> 172 | xstep (Read fn) tid 173 | (mk_state fs lock) 174 | (Some m) 175 | (mk_state fs lock) 176 | nil 177 | | StepReadNone : forall fn fs tid lock, 178 | ~ FMap.In (mail_string, fn) fs -> 179 | xstep (Read fn) tid 180 | (mk_state fs lock) 181 | None 182 | (mk_state fs lock) 183 | nil 184 | 185 | | StepDelete : forall fn fs tid lock, 186 | xstep (Delete fn) tid 187 | (mk_state fs lock) 188 | tt 189 | (mk_state (FMap.remove (mail_string, fn) fs) lock) 190 | nil 191 | 192 | | StepLock : forall fs tid, 193 | xstep Lock tid 194 | (mk_state fs false) 195 | tt 196 | (mk_state fs true) 197 | nil 198 | | StepUnlock : forall fs tid lock, 199 | xstep Unlock tid 200 | (mk_state fs lock) 201 | tt 202 | (mk_state fs false) 203 | nil 204 | 205 | | StepExt : forall s tid `(extop : extopT T) r, 206 | xstep (Ext extop) tid 207 | s 208 | r 209 | s 210 | (Event (extop, r) :: nil) 211 | . 212 | 213 | Definition step := xstep. 214 | 215 | Definition initP := initP. 216 | 217 | End MailFSPathAbsAPI. 218 | Module MailFSPathAbsHAPI := HLayer MailFSStringOp MailFSPathAbsState MailFSPathAbsAPI UserIdx. 219 | -------------------------------------------------------------------------------- /src/FS/MailServerProto.v: -------------------------------------------------------------------------------- 1 | Require Import CSPEC. 2 | Require Import FSModel. 3 | Require Import LinkAPI. 4 | Require Import FSAPI. 5 | Require Import MailServerAPI. 6 | Require Import MailServerLayers. 7 | 8 | Import ListNotations. 9 | Require Import String. 10 | Open Scope string. 11 | Open Scope list. 12 | 13 | 14 | (* 15 | Module MailProtoExperiment <: LayerImpl MailLinkAPI MailServerLinkAPI. 16 | *) 17 | 18 | Definition deliver (user : string) (m : message) : proc _ _ := 19 | cwd <- Call LinkGetRoot; 20 | tid <- Call GetTID; 21 | tmpname Ret (Some nil) 31 | | fn :: files' => 32 | msg deliver user msg 45 | | Read user => read user 46 | end. 47 | 48 | Ltac step_inv := 49 | match goal with 50 | | H : MailLinkAPI.step _ _ _ _ _ |- _ => 51 | inversion H; clear H; subst; repeat sigT_eq 52 | | H : MailServerLinkAPI.step _ _ _ _ _ |- _ => 53 | inversion H; clear H; subst; repeat sigT_eq 54 | | H : mailfs_step_allowed _ _ _ |- _ => 55 | inversion H; clear H; subst; repeat sigT_eq 56 | | H : LinkAPI.step _ _ _ _ _ |- _ => 57 | inversion H; clear H; subst; repeat sigT_eq 58 | | H : restricted_step _ _ _ _ _ _ _ |- _ => 59 | inversion H; clear H; subst; repeat sigT_eq 60 | end. 61 | 62 | Hint Extern 1 (MailLinkAPI.step _ _ _ _ _) => econstructor. 63 | Hint Extern 1 (MailServerLinkAPI.step _ _ _ _ _) => econstructor. 64 | Hint Extern 1 (LinkAPI.step _ _ _ _ _) => econstructor. 65 | Hint Constructors mailfs_step_allowed. 66 | 67 | 68 | Hint Constructors follows_protocol_proc. 69 | 70 | Theorem restricted_step_preserves_invariant : 71 | forall tid `(op : LinkAPI.Op T) s r s', 72 | restricted_step LinkAPI.step mailfs_step_allowed op tid s r s' -> 73 | invariant s -> 74 | invariant s'. 75 | Proof. 76 | intros. 77 | destruct H; intuition idtac; subst; eauto. 78 | repeat step_inv; eauto. 79 | - split. 80 | unfold unique_dir_pn. admit. 81 | unfold unique_pn_node. admit. 82 | - admit. 83 | - admit. 84 | - split. 85 | unfold unique_dir_pn. admit. 86 | unfold unique_pn_node. admit. 87 | Admitted. 88 | 89 | Theorem restricted_step_preserves_root : 90 | forall tid `(op : LinkAPI.Op T) s r s', 91 | restricted_step LinkAPI.step mailfs_step_allowed op tid s r s' -> 92 | FSRoot s = FSRoot s'. 93 | Proof. 94 | intros. 95 | destruct H; intuition idtac; subst; eauto. 96 | repeat step_inv; eauto. 97 | Qed. 98 | 99 | Theorem exec_others_preserves_invariant : 100 | forall tid s s', 101 | exec_others LinkAPI.step mailfs_step_allowed tid s s' -> 102 | invariant s -> 103 | invariant s'. 104 | Proof. 105 | induction 1; intros; eauto. 106 | repeat deex. 107 | clear H0. 108 | eapply IHclos_refl_trans_1n; clear IHclos_refl_trans_1n. 109 | clear H. 110 | eapply restricted_step_preserves_invariant; eauto. 111 | Qed. 112 | 113 | Theorem exec_others_preserves_root : 114 | forall tid s s', 115 | exec_others LinkAPI.step mailfs_step_allowed tid s s' -> 116 | FSRoot s = FSRoot s'. 117 | Proof. 118 | induction 1; intros; eauto. 119 | repeat deex. 120 | clear H0. 121 | rewrite <- IHclos_refl_trans_1n; clear IHclos_refl_trans_1n. 122 | clear H. 123 | eapply restricted_step_preserves_root; eauto. 124 | Qed. 125 | 126 | 127 | Ltac exec_propagate := 128 | match goal with 129 | (* 130 | | s : RawLockAPI.State |- _ => 131 | destruct s 132 | *) 133 | | H : exec_any _ _ _ _ (Call _) _ _ |- _ => 134 | eapply exec_any_op in H; repeat deex 135 | | H : exec_others _ _ _ ?s _, 136 | Hi : invariant ?s |- _ => 137 | eapply exec_others_preserves_invariant in Hi; [ | exact H ] 138 | | H : exec_others _ _ _ ?s _, 139 | Hi : context[FSRoot ?s] |- _ => 140 | rewrite (exec_others_preserves_root H) in Hi 141 | | H : restricted_step _ _ _ _ ?s _ _, 142 | Hi : invariant ?s |- _ => 143 | eapply restricted_step_preserves_invariant in Hi; [ | exact H ] 144 | end. 145 | 146 | Ltac clear_allowed := 147 | match goal with 148 | | H: mailfs_step_allowed _ _ _ |- _ => 149 | clear H 150 | end. 151 | 152 | Definition loopInv (s : FS) (tid : nat) := True. 153 | 154 | Lemma namei_maildir_user : 155 | forall s r user tid, 156 | r = FSRoot s -> 157 | follows_protocol_proc LinkAPI.step mailfs_step_allowed loopInv 158 | tid s (namei_spec (DirNode r) [maildir; user]). 159 | Proof. 160 | intros. 161 | constructor; intros. 162 | 163 | constructor. constructor; eauto. 164 | 165 | repeat exec_propagate. 166 | step_inv. clear_allowed. repeat step_inv. 167 | 168 | constructor. 169 | 170 | destruct target; try constructor; intros. 171 | constructor. eapply MailAllowLinkLookupMail. 172 | econstructor; eauto. constructor. 173 | 174 | repeat exec_propagate. 175 | step_inv. clear_allowed. repeat step_inv. 176 | 177 | constructor. 178 | constructor. 179 | Qed. 180 | 181 | Lemma read_follows_protocol : forall tid s user, 182 | follows_protocol_proc LinkAPI.step mailfs_step_allowed loopInv tid s (read user). 183 | Proof. 184 | intros. 185 | constructor; intros. 186 | constructor; intros. eauto. 187 | 188 | repeat exec_propagate. 189 | repeat step_inv. 190 | 191 | constructor; intros. 192 | constructor; intros. 193 | constructor; intros. 194 | eapply namei_maildir_user; eauto. 195 | 196 | destruct r; try constructor. 197 | destruct n; constructor. 198 | destruct r; try constructor. 199 | 200 | repeat exec_propagate. 201 | econstructor. 202 | 203 | constructor; intros. 204 | constructor; intros. 205 | 206 | constructor; intros. eauto. 207 | 208 | repeat exec_propagate. 209 | unfold restricted_step in *; intuition idtac; repeat step_inv. 210 | constructor; intros. 211 | constructor; intros. eauto. 212 | 213 | repeat exec_propagate. 214 | unfold restricted_step in *; intuition idtac; repeat step_inv. 215 | constructor; intros. 216 | constructor; intros. eauto. 217 | 218 | repeat exec_propagate. 219 | unfold restricted_step in *; intuition idtac; repeat step_inv. 220 | constructor; intros. 221 | Qed. 222 | 223 | 224 | Theorem compile_follows_protocol : forall s ts, 225 | ts_follows_protocol s (compile_ts compile_op ts). 226 | Admitted. 227 | 228 | Definition absR (s1 : LinkAPI.State) (s2 : MailLinkAPI.State) := 229 | s1 = s2. 230 | 231 | Theorem top_level : 232 | forall ts, 233 | traces_match_abs absR LinkAPI.initP LinkAPI.step MailLinkAPI.step 234 | (compile_ts compile_op ts) 235 | (compile_ts compile_op ts). 236 | Proof. 237 | unfold absR. 238 | unfold traces_match_abs; intros. 239 | subst. 240 | clear H. 241 | assert (ts_follows_protocol sm (compile_ts compile_op ts)). 242 | apply compile_follows_protocol. 243 | generalize dependent (compile_ts compile_op ts); intros. 244 | destruct H0. 245 | induction H0; intros; subst. 246 | - inversion H; clear H. 247 | edestruct H3; eauto. 248 | edestruct IHexec. 249 | eauto. 250 | intuition idtac. 251 | eexists; split. 252 | + eapply ExecOne with (tid := tid). 253 | eauto. 254 | eauto. 255 | eassumption. 256 | + eauto. 257 | - eauto. 258 | Qed. 259 | --------------------------------------------------------------------------------