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
|
{-# LANGUAGE UndecidableInstances #-}
module Identity (
Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..),
idData, idDataF, idName, idOwner, idKeyIdentity, idKeyMessage,
emptyIdentityData,
verifyIdentity, verifyIdentityF,
mergeIdentity, toComposedIdentity,
finalOwner,
displayIdentity,
) where
import Control.Monad
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
data Identity m = Identity
{ idData_ :: m (Stored (Signed IdentityData))
, idName_ :: Maybe Text
, idOwner_ :: Maybe UnifiedIdentity
, 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
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 "PREV") $ iddPrev idt
storeMbText "name" $ iddName idt
storeMbRef "owner" $ iddOwner idt
storeRef "key-id" $ iddKeyIdentity idt
storeMbRef "key-msg" $ iddKeyMessage idt
load' = loadRec $ IdentityData
<$> loadRefs "PREV"
<*> 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 UnifiedIdentity
idOwner = idOwner_
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
}
verifyIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity
verifyIdentity = verifyIdentityF . I.Identity
verifyIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m)
verifyIdentityF 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 <$> verifyIdentity owner
<*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata)
<*> lookupProperty iddKeyMessage idata
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 = flip unfoldr (map fst propHeads, S.empty) $ \(hs, cur) ->
case filter (`S.notMember` cur) $ (iddPrev . fromStored . signedData . fromStored) =<< hs of
[] -> Nothing
added -> let next = foldr S.insert cur added
in Just (next, (added, next))
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 | [sdata] <- toList $ idDataF idt = return $ idt { idData_ = I.Identity sdata }
mergeIdentity idt = do
(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 }
return $ idt { idData_ = I.Identity sdata }
toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity
toComposedIdentity idt = idt { idData_ = toList $ idDataF idt }
unfoldOwners :: (Foldable m, Applicative m) => Identity m -> [Identity m]
unfoldOwners cur = cur : case idOwner cur of
Nothing -> []
Just owner@Identity { idData_ = I.Identity pid } ->
unfoldOwners owner { idData_ = pure pid }
finalOwner :: (Foldable m, Applicative m) => Identity m -> Identity m
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
|