From a237e591b28b521dedeb0a6fe2ace1fd7ab60501 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 24 Apr 2018 00:47:50 +0200 Subject: [PATCH] Implement `--obfuscate` Support replacing all (non-keyword) identifiers with randomly generated characters --- brittany.cabal | 2 + src-brittany/Main.hs | 6 +- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Config.hs | 3 + .../Haskell/Brittany/Internal/Config/Types.hs | 1 + .../Internal/Config/Types/Instances.hs | 1 + .../Haskell/Brittany/Internal/Obfuscation.hs | 100 ++++++++++++++++++ 8 files changed, 114 insertions(+), 1 deletion(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Obfuscation.hs diff --git a/brittany.cabal b/brittany.cabal index 5c76137..38522cf 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -55,6 +55,7 @@ library { Language.Haskell.Brittany.Internal.Config Language.Haskell.Brittany.Internal.Config.Types Language.Haskell.Brittany.Internal.Config.Types.Instances + Language.Haskell.Brittany.Internal.Obfuscation Paths_brittany } other-modules: { @@ -112,6 +113,7 @@ library { , czipwith >=1.0.1.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.5 , filepath >=1.4.1.0 && <1.5 + , random >= 1.1 && <1.2 } default-extensions: { CPP diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 3b6f0b2..ba66188 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -28,6 +28,7 @@ import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation import qualified Text.PrettyPrint as PP @@ -272,7 +273,10 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx let out = TextL.toStrict $ if hackAroundIncludes then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw else outRaw - pure $ (ews, out) + out' <- if config & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out') let customErrOrder ErrorInput{} = 4 customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorOutputCheck{} = 1 diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 785d192..e505ffa 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -184,6 +184,7 @@ defaultTestConfig = Config , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index c14b3b8..3394dc9 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -66,4 +66,5 @@ defaultTestConfig = Config , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 2891c3d..e8ff5d6 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -90,6 +90,7 @@ staticDefaultConfig = Config { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions @@ -143,6 +144,7 @@ cmdlineConfigParser = do ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config { _conf_version = mempty @@ -190,6 +192,7 @@ cmdlineConfigParser = do { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 91fdb4d..e157c77 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -146,6 +146,7 @@ data CConfig f = Config , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) + , _conf_obfuscate :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config -- implementation. Could have re-used the existing field, but felt risky diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs index 6f879b4..82edaed 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -120,6 +120,7 @@ instance FromJSON (CConfig Maybe) where <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only" + <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid -- Pretends that the value is {} when the key is not present. diff --git a/src/Language/Haskell/Brittany/Internal/Obfuscation.hs b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs new file mode 100644 index 0000000..5bdcfa8 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Obfuscation.hs @@ -0,0 +1,100 @@ +module Language.Haskell.Brittany.Internal.Obfuscation + ( obfuscate + ) +where + + + +#include "prelude.inc" + +import Data.Char +import System.Random + + + +obfuscate :: Text -> IO Text +obfuscate input = do + let predi x = isAlphaNum x || x `elem` "_'" + let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) + let idents = Set.toList $ Set.fromList $ filter (all predi) groups + let exceptionFilter x | x `elem` keywords = False + exceptionFilter x | x `elem` extraKWs = False + exceptionFilter x = not $ null $ drop 1 x + let filtered = filter exceptionFilter idents + mappings <- fmap Map.fromList $ filtered `forM` \x -> do + r <- createAlias x + pure (x, r) + let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings) + pure $ Text.concat $ fmap Text.pack groups' + +keywords :: [String] +keywords = + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "mdo" + , "else" + , "forall" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "_" + , "foreign" + , "ccall" + , "as" + , "safe" + , "unsafe" + , "hiding" + , "proc" + , "rec" + , "family" + ] + +extraKWs :: [String] +extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"] + +createAlias :: String -> IO String +createAlias xs = go NoHint xs + where + go _hint "" = pure "" + go hint (c : cr) = do + c' <- case hint of + VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] + _ | isUpper c -> randomFrom ['A' .. 'Z'] + VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] + _ | isLower c -> randomFrom ['a' .. 'z'] + _ -> pure c + cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr + pure (c' : cr') + +data Hint = NoHint | VocalHint | NoVocalHint + +_randomRange :: Random a => a -> a -> IO a +_randomRange lo hi = do + gen <- getStdGen + let (x, gen') = randomR (lo, hi) gen + setStdGen gen' + pure x + +randomFrom :: Random a => [a] -> IO a +randomFrom l = do + let hi = length l - 1 + gen <- getStdGen + let (x, gen') = randomR (0, hi) gen + setStdGen gen' + pure $ l List.!! x