{-# LANGUAGE OverloadedStrings #-}
module Tokstyle.Analysis.PointsTo.ExternalSummaries
    ( getExternalSummary
    , locFromPos
    ) where

import           Data.Fix                         (Fix (..))
import           Data.IntSet                      (IntSet)
import qualified Data.IntSet                      as IntSet
import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import           Data.Set                         (Set)
import qualified Data.Set                         as Set
import           Data.Text                        (Text, pack)
import           Language.Cimple                  (AlexPosn (..), NodeF (..))
import qualified Language.Cimple                  as C
import           Tokstyle.Analysis.PointsTo.Types
import           Tokstyle.Analysis.Scope          (ScopedId (..))

-- A summary of an external function's behavior.
-- It takes the arguments and the current state, and returns the new state
-- and the set of memory locations the function's return value can point to.
type ExternalSummary = FilePath -> C.AlexPosn -> [C.Node (C.Lexeme ScopedId)] -> PointsToAnalysis (Set MemLoc, Bool)

-- Map from function names to their summaries.
summaries :: Map Text ExternalSummary
summaries :: Map Text ExternalSummary
summaries = [(Text, ExternalSummary)] -> Map Text ExternalSummary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"malloc", ExternalSummary
summaryMalloc)
    , (Text
"calloc", ExternalSummary
summaryMalloc) -- Treat calloc like malloc for now
    , (Text
"realloc", ExternalSummary
summaryRealloc)
    , (Text
"free", ExternalSummary
summaryFree)
    -- keep-sorted start
    , (Text
"GetAdaptersInfo", ExternalSummary
summaryNoOp)
    , (Text
"WSAGetLastError", ExternalSummary
summaryNoOp)
    , (Text
"assert", ExternalSummary
summaryNoOp)
    , (Text
"bind", ExternalSummary
summaryNoOp)
    , (Text
"closesocket", ExternalSummary
summaryNoOp)
    , (Text
"close", ExternalSummary
summaryNoOp)
    , (Text
"connect", ExternalSummary
summaryNoOp)
    , (Text
"crypto_box_beforenm", ExternalSummary
summaryNoOp)
    , (Text
"crypto_hash_sha256", ExternalSummary
summaryNoOp)
    , (Text
"crypto_memzero", ExternalSummary
summaryNoOp)
    , (Text
"crypto_pwhash_scryptsalsa208sha256", ExternalSummary
summaryNoOp)
    , (Text
"crypto_sign_detached", ExternalSummary
summaryNoOp)
    , (Text
"crypto_sign_ed25519_pk_to_curve25519", ExternalSummary
summaryNoOp)
    , (Text
"crypto_sign_ed25519_sk_to_curve25519", ExternalSummary
summaryNoOp)
    , (Text
"epoll_create", ExternalSummary
summaryNoOp)
    , (Text
"epoll_wait", ExternalSummary
summaryNoOp)
    , (Text
"fcntl", ExternalSummary
summaryNoOp)
    , (Text
"getaddrinfo", ExternalSummary
summaryGetaddrinfo)
    , (Text
"getsockopt", ExternalSummary
summaryNoOp)
    , (Text
"htonl", ExternalSummary
summaryNoOp)
    , (Text
"htons", ExternalSummary
summaryNoOp)
    , (Text
"inet_ntop", ExternalSummary
summaryReturnsPointer)
    , (Text
"inet_pton", ExternalSummary
summaryNoOp)
    , (Text
"ioctlsocket", ExternalSummary
summaryNoOp)
    , (Text
"listen", ExternalSummary
summaryNoOp)
    , (Text
"memcpy", ExternalSummary
summaryMemcpy)
    , (Text
"mem_is_heap", ExternalSummary
summaryNoOp)
    , (Text
"memmove", ExternalSummary
summaryMemcpy)
    , (Text
"ntohl", ExternalSummary
summaryNoOp)
    , (Text
"ntohs", ExternalSummary
summaryNoOp)
    , (Text
"opus_decode", ExternalSummary
summaryNoOp)
    , (Text
"opus_decoder_create", ExternalSummary
summaryNoOp)
    , (Text
"opus_decoder_get_nb_samples", ExternalSummary
summaryNoOp)
    , (Text
"opus_encode", ExternalSummary
summaryNoOp)
    , (Text
"opus_encoder_create", ExternalSummary
summaryNoOp)
    , (Text
"opus_encoder_ctl", ExternalSummary
summaryNoOp)
    , (Text
"opus_packet_get_nb_channels", ExternalSummary
summaryNoOp)
    , (Text
"printf", ExternalSummary
summaryNoOp)
    , (Text
"random_bytes", ExternalSummary
summaryNoOp)
    , (Text
"randombytes_random", ExternalSummary
summaryNoOp)
    , (Text
"randombytes_uniform", ExternalSummary
summaryNoOp)
    , (Text
"recvfrom", ExternalSummary
summaryNoOp)
    , (Text
"recv", ExternalSummary
summaryNoOp)
    , (Text
"send", ExternalSummary
summaryNoOp)
    , (Text
"sendto", ExternalSummary
summaryNoOp)
    , (Text
"setsockopt", ExternalSummary
summaryNoOp)
    , (Text
"snprintf", ExternalSummary
summaryNoOp)
    , (Text
"strcpy", ExternalSummary
summaryStrcpy)
    , (Text
"strerror_r", ExternalSummary
summaryNoOp)
    , (Text
"strlen", ExternalSummary
summaryNoOp)
    , (Text
"strrchr", ExternalSummary
summaryReturnsPointer)
    , (Text
"time", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_control", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_dec_init", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_decode", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_enc_config_default", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_enc_config_set", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_enc_init", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_encode", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_get_cx_data", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_get_frame", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_vp8_cx", ExternalSummary
summaryNoOp)
    , (Text
"vpx_codec_vp8_dx", ExternalSummary
summaryNoOp)
    -- keep-sorted end
    ]

