fix: remove GHC warnings and improve code quality in shared-kernel

lib/mobility-core/src/Kernel/External/Maps/OSRM/RoadsClient.hs

@@ -269,8 +269,7 @@ callOsrmGetDistancesAPI ::
     HasKafkaProducer r,
     ToJSON a,
     ToJSON b,
-    HasRequestId r,
-    MonadReader r m
+    HasRequestId r
   ) =>
   Maybe Text ->
   MapsInterfaceTypes.GetDistancesReq a b ->
@@ -297,8 +296,7 @@ callOsrmRouteAPI ::
     MonadFlow m,
     MonadReader r m,
     HasKafkaProducer r,
-    HasRequestId r,
-    MonadReader r m
+    HasRequestId r
   ) =>
   Maybe Text ->
   MapsInterfaceTypes.GetRoutesReq ->

lib/mobility-core/src/Kernel/External/Notification/FCM/Error.hs

@@ -33,3 +33,33 @@ newtype ErrorDetail = ErrorDetail
   { errorCode :: Maybe String
   }
   deriving (Show, Generic, FromJSON, ToJSON)
+
+data FCMErrorCategory
+  = FCMTransientError
+  | FCMPermanentError
+  | FCMInvalidTokenError
+  deriving (Show, Eq)
+
+categorizeErrorCode :: String -> FCMErrorCategory
+categorizeErrorCode "UNREGISTERED" = FCMInvalidTokenError
+categorizeErrorCode "NOT_FOUND" = FCMInvalidTokenError
+categorizeErrorCode "QUOTA_EXCEEDED" = FCMTransientError
+categorizeErrorCode "INTERNAL" = FCMTransientError
+categorizeErrorCode "UNAVAILABLE" = FCMTransientError
+categorizeErrorCode _ = FCMPermanentError
+
+categorizeHttpStatus :: Int -> FCMErrorCategory
+categorizeHttpStatus 429 = FCMTransientError
+categorizeHttpStatus 500 = FCMTransientError
+categorizeHttpStatus 503 = FCMTransientError
+categorizeHttpStatus 401 = FCMPermanentError
+categorizeHttpStatus 403 = FCMPermanentError
+categorizeHttpStatus 404 = FCMInvalidTokenError
+categorizeHttpStatus _ = FCMPermanentError
+
+classifyFcmError :: FcmError -> FCMErrorCategory
+classifyFcmError (FcmError Nothing) = FCMPermanentError
+classifyFcmError (FcmError (Just errRes)) =
+  case errRes.details >>= listToMaybe of
+    Just (ErrorDetail (Just code)) -> categorizeErrorCode code
+    _ -> maybe FCMPermanentError categorizeHttpStatus errRes.code

lib/mobility-core/src/Kernel/External/Notification/FCM/Flow.hs

@@ -44,6 +44,7 @@ module Kernel.External.Notification.FCM.Flow
   )
 where
 
+import qualified Control.Concurrent as Conc
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as BL
 import Data.Default.Class
@@ -231,40 +232,50 @@ sendMessage ::
   m ()
 sendMessage config fcmMsg action toWhom = fork desc $ do
   logTagInfo fcm $ "Message to be sent to the person: " <> show (Aeson.encode fcmMsg)
-  authToken <- getTokenText config
-  case authToken of
-    Right token -> do
-      let fcmUrl = config.fcmUrl
-      res <- callAPI fcmUrl (callFCM (Just $ FCMAuthToken token) fcmMsg) "sendMessage" fcmSendMessageAPI
-      case res of
-        Right _ -> logTagInfo fcm $ "Message sent successfully to a person with id " <> toWhom
-        Left clientError -> do
-          case clientError of
-            FailureResponse _ (Response _ _ _ resbody) -> do
-              let eitherError = Aeson.eitherDecodeStrict (BL.toStrict resbody) :: Either String FcmError
-              case eitherError of
-                Right fcmError -> handleFcmError fcmError action
-                Left errorMsg -> logTagError fcm $ "FCM decoding failed for person with id : " <> toWhom <> " Error Message : " <> T'.pack errorMsg
-            _ -> return ()
-    Left err -> logTagError fcm $ "AuthToken error while sending message to person with id " <> toWhom <> " : " <> show err
+  sendWithRetry 0
   where
