/
Main.hs
227 lines (201 loc) · 8.31 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}
module Main where
import Data.LLVM.Types
import LLVM.Parse
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Lazy
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Maybe
import Data.Word
import Debug.Trace
import Network
import System.Console.GetOpt
import System.Directory(setCurrentDirectory, canonicalizePath)
import System.Environment(getArgs)
import System.Exit(ExitCode(..), exitFailure)
import System.FilePath((</>))
import System.IO
import System.IO.Error
import Text.Printf
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Map.Strict as MS
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified System.Process as P
import Data.RESET.Types
import Eval
import Expr
import Memlog
import Options
deriving instance Show Command
deriving instance Show Response
type SymbReader = ReaderT SymbolicState IO
processCmd :: String -> IO Response
processCmd s = case parseCmd s of
Left err -> do
putStrLn $ printf "Parse error on %s:\n %s" (show s) err
return $ ErrorResponse err
Right cmd -> do
putStrLn $ printf "executing command: %s" (show cmd)
respond cmd
where parseCmd = eitherDecode . BSL.pack :: String -> Either String Command
respond :: Command -> IO Response
respond WatchIP{ commandIP = ip,
commandLimit = limit,
commandExprOptions = opts }
= MessagesResponse <$> map (messageMap $ renderExpr opts) <$>
take limit <$> messagesByIP ip <$> (parseOptions >>= symbolic ip)
process :: (Handle, HostName, PortNumber) -> IO ()
process (handle, _, _) = do
putStrLn "Client connected."
commands <- lines <$> hGetContents handle
mapM_ (BSL.hPutStrLn handle <=< liftM encode . processCmd) commands
-- Command line arguments
opts :: [OptDescr (Options -> Options)]
opts =
[ Option [] ["debug-ip"]
(ReqArg (\a o -> o{ optDebugIP = Just $ read a }) "Need IP")
"Run in debug mode on a given IP; write out trace at that IP."
, Option ['q'] ["qemu-dir"]
(ReqArg (\a o -> o{ optQemuDir = a }) "Need dir")
"Run QEMU on specified program."
, Option ['t'] ["qemu-target"]
(ReqArg (\a o -> o{ optQemuTarget = a }) "Need triple") $
"Run specified QEMU target. Default i386-linux-user for user mode " ++
"and i386-softmmu for whole-system mode."
, Option ['c'] ["qemu-cr3"]
(ReqArg (\a o -> o{ optQemuCr3 = Just $ read a }) "Need CR3")
"Run QEMU with filtering on a given CR3 (in whole-system mode)."
, Option ['r'] ["qemu-replay"]
(ReqArg (\a o -> o{ optQemuReplay = Just a }) "Need replay")
"Run specified replay in QEMU (exclude filename extension)."
, Option [] ["qemu-qcows"]
(ReqArg (\a o -> o{ optQemuQcows = Just a }) "Need qcows")
"Use specified Qcows2 with QEMU."
, Option ['d'] ["log-dir"]
(ReqArg (\a o -> o{ optLogDir = a }) "Need dir")
"Place or look for QEMU LLVM logs in a given dir."
]
data WholeSystemArgs = WSA
{ wsaCr3 :: Word64
, wsaReplay :: FilePath
, wsaQcows :: FilePath
}
getWSA :: Options -> Maybe WholeSystemArgs
getWSA Options{ optQemuCr3 = Just cr3,
optQemuReplay = Just replay,
optQemuQcows = Just qcows }
= Just $ WSA{ wsaCr3 = cr3, wsaReplay = replay, wsaQcows = qcows }
getWSA _ = Nothing
runQemu :: FilePath -> String -> FilePath -> Word64 -> Maybe WholeSystemArgs -> [String] -> IO ()
runQemu dir target logdir trigger wsArgs prog = do
arch <- case map T.unpack $ T.splitOn "-" (T.pack target) of
[arch, _, _] -> return arch
[arch, "softmmu"] -> return arch
_ -> putStrLn "Bad target triple." >> exitFailure
-- Make sure we run prog relative to old working dir.
progShifted <- case prog of
progName : progArgs -> do
progPath <- canonicalizePath progName
return $ progPath : progArgs
_ -> return $ error "Need a program to run."
let qemu = dir </> target </>
if isJust wsArgs -- if in whole-system mode
then printf "qemu-system-%s" arch
else printf "qemu-%s" arch
otherArgs = ["-tubtf", "-monitor", "tcp:localhost:4444,server,nowait"]
findPlugin = target </> "panda_plugins" </> "panda_findeip.so"
findArgs =
["-panda-plugin", findPlugin,
"-panda-arg", printf "findeip:eip=%x" trigger]
runArgs = case wsArgs of
Nothing -> progShifted -- user mode
Just (WSA cr3 replay qcows) -> -- whole-system mode
["-m", "2048", qcows, "-replay", replay]
qemuFindArgs = otherArgs ++ findArgs ++ runArgs
putStrLn $ printf "Running QEMU at %s with args %s..." qemu (show qemuFindArgs)
-- Don't pass an environment, and use our stdin/stdout
(_, Just out, _, procHandle) <- P.createProcess $
(P.proc qemu qemuFindArgs){ P.cwd = Just dir, P.std_out = P.CreatePipe }
exitCode <- P.waitForProcess procHandle
output <- lines <$> hGetContents out
let fracS = last $ catMaybes $ map (L.stripPrefix "REPLAYFRAC=") output
tracePlugin = target </> "panda_plugins" </> "panda_llvm_trace.so"
traceArgs =
["-panda-plugin", tracePlugin,
"-panda-arg", printf "llvm_trace:base=%s" logdir,
"-panda-arg", printf "llvm_trace:rfrac=%s" fracS]
++ case wsArgs of
Just (WSA cr3 _ _) ->
["-panda-arg", printf "llvm_trace:cr3=%x" cr3]
Nothing -> []
qemuTraceArgs = otherArgs ++ traceArgs ++ runArgs
putStrLn $ printf "Running QEMU at %s with args %s..." qemu (show qemuTraceArgs)
(_, _, _, procHandle2) <- P.createProcess $
(P.proc qemu qemuTraceArgs){ P.cwd = Just dir }
exitCode2 <- P.waitForProcess procHandle2
case exitCode of
ExitFailure code ->
putStrLn $ printf "\nQEMU exited with return code %d." code
ExitSuccess -> putStrLn "Done running QEMU."
-- Run a round of symbolic evaluation
symbolic :: Word64 -> (Options, [String]) -> IO SymbolicState
symbolic trigger (options, nonOptions) = do
let logDir = optLogDir options
dir = optQemuDir options
-- Run QEMU if necessary
if isJust $ optDebugIP options
then return ()
else
runQemu dir (optQemuTarget options) logDir trigger
(getWSA options) nonOptions
-- Load LLVM files and dynamic logs
let llvmMod = logDir </> "llvm-mod.bc"
printf "Loading LLVM module from %s.\n" llvmMod
theMod <- parseLLVMFile defaultParserOptions llvmMod
-- Align dynamic log with execution history
putStrLn "Loading dynamic log."
memlog <- parseMemlog $ optLogDir options </> "tubtf.log"
putStr "Aligning dynamic log data..."
let (associated, instCount) = associateFuncs memlog theMod
putStrLn $ printf " done.\nRunning symbolic execution analysis with %d instructions." instCount
-- Run symbolic execution analysis
let initialState = noSymbolicState{
symbolicInstTotal = instCount,
symbolicOptions = options
}
let (_, state) = runState (runBlocks associated) initialState
seq state $ return state
parseOptions :: IO (Options, [String])
parseOptions = do
args <- getArgs
let (optionFs, nonOptions, optionErrs) = getOpt RequireOrder opts args
case optionErrs of
[] -> return ()
_ -> mapM putStrLn optionErrs >> exitFailure
return $ (foldl (flip ($)) defaultOptions optionFs, nonOptions)
-- Serve requests for data from analysis
server :: IO ()
server = do
let addr = PortNumber 22022
sock <- listenOn addr
putStrLn $ printf "Listening on %s." (show addr)
forever $ catchIOError (accept sock >>= process) $ \e -> print e
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
(opts, _) <- parseOptions
case optDebugIP opts of
Nothing -> server
Just ip -> do
response <- respond WatchIP{ commandIP = ip,
commandLimit = 10,
commandExprOptions = defaultExprOptions }
printf "\n%s\n" $ show response