summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Channel.hs8
-rw-r--r--src/ICE.chs20
-rw-r--r--src/Main.hs3
-rw-r--r--src/Network.hs2
-rw-r--r--src/Pairing.hs8
-rw-r--r--src/Service.hs2
-rw-r--r--src/State.hs23
-rw-r--r--src/Storage/Internal.hs7
-rw-r--r--src/Test.hs26
9 files changed, 61 insertions, 38 deletions
diff --git a/src/Channel.hs b/src/Channel.hs
index 8753ecf..b273392 100644
--- a/src/Channel.hs
+++ b/src/Channel.hs
@@ -101,7 +101,9 @@ acceptChannelRequest self peer req = do
throwError $ "channel requent not signed by peer"
let st = storedStorage req
- KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
+ ksize <- case cipherKeySize (undefined :: AES128) of
+ KeySizeFixed s -> return s
+ _ -> throwError "expecting fixed key size"
liftIO $ do
(xsecret, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage self
@@ -119,7 +121,9 @@ acceptChannelRequest self peer req = do
acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel
acceptedChannel self peer acc = do
let req = caRequest $ fromStored $ signedData $ fromStored acc
- KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
+ ksize <- case cipherKeySize (undefined :: AES128) of
+ KeySizeFixed s -> return s
+ _ -> throwError "expecting fixed key size"
case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of
Nothing -> throwError $ "invalid peers in channel accept"
diff --git a/src/ICE.chs b/src/ICE.chs
index 06ad7aa..98584a2 100644
--- a/src/ICE.chs
+++ b/src/ICE.chs
@@ -131,13 +131,19 @@ iceCreate role cb = do
{#fun ice_destroy as ^ { isStrans `IceSession' } -> `()' #}
iceRemoteInfo :: IceSession -> IO IceRemoteInfo
-iceRemoteInfo sess =
- allocaBytes (32*128) $ \bytes ->
- allocaArray 29 $ \carr -> do
- let (ufrag : pass : def : cptrs) = take 32 $ iterate (`plusPtr` 128) bytes
- pokeArray carr cptrs
-
- ncand <- {#call ice_encode_session #} (isStrans sess) ufrag pass def carr 128 29
+iceRemoteInfo sess = do
+ let maxlen = 128
+ maxcand = 29
+
+ allocaBytes maxlen $ \ufrag ->
+ allocaBytes maxlen $ \pass ->
+ allocaBytes maxlen $ \def ->
+ allocaBytes (maxcand*maxlen) $ \bytes ->
+ allocaArray maxcand $ \carr -> do
+ let cptrs = take maxcand $ iterate (`plusPtr` maxlen) bytes
+ pokeArray carr $ take maxcand cptrs
+
+ ncand <- {#call ice_encode_session #} (isStrans sess) ufrag pass def carr (fromIntegral maxlen) (fromIntegral maxcand)
if ncand < 0 then fail "failed to generate ICE remote info"
else IceRemoteInfo
<$> (T.pack <$> peekCString ufrag)
diff --git a/src/Main.hs b/src/Main.hs
index 295a486..4a2d910 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -102,7 +102,8 @@ main = do
Nothing -> error "ref does not exist"
Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
- ["update-identity"] -> runReaderT updateSharedIdentity =<< loadLocalStateHead st
+ ["update-identity"] -> either fail return <=< runExceptT $ do
+ runReaderT updateSharedIdentity =<< loadLocalStateHead st
("update-identity" : srefs) -> do
sequence <$> mapM (readRef st . BC.pack) srefs >>= \case
diff --git a/src/Network.hs b/src/Network.hs
index 3cf714d..be6fa09 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -757,7 +757,7 @@ handleIdentityAnnounce self peer ref = liftIO $ atomically $ do
PeerIdentityRef wref wact
| wrDigest wref == refDigest ref
-> validateAndUpdate [] $ \pid -> do
- mapM_ (writeTQueue (serverIOActions $ peerServer peer) . ($pid)) .
+ mapM_ (writeTQueue (serverIOActions $ peerServer peer) . ($ pid)) .
reverse =<< readTVar wact
PeerIdentityFull pid
diff --git a/src/Pairing.hs b/src/Pairing.hs
index a264c42..8567168 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -195,9 +195,11 @@ nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $
]
confirmationNumber :: RefDigest -> String
-confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
- str = show $ ((a `shift` 24) .|. (b `shift` 16) .|. (c `shift` 8) .|. d) `mod` (10 ^ len)
- in replicate (len - length str) '0' ++ str
+confirmationNumber dgst =
+ case map fromIntegral $ BA.unpack dgst :: [Word32] of
+ (a:b:c:d:_) -> let str = show $ ((a `shift` 24) .|. (b `shift` 16) .|. (c `shift` 8) .|. d) `mod` (10 ^ len)
+ in replicate (len - length str) '0' ++ str
+ _ -> ""
where len = 6
pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
diff --git a/src/Service.hs b/src/Service.hs
index 3ef10d6..4fc8335 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -165,7 +165,7 @@ svcSelf = maybe (throwError "failed to validate own identity") return .
validateIdentity . lsIdentity . fromStored =<< svcGetLocal
svcPrint :: String -> ServiceHandler s ()
-svcPrint str = afterCommit . ($str) =<< asks svcPrintOp
+svcPrint str = afterCommit . ($ str) =<< asks svcPrintOp
replyPacket :: Service s => s -> ServiceHandler s ()
replyPacket x = tell [ServiceReply (Left x) True]
diff --git a/src/State.hs b/src/State.hs
index 6790d45..280e505 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -17,6 +17,7 @@ module State (
interactiveIdentityUpdate,
) where
+import Control.Monad.Except
import Control.Monad.Reader
import Data.Foldable
@@ -96,10 +97,10 @@ instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
snd <$> updateHead h f
-loadLocalStateHead :: Storage -> IO (Head LocalState)
+loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState)
loadLocalStateHead st = loadHeads st >>= \case
(h:_) -> return h
- [] -> do
+ [] -> liftIO $ do
putStr "Name: "
hFlush stdout
name <- T.getLine
@@ -166,14 +167,18 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState
}
-mergeSharedIdentity :: MonadHead LocalState m => m UnifiedIdentity
-mergeSharedIdentity = updateSharedState $ \(Just cidentity) -> do
- identity <- liftIO $ mergeIdentity cidentity
- return (Just $ toComposedIdentity identity, identity)
+mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity
+mergeSharedIdentity = updateSharedState $ \case
+ Just cidentity -> do
+ identity <- liftIO $ mergeIdentity cidentity
+ return (Just $ toComposedIdentity identity, identity)
+ Nothing -> throwError "no existing shared identity"
-updateSharedIdentity :: MonadHead LocalState m => m ()
-updateSharedIdentity = updateSharedState_ $ \(Just identity) -> do
- Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity)
+updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m ()
+updateSharedIdentity = updateSharedState_ $ \case
+ Just identity -> do
+ Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity)
+ Nothing -> throwError "no existing shared identity"
interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity
interactiveIdentityUpdate identity = do
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
index 85742a3..402d924 100644
--- a/src/Storage/Internal.hs
+++ b/src/Storage/Internal.hs
@@ -115,8 +115,11 @@ refDigest (Ref _ dgst) = dgst
showRef :: Ref' c -> ByteString
showRef = showRefDigest . refDigest
+showRefDigestParts :: RefDigest -> (ByteString, ByteString)
+showRefDigestParts x = (BC.pack "blake2", showHex x)
+
showRefDigest :: RefDigest -> ByteString
-showRefDigest x = BC.pack "blake2#" `BC.append` showHex x
+showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex
readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest x = case BC.split '#' x of
@@ -213,7 +216,7 @@ ioLoadBytesFromStorage st dgst = loadCurrent st >>=
refPath :: FilePath -> RefDigest -> FilePath
refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest]
- where [alg, dgst] = BC.split '#' $ showRefDigest rdgst
+ where (alg, dgst) = showRefDigestParts rdgst
(pref, rest) = splitAt 2 $ BC.unpack dgst
diff --git a/src/Test.hs b/src/Test.hs
index 8ea8925..7b06831 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -375,8 +375,8 @@ cmdUpdateLocalIdentity :: Command
cmdUpdateLocalIdentity = do
[name] <- asks tiParams
updateLocalState_ $ \ls -> liftIO $ do
- let Just identity = validateIdentity $ lsIdentity $ fromStored ls
- st = storedStorage ls
+ Just identity <- return $ validateIdentity $ lsIdentity $ fromStored ls
+ let st = storedStorage ls
public = idKeyIdentity identity
Just secret <- loadKey public
@@ -390,16 +390,18 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateSharedState_ $ \(Just identity) -> liftIO $ do
- let st = storedStorage $ head $ idDataF identity
- public = idKeyIdentity identity
-
- Just secret <- loadKey public
- maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateIdentity =<<
- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
- { iddPrev = toList $ idDataF identity
- , iddName = Just name
- }
+ updateSharedState_ $ \case
+ Nothing -> throwError "no existing shared identity"
+ Just identity -> liftIO $ do
+ let st = storedStorage $ head $ idDataF identity
+ public = idKeyIdentity identity
+
+ Just secret <- loadKey public
+ maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateIdentity =<<
+ wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
+ { iddPrev = toList $ idDataF identity
+ , iddName = Just name
+ }
cmdAttachTo :: Command
cmdAttachTo = do
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-30 18:14:03 +0000