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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
{-# LANGUAGE UndecidableInstances #-}
module Identity (
Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..),
idData, idDataF, idName, idOwner, idUpdates, idKeyIdentity, idKeyMessage,
emptyIdentityData,
validateIdentity, validateIdentityF,
loadIdentity,
mergeIdentity, toUnifiedIdentity, toComposedIdentity,
updateIdentity, updateOwners,
sameIdentity,
finalOwner,
displayIdentity,
) where
import Control.Arrow
import Control.Monad
import Control.Monad.Except
import qualified Control.Monad.Identity as I
import Data.Foldable
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import PubKey
import Storage
import Storage.Merge
data Identity m = Identity
{ idData_ :: m (Stored (Signed IdentityData))
, idName_ :: Maybe Text
, idOwner_ :: Maybe ComposedIdentity
, idUpdates_ :: [Stored (Signed IdentityData)]
, idKeyIdentity_ :: Stored PublicKey
, idKeyMessage_ :: Stored PublicKey
}
deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m)
type ComposedIdentity = Identity []
type UnifiedIdentity = Identity I.Identity
instance Eq UnifiedIdentity where
(==) = (==) `on` (idData &&& idUpdates)
data IdentityData = IdentityData
{ iddPrev :: [Stored (Signed IdentityData)]
, iddName :: Maybe Text
, iddOwner :: Maybe (Stored (Signed IdentityData))
, iddKeyIdentity :: Stored PublicKey
, iddKeyMessage :: Maybe (Stored PublicKey)
}
deriving (Show)
instance Storable IdentityData where
store' idt = storeRec $ do
mapM_ (storeRef "SPREV") $ iddPrev idt
storeMbText "name" $ iddName idt
storeMbRef "owner" $ iddOwner idt
storeRef "key-id" $ iddKeyIdentity idt
storeMbRef "key-msg" $ iddKeyMessage idt
load' = loadRec $ IdentityData
<$> loadRefs "SPREV"
<*> loadMbText "name"
<*> loadMbRef "owner"
<*> loadRef "key-id"
<*> loadMbRef "key-msg"
idData :: UnifiedIdentity -> Stored (Signed IdentityData)
idData = I.runIdentity . idDataF
idDataF :: Identity m -> m (Stored (Signed IdentityData))
idDataF = idData_
idName :: Identity m -> Maybe Text
idName = idName_
idOwner :: Identity m -> Maybe ComposedIdentity
idOwner = idOwner_
idUpdates :: Identity m -> [Stored (Signed IdentityData)]
idUpdates = idUpdates_
idKeyIdentity :: Identity m -> Stored PublicKey
idKeyIdentity = idKeyIdentity_
idKeyMessage :: Identity m -> Stored PublicKey
idKeyMessage = idKeyMessage_
emptyIdentityData :: Stored PublicKey -> IdentityData
emptyIdentityData key = IdentityData
{ iddName = Nothing
, iddPrev = []
, iddOwner = Nothing
, iddKeyIdentity = key
, iddKeyMessage = Nothing
}
validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity
validateIdentity = validateIdentityF . I.Identity
validateIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m)
validateIdentityF mdata = do
let idata = toList mdata -- TODO: eliminate ancestors
guard $ not $ null idata
mapM_ verifySignatures $ gatherPrevious S.empty idata
Identity
<$> pure mdata
<*> pure (lookupProperty iddName idata)
<*> case lookupProperty iddOwner idata of
Nothing -> return Nothing
Just owner -> Just <$> validateIdentityF [owner]
<*> pure []
<*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata)
<*> lookupProperty iddKeyMessage idata
loadIdentity :: String -> LoadRec ComposedIdentity
loadIdentity name = maybe (throwError "identity validation failed") return . validateIdentityF =<< loadRefs name
gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData))
gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns
| otherwise = gatherPrevious (S.insert n res) $ (iddPrev $ fromStored $ signedData $ fromStored n) ++ ns
gatherPrevious res [] = res
verifySignatures :: Stored (Signed IdentityData) -> Maybe ()
verifySignatures sidd = do
let idd = fromStored $ signedData $ fromStored sidd
required = concat
[ [ iddKeyIdentity idd ]
, map (iddKeyIdentity . fromStored . signedData . fromStored) $ iddPrev idd
, map (iddKeyIdentity . fromStored . signedData . fromStored) $ toList $ iddOwner idd
]
guard $ all (fromStored sidd `isSignedBy`) required
lookupProperty :: forall a. (IdentityData -> Maybe a) -> [Stored (Signed IdentityData)] -> Maybe a
lookupProperty sel topHeads = findResult filteredLayers
where findPropHeads :: Stored (Signed IdentityData) -> [(Stored (Signed IdentityData), a)]
findPropHeads sobj | Just x <- sel $ fromStored $ signedData $ fromStored sobj = [(sobj, x)]
| otherwise = findPropHeads =<< (iddPrev $ fromStored $ signedData $ fromStored sobj)
propHeads :: [(Stored (Signed IdentityData), a)]
propHeads = findPropHeads =<< topHeads
historyLayers :: [Set (Stored (Signed IdentityData))]
historyLayers = generations $ map fst propHeads
filteredLayers :: [[(Stored (Signed IdentityData), a)]]
filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers
findResult ([(_, x)] : _) = Just x
findResult ([] : _) = Nothing
findResult [] = Nothing
findResult [xs] = Just $ snd $ minimumBy (comparing fst) xs
findResult (_:rest) = findResult rest
mergeIdentity :: Foldable m => Identity m -> IO UnifiedIdentity
mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt'
mergeIdentity idt = do
(owner, ownerData) <- case idOwner_ idt of
Nothing -> return (Nothing, Nothing)
Just cowner | Just owner <- toUnifiedIdentity cowner -> return (Just owner, Nothing)
| otherwise -> do owner <- mergeIdentity cowner
return (Just owner, Just $ idData owner)
(sid:_) <- return $ toList $ idDataF idt
let st = storedStorage sid
public = idKeyIdentity idt
Just secret <- loadKey public
sdata <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
{ iddPrev = toList $ idDataF idt, iddOwner = ownerData }
return $ idt { idData_ = I.Identity sdata, idOwner_ = toComposedIdentity <$> owner }
toUnifiedIdentity :: Foldable m => Identity m -> Maybe UnifiedIdentity
toUnifiedIdentity idt
| [sdata] <- toList $ idDataF idt = Just idt { idData_ = I.Identity sdata }
| otherwise = Nothing
toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity
toComposedIdentity idt = idt { idData_ = toList $ idDataF idt
, idOwner_ = toComposedIdentity <$> idOwner_ idt
}
updateIdentitySets :: Foldable m => [(Stored (Signed IdentityData), Set (Stored (Signed IdentityData)))] -> Identity m -> ComposedIdentity
updateIdentitySets updates orig@Identity { idData_ = idata } =
case validateIdentityF $ map update $ toList idata of
Just updated -> updated { idOwner_ = updateIdentitySets updates <$> idOwner_ updated }
Nothing -> toComposedIdentity orig
where update x = foldl (\y (y', set) -> if y `S.member` set then y' else y) x updates
updateIdentity :: Foldable m => [Stored (Signed IdentityData)] -> Identity m -> ComposedIdentity
updateIdentity = updateIdentitySets . map (\u -> (u, ancestors [u]))
updateOwners :: [Stored (Signed IdentityData)] -> Identity m -> Identity m
updateOwners updates orig@Identity { idOwner_ = Just owner, idUpdates_ = cupdates } =
orig { idOwner_ = Just $ updateIdentity updates owner, idUpdates_ = updates ++ cupdates {- TODO: eliminate ancestors -} }
updateOwners _ orig@Identity { idOwner_ = Nothing } = orig
sameIdentity :: (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool
sameIdentity x y = not $ S.null $ S.intersection (refset x) (refset y)
where refset idt = foldr S.insert (ancestors $ toList $ idDataF idt) (idDataF idt)
unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity]
unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity
finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity
finalOwner = last . unfoldOwners
displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text
displayIdentity identity = T.concat
[ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName) owners
]
where owners = reverse $ unfoldOwners identity
|