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

    loadLocalState,
    updateLocalState, updateLocalState_,
    updateIdentity,
) where

import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T

import System.IO

import Identity
import Message
import PubKey
import Storage
import Util

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

data SharedState = SharedState
    { ssPrev :: [Stored SharedState]
    , ssIdentity :: [Stored (Signed IdentityData)]
    }

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
        mapM_ (storeRef "id") $ ssIdentity st

    load' = loadRec $ SharedState
        <$> loadRefs "PREV"
        <*> loadRefs "id"


loadLocalState :: Storage -> IO Head
loadLocalState 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 = []
        , ssIdentity = [fromMaybe identity owner]
        }
    return $ LocalState
        { lsIdentity = identity
        , lsShared = [shared]
        , lsMessages = msgs
        }

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 ls f = do
    Just erebosHead <- loadHead ls "erebos"
    (st, x) <- f $ wrappedLoad (headRef erebosHead)
    Right _ <- replaceHead st (Right erebosHead)
    return x

updateSharedState_ :: Storage -> (Stored SharedState -> IO (Stored SharedState)) -> IO ()
updateSharedState_ st f = updateSharedState st (fmap (,()) . f)

updateSharedState :: Storage -> (Stored SharedState -> IO (Stored SharedState, a)) -> IO a
updateSharedState st f = updateLocalState st $ \ls -> do
    (shared, x) <- f =<< mergeSharedStates (lsShared $ fromStored ls)
    (,x) <$> wrappedStore st (fromStored ls) { lsShared = [shared] }

mergeSharedStates :: [(Stored SharedState)] -> IO (Stored SharedState)
mergeSharedStates [s] = return s
mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState
        { ssPrev = ss
        , ssIdentity = uniq $ sort $ concatMap (ssIdentity . fromStored) $ ss -- TODO: ancestor elimination
        }
mergeSharedStates [] = error "mergeSharedStates: empty list"

updateIdentity :: Storage -> IO ()
updateIdentity st = updateSharedState_ st $ \sshared -> do
    let shared = fromStored sshared
        Just identity = verifyIdentityF $ ssIdentity shared
        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

    identity' <- if
        | T.null name -> idData <$> mergeIdentity identity
        | otherwise -> do
            Just secret <- loadKey public
            wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
                { iddPrev = ssIdentity shared
                , iddName = Just name
                }

    wrappedStore st shared { ssIdentity = [identity'] }