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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
module State (
LocalState(..),
SharedState, SharedType(..),
SharedTypeID, mkSharedTypeID,
MonadStorage(..), MonadHead(..),
updateLocalHead_,
loadLocalStateHead,
updateSharedState, updateSharedState_,
lookupSharedValue, makeSharedStateUpdate,
localIdentity,
headLocalIdentity,
mergeSharedIdentity,
updateSharedIdentity,
interactiveIdentityUpdate,
) where
import Control.Monad.Except
import Control.Monad.Reader
import Data.Foldable
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import Data.UUID (UUID)
import qualified Data.UUID as U
import System.IO
import Identity
import PubKey
import Storage
import Storage.Merge
data LocalState = LocalState
{ lsIdentity :: Stored (Signed IdentityData)
, lsShared :: [Stored SharedState]
}
data SharedState = SharedState
{ ssPrev :: [Stored SharedState]
, ssType :: Maybe SharedTypeID
, ssValue :: [Ref]
}
newtype SharedTypeID = SharedTypeID UUID
deriving (Eq, Ord, StorableUUID)
mkSharedTypeID :: String -> SharedTypeID
mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString
class Mergeable a => SharedType a where
sharedTypeID :: proxy a -> SharedTypeID
instance Storable LocalState where
store' st = storeRec $ do
storeRef "id" $ lsIdentity st
mapM_ (storeRef "shared") $ lsShared st
load' = loadRec $ LocalState
<$> loadRef "id"
<*> loadRefs "shared"
instance HeadType LocalState where
headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e"
instance Storable SharedState where
store' st = storeRec $ do
mapM_ (storeRef "PREV") $ ssPrev st
storeMbUUID "type" $ ssType st
mapM_ (storeRawRef "value") $ ssValue st
load' = loadRec $ SharedState
<$> loadRefs "PREV"
<*> loadMbUUID "type"
<*> loadRawRefs "value"
instance SharedType (Maybe ComposedIdentity) where
sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
class Monad m => MonadStorage m where
getStorage :: m Storage
class (MonadIO m, MonadStorage m) => MonadHead a m where
updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b
updateLocalHead_ :: MonadHead a m => (Stored a -> m (Stored a)) -> m ()
updateLocalHead_ f = updateLocalHead (fmap (,()) . f)
instance Monad m => MonadStorage (ReaderT (Head a) m) where
getStorage = asks $ refStorage . headRef
instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
updateLocalHead f = do
h <- ask
snd <$> updateHead h f
loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState)
loadLocalStateHead st = loadHeads st >>= \case
(h:_) -> return h
[] -> liftIO $ do
putStr "Name: "
hFlush stdout
name <- T.getLine
putStr "Device: "
hFlush stdout
devName <- T.getLine
owner <- if
| T.null name -> return Nothing
| otherwise -> Just <$> createIdentity st (Just name) Nothing
identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner
shared <- wrappedStore st $ SharedState
{ ssPrev = []
, ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
, ssValue = [storedRef $ idData $ fromMaybe identity owner]
}
storeHead st $ LocalState
{ lsIdentity = idData identity
, lsShared = [shared]
}
localIdentity :: LocalState -> UnifiedIdentity
localIdentity ls = maybe (error "failed to verify local identity")
(updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls)
(validateIdentity $ lsIdentity ls)
headLocalIdentity :: Head LocalState -> UnifiedIdentity
headLocalIdentity = localIdentity . headObject
updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState)
updateSharedState_ f = fmap fst <$> updateSharedState (fmap (,()) . f)
updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> m (a, b)) -> Stored LocalState -> m (Stored LocalState, b)
updateSharedState f = \ls -> do
let shared = lsShared $ fromStored ls
val = lookupSharedValue shared
st = storedStorage ls
(val', x) <- f val
(,x) <$> if toComponents val' == toComponents val
then return ls
else do shared' <- makeSharedStateUpdate st val' shared
wrappedStore st (fromStored ls) { lsShared = [shared'] }
lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a
lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper
where helper (x:xs) | Just sid <- ssType (fromStored x), sid == sharedTypeID @a Proxy = x : helper xs
| otherwise = helper $ ssPrev (fromStored x) ++ xs
helper [] = []
makeSharedStateUpdate :: forall a m. MonadIO m => SharedType a => Storage -> a -> [Stored SharedState] -> m (Stored SharedState)
makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState
{ ssPrev = prev
, ssType = Just $ sharedTypeID @a Proxy
, ssValue = storedRef <$> toComponents val
}
mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity
mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case
Just cidentity -> do
identity <- liftIO $ mergeIdentity cidentity
return (Just $ toComposedIdentity identity, identity)
Nothing -> throwError "no existing shared identity"
updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m ()
updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case
Just identity -> do
Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity)
Nothing -> throwError "no existing shared 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
}
|