{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Krank
  ( runKrank,
    Krank (..),
  )
where

import Control.Concurrent.Async.Lifted (mapConcurrently)
import Control.Exception.Safe
import Control.Monad.Reader
import qualified Data.ByteString
import Data.Coerce
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import Krank.Checkers.Ignore (filterViolations)
import qualified Krank.Checkers.IssueTracker as IT
import Krank.Formatter
import Krank.Types
import qualified Network.HTTP.Req as Req
import PyF
import System.IO (stderr)

processFile ::
  MonadKrank m =>
  -- | the file to analyze
  FilePath ->
  m [Violation]
processFile :: FilePath -> m [Violation]
processFile FilePath
filePath = do
  ByteString
content <- FilePath -> m ByteString
forall (m :: * -> *). MonadKrank m => FilePath -> m ByteString
krankReadFile FilePath
filePath
  [Violation]
violations <- FilePath -> ByteString -> m [Violation]
forall (m :: * -> *).
MonadKrank m =>
FilePath -> ByteString -> m [Violation]
IT.checkText FilePath
filePath ByteString
content
  let filtered :: [Violation]
filtered = [Violation] -> FilePath -> ByteString -> [Violation]
filterViolations [Violation]
violations FilePath
filePath ByteString
content
  -- forcing 'violations' to WHNF forces more of the processing to happen inside the thread and
  -- improves a bit the runtime performances in parallel.
  -- forcing to Normal Form (with deepseq) does not bring anymore improvement
  [Violation] -> m [Violation]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Violation] -> m [Violation]) -> [Violation] -> m [Violation]
forall a b. (a -> b) -> a -> b
$! [Violation]
filtered

runKrank :: MonadKrank m => [FilePath] -> m Bool
runKrank :: [FilePath] -> m Bool
runKrank [FilePath]
paths = do
  KrankConfig {Bool
useColors :: KrankConfig -> Bool
useColors :: Bool
useColors} <- (KrankConfig -> KrankConfig) -> m KrankConfig
forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks KrankConfig -> KrankConfig
forall a. a -> a
id
  [Either Text [Violation]]
res <- [FilePath]
-> (FilePath -> m (Either Text [Violation]))
-> m [Either Text [Violation]]
forall (m :: * -> *) a b.
MonadKrank m =>
[a] -> (a -> m b) -> m [b]
krankForConcurrently [FilePath]
paths ((FilePath -> m (Either Text [Violation]))
 -> m [Either Text [Violation]])
-> (FilePath -> m (Either Text [Violation]))
-> m [Either Text [Violation]]
forall a b. (a -> b) -> a -> b
$ \FilePath
path ->
    ([Violation] -> Either Text [Violation]
forall a b. b -> Either a b
Right ([Violation] -> Either Text [Violation])
-> m [Violation] -> m (Either Text [Violation])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m [Violation]
forall (m :: * -> *). MonadKrank m => FilePath -> m [Violation]
processFile FilePath
path)
      m (Either Text [Violation])
-> (SomeException -> m (Either Text [Violation]))
-> m (Either Text [Violation])
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\(SomeException e
e) -> Either Text [Violation] -> m (Either Text [Violation])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text [Violation] -> m (Either Text [Violation]))
-> Either Text [Violation] -> m (Either Text [Violation])
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Violation]
forall a b. a -> Either a b
Left [fmt|Error when processing {path}: {show e}|])
  [Either Text [Violation]]
