server: make more use of hlint

scripts/dev.sh

@@ -484,7 +484,7 @@ elif [ "$MODE" = "test" ]; then
   if [ "$RUN_HLINT" = true ]; then
 
     cd "$PROJECT_ROOT/server"
-    hlint .
+    hlint src-*
 
   fi # RUN_HLINT
 

server/.hlint.yaml

@@ -35,6 +35,10 @@
 # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
 # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
 
+- warn: {lhs: "maybe (f x) f", rhs: "f . fromMaybe x"}
+- warn: {lhs: "either (f . g) (f . h)", rhs: "f . either g h"}
+- warn: {lhs: "onNothing x (return y)", rhs: "return (fromMaybe y x)"}
+- warn: {lhs: "onLeft x (return . f)", rhs: "return (either f id x)"}
 
 # Turn on hints that are off by default
 #
@@ -52,54 +56,50 @@
 # - ignore: {name: Use let}
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
 
-- ignore: {name: Use <$>}
 - ignore: {name: Reduce duplication}
-- ignore: {name: Use fromMaybe}
 - ignore: {name: Redundant $}
 - ignore: {name: Redundant bracket}
 - ignore: {name: Use fmap}
 - ignore: {name: Use first}
 - ignore: {name: Use if}
 - ignore: {name: Redundant <$>}
-- ignore: {name: Functor law}
-- ignore: {name: Move brackets to avoid $}
-- ignore: {name: Use null}
-- ignore: {name: Use map once}
 - ignore: {name: Use ++}
-- ignore: {name: Use lambda-case}
 - ignore: {name: Use const}
 - ignore: {name: Eta reduce}
 - ignore: {name: Redundant multi-way if}
 - ignore: {name: Use newtype instead of data}
 - ignore: {name: Use bimap}
-- ignore: {name: Use section}
 - ignore: {name: Use $>}
-- ignore: {name: Use unless}
-- ignore: {name: Redundant $!}
 - ignore: {name: "Use ?~"}
-- ignore: {name: Use Just}
-- ignore: {name: Redundant flip}
-- ignore: {name: Use for_}
-- ignore: {name: Avoid lambda}
-- ignore: {name: Use mapM}
-- ignore: {name: Redundant lambda}
 - ignore: {name: Use <=<}
-- ignore: {name: Replace case with maybe}
 - ignore: {name: Use sequenceA}
 - ignore: {name: Use camelCase}
-- ignore: {name: Avoid lambda using `infix`}
-- ignore: {name: Redundant irrefutable pattern}
-- ignore: {name: Use tuple-section}
-- ignore: {name: Use mapMaybe}
-- ignore: {name: Use second}
-- ignore: {name: Use isNothing}
-- ignore: {name: Use maybe}
 - ignore: {name: Redundant return}
-- ignore: {name: Unused LANGUAGE pragma}
+- ignore: {name: Use <$>, within: Hasura.RQL.DDL.Metadata}
+- ignore: {name: Functor law, within: Hasura.Server.AuthSpec}
 
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~
 
 
 # To generate a suitable file for HLint do:
 # $ hlint --default > .hlint.yaml
+
+
+- group:
+    name: hasura-prelude
+    enabled: true
+    imports:
+    - package base
+    rules:
+    - warn: {lhs: "maybe b return a", rhs: "onNothing a b"}
+    - warn: {lhs: "maybe (return ()) b a", rhs: "onJust a b"}
+    - warn: {lhs: "either b return a", rhs: "onLeft a b"}
+
+- group:
+    name: data-text-extended
+    enabled: true
+    imports:
+    - package base
+    rules:
+    - warn: {lhs: "Data.Text.intercalate \", \" x", rhs: "commaSeparated x", note: "From Data.Text.Extended"}

server/bench-wrk/wrk-websocket-server/src/Wrk/Server.hs

@@ -56,7 +56,7 @@ processReq conn msg lock = do
     catchIO :: IO (Either ErrorMessage a) -> IO (Either ErrorMessage a)
     catchIO f = do
       resIOE <- E.try f