-- The main function to get a summary for an external call.
getExternalSummary :: ScopedId -> Maybe ExternalSummary
getExternalSummary :: ScopedId -> Maybe ExternalSummary
getExternalSummary ScopedId
sid = Text -> Map Text ExternalSummary -> Maybe ExternalSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScopedId -> Text
sidName ScopedId
sid) Map Text ExternalSummary
summaries

-- Summaries Implementation

summaryMalloc :: ExternalSummary
summaryMalloc :: ExternalSummary
summaryMalloc FilePath
file AlexPosn
pos [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([MemLoc] -> Set MemLoc
forall a. Ord a => [a] -> Set a
Set.fromList [Text -> MemLoc
HeapLoc (FilePath -> AlexPosn -> Text
locFromPos FilePath
file AlexPosn
pos)], Bool
False)

summaryRealloc :: ExternalSummary
summaryRealloc :: ExternalSummary
summaryRealloc FilePath
file AlexPosn
pos [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([MemLoc] -> Set MemLoc
forall a. Ord a => [a] -> Set a
Set.fromList [Text -> MemLoc
HeapLoc (FilePath -> AlexPosn -> Text
locFromPos FilePath
file AlexPosn
pos)], Bool
True)

summaryFree :: ExternalSummary
summaryFree :: ExternalSummary
summaryFree FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set MemLoc
forall a. Set a
Set.empty, Bool
True)

-- For now, we assume strcpy, memcpy, etc., don't transfer pointers.
-- This is a simplifying assumption as per the design doc.
summaryStrcpy :: ExternalSummary
summaryStrcpy :: ExternalSummary
summaryStrcpy FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set MemLoc
forall a. Set a
Set.empty, Bool
True)

summaryMemcpy :: ExternalSummary
summaryMemcpy :: ExternalSummary
summaryMemcpy FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set MemLoc
forall a. Set a
Set.empty, Bool
True)

summaryNoOp :: ExternalSummary
summaryNoOp :: ExternalSummary
summaryNoOp FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set MemLoc
forall a. Set a
Set.empty, Bool
False)

summaryGetaddrinfo :: ExternalSummary
summaryGetaddrinfo :: ExternalSummary
summaryGetaddrinfo FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set MemLoc
forall a. Set a
Set.empty, Bool
True) -- returns int, but modifies pointer arg

summaryReturnsPointer :: ExternalSummary
summaryReturnsPointer :: ExternalSummary
summaryReturnsPointer FilePath
_ AlexPosn
_ [Node (Lexeme ScopedId)]
_ = (Set MemLoc, Bool) -> StateT MemLocPool Identity (Set MemLoc, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (MemLoc -> Set MemLoc
forall a. a -> Set a
Set.singleton MemLoc
UnknownLoc, Bool
False)


-- Helpers

locFromPos :: FilePath -> C.AlexPosn -> Text
locFromPos :: FilePath -> AlexPosn -> Text
locFromPos FilePath
file (C.AlexPn Int
_ Int
line Int
col) = FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
col