-> (Either Text [Violation] -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Either Text [Violation]]
res ((Either Text [Violation] -> m ()) -> m ())
-> (Either Text [Violation] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \case
    Left Text
err -> Text -> m ()
forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStrLnStderr Text
err
    Right [Violation]
violations -> Text -> m ()
forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStr ((Violation -> Text) -> [Violation] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> Violation -> Text
showViolation Bool
useColors) [Violation]
violations)
  -- Check if any violation is an error
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ((Either Text [Violation] -> Bool)
-> [Either Text [Violation]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Text [Violation] -> Bool
isError [Either Text [Violation]]
res)

-- | Returns 'True' if any violation level is error or if any error occurs.
isError :: Either Text.Text [Violation] -> Bool
isError :: Either Text [Violation] -> Bool
isError (Left Text
_) = Bool
True
isError (Right [Violation]
violations) = (Violation -> Bool) -> [Violation] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Violation -> Bool
isViolationError [Violation]
violations

isViolationError :: Violation -> Bool
isViolationError :: Violation -> Bool
isViolationError Violation {level :: Violation -> ViolationLevel
level = ViolationLevel
Error} = Bool
True
isViolationError Violation
_ = Bool
False

-- | This just exists to avoid the orphan instance on MonadKrank
newtype Krank t = Krank {Krank t -> ReaderT KrankConfig IO t
unKrank :: ReaderT KrankConfig IO t}
  deriving newtype (a -> Krank b -> Krank a
(a -> b) -> Krank a -> Krank b
(forall a b. (a -> b) -> Krank a -> Krank b)
-> (forall a b. a -> Krank b -> Krank a) -> Functor Krank
forall a b. a -> Krank b -> Krank a
forall a b. (a -> b) -> Krank a -> Krank b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Krank b -> Krank a
$c<$ :: forall a b. a -> Krank b -> Krank a
fmap :: (a -> b) -> Krank a -> Krank b
$cfmap :: forall a b. (a -> b) -> Krank a -> Krank b
Functor, Functor Krank
a -> Krank a
Functor Krank
-> (forall a. a -> Krank a)
-> (forall a b. Krank (a -> b) -> Krank a -> Krank b)
-> (forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c)
-> (forall a b. Krank a -> Krank b -> Krank b)
-> (forall a b. Krank a -> Krank b -> Krank a)
-> Applicative Krank
Krank a -> Krank b -> Krank b
Krank a -> Krank b -> Krank a
Krank (a -> b) -> Krank a -> Krank b
(a -> b -> c) -> Krank a -> Krank b -> Krank c
forall a. a -> Krank a
forall a b. Krank a -> Krank b -> Krank a
forall a b. Krank a -> Krank b -> Krank b
forall a b. Krank (a -> b) -> Krank a -> Krank b
forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Krank a -> Krank b -> Krank a
$c<* :: forall a b. Krank a -> Krank b -> Krank a
*> :: Krank a -> Krank b -> Krank b
$c*> :: forall a b. Krank a -> Krank b -> Krank b
liftA2 :: (a -> b -> c) -> Krank a -> Krank b -> Krank c
$cliftA2 :: forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
<*> :: Krank (a -> b) -> Krank a -> Krank b
$c<*> :: forall a b. Krank (a -> b) -> Krank a -> Krank b
pure :: a -> Krank a
$cpure :: forall a. a -> Krank a
$cp1Applicative :: Functor Krank
Applicative, Applicative Krank
a -> Krank a
Applicative Krank
-> (forall a b. Krank a -> (a -> Krank b) -> Krank b)
-> (forall a b. Krank a -> Krank b -> Krank b)
-> (forall a. a -> Krank a)
-> Monad Krank
Krank a -> (a -> Krank b) -> Krank b
Krank a -> Krank b -> Krank b
forall a. a -> Krank a
forall a b. Krank a -> Krank b -> Krank b
forall a b. Krank a -> (a -> Krank b) -> Krank b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Krank a
$creturn :: forall a. a -> Krank a
>> :: Krank a -> Krank b -> Krank b
$c>> :: forall a b. Krank a -> Krank b -> Krank b
>>= :: Krank a -> (a -> Krank b) -> Krank b
$c>>= :: forall a b. Krank a -> (a -> Krank b) -> Krank b
$cp1Monad :: Applicative Krank
Monad, MonadThrow Krank
MonadThrow Krank
-> (forall e a.
    Exception e =>
    Krank a -> (e -> Krank a) -> Krank a)
-> MonadCatch Krank
Krank a -> (e -> Krank a) -> Krank a
forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: Krank a -> (e -> Krank a) -> Krank a
$ccatch :: forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
$cp1MonadCatch :: MonadThrow Krank
MonadCatch, Monad Krank
e -> Krank a
Monad Krank
-> (forall e a. Exception e => e -> Krank a) -> MonadThrow Krank
forall e a. Exception e => e -> Krank a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> Krank a
$cthrowM :: forall e a. Exception e => e -> Krank a
$cp1MonadThrow :: Monad Krank
MonadThrow)

-- | The real monad implementation for Krank
instance MonadKrank Krank where
  krankReadFile :: FilePath -> Krank ByteString
krankReadFile = ReaderT KrankConfig IO ByteString -> Krank ByteString
forall t. ReaderT KrankConfig IO t -> Krank t
Krank (ReaderT KrankConfig IO ByteString -> Krank ByteString)
-> (FilePath -> ReaderT KrankConfig IO ByteString)
-> FilePath
-> Krank ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> ReaderT KrankConfig IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ReaderT KrankConfig IO ByteString)
-> (FilePath -> IO ByteString)
-> FilePath
-> ReaderT KrankConfig IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
Data.ByteString.readFile

  krankAsks :: (KrankConfig -> b) -> Krank b
