{-# 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 =>
FilePath ->
m [Violation]
processFile :: forall (m :: * -> *). MonadKrank m => FilePath -> m [Violation]
processFile FilePath
filePath = do
ByteString
content <- forall (m :: * -> *). MonadKrank m => FilePath -> m ByteString
krankReadFile FilePath
filePath
[Violation]
violations <- 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! [Violation]
filtered
runKrank :: MonadKrank m => [FilePath] -> m Bool
runKrank :: forall (m :: * -> *). MonadKrank m => [FilePath] -> m Bool
runKrank [FilePath]
paths = do
KrankConfig {Bool
useColors :: KrankConfig -> Bool
useColors :: Bool
useColors} <- forall (m :: * -> *) b. MonadKrank m => (KrankConfig -> b) -> m b
krankAsks forall a. a -> a
id
[Either Text [Violation]]
res <- forall (m :: * -> *) a b.
MonadKrank m =>
[a] -> (a -> m b) -> m [b]
krankForConcurrently [FilePath]
paths forall a b. (a -> b) -> a -> b
$ \FilePath
path ->
(forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadKrank m => FilePath -> m [Violation]
processFile FilePath
path)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\(SomeException e
e) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [fmt|Error when processing {path}: {show e}|])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Either Text [Violation]]
res forall a b. (a -> b) -> a -> b
$ \case
Left Text
err -> forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStrLnStderr Text
err
Right [Violation]
violations -> forall (m :: * -> *). MonadKrank m => Text -> m ()
krankPutStr (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Bool -> Violation -> Text
showViolation Bool
useColors) [Violation]
violations)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either Text [Violation] -> Bool
isError [Either Text [Violation]]
res)
isError :: Either Text.Text [Violation] -> Bool
isError :: Either Text [Violation] -> Bool
isError (Left Text
_) = Bool
True
isError (Right [Violation]
violations) = 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
newtype Krank t = Krank {forall t. Krank t -> ReaderT KrankConfig IO t
unKrank :: ReaderT KrankConfig IO t}
deriving newtype (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
<$ :: forall a b. a -> Krank b -> Krank a
$c<$ :: forall a b. a -> Krank b -> Krank a
fmap :: forall a b. (a -> b) -> Krank a -> Krank b
$cfmap :: forall a b. (a -> b) -> Krank a -> Krank b
Functor, Functor Krank
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
<* :: forall a b. Krank a -> Krank b -> Krank a
$c<* :: forall a b. Krank a -> Krank b -> Krank a
*> :: forall a b. Krank a -> Krank b -> Krank b
$c*> :: forall a b. Krank a -> Krank b -> Krank b
liftA2 :: forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
$cliftA2 :: forall a b c. (a -> b -> c) -> Krank a -> Krank b -> Krank c
<*> :: forall a b. Krank (a -> b) -> Krank a -> Krank b
$c<*> :: forall a b. Krank (a -> b) -> Krank a -> Krank b
pure :: forall a. a -> Krank a
$cpure :: forall a. a -> Krank a
Applicative, Applicative Krank
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 :: forall a. a -> Krank a
$creturn :: forall a. a -> Krank a
>> :: forall a b. Krank a -> Krank b -> Krank b
$c>> :: forall a b. Krank a -> Krank b -> Krank b
>>= :: forall a b. Krank a -> (a -> Krank b) -> Krank b
$c>>= :: forall a b. Krank a -> (a -> Krank b) -> Krank b
Monad, MonadThrow Krank
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 :: forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
$ccatch :: forall e a. Exception e => Krank a -> (e -> Krank a) -> Krank a
MonadCatch, Monad Krank
forall e a. Exception e => e -> Krank a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> Krank a
$cthrowM :: forall e a. Exception e => e -> Krank a
MonadThrow)
instance MonadKrank Krank where
krankReadFile :: FilePath -> Krank ByteString
krankReadFile = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
Data.ByteString.readFile
krankAsks :: forall b. (KrankConfig -> b) -> Krank b
krankAsks = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks
krankPutStrLnStderr :: Text -> Krank ()
krankPutStrLnStderr = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
stderr
krankPutStr :: Text -> Krank ()
krankPutStr = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.IO.putStr
krankMapConcurrently :: forall a b. (a -> Krank b) -> [a] -> Krank [b]
krankMapConcurrently a -> Krank b
f [a]
l = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadBaseControl IO m) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Krank b
f) [a]
l
krankRunRESTRequest :: forall t. FromJSON t => Url 'Https -> Option 'Https -> Krank t
krankRunRESTRequest Url 'Https
url Option 'Https
headers = forall t. ReaderT KrankConfig IO t -> Krank t
Krank forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig forall a b. (a -> b) -> a -> b
$
do
JsonResponse t
r <-
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
forall a. Proxy (JsonResponse a)
Req.jsonResponse
( forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
Req.header ByteString
"User-Agent" ByteString
"krank"
forall a. Semigroup a => a -> a -> a
<> Option 'Https
headers
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody JsonResponse t
r