diff --git a/EnclaveIFC.cabal b/EnclaveIFC.cabal index 7450e37..2c9c90e 100644 --- a/EnclaveIFC.cabal +++ b/EnclaveIFC.cabal @@ -65,6 +65,27 @@ executable EnclaveIFC-exe , bytestring , network-simple , transformers + , time + , process + if (flag(enclave)) + cpp-options: -DENCLAVE + else + cpp-options: -DUMMY + default-language: Haskell2010 + +executable SecureWallet-exe + main-is: SecureWallet.hs + hs-source-dirs: examples/SecureWallet + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -main-is SecureWallet + build-depends: + EnclaveIFC + , base >=4.7 && <5 + , binary + , bytestring + , network-simple + , transformers + , time + , process if (flag(enclave)) cpp-options: -DENCLAVE else diff --git a/HasNoSGX.diff b/HasNoSGX.diff new file mode 100644 index 0000000..885781d --- /dev/null +++ b/HasNoSGX.diff @@ -0,0 +1,142 @@ +diff --git a/app/Main.hs b/app/Main.hs +index 86a436e..b293fe6 100644 +--- a/app/Main.hs ++++ b/app/Main.hs +@@ -7,10 +7,14 @@ import System.IO + import Text.Read + import Data.Binary + import GHC.Generics +- ++import Data.Time.Clock + + import App + ++import System.IO ++import Control.Exception ++ ++ + #ifdef ENCLAVE + import Server as API + #else +@@ -32,7 +36,7 @@ data ReturnCode + | ItemTooLong + | FailSeal + | FailUnseal +- deriving Generic ++ deriving (Generic, Show) + + instance Binary ReturnCode + +@@ -81,6 +85,35 @@ loadWallet = do + return $ (readMaybe contents :: Maybe Wallet) + else return Nothing + ++dFx :: IO Bool ++dFx = (openFile fp ReadMode >>= hClose >> return True) `catch` \ex -> let e = ex :: SomeException ++ in return False ++ where fp = "db/wallet.seal.pf" ++ ++rF :: String -> IO String ++rF fp = (do handle <- openFile fp ReadMode ++ contents <- hGetContents' handle ++ hClose handle ++ return contents) ++ where ++ hGetContents' :: Handle -> IO String ++ hGetContents' h = do ++ eof <- hIsEOF h ++ if eof ++ then ++ return [] ++ else do ++ c <- hGetChar h ++ fmap (c:) $ hGetContents' h ++ ++loadWallet' :: IO (Maybe Wallet) ++loadWallet' = do ++ b <- dFx ++ if b ++ then do contents <- rF "db/wallet.seal.pf" ++ return (readMaybe contents :: Maybe Wallet) ++ else return Nothing ++ + saveWallet :: Wallet -> Server ReturnCode + saveWallet w = API.writeFile wallet (show w) >> return Success + +@@ -145,6 +178,20 @@ showItem mp title' username' = do + let singleton = filter (\t -> title t == title' && username t == username') items + in password (head singleton) + ++sI :: Password -> String -> String -> IO (Either ReturnCode Password) ++sI mp title' username' = do ++ w <- loadWallet' ++ case w of ++ Nothing -> return $ Left CannotLoadWallet ++ Just w | not (itemExists title' username' (items w)) -> return $ Left ItemDoesNotExist ++ Just w | not (masterPassword w == mp) -> return $ Left WrongMasterPassword ++ Just w -> return $ Right (findPass title' username' (items w)) ++ where ++ findPass :: String -> String -> [Item] -> Password ++ findPass title' username' items = ++ let singleton = filter (\t -> title t == title' && username t == username') items ++ in password (head singleton) ++ + itemExists :: String -> String -> [Item] -> Bool + itemExists title' uname items = + any (\t -> title t == title' && username t == uname) items +@@ -183,6 +230,12 @@ data Command + clientApp :: Api -> Client () + clientApp api = do + cmd <- getCommand ++ codeOrPass <- hC cmd ++ case codeOrPass of ++ Left code -> liftIO $ putStrLn $ show code ++ Right pass -> liftIO $ putStrLn pass ++ ++ {- + case cmd of + Shutoff -> return () + Create mp -> do +@@ -202,6 +255,7 @@ clientApp api = do + case p of + Left code -> printCode code + Right pass -> liftIO $ putStrLn pass ++ -} + + getCommand :: Client Command + getCommand = do +@@ -224,6 +278,15 @@ getCommand = do + usage :: String -> Client () + usage str = liftIO $ putStrLn $ "" ++ " : " ++ str + ++hC :: Command -> IO (Either ReturnCode String) ++hC cmd = case cmd of ++ Create s -> fmap Left $ return PasswordOutOfRange ++ Change s str -> fmap Left $ return PasswordOutOfRange ++ Add s str cs s' -> fmap Left $ return ItemTooLong ++ Remove s str cs -> fmap Left $ return CannotLoadWallet ++ Show s str cs -> sI s str cs ++ Shutoff -> return $ Left Success ++ + printCode :: ReturnCode -> Client () + printCode Success = liftIO $ putStrLn $ "# ok" + printCode PasswordOutOfRange = liftIO $ putStrLn $ "= password out of range" +@@ -238,7 +301,17 @@ printCode ItemTooLong = liftIO $ putStrLn $ "= item is too long" + printCode FailSeal = liftIO $ putStrLn $ "= failure while sealing wallet" + printCode FailUnseal = liftIO $ putStrLn $ "= failure while unsealing wallet" + ++ ++ ++timeit::IO Done -> IO NominalDiffTime ++timeit doit=do ++ start <- getCurrentTime ++ doit ++ end <- getCurrentTime ++ return (diffUTCTime end start) ++ + main :: IO () + main = do +- res <- runApp app ++ res <- timeit $ runApp app ++ putStrLn $ "Time : " ++ show res + return $ res `seq` () diff --git a/app/Denotation.hs b/app/Denotation.hs new file mode 100644 index 0000000..585149d --- /dev/null +++ b/app/Denotation.hs @@ -0,0 +1,27 @@ +module Denotation where + +import qualified Data.Map as Map + +type Var = String + +supply :: [Var] +supply = map ((++) "v" . show) [0..] + +fresh :: Int -> Var +fresh i = supply !! i + +type Store = (Map.Map Var Int, Map.Map Var Int) + +data Instruction + = ServerConstant Int + | Bind Instruction (Var -> Instruction) + +type StoreT = (Int,Store) -> (Int,Store,Var) + +eval :: Instruction -> StoreT +eval (ServerConstant x) = \(i, (tm, um)) -> + let v = fresh i + in (i+1, Map.insert v x tm, um, v) +eval (Bind ins f) = \(i, tm, um)) -> + let (i',(tm', um'),v) = eval ins (i, tm, um) + in eval (f (i, (tm', um'), v)) diff --git a/app/Main.hs b/app/Main.hs index 4eec4d5..9190026 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,69 +1,300 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP #-} module Main where import Control.Monad.IO.Class(liftIO) -import Data.List(genericLength) -import GHC.Float(int2Float) +import Text.Read ( readMaybe ) +import Data.Binary +import GHC.Generics +import Data.Time.Clock + +import System.IO +import Control.Exception +import System.Process + import App #ifdef ENCLAVE -import Server +import Server as API #else -import Client +import Client as API #endif +-- * Return codes + +data ReturnCode + = Success | PasswordOutOfRange | WalletAlreadyExists | CannotSaveWallet | CannotLoadWallet + | WrongMasterPassword | WalletFull | ItemDoesNotExist | ItemAlreadyExists | ItemTooLong + | FailSeal | FailUnseal deriving (Generic, Show) + +instance Binary ReturnCode + +-- * Static values + +maxItems :: Int +maxItems = 100 + +maxItemSize :: Int +maxItemSize = 100 + +wallet :: SecureFilePath +wallet = createSecurePath "wallet.seal.pf" + +-- * Data types +-- | A single entry of authentication tokens +data Item = Item + { title :: String + -- ^ Title of the online service, e.g Twitter, Youtune + , username :: String + , password :: String + } + deriving (Show, Read) -getData :: Server (Ref (Sec [Int])) -> Int -> Server Int -getData serv_secret idx = do - secret <- serv_secret - sech <- readRef secret - let sec_i = fmap (\s -> s !! idx) sech - return (declassify sec_i) +-- | The secure wallet +data Wallet = Wallet + { items :: [Item] + -- ^ All authentication tokens + , size :: Int + -- ^ The size of the wallet + , masterPassword :: String + -- ^ The master password that unlocks the wallet + } + deriving (Show, Read) -releaseAvg :: Server (Ref Bool) -> Server () -releaseAvg sbool = do - bool <- sbool - writeRef bool True +newWallet :: Password -> Wallet +newWallet mp = Wallet [] 0 mp -doAvg :: [Int] -> Float -doAvg xs = realToFrac (sum xs) / genericLength xs +type Password = String -getAvg :: Server (Ref Bool) -> Server (Ref (Sec [Int])) -> Server Float -getAvg serv_bool serv_secret = do - bool <- serv_bool - secret <- serv_secret - b <- readRef bool +-- * Enclave code + +passwordPolicy :: Password -> Bool +passwordPolicy pass = length pass >= 8 && length pass + 1 <= maxItemSize + +loadWallet :: Server (Maybe Wallet) +loadWallet = do + b <- API.doesSecureFileExist wallet if b - then do - s <- readRef secret - let s' = declassify s - let avg = doAvg s' - return avg - else return 0.0 + then do contents <- API.readSecureFile wallet + return $ (readMaybe contents :: Maybe Wallet) + else return Nothing + + +dFx :: IO Bool +dFx = (openFile fp ReadMode >>= hClose >> return True) `catch` \ex -> let e = ex :: SomeException + in return False + where fp = "db/wallet.seal.pf" + +rF :: String -> IO String +rF fp = (do handle <- openFile fp ReadMode + contents <- hGetContents' handle + hClose handle + return contents) + where + hGetContents' :: Handle -> IO String + hGetContents' h = do + eof <- hIsEOF h + if eof + then + return [] + else do + c <- hGetChar h + fmap (c:) $ hGetContents' h + +loadWallet' :: IO (Maybe Wallet) +loadWallet' = do + b <- dFx + if b + then do contents <- rF "db/wallet.seal.pf" + return (readMaybe contents :: Maybe Wallet) + else return Nothing + +saveWallet :: Wallet -> Server ReturnCode +saveWallet w = API.writeSecureFile wallet (show w) >> return Success +-- | Create a new password wallet +createWallet :: Password -> Server ReturnCode +createWallet mp | not $ passwordPolicy mp = return PasswordOutOfRange + | otherwise = do w <- loadWallet -- does a wallet already exist? + case w of + Just _ -> return WalletAlreadyExists + Nothing -> saveWallet (newWallet mp) -printCl :: String -> Client () -printCl = liftIO . putStrLn +changeMasterPassword :: Password -> Password -> Server ReturnCode +changeMasterPassword old new + | not $ passwordPolicy new = return PasswordOutOfRange + | otherwise = do + w <- loadWallet + case w of + Nothing -> return CannotLoadWallet + Just w -> if masterPassword w == old + then saveWallet (w { masterPassword = new }) + else return WrongMasterPassword + +addItem :: Password -> String -> String -> Password -> Server ReturnCode +addItem mp item username pass + | length item + 1 > maxItemSize || + length username + 1 > maxItemSize || + length pass + 1 > maxItemSize = return ItemTooLong + | otherwise = do + w <- loadWallet + case w of + Nothing -> return CannotLoadWallet + Just w | not (masterPassword w == mp) -> return WrongMasterPassword + Just w | itemExists item username (items w) -> return ItemAlreadyExists + Just w -> saveWallet (w { items = (Item item username pass) : items w, size = size w + 1}) + +removeItem :: Password -> String -> String -> Server ReturnCode +removeItem mp title' username' = do + w <- loadWallet + case w of + Nothing -> return CannotLoadWallet + Just w | not (itemExists title' username' (items w)) -> return ItemDoesNotExist + Just w | not (masterPassword w == mp) -> return WrongMasterPassword + Just w -> let newitems = removeItem' title' username' (items w) + in saveWallet (w { items = newitems, size = size w - 1}) + where + removeItem' :: String -> String -> [Item] -> [Item] + removeItem' title' uname items = + filter (\t -> title t /= title' && username t /= uname) items + +showItem :: Password -> String -> String -> Server (Either ReturnCode Password) +showItem mp title' username' = do + w <- loadWallet + case w of + Nothing -> return $ Left CannotLoadWallet + Just w | not (itemExists title' username' (items w)) -> return $ Left ItemDoesNotExist + Just w | not (masterPassword w == mp) -> return $ Left WrongMasterPassword + Just w -> return $ Right (findPass title' username' (items w)) + where + findPass :: String -> String -> [Item] -> Password + findPass title' username' items = + let singleton = filter (\t -> title t == title' && username t == username') items + in password (head singleton) + +sI :: Password -> String -> String -> IO (Either ReturnCode Password) +sI mp title' username' = do + w <- loadWallet' + case w of + Nothing -> return $ Left CannotLoadWallet + Just w | not (itemExists title' username' (items w)) -> return $ Left ItemDoesNotExist + Just w | not (masterPassword w == mp) -> return $ Left WrongMasterPassword + Just w -> return $ Right (findPass title' username' (items w)) + where + findPass :: String -> String -> [Item] -> Password + findPass title' username' items = + let singleton = filter (\t -> title t == title' && username t == username') items + in password (head singleton) + +itemExists :: String -> String -> [Item] -> Bool +itemExists title' uname items = + any (\t -> title t == title' && username t == uname) items + +handleCommand :: Command -> Server (Either ReturnCode String) +handleCommand cmd = case cmd of + Create s -> fmap Left $ createWallet s + Change s str -> fmap Left $ changeMasterPassword s str + Add s str cs s' -> fmap Left $ addItem s str cs s' + Remove s str cs -> fmap Left $ removeItem s str cs + Show s str cs -> showItem s str cs + Shutoff -> return $ Left Success + +hC :: Command -> IO (Either ReturnCode String) +hC cmd = case cmd of + Create s -> fmap Left $ return PasswordOutOfRange + Change s str -> fmap Left $ return PasswordOutOfRange + Add s str cs s' -> fmap Left $ return ItemTooLong + Remove s str cs -> fmap Left $ return CannotLoadWallet + Show s str cs -> sI s str cs + Shutoff -> return $ Left Success + +-- * The application + +data Api = Api { execute :: Remote (Command -> Server (Either ReturnCode String)) } app :: App Done app = do - remoteSec1 <- liftNewRef (sec [15,30,11,6]) :: App (Server (Ref (Sec [Int]))) - remoteSec2 <- liftNewRef False :: App (Server (Ref Bool)) - gD <- remote $ getData remoteSec1 - rA <- remote $ releaseAvg remoteSec2 - gA <- remote $ getAvg remoteSec2 remoteSec1 - runClient $ do - data1 <- onServer (gD <.> 3) - _ <- onServer rA - avg <- onServer gA - let b = dummyCompOnData data1 avg - printCl $ "Is data less than avg? " <> show b + execute <- remote handleCommand + runClient $ clientApp $ Api execute + +-- | Commands exposed by the password wallet +data Command + = Create Password + -- ^ Create a new wallet with the given master password + | Change Password Password + -- ^ Change the master password + | Add Password String String Password + -- ^ Add an item to the password wallet + | Remove Password String String + -- ^ Remove an item from the password wallet + | Show Password String String + -- ^ Retrieve a password from the password wallet + | Shutoff + -- ^ No-op + deriving Show + +instance Binary Command where + put (Create pw) = put (1 :: Word8) >> put pw + put (Change pw npw) = put (2 :: Word8) >> put pw >> put npw + put (Add pw title uname pass) = put (3 :: Word8) >> put pw >> put title >> put uname >> put pass + put (Remove pw title uname) = put (4 :: Word8) >> put pw >> put title >> put uname + put (Show pw title uname) = put (5 :: Word8) >> put pw >> put title >> put uname + put Shutoff = put (6 :: Word8) + + get = do + c <- get :: Get Word8 + case c of + 1 -> Create <$> get + 2 -> Change <$> get <*> get + 3 -> Add <$> get <*> get <*> get <*> get + 4 -> Remove <$> get <*> get <*> get + 5 -> Show <$> get <*> get <*> get + 6 -> return Shutoff + _ -> error "unrecognized command" + +clientApp :: Api -> Client () +clientApp api = do + cmd <- getCommand + runCommand shell -- decrypt + --codeOrPass <- onServer $ execute api <.> cmd + codeOrPass <- hC cmd + --let codeOrPass = Right "strongpassword" :: Either ReturnCode Password + case codeOrPass of + Left code -> liftIO $ putStrLn $ show code + Right pass -> liftIO $ putStrLn pass + where + shell = "gpg --batch --output db/wallet.seal.pf --passphrase mypassword --decrypt db/wallet.gpg" + +getCommand :: Client Command +getCommand = do + input <- liftIO $ getContents + case input of + [] -> return Shutoff + s -> case tryParse s of + Just c -> return c + Nothing -> return Shutoff where - dummyCompOnData i av = int2Float i < av + tryParse :: String -> Maybe Command + tryParse input = case words input of + ["-create", mp] -> Just (Create mp) + ["-p", old, "-c", new] -> Just (Change old new) + [ "-p", mp, "-a", "-title", title, "-username", username, "-password", password] -> Just (Add mp title username password) + [ "-p", mp, "-r", "-title", title, "-username", username] -> Just (Remove mp title username) + [ "-p", mp, "-s", "-title", title, "-username", username] -> Just (Show mp title username) + [ "-shutoff"] -> Just Shutoff + _ -> Nothing + +timeit :: IO Done -> IO NominalDiffTime +timeit doit=do + start <- getCurrentTime + doit + end <- getCurrentTime + return (diffUTCTime end start) main :: IO () main = do - res <- runApp app + res <- timeit $ runApp app + putStrLn $ "Time : " ++ show res return $ res `seq` () diff --git a/benchmarks.md b/benchmarks.md new file mode 100644 index 0000000..08aa672 --- /dev/null +++ b/benchmarks.md @@ -0,0 +1,60 @@ +#### Response Time for password retrieval (involves file read as well) + +Time is measure in seconds + +Note the non-SGX Haskell file is unencrypted + +Average numbers for non-SGX Haskell + encryption ~ 0.0006-0.0008; encryption (gpg) adds 0.0002 + +HasTEE + SGX | Haskell (no SGX) | C (with SGX) +------------------------------------------------ +0.069940556 | 0.000294702 | +0.068725749 | 0.000281502 | +0.067006642 | 0.000269602 | +0.066853754 | 0.000269502 | +0.065263212 | 0.000263302 | +0.067077723 | 0.000273002 | +0.065565735 | 0.000270201 | +0.066263339 | 0.000267401 | +0.069965863 | 0.000278902 | +0.067200845 | 0.000266402 | +0.066725642 | 0.000261902 | +0.066660041 | 0.000669205 | +0.064793828 | 0.000265201 | +0.067570645 | 0.000270102 | +0.066741938 | 0.000346202 | +0.066609036 | 0.000265802 | +0.069043651 | 0.000265202 | +0.064523418 | 0.000271402 | +0.068659852 | 0.000312402 | +0.068592748 | 0.000316202 | +0.065454141 | 0.000267502 | +0.068226754 | 0.000277202 | +0.068951357 | 0.000265802 | + + +##### Memory usage + +ps aux | grep gramine +syrupy.py -p <> + +pidstat -h -r -u -v -p 2070798 1 +sample every 1 second for pid 2070798 + +pmap <> | tail -n 1 +287920 KB - 287.92 MB +287924 KB - 287.92 MB + +ps +-- +RSS - RSS is Resident Set Size. This is the size of memory that a process has currently used to load all of its pages. At first glance, it may seem like the RSS number is the real amount of physical memory that a system process is using. However, shared libraries are counted for each process, making the reported amount of physical memory usage less accurate. + +Vsize - VSZ is Virtual Memory Size. This is the size of memory that Linux has given to a process, but it doesn’t necessarily mean that the process is using all of that memory. The VSZ size you see has taken all of these pages into consideration, but it doesn’t mean they’ve been loaded into physical memory. + +Wallet app +---------- + RSS Vsize +at rest 19132KB 287920KB +peak 20796KB 290032KB + +No disk swapping \ No newline at end of file diff --git a/client.sh b/client.sh index fa0fccf..11dac1a 100755 --- a/client.sh +++ b/client.sh @@ -1 +1,4 @@ -cabal run EnclaveIFC-exe --project-file=cabal-nosgx.project +if [ $# -eq 0 ] + then cabal run EnclaveIFC-exe --project-file=cabal-nosgx.project + else echo "$@" | cabal run EnclaveIFC-exe --project-file=cabal-nosgx.project +fi diff --git a/db/gpg b/db/gpg new file mode 100644 index 0000000..e69de29 diff --git a/db/secretfile.gpg b/db/secretfile.gpg new file mode 100644 index 0000000..9799d38 --- /dev/null +++ b/db/secretfile.gpg @@ -0,0 +1,2 @@ +  uSB'HUQsuokEx~ +J!NVp!|=,,+ \ No newline at end of file diff --git a/db/wallet.gpg b/db/wallet.gpg new file mode 100644 index 0000000..69b6cfe --- /dev/null +++ b/db/wallet.gpg @@ -0,0 +1 @@ +  iyHG.ҫ&,inDY_2vVP{Uڍc@%/)iے!Ac>5F k%lqt-^VXg{O ڵC6<=p/Xy!fJSr;=yD &;l̍7C_.`6so \ No newline at end of file diff --git a/db/wallet.seal.pf b/db/wallet.seal.pf new file mode 100644 index 0000000..2c8089b --- /dev/null +++ b/db/wallet.seal.pf @@ -0,0 +1 @@ +Wallet {items = [Item {title = "youtube", username = "rewbert", password = "strongpassword"}], size = 1, masterPassword = "abhiroop"} \ No newline at end of file diff --git a/db/wallet.seal.pf1 b/db/wallet.seal.pf1 new file mode 100644 index 0000000..2c8089b --- /dev/null +++ b/db/wallet.seal.pf1 @@ -0,0 +1 @@ +Wallet {items = [Item {title = "youtube", username = "rewbert", password = "strongpassword"}], size = 1, masterPassword = "abhiroop"} \ No newline at end of file diff --git a/examples/SecureWallet/SecureWallet.hs b/examples/SecureWallet/SecureWallet.hs new file mode 100644 index 0000000..12e3663 --- /dev/null +++ b/examples/SecureWallet/SecureWallet.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +module SecureWallet where + +import App + +#ifdef ENCLAVE +import Server +#else +import Client +#endif + +-- * Return codes + +retSuccess, passwordOutOfRange, walletAlreadyExists :: Int +retSuccess = 0 +passwordOutOfRange = 1 +walletAlreadyExists = 2 + +cannotSaveWallet, cannotLoadWallet, wrongMasterPassword :: Int +cannotSaveWallet = 3 +cannotLoadWallet = 4 +wrongMasterPassword = 5 + +walletFull, itemDoesNotExist, itemTooLong, failSeal, failUnseal :: Int +walletFull = 6 +itemDoesNotExist = 7 +itemTooLong = 8 +failSeal = 9 +failUnseal = 10 + +-- * Static values + +maxItems :: Int +maxItems = 100 + +maxItemSize :: Int +maxItemSize = 100 + +wallet :: String +wallet = "wallet.seal" + +-- * Data types + +data Item = Item + { title :: String + , username :: String + , password :: String + } + +data Wallet = Wallet + { items :: [Item] + , size :: Int + , masterPassword :: String + } + +newWallet :: Password -> Wallet +newWallet mp = Wallet [] 0 mp + +type Password = String + +-- * Enclave code + +passwordPolicy :: Password -> Bool +passwordPolicy pass = length pass >= 8 && length pass + 1 <= maxItemSize + +createWallet :: Server (Ref (Maybe Wallet)) -> Password -> Server Int +createWallet srw mp + | not $ passwordPolicy mp = return passwordOutOfRange + | otherwise = do + w <- readRef =<< srw + case w of + Just _ -> return walletAlreadyExists + Nothing -> srw >>= \r -> writeRef r (Just $ newWallet mp) >> return retSuccess + +changeMasterPassword :: Server (Ref (Maybe Wallet)) -> Password -> Password -> Server Int +changeMasterPassword srw old new + | not $ passwordPolicy new = return passwordOutOfRange + | otherwise = do + w <- readRef =<< srw + if masterPassword w == old + then do r <- srw + writeRef r (Just $ w { masterPassword = new }) + return retSuccess + else return wrongMasterPassword + +addItem :: Server (Ref (Maybe Wallet)) -> Password -> String -> String -> Password -> Server Int +addItem srw mp item username pass + | length item + 1 > maxItemSize || + length username + 1 > maxItemSize || + length password + 1 > maxItemSize = return itemTooLong + | otherwise = do + w <- readRef =<< srw + case w of + Nothing -> return cannotLoadWallet + Just w -> + if masterPassword w == mp + then do r <- srw + writeRef r (Just $ w { items = (Item item username pass) : items w, size = size w + 1}) + return retSuccess + else return wrongMasterPassword + +removeItem :: Server (Ref (Maybe Wallet)) -> Password -> String -> Server Int +removeItem srw mp item = do + w <- readRef =<< srw + case w of + Nothing -> return cannotLoadWallet + Just w | not (item `elem` (map title (items w))) -> return itemDoesNotExist + Just w | not (masterPassword w == mp) -> return wrongMasterPassword + Just w -> do r <- srw + writeRef r $ Just $ w { items = filter (not . (==) item . title) items, size = size w - 1} + return retSuccess + +-- * The application + +data Api = Api + { create :: Server Int + , changePass :: Password -> Password -> Server Int + , add :: String -> String -> Password -> Server Int + , remove :: String -> Server Int} + +app :: App Done +app = do + -- The data + walletref <- liftNewRef Nothing + + -- The api + create <- remote $ createWallet walletref + changePass <- remote $ changeMasterPassword walletref + add <- remote $ addItem walletref + remove <- remote $ removeItem walletref + + -- Client code + runClient $ clientApp $ Api create changePass add remove + +data Command + = Create + | Change Password Password + | Add String String Password + | Remove String + | Shutoff + +clientApp :: Api -> Client () +clientApp api = do + cmd <- getCommand + case cmd of + Shutoff -> liftIO (putStrLn "turning off...") >> return () + _ -> r <- onServer $ case cmd of + Create -> create api + Change old new -> change api old new + Add title username password -> add api title username password + Remove title -> remove api title + printCode r + +getCommand :: Client Command +getCommand = do + liftIO $ putStr ">" + input <- liftIO $ getLine + case input of + [] -> getCommand + s -> case tryParse s of + Just c -> return C + Nothing -> getCommand + where + tryParse :: String -> Just Command + tryParse input = case words input of + ["create"] -> Just Create + ["change", old, new] -> Just $ Change old new + ["add", title, username, password] -> Just $ Add title username password + ["remote", title] -> Just $ Remove title + ["shutoff"] -> Just Shutoff + otherwise -> Nothing + +printCode :: Int -> Client () +printCode c + | c == retSuccess = liftIO $ putStrLn $ "# ok" + | c == passwordOutOfRange = liftIO $ putStrLn $ "= password out of range" + | c == walletAlreadyExists = liftIO $ putStrLn $ "= wallet already exists" + | c == cannotSaveWallet = liftIO $ putStrLn $ "= cannot save wallet" + | c == cannotLoadWallet = liftIO $ putStrLn $ "= cannot load wallet" + | c == wrongMasterPassword = liftIO $ putStrLn $ "= wrong master password" + | c == walletFull = liftIO $ putStrLn $ "= wallet is full" + | c == itemDoesNotExists = liftIO $ putStrLn $ "= item does not exist" + | c == itemTooLong = liftIO $ putStrLn $ "= item is too long" + | c == failSeal = liftIO $ putStrLn $ "= failure while sealing wallet" + | c == failUnseal = liftIO $ putStrLn $ "= failure while unsealing wallet" + +main :: IO () +main = do + res <- runApp app + return $ res `seq` () diff --git a/src/Client.hs b/src/Client.hs index 950f929..9256019 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -58,6 +58,37 @@ readRef _ = ServerDummy writeRef :: Ref a -> a -> Server () writeRef _ _ = ServerDummy +writeFile :: String -> String -> Server () +writeFile _ _ = ServerDummy + +readFile :: String -> Server String +readFile _ = ServerDummy + +doesFileExist :: String -> Server Bool +doesFileExist _ = ServerDummy + +unsafePrint :: String -> Server () +unsafePrint _ = ServerDummy + +-- + +securePath :: String +securePath = "" + +data SecureFilePath = SecureFilePath String + +createSecurePath :: FilePath -> SecureFilePath +createSecurePath fp = SecureFilePath $ securePath <> fp + +readSecureFile :: SecureFilePath -> Server String +readSecureFile (SecureFilePath fp) = Client.readFile fp + +writeSecureFile :: SecureFilePath -> String -> Server () +writeSecureFile (SecureFilePath fp) str = Client.writeFile fp str + +doesSecureFileExist :: SecureFilePath -> Server Bool +doesSecureFileExist (SecureFilePath fp) = Client.doesFileExist fp +-- type Client = IO diff --git a/src/Server.hs b/src/Server.hs index c4e0bbf..55a8c77 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -9,12 +9,13 @@ module Server(module Server) where import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict +import Control.Exception import Data.Binary(Binary, encode, decode) import Data.ByteString.Lazy(ByteString) import Data.IORef import Data.Maybe import Network.Simple.TCP -import System.IO(hFlush, stdout) +import System.IO import App import qualified Data.ByteString.Lazy as B @@ -42,6 +43,8 @@ data Remote a = RemoteDummy serverConstant :: a -> App (Server a) serverConstant = return . return +-- * Reference management + liftNewRef :: a -> App (Server (Ref a)) liftNewRef a = App $ do r <- liftIO $ newIORef a @@ -56,6 +59,56 @@ readRef ref = Server $ readIORef ref writeRef :: Ref a -> a -> Server () writeRef ref v = Server $ writeIORef ref v +writeFile :: String -> String -> Server () +writeFile fp contents = Server (Prelude.writeFile fp contents) + +readFile :: String -> Server String +readFile fp = Server (do handle <- openFile fp ReadMode + contents <- hGetContents' handle + hClose handle + return contents) + where + hGetContents' :: Handle -> IO String + hGetContents' h = do + eof <- hIsEOF h + if eof + then + return [] + else do + c <- hGetChar h + fmap (c:) $ hGetContents' h + +doesFileExist :: String -> Server Bool +doesFileExist fp = Server $ + (openFile fp ReadMode >>= hClose >> return True) `catch` \ex -> let e = ex :: SomeException + in return False + +unsafePrint :: String -> Server () +unsafePrint str = Server $ putStrLn str + +-- * Secure file io + +securePath :: String +securePath = "db/" + +data SecureFilePath = SecureFilePath String + +createSecurePath :: FilePath -> SecureFilePath +createSecurePath fp = SecureFilePath $ securePath <> fp + +readSecureFile :: SecureFilePath -> Server String +readSecureFile (SecureFilePath fp) = Server.readFile fp + +writeSecureFile :: SecureFilePath -> String -> Server () +writeSecureFile (SecureFilePath fp) str = Server.writeFile fp str + +doesSecureFileExist :: SecureFilePath -> Server Bool +doesSecureFileExist (SecureFilePath fp) = Server.doesFileExist fp + +-- + +-- * Other stuff + remote :: (Remotable a) => a -> App (Remote a) remote f = App $ do (next_id, remotes) <- get