import Control.Arrow
import Lattice
import FlowArrow
import System

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

getNumber :: IO Int
getNumber = do 
{ 
  line <- getLine;
  case reads line of
      [] -> return 0;
      (i,_):s -> return i;
}

guest_service :: Priv -> 
      (Protected Int) -> IO (Protected Int)
guest_service priv stat = do 
{
  putStrLn "Enter a number:";
  i <- getNumber;
  putStrLn "Thank you";
  let stat' = proc () -> do 
    {   
      x <- stat -< ();
      if i>x then returnA -< i 
             else returnA -< x;
    } 
  ;
  return stat';
}

admin_service :: Priv -> 
      (Protected Int) -> IO (Protected Int)
admin_service priv stat = do
{
  let low = stat >>> (declassify HIGH LOW) in
  let summary = cert priv low () in
  putStrLn (show summary);

  let stat_new = (pure (\_->0) >>> tag HIGH) in
  return stat_new;
}

service_loop :: (Protected AuthDB) -> 
                (Protected Int) -> IO ()
service_loop auth_db stat = do
{
  putStrLn "Enter username and password:";
  u <- getLine; p <- getLine;
  let (ident,priv) = authenticate auth_db u p
  ;
  stat_new <- case ident of 
    "admin" -> admin_service priv stat;
    "guest" -> guest_service priv stat;
     _ -> do { 
               putStrLn "login error"; 
               return stat;
             }
  ; 
  service_loop auth_db stat_new;
}

main = do
{
  let auth_db :: (Protected AuthDB) = 
       (
         pure (\_-> [("admin","admin",HIGH), 
                     ("guest","guest",LOW)] ) >>> 
         tag HIGH
       )
      secret_val :: (Protected Int) = 
       (   
          pure (\_->0) >>> 
          tag HIGH
       )
  in
  service_loop auth_db secret_val;
}