Fix non-exhaustive pattern match warnings

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