{-# 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 (warn)
import           Language.Cimple.Pretty      (showNode)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Tokstyle.Common             (semEq, skip)
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 [Text] ()
checkType :: FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
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 [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    NodeF (Lexeme Text) (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)
castTy (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
        Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should be used for builtin types only "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(e.g. `uint8_t *` or `int16_t *`); use `mem_alloc` instead"

checkExpr :: FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
checkExpr :: FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
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) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
size (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`sizeof` in call to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should appear only once, "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"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 [Text] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
l
        FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
r
    VarExpr{} -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    LiteralExpr{} -> () -> State [Text] ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MemberAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
e
    PointerAccess Node (Lexeme Text)
e Lexeme Text
_ -> FilePath -> Text -> Node (Lexeme Text) -> State [Text] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
x ->
        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)
size (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` should only have sizeof and simple expression arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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 [Text] ()
checkSize :: FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
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 [Text] ()
checkExpr FilePath
file Text
malloc Node (Lexeme Text)
l
        FilePath
-> Text
-> Node (Lexeme Text)
-> Node (Lexeme Text)
-> State [Text] ()
checkSize FilePath
file Text
malloc Node (Lexeme Text)
castTy Node (Lexeme Text)
r
    SizeofType Node (Lexeme Text)
sizeTy ->
        Bool -> State [Text] () -> State [Text] ()
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 [Text] () -> State [Text] ())
-> State [Text] () -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
            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)
size (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`size` argument in call to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` indicates "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"creation of an array with element type `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
sizeTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`, "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"but result is cast to `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
showNode Node (Lexeme Text)
castTy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ ->
        Bool -> State [Text] () -> State [Text] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Node (Lexeme Text) -> Bool
isByteSize Node (Lexeme Text)
objTy) (State [Text] () -> State [Text] ())
-> State [Text] () -> State [Text] ()
forall a b. (a -> b) -> a -> b
$
            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)
size (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` 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) -> Text -> State [Text] ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
FilePath -> at -> Text -> DiagnosticsT diags ()
warn FilePath
file Node (Lexeme Text)
castTy (Text -> State [Text] ()) -> Text -> State [Text] ()
forall a b. (a -> b) -> a -> b
$ Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
malloc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` result must be cast to a pointer type"


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

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

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