diff --git a/Generator/Cabal.hs b/Generator/Cabal.hs new file mode 100644 --- /dev/null +++ b/Generator/Cabal.hs @@ -0,0 +1,76 @@ +module Generator.Cabal (syncCabal) where +import AST +import Distribution.PackageDescription +import Distribution.ModuleName +import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.PrettyPrint +import Distribution.Package +import Distribution.Version +import Data.Maybe (fromMaybe) +import System.Directory +import Distribution.Verbosity +import System.FilePath.Posix +import Data.List +import Generator.Routes +import SyncFile +stripGenerated :: Module -> [ModuleName] -> [ModuleName] +stripGenerated m mods = [ mn | mn <- mods, + not $("Handler." ++ (fromMaybe "" $ modName m)) `isPrefixOf` (mnToString mn) ] + where mnToString mn = intercalate "." (components mn) + +generatedMods :: Module -> [ModuleName] +generatedMods m = map fromString $ [pfx, pfx ++ ".Internal", pfx ++ ".Enums", pfx ++ ".Routes", pfx ++ ".Esqueleto"] + ++ [pfx ++ "." ++ (routeModuleName r) | r <- modRoutes m ] + where pfx = "Handler." ++ (fromMaybe "" $ modName m) + +ensureDeps :: [Dependency] -> [Dependency] +ensureDeps deps = nubBy samePackage ([Dependency (PackageName name) AnyVersion + | name <- ["unordered-containers", + "transformers", + "tagged", + "blaze-builder", + "http-types", + "wai", + "resourcet", + "attoparsec", + "time", + "vector", + "esqueleto", + "yesod-persistent", + "old-locale", + "filepath", + "unix", + "path-pieces" ] ] ++ deps) + where samePackage (Dependency pn1 _) (Dependency pn2 _) = pn1 == pn2 + + +modifyDesc :: Module -> GenericPackageDescription -> GenericPackageDescription +modifyDesc m d = d { + condLibrary = (condLibrary d) >>= modifyCtree + } + where + modifyCtree ctree = Just $ ctree { + condTreeData = modifyLib (condTreeData ctree), + condTreeConstraints = ensureDeps (condTreeConstraints ctree) + } + modifyLib l = l { + exposedModules = modifyExposed (exposedModules l) + } + modifyExposed mods = stripGenerated m mods ++ generatedMods m + +syncCabal :: FilePath -> Module -> IO () +syncCabal path' m = do + let path = addExtension (dropExtension path') ".cabal" + e <- doesFileExist path + if e + then do + desc <- readPackageDescription verbose path + + let content = showGenericPackageDescription (modifyDesc m desc) + syncFile path content + + else return () + + + + diff --git a/Obfuscate.hs b/Obfuscate.hs new file mode 100644 --- /dev/null +++ b/Obfuscate.hs @@ -0,0 +1,98 @@ +module Obfuscate where +import Data.Hash.MD5 +import AST +import Data.Char +hash :: String -> String +hash (s@(x:xs)) + | isUpper x = "I" ++ h + | otherwise = "i" ++ h + where h = (md5s (Str s)) + +obfuscate :: [(FilePath,Module)] -> [(FilePath,Module)] +obfuscate dbs = [ (fp,f m) | (fp,m) <- dbs ] + where + f m = m { + modEntities = [ oEntity e | e <- modEntities m ], + modClasses = [ oClass c | c <- modClasses m ], + modEnums = [ oEnum e | e <- modEnums m ], + modRoutes = map oRoute $ modRoutes m + } + oEntity e = e { + entityName = hash $ entityName e, + entityInstances = [ hash i | i <- entityInstances e], + entityFields = map oField $ entityFields e, + entityUniques = map oUnique $ entityUniques e, + entityChecks = map hash $ entityChecks e + } + oField f = f { + fieldName = hash $ fieldName f, + fieldContent = case (fieldContent f) of + NormalField _ _ -> fieldContent f + EntityField en -> EntityField (hash en) + EnumField en -> EnumField (hash en) + } + oClass c = c { + className = hash $ className c, + classFields = map oField $ classFields c, + classUniques = map oUnique $ classUniques c + } + oUnique u = u { + uniqueName = hash $ uniqueName u, + uniqueFields = map hash $ uniqueFields u + } + oEnum e = e { + enumName = hash $ enumName e, + enumValues = map hash $ enumValues e + } + oRoute r = r { + routePath = map oPathPiece $ routePath r, + routeHandlers = map oHandler $ routeHandlers r + } + oPathPiece (PathText s) = PathText $ hash s + oPathPiece (PathId en) = PathId $ hash en + + oHandler h = h { + handlerParams = map oParam $ handlerParams h + } + oParam (Select sq) = Select (oSelectQuery sq) + oParam (IfFilter (pn,joins,expr)) = IfFilter (hash pn, map oJoin joins,oExpr expr) + oParam (DeleteFrom en vn expr) = DeleteFrom (hash en) vn (maybe Nothing (Just . oExpr) expr) + oParam (GetById en ifr vn) = GetById (hash en) (oInputFieldRef ifr) vn + oParam (Update en ifr ifs) = Update (hash en) (oInputFieldRef ifr) + (maybe Nothing (Just . (map oInputField)) ifs) + oParam (Insert en ifs vn) = Insert (hash en) (maybe Nothing (Just . (map oInputField)) ifs) vn + oParam (Return ofs) = Return ofs + oParam (Require sq) = Require $ oSelectQuery sq + oParam p = p + oSelectQuery sq = sq { + sqFields = map oSelectField $ sqFields sq, + sqFrom = (hash en, vn), + sqJoins = map oJoin $ sqJoins sq, + sqWhere = maybe Nothing (Just . oExpr) (sqWhere sq), + sqOrderBy = [ (oFieldRef fr, sd) | (fr,sd) <- sqOrderBy sq ] + } + where (en,vn) = sqFrom sq + oSelectField (SelectField vn fn mvn) = SelectField vn (hash fn) mvn + oSelectField sf = sf + oJoin join = join { + joinEntity = hash $ joinEntity join, + joinExpr = maybe Nothing (Just . oExpr) (joinExpr join) + } + oExpr (AndExpr e1 e2) = AndExpr (oExpr e1) (oExpr e2) + oExpr (NotExpr e) = NotExpr (oExpr e) + oExpr (OrExpr e1 e2) = OrExpr (oExpr e1) (oExpr e2) + oExpr (ListOpExpr fr1 lo fr2) = ListOpExpr (oFieldRef fr1) lo (oFieldRef fr2) + oExpr (BinOpExpr ve1 op ve2) = BinOpExpr (oValExpr ve1) op (oValExpr ve2) + + oValExpr (FieldExpr fr) = FieldExpr (oFieldRef fr) + oValExpr (ConcatExpr ve1 ve2) = ConcatExpr (oValExpr ve1) (oValExpr ve2) + oValExpr ve = ve + oFieldRef (FieldRefNormal vn fn) = FieldRefNormal vn (hash fn) + oFieldRef (FieldRefEnum en fn) = FieldRefEnum (hash en) (hash fn) + oFieldRef (FieldRefSubQuery sq) = FieldRefSubQuery (oSelectQuery sq) + oFieldRef fr = fr + oInputField (pn,ifr) = (hash pn,oInputFieldRef ifr) + oInputFieldRef (InputFieldNormal fn) = (InputFieldNormal $ hash fn) + oInputFieldRef (InputFieldLocalParamField vn fn) = InputFieldLocalParamField vn (hash fn) + oInputFieldRef ifr = ifr + diff --git a/SyncFile.hs b/SyncFile.hs new file mode 100644 --- /dev/null +++ b/SyncFile.hs @@ -0,0 +1,14 @@ +module SyncFile where +import Prelude hiding (readFile) +import System.IO (FilePath, writeFile) +import System.IO.Strict (readFile) + +syncFile :: FilePath -> String -> IO () +syncFile path content = do + oldContent <- catch (readFile path) (\_ -> return "") + if content /= oldContent + then do + putStrLn $ "Updating " ++ path + writeFile path content + else return () + diff --git a/codegen/enums-header.cg b/codegen/enums-header.cg --- a/codegen/enums-header.cg +++ b/codegen/enums-header.cg @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Handler.~{moduleName m}.Enums where import Database.Persist.TH import qualified Data.Aeson as A diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -12,25 +12,27 @@ import System.Directory import Control.Monad import System.IO - -data Flag = Input FilePath +import Obfuscate +data Flag = Obfuscate deriving Eq options :: [OptDescr Flag] options = [ + Option ['o'] ["obfuscate"] (NoArg Obfuscate) "obfuscated output" ] header = "Usage: yesod-dsl FILE" main = do args <- getArgs case getOpt RequireOrder options args of - (_, (path:_), []) -> main' path + (o, (path:_), []) -> main' o path (_, _, msgs) -> error $ concat msgs ++ usageInfo header options where - main' path = do - dbs <- parse path + main' o path = do + dbs' <- parse path + let dbs = if Obfuscate `elem` o then obfuscate dbs' else dbs' let ast = implementClasses . mergeModules $ dbs let errors = validate ast if null errors diff --git a/yesod-dsl.cabal b/yesod-dsl.cabal --- a/yesod-dsl.cabal +++ b/yesod-dsl.cabal @@ -1,5 +1,5 @@ name: yesod-dsl -version: 0.1.1.7 +version: 0.1.1.8 license: BSD3 license-file: LICENSE author: Tero Laitinen @@ -41,6 +41,9 @@ Generator.UpdateHandlers Generator.Validation Generator.Require + Generator.Cabal + Obfuscate + SyncFile Validation.Fields Validation.Handlers Validation.State