{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.Linter.MallocType (descr) where

import           Control.Monad               (unless)
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             (BinaryOp (..), Lexeme (..), Node,
                                              NodeF (..), Scope (..))
import           Language.Cimple.Diagnostics (CimplePos, Diagnostic)
import           Language.Cimple.Pretty      (ppNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (pretty)
import           Tokstyle.Common             (semEq, skip, warnDoc)
import           Tokstyle.Common.Patterns

supportedTypes :: [Text]
supportedTypes :: [Text]
supportedTypes = [Text
"char", Text
"uint8_t", Text
"int16_t"]

mallocs :: [Text]
mallocs :: [Text]
mallocs = [Text
"mem_balloc", Text
"malloc"]

isByteSize :: Node (Lexeme Text) -> Bool
isByteSize :: Node (Lexeme Text) -> Bool
isByteSize Node (Lexeme Text)
ty = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
ty of
    TyStd (L AlexPosn
_ LexemeClass
_ Text
"char")    -> Bool
True
    TyStd (L AlexPosn
_ LexemeClass
_ Text
"int8_t")  -> Bool
True
    TyStd (L AlexPosn
_ LexemeClass
_ Text
"uint8_t") -> Bool
True
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                       -> Bool
False

removeOwner :: Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner :: Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner (Fix (TyOwner Node (Lexeme Text)
ty)) = Node (Lexeme Text)
ty
removeOwner Node (Lexeme Text)
ty                 = Node (Lexeme Text)
ty

checkType :: FilePath -> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkType :: FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkType FilePath
file Text
malloc Node (Lexeme Text)
castTy = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
castTy of
    TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
_ Text
tyName))) | Text
tyName Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
supportedTypes -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NodeF (Lexeme Text) (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)
castTy (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
        Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` should be used for builtin types only "
        Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"(e.g. `uint8_t *` or `int16_t *`); use `mem_alloc` instead"

checkExpr :: FilePath -> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr :: FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
size = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
size of
    SizeofType{} ->
        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)
size (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"`sizeof` in call to `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` should appear only once, "
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"and only on the right hand side of the expression"
    BinaryExpr Node (Lexeme Text)
l BinaryOp
_ Node (Lexeme Text)
r -> do
        FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
l
        FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
r
    VarExpr{} -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    LiteralExpr{} -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MemberAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
e
    PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
x ->
        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)
size (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` should only have sizeof and simple expression arguments: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (FilePath -> Text
Text.pack (NodeF (Lexeme Text) (Node (Lexeme Text)) -> FilePath
forall a. Show a => a -> FilePath
show NodeF (Lexeme Text) (Node (Lexeme Text))
x))

checkSize :: FilePath -> Text -> Node (Lexeme Text) -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkSize :: FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize FilePath
file Text
malloc castTy :: Node (Lexeme Text)
castTy@(Fix (TyPointer Node (Lexeme Text)
objTy)) Node (Lexeme Text)
size = case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
size of
    BinaryExpr Node (Lexeme Text)
l BinaryOp
BopMul Node (Lexeme Text)
r -> do
        FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
l
        FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize FilePath
file Text
malloc Node (Lexeme Text)
castTy Node (Lexeme Text)
r
    SizeofType Node (Lexeme Text)
sizeTy ->
        Bool
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node (Lexeme Text)
sizeTy Node (Lexeme Text) -> Node (Lexeme Text) -> Bool
`semEq` Node (Lexeme Text)
objTy) (State [Diagnostic CimplePos] ()
 -> State [Diagnostic CimplePos] ())
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
            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)
size (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"`size` argument in call to `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` indicates "
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"creation of an array with element type `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
sizeTy Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"`, "
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"but result is cast to `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Doc AnsiStyle
forall a. Pretty a => Node (Lexeme a) -> Doc AnsiStyle
ppNode Node (Lexeme Text)
castTy Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"`"
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ ->
        Bool
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node (Lexeme Text) -> Bool
isByteSize Node (Lexeme Text)
objTy) (State [Diagnostic CimplePos] ()
 -> State [Diagnostic CimplePos] ())
-> State [Diagnostic CimplePos] ()
-> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$
            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)
size (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` result must be cast to a byte-sized type if `sizeof` is omitted"
checkSize FilePath
file Text
malloc Node (Lexeme Text)
castTy 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)
castTy (Doc AnsiStyle -> State [Diagnostic CimplePos] ())
-> Doc AnsiStyle -> State [Diagnostic CimplePos] ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"`" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
malloc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` result must be cast to a pointer type"


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
            -- Windows API weirdness: ignore completely.
            CastExpr               (Fix (TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
_ Text
"IP_ADAPTER_INFO")))))   Node (Lexeme Text)
_ -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            CastExpr (Fix (TyOwner (Fix (TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
_ Text
"IP_ADAPTER_INFO"))))))) Node (Lexeme Text)
_ -> () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            CastExpr Node (Lexeme Text)
castTy (Fix (FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
"malloc"))) [Node (Lexeme Text)
size])) -> do
                FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkType FilePath
file Text
"malloc" (Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner Node (Lexeme Text)
castTy)
                FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize FilePath
file Text
"malloc" (Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner Node (Lexeme Text)
castTy) Node (Lexeme Text)
size
            CastExpr Node (Lexeme Text)
castTy (Fix (FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
"mem_balloc"))) [Node (Lexeme Text)
_, Node (Lexeme Text)
size])) -> do
                FilePath
-> Text -> Node (Lexeme Text) -> State [Diagnostic CimplePos] ()
checkType FilePath
file Text
"mem_balloc" (Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner Node (Lexeme Text)
castTy)
                FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Diagnostic CimplePos] ()
checkSize FilePath
file Text
"mem_balloc" (Node (Lexeme Text) -> Node (Lexeme Text)
removeOwner Node (Lexeme Text)
castTy) Node (Lexeme Text)
size

            FunctionCall (Fix (VarExpr (L AlexPosn
_ LexemeClass
_ Text
name))) [Node (Lexeme Text)]
_ | Text
name Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
mallocs ->
                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
"the result of `" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Text
name Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"` must be cast; plain `void *` is not supported"

            FunctionDefn Scope
Static (Fix (FunctionPrototype Node (Lexeme Text)
TY_void_ptr Lexeme Text
_ [Node (Lexeme Text)]
_)) Node (Lexeme Text)
_ ->
                -- Ignore static functions returning void pointers. These are allocator
                -- functions from mem.c.
                () -> State [Diagnostic CimplePos] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

            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 ((FilePath, [Node (Lexeme Text)])
 -> State [Diagnostic CimplePos] ())
-> ((FilePath, [Node (Lexeme Text)])
    -> (FilePath, [Node (Lexeme Text)]))
-> (FilePath, [Node (Lexeme Text)])
-> State [Diagnostic CimplePos] ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> (FilePath, [Node (Lexeme Text)])
-> (FilePath, [Node (Lexeme Text)])
skip
    [ FilePath
"toxcore/mem.c"
    , FilePath
"toxcore/os_memory.c"
    ]

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
"malloc-type", [Text] -> Text
Text.unlines
    [ Text
"Checks that `mem_balloc` is only used for built-in types. For struct allocations"
    , Text
"`mem_alloc` and other `calloc`-like functions should be used."
    , Text
""
    , Text
"**Reason:** `mem_balloc` does not zero-initialise its memory, which is ok for"
    , Text
"byte arrays (at most it can cause incorrect behaviour on most systems), but very"
    , Text
"risky for aggregate types containing pointers, which can point at random (or"
    , Text
"worse, attacker-controlled) memory."
    ]))