+    maxRetries = 3 :: Int
     callFCM token msg = void $ ET.client fcmSendMessageAPI token msg
     desc = "FCM send message forked flow"
     fcm = "FCM"
 
-    handleFcmError :: MonadFlow m => FcmError -> m () -> m ()
-    handleFcmError (FcmError (Just (ErrorRes _ _ _ (Just details)))) action' =
-      mapM_ (`handleDetail` action') details
-    handleFcmError _ _ = pure ()
-
-    handleDetail :: MonadFlow m => ErrorDetail -> m () -> m ()
-    handleDetail (ErrorDetail (Just errorCode)) action' =
-      case errorCode of
-        "UNREGISTERED" -> do
-          logTagError fcm $ "Error while sending message to person with id " <> toWhom <> " : " <> "device token is unregistered and errorCode is : " <> show errorCode
-          action'
-        _ -> logTagError fcm $ "Error while sending message to person with id " <> toWhom <> " : " <> "unknown error code " <> show errorCode
-    handleDetail _ _ = pure ()
+    retryDelayMs :: Int -> Int
+    retryDelayMs attempt = 100000 * (2 ^ attempt) -- 100ms, 200ms, 400ms (in microseconds)
+    sendWithRetry attempt = do
+      authToken <- getTokenText config
+      case authToken of
+        Right token -> do
+          let fcmUrl = config.fcmUrl
+          res <- callAPI fcmUrl (callFCM (Just $ FCMAuthToken token) fcmMsg) "sendMessage" fcmSendMessageAPI
+          case res of
+            Right _ -> logTagInfo fcm $ "Message sent successfully to a person with id " <> toWhom
+            Left clientError -> handleClientError clientError attempt
+        Left err -> logTagError fcm $ "AuthToken error while sending message to person with id " <> toWhom <> " : " <> show err
+
+    handleClientError clientError attempt =
+      case clientError of
+        FailureResponse _ (Response _ _ _ resbody) -> do
+          let eitherError = Aeson.eitherDecodeStrict (BL.toStrict resbody) :: Either String FcmError
+          case eitherError of
+            Right fcmError -> handleFcmError fcmError attempt
+            Left errorMsg -> logTagError fcm $ "FCM decoding failed for person with id : " <> toWhom <> " Error Message : " <> T'.pack errorMsg
+        _ -> logTagError fcm $ "FCM client error for person with id : " <> toWhom <> " : " <> show clientError
+
+    handleFcmError fcmError attempt = do
+      let errorCategory = classifyFcmError fcmError
+      case errorCategory of
+        FCMInvalidTokenError -> do
+          logTagError fcm $ "FCM token invalid/unregistered for person " <> toWhom <> " error: " <> show fcmError
+          action
+        FCMTransientError
+          | attempt < maxRetries -> do
+            logTagWarning fcm $ "FCM transient error for person " <> toWhom <> " (attempt " <> show (attempt + 1) <> "/" <> show maxRetries <> "): " <> show fcmError
+            liftIO $ Conc.threadDelay (retryDelayMs attempt)
+            sendWithRetry (attempt + 1)
+        FCMTransientError -> do
+          logTagError fcm $ "FCM transient error exhausted retries for person " <> toWhom <> ": " <> show fcmError
+        FCMPermanentError -> do
+          logTagError fcm $ "FCM permanent error for person " <> toWhom <> ": " <> show fcmError
 
 -- | try to get FCM text token
 getTokenText ::

lib/mobility-core/src/Kernel/InternalAPI/Auth/Client.hs

@@ -11,8 +11,6 @@
 
   General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
 -}
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-
 module Kernel.InternalAPI.Auth.Client where
 
 import qualified EulerHS.Types as E
@@ -44,3 +42,4 @@ auth token = do
       "INVALID_TOKEN" -> InvalidToken token
       "TOKEN_IS_NOT_VERIFIED" -> TokenIsNotVerified
       "TOKEN_EXPIRED" -> TokenExpired
