import Control.Arrow
import Lattice
import FlowArrow
import System

type Protected a = FlowArrow TriLabel (->) () a
type Priv = Privilege TriLabel

liftA2 :: Arrow a => (b -> c -> d) 
       -> a e b -> a e c -> a e d
liftA2 op f g = proc x -> do
     y <- f -< x
     z <- g -< x
     returnA -< y `op` z

expects_medium :: Protected a -> Protected a 
expects_medium c = c >>> tag MEDIUM

tag_val :: a -> TriLabel -> Protected a
tag_val x l = pure (\y -> x) >>> tag l
cH = tag_val 3 HIGH
cM = tag_val 4 MEDIUM
cL = tag_val 5 LOW

t1 = liftA2 (+) cL cM
t2 = liftA2 (*) cH cM
t3 = proc () -> do
{
       h <- cH -< ();
       if h>3 then do { x <- cM -< ();
                        returnA -< x;
                      }
              else do { y <- t1 -< ();
                        returnA -< y;
                      }
}

success1 = expects_medium t1
failure2 = expects_medium t2
failure3 = expects_medium t3

output_med priv c =
  putStrLn $ show $ 
    cert priv (c >>> declassify MEDIUM LOW) ();
 
main = do
  let auth_db :: (Protected AuthDB) = 
        pure (\_-> [("admin","admin",HIGH)] ) 
        >>> tag HIGH
  let (ident,p) = authenticate auth_db "admin" "admin"
  output_med p success1
  output_med p failure3
  output_med p failure2