1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
module State (
LocalState(..),
SharedState(..),
loadLocalState, loadLocalStateHead,
updateLocalState, updateLocalState_,
updateSharedState, updateSharedState_,
mergeSharedStates,
loadLocalIdentity, headLocalIdentity,
mergeSharedIdentity,
updateSharedIdentity,
interactiveIdentityUpdate,
) where
import Control.Monad
import Data.Foldable
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.IO
import Identity
import Message
import PubKey
import Storage
import Storage.List
import Util
data LocalState = LocalState
{ lsIdentity :: Stored (Signed IdentityData)
, lsShared :: [Stored SharedState]
, lsMessages :: StoredList DirectMessageThread -- TODO: move to shared
}
data SharedState = SharedState
{ ssPrev :: [Stored SharedState]
, ssIdentity :: [Stored (Signed IdentityData)]
}
instance Storable LocalState where
store' st = storeRec $ do
storeRef "id" $ lsIdentity st
mapM_ (storeRef "shared") $ lsShared st
storeRef "dmsg" $ lsMessages st
load' = loadRec $ LocalState
<$> loadRef "id"
<*> loadRefs "shared"
<*> loadRef "dmsg"
instance Storable SharedState where
store' st = storeRec $ do
mapM_ (storeRef "PREV") $ ssPrev st
mapM_ (storeRef "id") $ ssIdentity st
load' = loadRec $ SharedState
<$> loadRefs "PREV"
<*> loadRefs "id"
loadLocalState :: Storage -> IO (Stored LocalState)
loadLocalState = return . wrappedLoad . headRef <=< loadLocalStateHead
loadLocalStateHead :: Storage -> IO Head
loadLocalStateHead st = loadHeadDef st "erebos" $ do
putStr "Name: "
hFlush stdout
name <- T.getLine
putStr "Device: "
hFlush stdout
devName <- T.getLine
(owner, secret) <- if
| T.null name -> return (Nothing, Nothing)
| otherwise -> do
(secret, public) <- generateKeys st
(_secretMsg, publicMsg) <- generateKeys st
return . (, Just secret) . Just =<< wrappedStore st =<< sign secret =<<
wrappedStore st (emptyIdentityData public)
{ iddName = Just name, iddKeyMessage = Just publicMsg }
(devSecret, devPublic) <- generateKeys st
(_devSecretMsg, devPublicMsg) <- generateKeys st
identity <- wrappedStore st =<< maybe return signAdd secret =<< sign devSecret =<< wrappedStore st (emptyIdentityData devPublic)
{ iddName = if T.null devName then Nothing else Just devName
, iddOwner = owner
, iddKeyMessage = Just devPublicMsg
}
msgs <- emptySList st
shared <- wrappedStore st $ SharedState
{ ssPrev = []
, ssIdentity = [fromMaybe identity owner]
}
return $ LocalState
{ lsIdentity = identity
, lsShared = [shared]
, lsMessages = msgs
}
loadLocalIdentity :: Storage -> IO UnifiedIdentity
loadLocalIdentity = return . headLocalIdentity <=< loadLocalStateHead
headLocalIdentity :: Head -> UnifiedIdentity
headLocalIdentity h =
let ls = load $ headRef h
in maybe (error "failed to verify local identity")
(updateOwners (ssIdentity . fromStored =<< lsShared ls))
(validateIdentity $ lsIdentity ls)
updateLocalState_ :: Storage -> (Stored LocalState -> IO (Stored LocalState)) -> IO ()
updateLocalState_ st f = updateLocalState st (fmap (,()) . f)
updateLocalState :: Storage -> (Stored LocalState -> IO (Stored LocalState, a)) -> IO a
updateLocalState ls f = do
Just erebosHead <- loadHead ls "erebos"
(st, x) <- f $ wrappedLoad (headRef erebosHead)
Right _ <- replaceHead st (Right erebosHead)
return x
updateSharedState_ :: Storage -> (Stored SharedState -> IO (Stored SharedState)) -> IO ()
updateSharedState_ st f = updateSharedState st (fmap (,()) . f)
updateSharedState :: Storage -> (Stored SharedState -> IO (Stored SharedState, a)) -> IO a
updateSharedState st f = updateLocalState st $ \ls -> do
(shared, x) <- f =<< mergeSharedStates (lsShared $ fromStored ls)
(,x) <$> wrappedStore st (fromStored ls) { lsShared = [shared] }
mergeSharedStates :: [(Stored SharedState)] -> IO (Stored SharedState)
mergeSharedStates [s] = return s
mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState
{ ssPrev = ss
, ssIdentity = uniq $ sort $ concatMap (ssIdentity . fromStored) $ ss -- TODO: ancestor elimination
}
mergeSharedStates [] = error "mergeSharedStates: empty list"
mergeSharedIdentity :: Storage -> IO UnifiedIdentity
mergeSharedIdentity st = updateSharedState st $ \sshared -> do
let shared = fromStored sshared
Just cidentity = validateIdentityF $ ssIdentity shared
identity <- mergeIdentity cidentity
sshared' <- wrappedStore st $ shared { ssIdentity = [idData identity] }
return (sshared', identity)
updateSharedIdentity :: Storage -> IO ()
updateSharedIdentity st = updateSharedState_ st $ \sshared -> do
let shared = fromStored sshared
Just identity = validateIdentityF $ ssIdentity shared
identity' <- interactiveIdentityUpdate identity
wrappedStore st shared { ssIdentity = [idData identity'] }
interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity
interactiveIdentityUpdate identity = do
let st = storedStorage $ head $ toList $ idDataF $ identity
public = idKeyIdentity identity
T.putStr $ T.concat $ concat
[ [ T.pack "Name" ]
, case idName identity of
Just name -> [T.pack " [", name, T.pack "]"]
Nothing -> []
, [ T.pack ": " ]
]
hFlush stdout
name <- T.getLine
if | T.null name -> mergeIdentity identity
| otherwise -> do
Just secret <- loadKey public
maybe (error "created invalid identity") return . validateIdentity =<<
wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
{ iddPrev = toList $ idDataF identity
, iddName = Just name
}
|