-      either (return . Left . ioExToErr) return resIOE
+      return $ either (Left . ioExToErr) id resIOE
     ioExToErr :: E.SomeException -> ErrorMessage
     ioExToErr e = ErrorMessage $ J.object ["IOError" J..= show e ]
 
@@ -253,5 +253,5 @@ uptoFirstMatch str = fmap T.concat $ AT.manyTill nextPossibleMatch $ AT.string s
 takeIncludingFirstMatch :: T.Text -> AT.Parser T.Text
 takeIncludingFirstMatch str = withSubStr <|> errMsg
   where
-    withSubStr = fmap (`T.append` str) $ uptoFirstMatch str
+    withSubStr = (`T.append` str) <$> uptoFirstMatch str
     errMsg = fail $ "Could not find sub-string: " <> T.unpack str

server/src-bench-cache/Main.hs

@@ -35,7 +35,7 @@ main = defaultMain [
     ]
     -- simple insert benchmark. Try to avoid drift by initialising fresh
     -- and measuring 1000 inserts at a time.
-  , env (randomInts 1000) $ \ ~rs->
+  , env (randomInts 1000) $ \rs ->
       bgroup "insert x1000" [
         -- use perRunEnv so we can be sure we're not triggering cache
         -- evictions in bounded due to long bootstrap batch runs
@@ -45,7 +45,7 @@ main = defaultMain [
       -- an eviction on each insert, all LRU counters at zero. Simulates a scan.
       , bench "bounded evicting scan" $
           let preloaded = populate 5000 (Cache.initialise 5000) Cache.insertAllStripes
-           in perRunEnv (preloaded) $ \(cache, _) ->
+           in perRunEnv preloaded $ \(cache, _) ->
                 V.mapM_ (\k -> Cache.insert k k cache) rs
       ]
 
@@ -147,7 +147,7 @@ realisticBenches name wrk =
       --   We should also look into just generating a report by hand that takes
       -- into account per-thread misses without actually simulating them with
       -- burnCycles.
-      putStrLn $ "TIMING: " <>(show $ fromIntegral (aft - bef) / (1000*1000 :: Double)) <> "ms"
+      putStrLn $ "TIMING: " <> show (fromIntegral (aft - bef) / (1000*1000 :: Double)) <> "ms"
       -- putStrLn $ "HITS/MISSES: "<> show _hitsMisses  -- DEBUGGING/FYI
       return ()
       where
@@ -198,9 +198,9 @@ readBenches n =
     env (populate n (Cache.initialise (fromIntegral $ n*2)) Cache.insertAllStripes) $ \ ~(cache, k)->
       bgroup "bounded" [
         bench "hit" $
-          nfAppIO (\k' -> Cache.lookup k' cache) k
+          nfAppIO (`Cache.lookup` cache) k
       , bench "miss" $
-          nfAppIO (\k' -> Cache.lookup k' cache) 0xDEAD
+          nfAppIO (`Cache.lookup` cache) 0xDEAD
       ]
   ]
 

server/src-lib/Control/Arrow/Extended.hs

@@ -102,7 +102,7 @@ instance Applicative (Traversal a r) where
     Yield v k -> Yield v ((<*> tx) . k)
 
 traversal :: (Traversable t) => t a -> Traversal a b (t b)
-traversal = traverse (flip Yield Done)
+traversal = traverse (`Yield` Done)
 
 -- | 'traverse' lifted to arrows. See also Note [Weird control operator types].
 traverseA :: (ArrowChoice arr, Traversable t) => arr (e, (a, s)) b -> arr (e, (t a, s)) (t b)

server/src-lib/Control/Arrow/Trans.hs