krankAsks = ReaderT KrankConfig IO b -> Krank b
forall t. ReaderT KrankConfig IO t -> Krank t
Krank (ReaderT KrankConfig IO b -> Krank b)
-> ((KrankConfig -> b) -> ReaderT KrankConfig IO b)
-> (KrankConfig -> b)
-> Krank b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KrankConfig -> b) -> ReaderT KrankConfig IO b
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks

  krankPutStrLnStderr :: Text -> Krank ()
krankPutStrLnStderr = ReaderT KrankConfig IO () -> Krank ()
forall t. ReaderT KrankConfig IO t -> Krank t
Krank (ReaderT KrankConfig IO () -> Krank ())
-> (Text -> ReaderT KrankConfig IO ()) -> Text -> Krank ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ReaderT KrankConfig IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT KrankConfig IO ())
-> (Text -> IO ()) -> Text -> ReaderT KrankConfig IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
stderr

  krankPutStr :: Text -> Krank ()
krankPutStr = ReaderT KrankConfig IO () -> Krank ()
forall t. ReaderT KrankConfig IO t -> Krank t
Krank (ReaderT KrankConfig IO () -> Krank ())
-> (Text -> ReaderT KrankConfig IO ()) -> Text -> Krank ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ReaderT KrankConfig IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT KrankConfig IO ())
-> (Text -> IO ()) -> Text -> ReaderT KrankConfig IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.IO.putStr

  -- Use threads for concurrency
  krankMapConcurrently :: (a -> Krank b) -> [a] -> Krank [b]
krankMapConcurrently a -> Krank b
f [a]
l = ReaderT KrankConfig IO [b] -> Krank [b]
forall t. ReaderT KrankConfig IO t -> Krank t
Krank (ReaderT KrankConfig IO [b] -> Krank [b])
-> ReaderT KrankConfig IO [b] -> Krank [b]
forall a b. (a -> b) -> a -> b
$ (a -> ReaderT KrankConfig IO b)
-> [a] -> ReaderT KrankConfig IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (Krank b -> ReaderT KrankConfig IO b
coerce (Krank b -> ReaderT KrankConfig IO b)
-> (a -> Krank b) -> a -> ReaderT KrankConfig IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Krank b
f) [a]
l

  -- This implements a Req REST request
  krankRunRESTRequest :: Url 'Https -> Option 'Https -> Krank t
krankRunRESTRequest Url 'Https
url Option 'Https
headers = ReaderT KrankConfig IO t -> Krank t
forall t. ReaderT KrankConfig IO t -> Krank t
Krank
    (ReaderT KrankConfig IO t -> Krank t)
-> ReaderT KrankConfig IO t -> Krank t
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req t -> ReaderT KrankConfig IO t
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig
    (Req t -> ReaderT KrankConfig IO t)
-> Req t -> ReaderT KrankConfig IO t
forall a b. (a -> b) -> a -> b
$ do
      JsonResponse t
r <-
        GET
-> Url 'Https
-> NoReqBody
-> Proxy (JsonResponse t)
-> Option 'Https
-> Req (JsonResponse t)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
          GET
Req.GET
          Url 'Https
url
          NoReqBody
Req.NoReqBody
          Proxy (JsonResponse t)
forall a. Proxy (JsonResponse a)
Req.jsonResponse
          ( ByteString -> ByteString -> Option 'Https
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
Req.header ByteString
"User-Agent" ByteString
"krank"
              Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> Option 'Https
headers
          )
      t -> Req t
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> Req t) -> t -> Req t
forall a b. (a -> b) -> a -> b
$ JsonResponse t -> HttpResponseBody (JsonResponse t)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody JsonResponse t
r