summaryrefslogtreecommitdiff
path: root/src/Identity.hs
blob: 96346d898cb6818a521b1addbcd38b3ef650f694 (plain)
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
module Identity (
    Identity, IdentityData(..),
    emptyIdentity,
    finalOwner,
    displayIdentity,
) where

import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T

import PubKey
import Storage

type Identity = Signed IdentityData

data IdentityData = Identity
    { idName :: Maybe Text
    , idPrev :: Maybe (Stored Identity)
    , idOwner :: Maybe (Stored Identity)
    , idKeyIdentity :: Stored PublicKey
    , idKeyMessage :: Stored PublicKey
    }
    deriving (Show)

emptyIdentity :: Stored PublicKey -> Stored PublicKey -> IdentityData
emptyIdentity key kmsg = Identity
    { idName = Nothing
    , idPrev = Nothing
    , idOwner = Nothing
    , idKeyIdentity = key
    , idKeyMessage = kmsg
    }

instance Storable IdentityData where
    store' idt = storeRec $ do
        storeMbText "name" $ idName idt
        storeMbRef "prev" $ idPrev idt
        storeMbRef "owner" $ idOwner idt
        storeRef "key-id" $ idKeyIdentity idt
        storeRef "key-msg" $ idKeyMessage idt

    load' = loadRec $ Identity
        <$> loadMbText "name"
        <*> loadMbRef "prev"
        <*> loadMbRef "owner"
        <*> loadRef "key-id"
        <*> loadRef "key-msg"

unfoldOwners :: Stored Identity -> [Stored Identity]
unfoldOwners cur = cur : case idOwner $ fromStored $ signedData $ fromStored cur of
                              Nothing   -> []
                              Just prev -> unfoldOwners prev

finalOwner :: Stored Identity -> Stored Identity
finalOwner = last . unfoldOwners

displayIdentity :: Stored Identity -> Text
displayIdentity sidentity = T.concat
    [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName . fromStored . signedData . fromStored) owners
    ]
    where owners = reverse $ unfoldOwners sidentity