{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.C.Linter.SizeofTarget (descr) where

import           Control.Monad                   (forM_, unless)
import           Data.Functor.Identity           (Identity)
import qualified Data.Map                        as Map
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Language.C.Analysis.AstAnalysis (ExprSide (..), defaultMD,
                                                  tExpr)
import           Language.C.Analysis.ConstEval   (constEval, intValue)
import           Language.C.Analysis.SemRep      (GlobalDecls, Type (..),
                                                  TypeName (..), declType)
import           Language.C.Analysis.TravMonad   (Trav, TravT, catchTravError)
import           Language.C.Analysis.TypeUtils   (canonicalType)
import qualified Language.C.Pretty               as C
import           Language.C.Syntax.AST           (CExpr, CExpression (..),
                                                  CUnaryOp (..), annotation)
import           Prettyprinter                   (pretty, (<+>))
import           Tokstyle.C.Env                  (Env, recordLinterError)
import           Tokstyle.C.Patterns
import           Tokstyle.C.TraverseAst          (AstActions (..), astActions,
                                                  traverseAst)
import           Tokstyle.C.TravUtils            (backticks)


-- | Parameters that take a buffer of bytes or numbers.
isBufferParam :: Type -> Bool
isBufferParam :: Type -> Bool
isBufferParam Type
ty = case Type -> Type
canonicalType Type
ty of
    PtrType Type
t TypeQuals
_ Attributes
_     -> Type -> Bool
isVoid Type
t Bool -> Bool -> Bool
|| Type -> Bool
isIntegral Type
t
    ArrayType Type
t ArraySize
_ TypeQuals
_ Attributes
_ -> Type -> Bool
isIntegral Type
t
    Type
_                 -> Bool
False
  where
    isVoid :: Type -> Bool
isVoid (DirectType TypeName
TyVoid TypeQuals
_ Attributes
_) = Bool
True
    isVoid Type
_                       = Bool
False

-- | What an argument points at, without casts or `&`.
target :: CExpr -> CExpr
target :: CExpr -> CExpr
target = \case
    CCast CDeclaration NodeInfo
_ CExpr
e NodeInfo
_       -> CExpr -> CExpr
target CExpr
e
    CUnary CUnaryOp
CAdrOp CExpr
e NodeInfo
_ -> CExpr -> CExpr
target CExpr
e
    CExpr
e                 -> CExpr
e

-- | `sizeof(*p)` is the size of what `p` points at.
sized :: CExpr -> CExpr
sized :: CExpr -> CExpr
sized = \case
    CUnary CUnaryOp
CIndOp CExpr
e NodeInfo
_ -> CExpr -> CExpr
target CExpr
e
    CExpr
e                 -> CExpr -> CExpr
target CExpr
e

render :: CExpr -> String
render :: CExpr -> String
render = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (CExpr -> Doc) -> CExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Doc
forall p. Pretty p => p -> Doc
C.pretty

sizeOf :: CExpr -> TravT Env Identity (Maybe Integer)
sizeOf :: CExpr -> TravT Env Identity (Maybe Integer)
sizeOf CExpr
e = TravT Env Identity (Maybe Integer)
-> (CError -> TravT Env Identity (Maybe Integer))
-> TravT Env Identity (Maybe Integer)
forall a.
TravT Env Identity a
-> (CError -> TravT Env Identity a) -> TravT Env Identity a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
catchTravError (CExpr -> Maybe Integer
intValue (CExpr -> Maybe Integer)
-> TravT Env Identity CExpr -> TravT Env Identity (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MachineDesc -> Map Ident CExpr -> CExpr -> TravT Env Identity CExpr
forall (m :: * -> *).
MonadTrav m =>
MachineDesc -> Map Ident CExpr -> CExpr -> m CExpr
constEval MachineDesc
defaultMD Map Ident CExpr
forall k a. Map k a
Map.empty CExpr
e) (TravT Env Identity (Maybe Integer)
-> CError -> TravT Env Identity (Maybe Integer)
forall a b. a -> b -> a
const (Maybe Integer -> TravT Env Identity (Maybe Integer)
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing))

-- | We don't know how much a pointer points at.
bufferSize :: CExpr -> TravT Env Identity (Maybe Integer)
bufferSize :: CExpr -> TravT Env Identity (Maybe Integer)
bufferSize CExpr
b = (TravT Env Identity (Maybe Integer)
 -> (CError -> TravT Env Identity (Maybe Integer))
 -> TravT Env Identity (Maybe Integer))
-> (CError -> TravT Env Identity (Maybe Integer))
-> TravT Env Identity (Maybe Integer)
-> TravT Env Identity (Maybe Integer)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TravT Env Identity (Maybe Integer)
-> (CError -> TravT Env Identity (Maybe Integer))
-> TravT Env Identity (Maybe Integer)
forall a.
TravT Env Identity a
-> (CError -> TravT Env Identity a) -> TravT Env Identity a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
catchTravError (TravT Env Identity (Maybe Integer)
-> CError -> TravT Env Identity (Maybe Integer)
forall a b. a -> b -> a
const (Maybe Integer -> TravT Env Identity (Maybe Integer)
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing)) (TravT Env Identity (Maybe Integer)
 -> TravT Env Identity (Maybe Integer))
-> TravT Env Identity (Maybe Integer)
-> TravT Env Identity (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ do
    Type
ty <- [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
b
    case Type -> Type
canonicalType Type
ty of
        PtrType{} -> Maybe Integer -> TravT Env Identity (Maybe Integer)
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        Type
_         -> CExpr -> TravT Env Identity (Maybe Integer)
sizeOf (CExpr -> NodeInfo -> CExpr
forall a. CExpression a -> a -> CExpression a
CSizeofExpr CExpr
b (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
b))

checkCall :: [Type] -> [CExpr] -> TravT Env Identity ()
checkCall :: [Type] -> [CExpr] -> TravT Env Identity ()
checkCall [Type]
params [CExpr]
args =
    [(Int, Type, CExpr)]
-> ((Int, Type, CExpr) -> TravT Env Identity ())
-> TravT Env Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Type] -> [CExpr] -> [(Int, Type, CExpr)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0 ..] [Type]
params [CExpr]
args) (((Int, Type, CExpr) -> TravT Env Identity ())
 -> TravT Env Identity ())
-> ((Int, Type, CExpr) -> TravT Env Identity ())
-> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ \case
        (Int
i, Type
ty, size :: CExpr
size@(CSizeofExpr CExpr
e NodeInfo
_)) | Type -> Bool
isIntegral Type
ty -> do
            let buffers :: [CExpr]
buffers = [ CExpr
a | (Type
pty, CExpr
a) <- Int -> [(Type, CExpr)] -> [(Type, CExpr)]
forall a. Int -> [a] -> [a]
take Int
i ([Type] -> [CExpr] -> [(Type, CExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
params [CExpr]
args), Type -> Bool
isBufferParam Type
pty ]
            Bool -> TravT Env Identity () -> TravT Env Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CExpr]
buffers Bool -> Bool -> Bool
|| CExpr -> String
render (CExpr -> CExpr
sized CExpr
e) String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (CExpr -> String) -> [CExpr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CExpr -> String
render (CExpr -> String) -> (CExpr -> CExpr) -> CExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> CExpr
target) [CExpr]
buffers) (TravT Env Identity () -> TravT Env Identity ())
-> TravT Env Identity () -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$ do
                Maybe Integer
n <- CExpr -> TravT Env Identity (Maybe Integer)
sizeOf CExpr
size
                [Maybe Integer]
ns <- (CExpr -> TravT Env Identity (Maybe Integer))
-> [CExpr] -> TravT Env Identity [Maybe Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CExpr -> TravT Env Identity (Maybe Integer)
bufferSize (CExpr -> TravT Env Identity (Maybe Integer))
-> (CExpr -> CExpr) -> CExpr -> TravT Env Identity (Maybe Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> CExpr
target) [CExpr]
buffers
                let names :: Doc ann
names = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> [Text] -> Text
Text.intercalate Text
" or " [ Text
"`" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (CExpr -> String
render CExpr
b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`" | CExpr
b <- [CExpr]
buffers ])
                    wrong :: Bool
wrong = case (Maybe Integer
n, [Maybe Integer] -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe Integer]
ns) of
                        (Just Integer
n', Just [Integer]
ns') -> Integer
n' Integer -> [Integer] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Integer]
ns'
                        (Maybe Integer, Maybe [Integer])
_                   -> Bool
False
                NodeInfo -> Doc AnsiStyle -> TravT Env Identity ()
recordLinterError (CExpr -> NodeInfo
forall a. CExpression a -> a
forall (ast :: * -> *) a. Annotated ast => ast a -> a
annotation CExpr
e) (Doc AnsiStyle -> TravT Env Identity ())
-> Doc AnsiStyle -> TravT Env Identity ()
forall a b. (a -> b) -> a -> b
$
                    Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
backticks (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"sizeof(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CExpr -> String
render CExpr
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
                    if Bool
wrong
                        then Doc AnsiStyle
"is not the size of" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall {ann}. Doc ann
names
                        else Doc AnsiStyle
"measures" 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 (String -> Doc AnsiStyle
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CExpr -> String
render CExpr
e)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
", not" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall {ann}. Doc ann
names
        (Int, Type, CExpr)
_ -> () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

linter :: AstActions (TravT Env Identity)
linter :: AstActions (TravT Env Identity)
linter = AstActions (TravT Env Identity)
forall (f :: * -> *). Applicative f => AstActions f
astActions
    { doExpr = \CExpr
node TravT Env Identity ()
act -> case CExpr
node of
        CCall CExpr
fun [CExpr]
args NodeInfo
_ -> do
            [StmtCtx] -> ExprSide -> CExpr -> TravT Env Identity Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
fun TravT Env Identity Type
-> (Type -> TravT Env Identity ()) -> TravT Env Identity ()
forall a b.
TravT Env Identity a
-> (a -> TravT Env Identity b) -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                FunPtrParams [ParamDecl]
params -> [Type] -> [CExpr] -> TravT Env Identity ()
checkCall ((ParamDecl -> Type) -> [ParamDecl] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ParamDecl -> Type
forall n. Declaration n => n -> Type
declType [ParamDecl]
params) [CExpr]
args
                Type
_                   -> () -> TravT Env Identity ()
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            TravT Env Identity ()
act
        CExpr
_ -> TravT Env Identity ()
act
    }

analyse :: GlobalDecls -> Trav Env ()
analyse :: GlobalDecls -> TravT Env Identity ()
analyse = AstActions (TravT Env Identity)
-> GlobalDecls -> TravT Env Identity ()
forall a (f :: * -> *).
(TraverseAst a, Applicative f) =>
AstActions f -> a -> f ()
forall (f :: * -> *).
Applicative f =>
AstActions f -> GlobalDecls -> f ()
traverseAst AstActions (TravT Env Identity)
linter

descr :: (GlobalDecls -> Trav Env (), (Text, Text))
descr :: (GlobalDecls -> TravT Env Identity (), (Text, Text))
descr = (GlobalDecls -> TravT Env Identity ()
analyse, (Text
"sizeof-target", [Text] -> Text
Text.unlines
    [ Text
"Checks that a `sizeof` passed as a size is the size of a buffer in the same call."
    , Text
""
    , Text
"In a call such as `crypto_memzero(key, sizeof(other_key))`, the size must be"
    , Text
"of `key` (or `*key` when it's a pointer). For `memcpy`, either buffer will do."
    , Text
""
    , Text
"**Reason:** two buffers often have the same size by chance, such as public"
    , Text
"and secret keys, so the wrong `sizeof` works until one of them changes."
    ]))