+      _ -> InvalidAuthData

lib/mobility-core/src/Kernel/Randomizer.hs

@@ -11,8 +11,6 @@
 
   General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
 -}
-{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-}
-
 module Kernel.Randomizer where
 
 import Safe (at)
@@ -38,8 +36,9 @@ randomizeList = randomizeList' . toList
     randomizeList' l = do
       let len = length l
       randNum <- getRandomInRange (0, len - 1)
-      let (leftPart, el : rightPart) = splitAt randNum l
-      (pure el <>) <$> randomizeList' (leftPart <> rightPart)
+      case splitAt randNum l of
+        (leftPart, el : rightPart) -> (pure el <>) <$> randomizeList' (leftPart <> rightPart)
+        _ -> return mempty
 
 getRandomElement :: (Element (arr a) ~ a, MonadIO m, Container (arr a)) => arr a -> m a
 getRandomElement arr = do

lib/mobility-core/src/Kernel/ServantMultipart.hs

@@ -11,7 +11,7 @@
 
   General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
 -}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Kernel.ServantMultipart
   ( module Servant.Multipart,

lib/mobility-core/src/Kernel/Storage/Beam/MerchantOperatingCity.hs

@@ -1,18 +1,12 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Kernel.Storage.Beam.MerchantOperatingCity where
 
-import qualified Data.Text as T
 import qualified Database.Beam as B
 import Kernel.Beam.Lib.UtilsTH
-import Kernel.External.Encryption
 import Kernel.Prelude
-import qualified Kernel.Prelude
-import System.Environment (lookupEnv)
-import System.IO.Unsafe (unsafePerformIO)
 
 data MerchantOperatingCityT f = MerchantOperatingCityT
   { id :: B.C f Kernel.Prelude.Text,

lib/mobility-core/src/Kernel/Storage/ClickhouseV2/Internal/Types.hs

@@ -60,7 +60,7 @@ data Column (a :: IsAggregated) t v where
   CoerceNum :: (ClickhouseTable t, ClickhouseNum v1, ClickhouseNum v2) => Column a t v1 -> Column a t v2
   ToDate :: (ClickhouseTable t, ClickhouseValue DateTime, ClickhouseValue Time.Day) => Column a t DateTime -> Column a t Time.Day -- FIXME create some generic constructor for different clickhouse functions
   ToHour :: (ClickhouseTable t, ClickhouseValue DateTime, ClickhouseValue Int) => Column a t DateTime -> Column a t Int
-  TimeDiff :: (ClickhouseTable t, ClickhouseValue UTCTime, ClickhouseValue UTCTime, ClickhouseValue Int) => Column a t UTCTime -> Column a t UTCTime -> Column a t Int
+  TimeDiff :: (ClickhouseTable t, ClickhouseValue UTCTime, ClickhouseValue Int) => Column a t UTCTime -> Column a t UTCTime -> Column a t Int
   ToStartOfWeek :: (ClickhouseTable t, ClickhouseValue Time.Day, ClickhouseValue Int) => Column a t Time.Day -> Column a t Int -> Column a t Time.Day
   ToStartOfMonth :: (ClickhouseTable t, ClickhouseValue Time.Day) => Column a t Time.Day -> Column a t Time.Day
   ValColumn :: (ClickhouseTable t, ClickhouseValue v) => v -> Column a t v

lib/mobility-core/src/Kernel/Storage/ClickhouseV2/Operators.hs

@@ -214,7 +214,7 @@ toStartOfWeek = ToStartOfWeek
 toStartOfMonth :: (ClickhouseTable t, ClickhouseValue Time.Day) => Column a t Time.Day -> Column a t Time.Day
 toStartOfMonth = ToStartOfMonth
 
-timeDiff :: (ClickhouseTable t, ClickhouseValue UTCTime, ClickhouseValue UTCTime, ClickhouseValue Int) => Column a t UTCTime -> Column a t UTCTime -> Column a t Int
+timeDiff :: (ClickhouseTable t, ClickhouseValue UTCTime, ClickhouseValue Int) => Column a t UTCTime -> Column a t UTCTime -> Column a t Int
 timeDiff = TimeDiff
 
 if_ :: (ClickhouseTable t, ClickhouseValue v) => Column a t Bool -> Column a t v -> Column a t v -> Column a t v

lib/mobility-core/src/Kernel/Storage/Hedis/Queries.hs

@@ -20,7 +20,6 @@ import qualified Data.ByteString.Lazy as BSL
 import Data.String.Conversions
 import Data.Text hiding (concatMap, map, null)
 import qualified Data.Text as T
-import qualified Data.Text as Text
 import Database.Redis as Reexport (GeoBy (..), GeoFrom (..), Queued, Redis, RedisTx, Reply, TxResult (..))
 import qualified Database.Redis as Hedis
 import qualified Database.Redis.Cluster as Cluster
@@ -614,7 +613,7 @@ withWaitOnLockRedisWithExpiry' recursionTimedOutKey key timeout func = do
           tryLockRedis key timeout
 
 buildLockResourceName :: (IsString a) => Text -> a
-buildLockResourceName key = fromString $ "mobility:locker:" <> Text.unpack key
+buildLockResourceName key = fromString $ "mobility:locker:" <> T.unpack key
 
 hSetExp :: (ToJSON a, HedisFlow m env, TryException m) => Text -> Text -> a -> ExpirationTime -> m ()
 hSetExp key field value expirationTime = withLogTag "Redis" $ do
@@ -655,6 +654,7 @@ hGet key field =
       Just bs -> Error.fromMaybeM (HedisDecodeError $ cs bs) $ Ae.decode $ BSL.fromStrict bs
 
 hmGet :: (FromJSON a, HedisFlow m env, TryException m) => Text -> [Text] -> m [Maybe a]
+hmGet _ [] = pure []
 hmGet key fields =
   withTimeRedis "RedisCluster" "hmGet" $ do
     listBS <- runWithPrefix key (`Hedis.hmget` map cs fields)
@@ -665,6 +665,7 @@ hmGet key fields =
     decodeBS (Just bs) = Error.fromMaybeM (HedisDecodeError $ cs bs) $ Ae.decode $ BSL.fromStrict bs
 
 hDel :: (HedisFlow m env, TryException m) => Text -> [Text] -> m ()
+hDel _ [] = pure ()
 hDel key fields = withTimeRedis "RedisCluster" "hDel" $ runWithPrefix_ key (`Hedis.hdel` map cs fields)
 
 hGetAll :: (FromJSON a, HedisFlow m env, TryException m) => Text -> m [(Text, a)]

lib/mobility-core/src/Kernel/Storage/Queries/MerchantOperatingCity.hs

@@ -1,21 +1,15 @@
 {-# OPTIONS_GHC -Wno-dodgy-exports #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Kernel.Storage.Queries.MerchantOperatingCity where
 
 import Kernel.Beam.Functions
 import Kernel.Beam.Lib.UtilsTH
-import Kernel.External.Encryption
-import qualified Kernel.External.Maps.Types
 import Kernel.Prelude
-import qualified Kernel.Prelude
 import qualified Kernel.Storage.Beam.MerchantOperatingCity as Beam
 import Kernel.Storage.Esqueleto.Config
 import Kernel.Types.App
 import Kernel.Types.CacheFlow
-import qualified Kernel.Types.Common
-import Kernel.Types.Error
 import Kernel.Types.Id
 import Kernel.Types.MerchantOperatingCity
 import qualified Sequelize as Se

lib/mobility-core/src/Kernel/Tools/Metrics/Init.hs

@@ -19,7 +19,6 @@ module Kernel.Tools.Metrics.Init where
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.Ratio ((%))
-import qualified Data.Text as DT
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
 import EulerHS.Prelude as E hiding (decodeUtf8)
@@ -77,7 +76,7 @@ addServantInfo ::
   Application
 addServantInfo version proxy app request respond =
   let mpath = getSanitizedUrl proxy request
-      fullpath = DT.intercalate "/" (normalizedPathInfo request)
+      fullpath = T.intercalate "/" (normalizedPathInfo request)
    in instrumentHandlerValueWithVersionLabel version.getDeploymentVersion (\_ -> "/" <> fromMaybe fullpath mpath) app request respond
 
 instrumentHandlerValueWithVersionLabel ::

lib/mobility-core/src/Kernel/Types/Beckn/DecimalValue.hs

@@ -91,11 +91,11 @@ rationalToString precision rational
 -- Note: valueToString will fail with an error if the integer
 -- part of the number exceeds the precision (total number of digits).
 valueToString :: DecimalValue -> Text
-valueToString value =
+valueToString value@(DecimalValue r) =
   maybe
     (error ("Cannot convert " <> show value <> " to a string. " <> message))
     T.pack
-    (rationalToString maxPrecision (toRational value))
+    (rationalToString maxPrecision r)
 
 valueFromString :: Text -> Maybe DecimalValue
 valueFromString valueString =

lib/mobility-core/src/Kernel/Types/Error.hs

@@ -13,7 +13,7 @@
 -}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Kernel.Types.Error where
 

lib/mobility-core/src/Kernel/Types/MerchantOperatingCity.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ApplicativeDo #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
 
 module Kernel.Types.MerchantOperatingCity where
 

lib/mobility-core/src/Kernel/Utils/Monitoring/Prometheus/Servant.hs

@@ -11,8 +11,6 @@
 
   General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
 -}
-{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-}
-
 module Kernel.Utils.Monitoring.Prometheus.Servant where
 
 import qualified Data.List as List
@@ -44,34 +42,30 @@ instance
   ) =>
   SanitizedUrl (path :> subroute)
   where
