summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-06-02 20:29:35 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2019-06-04 21:35:37 +0200
commit394d35d586fba3db55217e1e9f1e88e8bc8a0719 (patch)
tree9af6c1a33c53f9d0906ce6dd8b365682d307b37a /src/Main.hs
parent61595dec8bfd7d74e7cd2f3500eec86c08eff436 (diff)
Partial and memory-backed storage variants
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs48
1 files changed, 21 insertions, 27 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 59e6d5c..b42c3cf 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,7 +1,6 @@
module Main (main) where
import Control.Concurrent
-import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
@@ -18,7 +17,6 @@ import Data.Time.LocalTime
import System.Console.Haskeline
import System.Environment
import System.IO
-import System.IO.Error
import Identity
import Message
@@ -43,36 +41,32 @@ instance Storable Erebos where
loadErebosHead :: Storage -> IO Head
-loadErebosHead st = do
- catchJust (guard . isDoesNotExistError) (loadHead st "erebos") $ \_ -> do
- putStr "Name: "
- hFlush stdout
- name <- T.getLine
-
- (secret, public) <- generateKeys st
- (_secretMsg, publicMsg) <- generateKeys st
- (devSecret, devPublic) <- generateKeys st
- (_devSecretMsg, devPublicMsg) <- generateKeys st
-
- owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
- identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
- wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
-
- msgs <- emptySList st
- let erebos = Erebos
- { erbIdentity = identity
- , erbMessages = msgs
- }
-
- Right h <- replaceHead erebos (Left (st, "erebos"))
- return h
+loadErebosHead st = loadHeadDef st "erebos" $ do
+ putStr "Name: "
+ hFlush stdout
+ name <- T.getLine
+
+ (secret, public) <- generateKeys st
+ (_secretMsg, publicMsg) <- generateKeys st
+ (devSecret, devPublic) <- generateKeys st
+ (_devSecretMsg, devPublicMsg) <- generateKeys st
+
+ owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
+ identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
+ wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
+
+ msgs <- emptySList st
+ return $ Erebos
+ { erbIdentity = identity
+ , erbMessages = msgs
+ }
updateErebosHead_ :: Storage -> (Stored Erebos -> IO (Stored Erebos)) -> IO ()
updateErebosHead_ st f = updateErebosHead st (fmap (,()) . f)
updateErebosHead :: Storage -> (Stored Erebos -> IO (Stored Erebos, a)) -> IO a
updateErebosHead st f = do
- erebosHead <- loadHead st "erebos"
+ Just erebosHead <- loadHead st "erebos"
(erebos, x) <- f $ wrappedLoad (headRef erebosHead)
Right _ <- replaceHead erebos (Right erebosHead)
return x
@@ -211,7 +205,7 @@ cmdHistory = void $ runMaybeT $ do
Just peer <- gets csPeer
Just powner <- return $ finalOwner <$> peerIdentity peer
- erebosHead <- liftIO $ loadHead st "erebos"
+ Just erebosHead <- liftIO $ loadHead st "erebos"
let erebos = wrappedLoad (headRef erebosHead)
Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
tzone <- liftIO $ getCurrentTimeZone