{-# 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 (CimplePos, Diagnostic)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty, (<+>))
import           Tokstyle.Common             (backticks, warn, warnDoc)

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_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 [Diagnostic CimplePos]) Text
linter :: AstActions (State [Diagnostic CimplePos]) Text
linter = AstActions (State [Diagnostic CimplePos]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: FilePath
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
doNode = \FilePath
file Node (Lexeme Text)
node State [Diagnostic CimplePos] ()
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)
-> Doc AnsiStyle
-> State [Diagnostic CimplePos] ()
forall diags at.
(HasDiagnosticsRich diags CimplePos,
 HasDiagnosticInfo at CimplePos) =>
FilePath -> at -> Doc AnsiStyle -> DiagnosticsT diags ()
warnDoc FilePath
file Node (Lexeme Text)
node (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"function" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
name) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"should not be used, because it" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg
                    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
-> (Text -> Doc AnsiStyle) -> Maybe Text -> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle
"" (\Text
r -> Doc AnsiStyle
"; use" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
r Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"instead") Maybe Text
replacement

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

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

descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos], (Text, Text))
descr :: ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos],
 (Text, Text))
descr = ((FilePath, [Node (Lexeme Text)]) -> [Diagnostic CimplePos]
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