Permalink
Fetching contributors…
Cannot retrieve contributors at this time
295 lines (247 sloc) 11 KB
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Language.Haskell.Exts hiding (ModuleName)
import qualified Language.Haskell.Exts as E
import Language.Haskell.Exts.Pretty
import Data.List
import Data.IORef
import System.Directory
import System.FilePath
import System.Posix.Files
import System.Process
import System.Environment
import Control.Arrow
import Control.Monad
import Control.Applicative ((<$>), (<*>))
import Control.Exception
import System.Console.ANSI
newtype ModuleName = ModuleName String
deriving (Show,Eq)
allowedExtensions =
[ ScopedTypeVariables, BangPatterns, ForeignFunctionInterface, DeriveDataTypeable, ViewPatterns, GeneralizedNewtypeDeriving, ExistentialQuantification, EmptyDataDecls
, TypeFamilies, KindSignatures, DataKinds ]
perModuleAllowedExtensions =
[ ("Crypto/Hash/Utils.hs", [MagicHash])
, ("Crypto/Hash/SHAKE.hs", [UndecidableInstances,TypeOperators,ConstraintKinds])
, ("Crypto/Internal/ByteArray.hs", [MagicHash, UnboxedTuples])
, ("Crypto/Internal/Memory.hs", [MagicHash, UnboxedTuples])
, ("Crypto/Internal/Compat.hs", [CPP])
, ("Crypto/Internal/CompatPrim.hs", [CPP,MagicHash,UnboxedTuples])
, ("Crypto/Internal/Endian.hs", [CPP])
, ("Crypto/Internal/WordArray.hs", [UnboxedTuples,MagicHash])
, ("Crypto/Internal/Hex.hs", [Rank2Types, UnboxedTuples, MagicHash])
, ("Crypto/Internal/DeepSeq.hs", [CPP])
, ("Crypto/Random/Entropy/Backend.hs", [ExistentialQuantification,CPP])
, ("Crypto/Random/Entropy/Windows.hs", [CPP])
, ("Crypto/Cipher/Blowfish/Box.hs", [MagicHash])
, ("Crypto/Cipher/Blowfish.hs", [CPP])
, ("Crypto/Cipher/AES.hs", [CPP])
, ("Crypto/Cipher/Types/Block.hs", [Rank2Types, MultiParamTypeClasses])
, ("Crypto/Cipher/Types/AEAD.hs", [Rank2Types])
, ("Crypto/Cipher/CAST5/Primitive.hs", [MagicHash])
, ("Crypto/Cipher/Camellia/Primitive.hs", [MagicHash])
, ("Crypto/Cipher/DES/Primitive.hs", [FlexibleInstances])
, ("Crypto/Cipher/Twofish/Primitive.hs", [MagicHash])
, ("Crypto/PubKey/Curve25519.hs", [MagicHash])
, ("Crypto/Number/Compat.hs", [UnboxedTuples,MagicHash,CPP])
]
disallowedModules =
[ (ModuleName "System.IO.Unsafe", ModuleName "Crypto.Internal.Compat")
, (ModuleName "Data.Byteable", ModuleName "Crypto.Internal.ByteArray")
, (ModuleName "Data.SecureMem", ModuleName "Crypto.Internal.ByteArray")
, (ModuleName "Data.ByteString", ModuleName "Crypto.Internal.ByteArray")
, (ModuleName "Control.Applicative", ModuleName "Crypto.Internal.Imports")
]
perModuleAllowedModules :: [(FilePath, [ModuleName])]
perModuleAllowedModules =
[ ("Crypto/Internal/Imports.hs",
[ ModuleName "Control.Applicative"
]
)
, ("Crypto/Internal/Memory.hs",
[ ModuleName "Data.SecureMem"
]
)
, ("Crypto/Internal/ByteArray.hs",
[ ModuleName "Data.ByteString"
]
)
, ("Crypto/Internal/Bytes.hs",
[ ModuleName "Data.ByteString"
]
)
, ("Crypto/Internal/Compat.hs",
[ ModuleName "System.IO.Unsafe"
]
)
, ("Crypto/Random/SystemDRG.hs",
[ ModuleName "System.IO.Unsafe"
]
)
]
data Issue =
Issue_FailedToParseExtension
| Issue_FailedToParseModule SrcLoc String
| Issue_Extension String
| Issue_Import ModuleName ModuleName
deriving (Eq)
prettyIssue Issue_FailedToParseExtension = "failed to parse extension"
prettyIssue (Issue_FailedToParseModule loc p) = "failed to parse module : " ++ show loc ++ " : " ++ p
prettyIssue (Issue_Extension e) = "extension not authorized: " ++ e
prettyIssue (Issue_Import (ModuleName old) (ModuleName new)) = "import : " ++ old ++ " should be : " ++ show new
data IssueLevel =
IssueFatal
| IssueError
| IssueWarning
| IssueUnknown
deriving (Show,Eq)
getIssueLevel :: Issue -> IssueLevel
getIssueLevel Issue_FailedToParseExtension = IssueFatal
getIssueLevel (Issue_FailedToParseModule {}) = IssueFatal
getIssueLevel _ = IssueUnknown
data InfoVal =
InfoValList [String]
| InfoValString String
deriving (Show,Eq)
data ModuleState = ModuleState
{ mInfo :: IORef [(String, InfoVal)]
, mIssues :: IORef [Issue]
}
data ModuleQA = ModuleQA FilePath [(String, InfoVal)] [Issue]
deriving (Eq)
moduleGetIssues :: ModuleQA -> [Issue]
moduleGetIssues (ModuleQA _ _ is) = is
newState :: IO ModuleState
newState = ModuleState <$> newIORef [] <*> newIORef []
freezeState :: FilePath -> ModuleState -> IO ModuleQA
freezeState file (ModuleState info issues) = ModuleQA file <$> readIORef info <*> readIORef issues
data Options = Options
{ optionWarningIsError :: Bool
}
defaultOptions = Options
{ optionWarningIsError = False
}
parseArgs opts [] = opts
parseArgs opts (x:xs) =
let nopts = case x of
"-Werror" -> opts { optionWarningIsError = True }
_ -> opts
in parseArgs nopts xs
main = do
options <- parseArgs defaultOptions <$> getArgs
modules <- findAllModules
qas <- mapM checkModule modules
mapM_ report qas
summary qas
where
summary :: [ModuleQA] -> IO ()
summary l = do
let (succeeded, failed) = (length *** length) $ partition (null . moduleGetIssues) l
putStrLn ("failed: " ++ show failed ++ " succeeded: " ++ show succeeded)
report :: ModuleQA -> IO ()
report (ModuleQA f infos issues)
| null issues = do
setColor Cyan >> putStr f >> setSGR [] >> putStr padding
setColor Green >> putStrLn "SUCCESS" >> setSGR []
| otherwise = do
setColor Cyan >> putStr f >> setSGR [] >> putStr padding
setColor Red >> putStrLn "FAILED" >> setSGR []
mapM_ reportIssue issues
where
padding = replicate padN ' '
padN = 64 - length f
reportIssue issue = setColor Red >> putStr " " >> putStrLn (prettyIssue issue) >> setSGR []
setColor c = setSGR [SetColor Foreground Vivid c]
checkModule file = do
st <- newState
content <- readFile file
case readExtensions content of
Nothing -> recordIssue st Issue_FailedToParseExtension
Just (_, exts) -> qaExts st file content exts
freezeState file st
qaExts st file contentRaw exts = do
recordInfo st "extensions" (intercalate ", " $ map show (getEnabledExts exts))
let hasCPP = EnableExtension CPP `elem` exts
content <- if hasCPP then processCPP file contentRaw else return contentRaw
let mode = defaultParseMode { parseFilename = file, extensions = exts, fixities = Nothing }
case parseModuleWithMode mode content of
ParseFailed srcLoc s -> do
recordIssue st $ Issue_FailedToParseModule srcLoc s
ParseOk mod -> do
let imports = getModulesImports mod
recordInfo st "modules" $ InfoValList (map (prettyPrint . importModule) imports)
-- check for allowed extensions
forM_ (getEnabledExts exts) $ \ext -> do
let allowed = elem ext allowedExtensions
allowed' = allowed || maybe False (\z -> elem ext z) (lookup file perModuleAllowedExtensions)
unless allowed' $ recordIssue st (Issue_Extension $ show ext)
-- check for disallowed modules
forM_ (map (flattenModuleName . importModule) $ getModulesImports mod) $ \impMod ->
case lookup impMod disallowedModules of
Nothing -> return ()
Just newMod | file == moduleToFile impMod -> return ()
| otherwise -> do
let allowed = case lookup file perModuleAllowedModules of
Nothing -> False
Just allowedMods -> elem impMod allowedMods
unless allowed $ recordIssue st (Issue_Import impMod newMod)
moduleToFile (ModuleName m) =
intercalate "/" (wordsWhen (== '.') m) ++ ".hs"
wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s = case dropWhile p s of
"" -> []
s' -> w : wordsWhen p s'' where (w, s'') = break p s'
processCPP file content = do
contentProcessed <- readProcess "cpphs" [d minVersionBase, d arch] content
return $ simpleCPP contentProcessed
where
d s = "-D" ++ s
minVersionBase = "MIN_VERSION_base(a,b,c)=(((a) >= 4) && ((b) >= 7))"
arch = "ARCH_X86"
-- simple CPP just strip # starting line
simpleCPP = unlines . filter (not . isHashStart) . lines
where
isHashStart s = case dropWhile (flip elem " \t\v") s of
[] -> False
'#':_ -> True
_ -> False
------------------------------------------------------------------------
recordIssue st s =
modifyIORef (mIssues st) ((:) s)
recordInfo st n f = return ()
getModulesImports (Module _ _ _ imports _) = imports
flattenModuleName (E.ModuleName _ mn) = ModuleName mn
getEnabledExts = foldl doAcc []
where doAcc acc (EnableExtension e) = e : acc
doAcc acc _ = acc
------------------------------------------------------------------------
findAllModules :: IO [FilePath]
findAllModules = dirTraverse "Crypto" fileCallback dirCallback []
where
fileCallback a m = return (if isSuffixOf ".hs" m then (m:a) else a)
dirCallback a d
| isSuffixOf "/.git" d = return (False, a)
| otherwise = return (True, a)
-- | Traverse directories and files starting from the @rootDir
dirTraverse :: FilePath
-> (a -> FilePath -> IO a)
-> (a -> FilePath -> IO (Bool, a))
-> a
-> IO a
dirTraverse rootDir fFile fDir a = loop a rootDir
where loop a dir = do
content <- try $ getDir dir
case content of
Left (exn :: SomeException) -> return a
Right l -> foldM (processEnt dir) a l
processEnt dir a ent = do
let fp = dir </> ent
stat <- getSymbolicLinkStatus fp
case (isDirectory stat, isRegularFile stat) of
(True,_) -> do (process,a') <- fDir a fp
if process
then loop a' fp
else return a'
(False,True) -> fFile a fp
(False,False) -> return a
getDir dir = filter (not . flip elem [".",".."]) <$> getDirectoryContents dir