{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}
module Tokstyle.Linter.UnsafeFunc (descr) where

import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), Node, NodeF (..))
import           Language.Cimple.Diagnostics (warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)

forbidden :: [(Text, (Text, Maybe Text))]
forbidden :: [(Text, (Text, Maybe Text))]
forbidden =
    [ (Text
"atexit"  , (Text
"creates global state that should be avoided"            , Maybe Text
forall a. Maybe a
Nothing))
    , (Text
"atof"    , (Text
"does not perform error checking"                        , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`strtod`"))
    , (Text
"atoi"    , (Text
"does not perform error checking"                        , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`strtol`"))
    , (Text
"atoll"   , (Text
"does not perform error checking"                        , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`strtoll`"))
    , (Text
"atol"    , (Text
"does not perform error checking"                        , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`strtol`"))
    , (Text
"gets"    , (Text
"performs unbounded writes to buffers"                   , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`fgets`"))
    , (Text
"sprintf" , (Text
"has no way of bounding the number of characters written", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`snprintf`"))
    , (Text
"strerror", (Text
"is not thread safe"                                     , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`strerror_r` or `net_new_strerror`"))
    , (Text
"strcat"  , (Text
"has no way of bounding the number of characters written", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`snprintf`"))
    , (Text
"strcpy"  , (Text
"has no way of bounding the number of characters written", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`snprintf` or `strlen` and `memcpy`"))
    , (Text
"strncpy" , (Text
"may not null-terminate the target string"               , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`snprintf` or `strlen` and `memcpy`"))
    , (Text
"strdup"  , (Text
"is non-portable"                                        , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`mem_balloc` followed by `memcpy`"))
    , (Text
"strtok"  , (Text
"is not thread-safe"                                     , Maybe Text
forall a. Maybe a
Nothing))
    , (Text
"vsprintf", (Text
"has no way of bounding the number of characters written", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"`vsnprintf`"))
    ]

checkName :: Text -> Maybe (Text, (Text, Maybe Text))
checkName :: Text -> Maybe (Text, (Text, Maybe Text))
checkName Text
name = (Text
name,) ((Text, Maybe Text) -> (Text, (Text, Maybe Text)))
-> Maybe (Text, Maybe Text) -> Maybe (Text, (Text, Maybe Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [(Text, (Text, Maybe Text))] -> Maybe (Text, Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, (Text, Maybe Text))]
forbidden

linter :: AstActions (State [Text]) Text
linter :: AstActions (State [Text]) Text
linter = AstActions (State [Text]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text) -> State [Text] () -> State [Text] ()
doNode = \FilePath
file Node (Lexeme Text)
node State [Text] ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ (Text -> Maybe (Text, (Text, Maybe Text))
checkName -> Just (Text
name, (Text
msg, Maybe Text
replacement)))))) [Node (Lexeme Text)]
_ ->
                FilePath -> Node (Lexeme Text) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
node (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"function `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should not be used, because it " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
r -> Text
"; use " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" instead") Maybe Text
replacement

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State [Text] ()
act
    }

analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse :: (FilePath, [Node (Lexeme Text)]) -> [Text]
analyse = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> [Text])
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [Text] () -> [Text] -> [Text])
-> [Text] -> State [Text] () -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Text] () -> [Text] -> [Text]
forall s a. State s a -> s -> s
State.execState [] (State [Text] () -> [Text])
-> ((FilePath, [Node (Lexeme Text)]) -> State [Text] ())
-> (FilePath, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Text]) Text
-> (FilePath, [Node (Lexeme Text)]) -> State [Text] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Text]) Text
linter

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Text], (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Text]
analyse, (Text
"unsafe-func", [Text] -> Text
Text.unlines
    [ Text
"Explicitly forbids the use of some C functions considered unsafe:"
    , Text
""
    , Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text)
-> ([(Text, (Text, Maybe Text))] -> [Text])
-> [(Text, (Text, Maybe Text))]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, (Text, Maybe Text)) -> Text)
-> [(Text, (Text, Maybe Text))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, (Text, Maybe Text)) -> Text
forall a. (Semigroup a, IsString a) => (a, (a, Maybe a)) -> a
mkWhy ([(Text, (Text, Maybe Text))] -> Text)
-> [(Text, (Text, Maybe Text))] -> Text
forall a b. (a -> b) -> a -> b
$ [(Text, (Text, Maybe Text))]
forbidden
    , Text
""
    , Text
"**Reason:** ."
    ]))
  where
    mkWhy :: (a, (a, Maybe a)) -> a
mkWhy (a
name, (a
msg, Maybe a
replacement)) =
        a
"- `" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"`, because it " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
msg a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"."
        a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
"" (\a
r -> a
"\n  " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
r a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" should be used, instead.") Maybe a
replacement