-  getSanitizedUrl _ req = do
-    let path = normalizedPathInfo req
-    if E.null path
-      then Nothing
-      else do
-        let (x : xs) = path
-            p = DT.pack $ symbolVal (Proxy :: Proxy path)
+  getSanitizedUrl _ req =
+    case normalizedPathInfo req of
+      (x : xs) -> do
+        let p = DT.pack $ symbolVal (Proxy :: Proxy path)
         if p == x
           then
             let maybeUrl = getSanitizedUrl (Proxy :: Proxy subroute) $ req {pathInfo = xs}
              in (\url -> Just (p <> "/" <> url)) =<< maybeUrl
           else Nothing
+      [] -> Nothing
 
 instance
   ( KnownSymbol (capture :: Symbol),
     SanitizedUrl (subroute :: Type)
   ) =>
   SanitizedUrl (Capture capture a :> subroute)
   where
-  getSanitizedUrl _ req = do
-    let path = normalizedPathInfo req
-    if E.null path
-      then Nothing
-      else
-        let (_ : xs) = path
-            p = DT.pack $ ":" <> symbolVal (Proxy :: Proxy capture)
+  getSanitizedUrl _ req =
+    case normalizedPathInfo req of
+      (_ : xs) ->
+        let p = DT.pack $ ":" <> symbolVal (Proxy :: Proxy capture)
             maybeUrl = getSanitizedUrl (Proxy :: Proxy subroute) $ req {pathInfo = xs}
          in (\url -> Just (p <> "/" <> url)) =<< maybeUrl
+      [] -> Nothing
 
 instance
   ReflectMethod m =>

lib/mobility-core/src/Kernel/Utils/Servant/Client.hs

@@ -17,7 +17,6 @@ module Kernel.Utils.Servant.Client where
 import qualified Data.Aeson as A
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict as HM
-import qualified Data.HashMap.Strict as HMS
 import qualified Data.Sequence as Seq
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@@ -218,7 +217,7 @@ managersFromManagersSettings ::
 managersFromManagersSettings timeout =
   mapM Http.newManager
     . fmap (setResponseTimeout timeout)
-    . HMS.insert defaultHttpManagerString Http.tlsManagerSettings
+    . HM.insert defaultHttpManagerString Http.tlsManagerSettings
   where
     extractDefaultManagerString (ET.ManagerSelector x) = x
     defaultHttpManagerString = extractDefaultManagerString defaultHttpManager