@@ -38,7 +38,7 @@ liftEitherA :: (ArrowChoice arr, ArrowError e arr) => arr (Either e a) a
 liftEitherA = throwA ||| returnA
 {-# INLINE liftEitherA #-}
 
-mapErrorA :: (ArrowError e arr) => arr (a, s) b -> arr (a, ((e -> e), s)) b
+mapErrorA :: (ArrowError e arr) => arr (a, s) b -> arr (a, (e -> e, s)) b
 mapErrorA f = proc (a, (g, s)) -> (f -< (a, s)) `catchA` \e -> throwA -< g e
 {-# INLINE mapErrorA #-}
 
@@ -178,7 +178,7 @@ newtype WriterA w arr a b
   = MkWriterA (arr (a, w) (b, w))
 
 pattern WriterA :: (Monoid w, Arrow arr) => arr a (b, w) -> WriterA w arr a b
-pattern WriterA { runWriterA } <- MkWriterA ((\f -> f . arr (, mempty)) -> runWriterA)
+pattern WriterA { runWriterA } <- MkWriterA (\f -> f . arr (, mempty) -> runWriterA)
   where
     WriterA f = MkWriterA (arr (\((b, w), w1) -> let !w2 = w1 <> w in (b, w2)) . first f)
 {-# COMPLETE WriterA #-}

server/src-lib/Data/URL/Template.hs

@@ -88,7 +88,7 @@ instance Arbitrary Variable where
 instance Arbitrary URLTemplate where
   arbitrary = URLTemplate <$> listOf (oneof [genText, genVariable])
     where
-      genText = (TIText . T.pack) <$> listOf1 (elements $ alphaNumerics <> " ://")
+      genText = TIText . T.pack <$> listOf1 (elements $ alphaNumerics <> " ://")
       genVariable = TIVariable <$> arbitrary
 
 genURLTemplate :: Gen URLTemplate

server/src-lib/Hasura/App.hs

@@ -137,7 +137,7 @@ parseArgs = do
   rawHGEOpts <- execParser opts
   env <- getEnvironment
   let eitherOpts = runWithEnv env $ mkHGEOptions rawHGEOpts
-  either (printErrExit InvalidEnvironmentVariableOptionsError) return eitherOpts
+  onLeft eitherOpts $ printErrExit InvalidEnvironmentVariableOptionsError
   where
     opts = info (helper <*> hgeOpts)
            ( fullDesc <>
@@ -221,7 +221,7 @@ initialiseCtx env hgeCmd rci = do
   pure (InitCtx httpManager instanceId loggers connInfo pool latch res, initTime)
   where
     procConnInfo =
-      either (printErrExit InvalidDatabaseConnectionParamsError . ("Fatal Error : " <>)) return $ mkConnInfo rci
+      onLeft (mkConnInfo rci) $ printErrExit InvalidDatabaseConnectionParamsError . ("Fatal Error : " <>)
 
     getMinimalPool pgLogger ci = do
       let connParams = Q.defaultConnParams { Q.cpConns = 1 }
@@ -260,7 +260,7 @@ migrateCatalogSchema env logger pool httpManager sqlGenCtx = do
 runTxIO :: Q.PGPool -> Q.TxMode -> Q.TxE QErr a -> IO a
 runTxIO pool isoLevel tx = do
   eVal <- liftIO $ runExceptT $ Q.runTx pool isoLevel tx
-  either (printErrJExit DatabaseMigrationError) return eVal
+  onLeft eVal (printErrJExit DatabaseMigrationError)
 
 -- | A latch for the graceful shutdown of a server process.
 newtype ShutdownLatch = ShutdownLatch { unShutdownLatch :: C.MVar () }
@@ -335,7 +335,7 @@ runHGEServer env ServeOptions{..} InitCtx{..} pgExecCtx initTime shutdownApp pos
   authModeRes <- runExceptT $ setupAuthMode soAdminSecret soAuthHook soJwtSecret soUnAuthRole
                               _icHttpManager logger
 
-  authMode <- either (printErrExit AuthConfigurationError . T.unpack) return authModeRes
+  authMode <- onLeft authModeRes (printErrExit AuthConfigurationError . T.unpack)
 
   _idleGCThread <- C.forkImmortal "ourIdleGC" logger $ liftIO $
     ourIdleGC logger (seconds 0.3) (seconds 10) (seconds 60)
@@ -459,7 +459,7 @@ runHGEServer env ServeOptions{..} InitCtx{..} pgExecCtx initTime shutdownApp pos
     prepareScheduledEvents pool (Logger logger) = do
       liftIO $ logger $ mkGenericStrLog LevelInfo "scheduled_triggers" "preparing data"
       res <- liftIO $ runTx pool (Q.ReadCommitted, Nothing) unlockAllLockedScheduledEvents
-      either (printErrJExit EventSubSystemError) return res
+      onLeft res (printErrJExit EventSubSystemError)
 
     -- | shutdownEvents will be triggered when a graceful shutdown has been inititiated, it will
     -- get the locked events from the event engine context and the scheduled event engine context

server/src-lib/Hasura/Backends/Postgres/Connection.hs

@@ -46,23 +46,23 @@ import           Hasura.Session
 
 data PGExecCtx
   = PGExecCtx
-  { _pecRunReadOnly  :: (forall a. Q.TxE QErr a -> ExceptT QErr IO a)
+  { _pecRunReadOnly  :: forall a. Q.TxE QErr a -> ExceptT QErr IO a
   -- ^ Run a Q.ReadOnly transaction
-  , _pecRunReadNoTx  :: (forall a. Q.TxE QErr a -> ExceptT QErr IO a)
+  , _pecRunReadNoTx  :: forall a. Q.TxE QErr a -> ExceptT QErr IO a
   -- ^ Run a read only statement without an explicit transaction block
-  , _pecRunReadWrite :: (forall a. Q.TxE QErr a -> ExceptT QErr IO a)
+  , _pecRunReadWrite :: forall a. Q.TxE QErr a -> ExceptT QErr IO a
   -- ^ Run a Q.ReadWrite transaction
-  , _pecCheckHealth  :: (IO Bool)
+  , _pecCheckHealth  :: IO Bool
   -- ^ Checks the health of this execution context
   }
 
 -- | Creates a Postgres execution context for a single Postgres master pool
 mkPGExecCtx :: Q.TxIsolation -> Q.PGPool -> PGExecCtx
 mkPGExecCtx isoLevel pool =
   PGExecCtx
-  { _pecRunReadOnly = (Q.runTx pool (isoLevel, Just Q.ReadOnly))
-  , _pecRunReadNoTx = (Q.runTx' pool)
-  , _pecRunReadWrite = (Q.runTx pool (isoLevel, Just Q.ReadWrite))
+  { _pecRunReadOnly = Q.runTx pool (isoLevel, Just Q.ReadOnly)
+  , _pecRunReadNoTx = Q.runTx' pool
+  , _pecRunReadWrite = Q.runTx pool (isoLevel, Just Q.ReadWrite)
   , _pecCheckHealth = checkDbConnection
   }
   where

server/src-lib/Hasura/Eventing/EventTrigger.hs

@@ -350,7 +350,7 @@ processError pool e retryConf decodedHeaders ep err = do
               respStatus = hrsStatus errResp
           mkInvocation ep respStatus decodedHeaders respPayload respHeaders
         HOther detail -> do
-          let errMsg = (TBS.fromLBS $ encode detail)
+          let errMsg = TBS.fromLBS $ encode detail
           mkInvocation ep 500 decodedHeaders errMsg []
   liftIO $ runExceptT $ Q.runTx pool (Q.ReadCommitted, Just Q.ReadWrite) $ do
     insertInvocation invocation
@@ -381,7 +381,7 @@ retryOrSetError e retryConf err = do
 
 mkInvocation
   :: EventPayload -> Int -> [HeaderConf] -> TBS.TByteString -> [HeaderConf]
-  -> (Invocation 'EventType)
+  -> Invocation 'EventType
 mkInvocation ep status reqHeaders respBody respHeaders
   = let resp = if isClientError status
           then mkClientErr respBody
@@ -506,7 +506,7 @@ instance Q.ToPrepArg EventIdArray where
 --   when a graceful shutdown is initiated.
 unlockEvents :: [EventId] -> Q.TxE QErr Int
 unlockEvents eventIds =
-   (runIdentity . Q.getRow) <$> Q.withQE defaultTxErrorHandler
+   runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler
    [Q.sql|
      WITH "cte" AS
      (UPDATE hdb_catalog.event_log

server/src-lib/Hasura/Eventing/HTTP.hs

@@ -132,7 +132,7 @@ data Invocation (a :: TriggerTypes)
   { iEventId  :: EventId
   , iStatus   :: Int
   , iRequest  :: WebhookRequest
-  , iResponse :: (Response a)
+  , iResponse :: Response a
   }
 
 data ExtraLogContext

server/src-lib/Hasura/Eventing/ScheduledTrigger.hs

@@ -321,7 +321,7 @@ insertCronEventsFor cronTriggersWithStats = do
               }
       Q.unitQE defaultTxErrorHandler (Q.fromText insertCronEventsSql) () False
   where
-    toArr (CronEventSeed n t) = [(triggerNameToTxt n), (formatTime' t)]
+    toArr (CronEventSeed n t) = [triggerNameToTxt n, formatTime' t]
     toTupleExp = TupleExp . map SELit
 
 insertCronEvents :: [CronEventSeed] -> Q.TxE QErr ()
@@ -336,7 +336,7 @@ insertCronEvents events = do
           }
   Q.unitQE defaultTxErrorHandler (Q.fromText insertCronEventsSql) () False
   where
-    toArr (CronEventSeed n t) = [(triggerNameToTxt n), (formatTime' t)]
+    toArr (CronEventSeed n t) = [triggerNameToTxt n, formatTime' t]
     toTupleExp = TupleExp . map SELit
 
 generateCronEventsFrom :: UTCTime -> CronTriggerInfo-> [CronEventSeed]
@@ -542,7 +542,7 @@ processError pgpool se decodedHeaders type' reqJson err = do
               respStatus = hrsStatus errResp
           mkInvocation se respStatus decodedHeaders respPayload respHeaders reqJson
         HOther detail -> do
-          let errMsg = (TBS.fromLBS $ J.encode detail)
+          let errMsg = TBS.fromLBS $ J.encode detail
           mkInvocation se 500 decodedHeaders errMsg [] reqJson
   liftExceptTIO $
     Q.runTx pgpool (Q.ReadCommitted, Just Q.ReadWrite) $ do
@@ -648,7 +648,7 @@ mkInvocation
   -> TBS.TByteString
   -> [HeaderConf]
   -> J.Value
-  -> (Invocation 'ScheduledType)
+  -> Invocation 'ScheduledType
 mkInvocation ScheduledEventFull {sefId} status reqHeaders respBody respHeaders reqBodyJson
   = let resp = if isClientError status
           then mkClientErr respBody
@@ -660,7 +660,7 @@ mkInvocation ScheduledEventFull {sefId} status reqHeaders respBody respHeaders r
       (mkWebhookReq reqBodyJson reqHeaders invocationVersionST)
       resp
 
-insertInvocation :: (Invocation 'ScheduledType) -> ScheduledEventType ->  Q.TxE QErr ()
+insertInvocation :: Invocation 'ScheduledType -> ScheduledEventType ->  Q.TxE QErr ()
 insertInvocation invo type' = do
   case type' of
     Cron -> do
@@ -784,7 +784,7 @@ instance Q.ToPrepArg ScheduledEventIdArray where
 
 unlockCronEvents :: [ScheduledEventId] -> Q.TxE QErr Int
 unlockCronEvents scheduledEventIds =
-   (runIdentity . Q.getRow) <$> Q.withQE defaultTxErrorHandler
+   runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler
    [Q.sql|
      WITH "cte" AS
      (UPDATE hdb_catalog.hdb_cron_events
@@ -796,7 +796,7 @@ unlockCronEvents scheduledEventIds =
 
 unlockOneOffScheduledEvents :: [ScheduledEventId] -> Q.TxE QErr Int
 unlockOneOffScheduledEvents scheduledEventIds =
-   (runIdentity . Q.getRow) <$> Q.withQE defaultTxErrorHandler
+   runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler
    [Q.sql|
      WITH "cte" AS
      (UPDATE hdb_catalog.hdb_scheduled_events