From 7a9ef992afa96ed177ae9a4a67d302017ab73852 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 5 Apr 2023 22:03:43 +0200 Subject: Fix non-exhaustive pattern match warnings --- src/Channel.hs | 8 ++++++-- src/ICE.chs | 20 +++++++++++++------- src/Main.hs | 3 ++- src/Network.hs | 2 +- src/Pairing.hs | 8 +++++--- src/Service.hs | 2 +- src/State.hs | 23 ++++++++++++++--------- src/Storage/Internal.hs | 7 +++++-- src/Test.hs | 26 ++++++++++++++------------ 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 -- cgit v1.2.3