summaryrefslogtreecommitdiff
path: root/src/State.hs
blob: bb7c570c7be9d483b46111eb39215c0596a1bd54 (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
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
module State (
    LocalState(..),
    SharedState, SharedType(..),
    SharedTypeID, mkSharedTypeID,

    loadLocalState, loadLocalStateHead,
    updateLocalState, updateLocalState_,

    updateSharedState, updateSharedState_,
    lookupSharedValue, makeSharedStateUpdate,

    loadLocalIdentity, headLocalIdentity,

    mergeSharedIdentity,
    updateSharedIdentity,
    interactiveIdentityUpdate,
) where

import Control.Monad

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 Message
import PubKey
import Storage
import Storage.List
import Storage.Merge

data LocalState = LocalState
    { lsIdentity :: Stored (Signed IdentityData)
    , lsShared :: [Stored SharedState]
    , lsMessages :: StoredList DirectMessageThread -- TODO: move to shared
    }

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 Storable 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
        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
        storeMbUUID "type" $ ssType st
        mapM_ (storeRawRef "value") $ ssValue st

    load' = loadRec $ SharedState
        <$> loadRefs "PREV"
        <*> loadMbUUID "type"
        <*> loadRawRefs "value"

instance SharedType (Signed IdentityData) where
    sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"


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 = []
        , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
        , ssValue = [storedRef $ 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 (lookupSharedValue $ 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 st f = do
    Just erebosHead <- loadHead st "erebos"
    let ls = wrappedLoad (headRef erebosHead)
    (ls', x) <- f ls
    when (ls' /= ls) $ do
        Right _ <- replaceHead ls' (Right erebosHead)
        return ()
    return x


updateSharedState_ :: SharedType a => Storage -> ([Stored a] -> IO ([Stored a])) -> IO ()
updateSharedState_ st f = updateSharedState st (fmap (,()) . f)

updateSharedState :: forall a b. SharedType a => Storage -> ([Stored a] -> IO ([Stored a], b)) -> IO b
updateSharedState st f = updateLocalState st $ \ls -> do
    let shared = lsShared $ fromStored ls
        val = lookupSharedValue shared
    (val', x) <- f val
    (,x) <$> if val' == val
                then return ls
                else do shared' <- makeSharedStateUpdate st val' shared
                        wrappedStore st (fromStored ls) { lsShared = [shared'] }

lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> [Stored a]
lookupSharedValue = 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. SharedType a => Storage -> [Stored a] -> [Stored SharedState] -> IO (Stored SharedState)
makeSharedStateUpdate st val prev = wrappedStore st SharedState
    { ssPrev = prev
    , ssType = Just $ sharedTypeID @a Proxy
    , ssValue = storedRef <$> val
    }


mergeSharedIdentity :: Storage -> IO UnifiedIdentity
mergeSharedIdentity st = updateSharedState st $ \sdata -> do
    let Just cidentity = validateIdentityF sdata
    identity <- mergeIdentity cidentity
    return ([idData identity], identity)

updateSharedIdentity :: Storage -> IO ()
updateSharedIdentity st = updateSharedState_ st $ \sdata -> do
    let Just identity = validateIdentityF sdata
    (:[]) . idData <$> interactiveIdentityUpdate 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
                }