diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for persistent-discover + +## Unreleased changes + +## 0.1.0.0 + +- Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Matt Parsons (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matt Parsons nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# persistent-discover + +![build status](https://github.com/parsonsmatt/persistent-discover/actions/workflows/haskell.yml/badge.svg) + + +Supports automatic discovery of your +[`persistent`](https://hackage.haskell.org/package/persistent) models. + +## As an executable + +Let's say you've got a ton of `persistent` database models, all defined in a +module hierarchy like this: + +``` +src/ + Models/ + Foo.hs + Bar.hs + Baz.hs + Blargh.hs + What.hs + OhNo.hs +``` + +If you're using `persistent` to automatically generate migrations, you'll want +to have all the `[EntityDef]` in scope from each module. You can do that by +importing each module that defines models and calling `$(discoverEntities)`, +introduced in `persistent-2.13`. + +But you may forget to import a module. + +This utility imports *all* the modules defined in the current directory and +sub-directories, and then it calls `$(discoverEntities)` for you. + +To use it, place the following command in a file, located in the same directory +that your Haskell modules are in: + +``` +{-# OPTIONS_GHC -F -pgmF persistent-discover #-} +``` + +Let's say we put that in `src/Models/All.hs`. +This generates a module `Models.All` that exports a single item: `allEntities`, +which is a `[EntityDef]` and can be used by `migrateModels` to properly perform +migrations. + +You'll need to add `persistent-discover` to the `build-tool-depends` on your cabal file +for this to work. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import Database.Persist.Discover.Exe +import System.Environment (getArgs) + +main :: IO () +main = do + args <- getArgs + case args of + src : _ : dest : _ -> + discoverModels (Source src) (Destination dest) + _ -> + fail . mconcat $ + [ "persistent-discover: expected to be called with three arguments as an -F -pgmF preprocessor. got:" + , show args + ] + + diff --git a/persistent-discover.cabal b/persistent-discover.cabal new file mode 100644 --- /dev/null +++ b/persistent-discover.cabal @@ -0,0 +1,96 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 367368542f35766d0f032885ef0642293c2d78cc493e4ed99fdd2d71c68d68d2 + +name: persistent-discover +version: 0.1.0.0 +synopsis: Persistent module discover utilities +description: This package provides an executable for discovering Persistent model definition files, as well as a library function to glob all persistent model files. Please see the README on GitHub at +category: Web +homepage: https://github.com/parsonsmatt/persistent-discover#readme +bug-reports: https://github.com/parsonsmatt/persistent-discover/issues +author: Matt Parsons +maintainer: parsonsmatt@gmail.com +copyright: Matt Parsons +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/parsonsmatt/persistent-discover + +library + exposed-modules: + Database.Persist.Discover + Database.Persist.Discover.Exe + Lib + other-modules: + Paths_persistent_discover + hs-source-dirs: + ./src + default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances + ghc-options: -Wall + build-depends: + base >=4.12 && <5 + , directory + , dlist + , file-embed + , filepath + , mtl + , persistent >=2.13.0.0 + , template-haskell >=2.16.0.0 + default-language: Haskell2010 + +executable persistent-discover + main-is: Main.hs + other-modules: + Paths_persistent_discover + hs-source-dirs: + app + default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <5 + , directory + , dlist + , file-embed + , filepath + , mtl + , persistent >=2.13.0.0 + , persistent-discover + , template-haskell >=2.16.0.0 + default-language: Haskell2010 + +test-suite persistent-discover-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Database.Persist.Discover.ExeSpec + Paths_persistent_discover + hs-source-dirs: + test + default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >=4.12 && <5 + , directory + , dlist + , file-embed + , filepath + , hspec + , hspec-discover + , mtl + , persistent >=2.13.0.0 + , persistent-discover + , template-haskell >=2.16.0.0 + default-language: Haskell2010 diff --git a/src/Database/Persist/Discover.hs b/src/Database/Persist/Discover.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Discover.hs @@ -0,0 +1,33 @@ +-- | +-- +-- @since 0.1.0.0 +module Database.Persist.Discover + ( findPersistentModelFiles + ) where + +import Database.Persist.Discover.Exe (getFilesRecursive, stripSuffix) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.FileEmbed + +-- | Returns a list of all files with the @.persistentmodels@ suffix. +-- +-- > allFiles :: [FilePath] +-- > allFiles = $$(findPersistentModelFiles "config/models/") +-- +-- @since 0.1.0.0 +findPersistentModelFiles + :: FilePath + -- ^ The root directory to search from. + -> Q (TExp [FilePath]) +findPersistentModelFiles root = do + projectRoot <- makeRelativeToProject root + files <- runIO $ filter isPersistentModelFile <$> getFilesRecursive projectRoot + liftTyped files + where + isPersistentModelFile filename = + case stripSuffix ".persistentmodels" filename of + Just _ -> + True + _ -> + False diff --git a/src/Database/Persist/Discover/Exe.hs b/src/Database/Persist/Discover/Exe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Discover/Exe.hs @@ -0,0 +1,214 @@ +-- | This module contains types, definitions, and the logic behind +-- finding persistent definitions. +-- +-- In brief, we do an import of all the models defined in the current +-- directory or any subdirectories. These imports are "instances only" +-- imports. Then we splice in @$(discoverEntities)@ to +-- +-- The result module is named @All@, and it's placed in the hierarchy where +-- you define this. So if you have a source file: +-- +-- @ +-- -- src/PersistentModels/All.hs +-- +-- {-# OPTIONS_GHC -F -pgmF persistent-discover +-- @ +-- +-- Then it will translate to: +-- +-- @ +-- -- src/PersistentModels/All.hs +-- +-- module PersistentModels.All where +-- +-- import PersistentModels.Foo () +-- import PersistentModels.Bar () +-- import PersistentModels.Baz () +-- +-- allEntityDefs :: [EntityDef] +-- allEntityDefs = $(discoverEntities) +-- @ +-- +-- @since 0.1.0.0 +module Database.Persist.Discover.Exe where + +import System.FilePath +import Control.Monad.State +import Data.String +import Data.DList (DList(..)) +import qualified Data.DList as DList +import Data.Foldable (for_) +import System.Directory +import Data.List +import Data.Char +import Control.Applicative +import Data.Maybe + +newtype Source = Source FilePath + +newtype Destination = Destination FilePath + +data AllModelsFile = AllModelsFile + { amfModuleBase :: Module + , amfModuleImports :: [Module] + } + +render :: Render -> String +render action = + unlines $ DList.toList $ execState (unRender action) mempty + +renderLine :: Render -> Render +renderLine action = + fromString $ mconcat $ DList.toList $ execState (unRender action) mempty + +newtype Render' a = Render { unRender :: State (DList String) a } + deriving newtype + (Functor, Applicative, Monad) + +type Render = Render' () + +instance (a ~ ()) => IsString (Render' a) where + fromString str = + Render (modify (\s -> s <> pure str)) + +indent :: Int -> Render -> Render +indent i doc = + Render do + let + new = + fmap (replicate i ' ' <>) + $ execState (unRender doc) mempty + modify (<> new) + +-- | +-- +-- @since 0.1.0.0 +discoverModels + :: Source + -> Destination + -> IO () +discoverModels (Source src) (Destination dest) = do + let (dir, file) = splitFileName src + files <- filter (/= file) <$> getFilesRecursive dir + let + input = + AllModelsFile + { amfModuleBase = + fromJust $ pathToModule src + , amfModuleImports = + mapMaybe pathToModule (fmap (dir ) files) + } + output = + renderFile input + + writeFile dest output + +-- | Returns a list of relative paths to all files in the given directory. +getFilesRecursive :: FilePath -- ^ The directory to search. + -> IO [FilePath] +getFilesRecursive baseDir = sort <$> go [] + where + go :: FilePath -> IO [FilePath] + go dir = do + c <- map (dir ) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (baseDir dir) + dirs <- filterM (doesDirectoryExist . (baseDir )) c >>= mapM go + files <- filterM (doesFileExist . (baseDir )) c + return (files ++ concat dirs) + +renderFile + :: AllModelsFile + -> String +renderFile amf = render do + let + modName = + moduleName $ amfModuleBase amf + renderLine do + "{-# LINE 1 " + fromString $ show modName + " #-}" + "" + renderLine do + "module " + fromString $ modName + " where" + "" + for_ (amfModuleImports amf) \mod' -> + renderLine do + "import " + fromString $ moduleName mod' + " ()" + "" + "import Database.Persist.TH (discoverEntities)" + "import Database.Persist.Types (EntityDef)" + "" + "-- | All of the entity definitions, as discovered by the @persistent-discover@ utility." + "allEntityDefs :: [EntityDef]" + "allEntityDefs = $(discoverEntities)" + +-- -- | Derive module name from specified path. +-- pathToModule :: FilePath -> Module +-- pathToModule f = +-- Module +-- { moduleName = +-- intercalate "." $ mapMaybe go $ splitDirectories f +-- , modulePath = +-- f +-- } +-- where +-- go :: String -> Maybe String +-- go (c:cs) = +-- Just (toUpper c : cs) +-- fileName = last $ splitDirectories f +-- m:ms = takeWhile (/='.') fileName + +data Module = Module + { moduleName :: String + , modulePath :: FilePath + } + deriving (Eq, Show) + +mkModulePieces + :: FilePath + -> [String] +mkModulePieces fp = + fmap dropSuffixes $ dropWhile isLowerFirst $ filter noDots $ splitDirectories fp + where + noDots x = + "." /= x && ".." /= x + dropSuffixes str = + fromMaybe str + $ stripSuffix ".hs" str + <|> stripSuffix ".lhs" str + +isLowerFirst :: String -> Bool +isLowerFirst [] = True +isLowerFirst (c:_) = isLower c + + +pathToModule + :: FilePath + -> Maybe Module +pathToModule file = do + case mkModulePieces file of + [] -> + empty + x:xs -> do + pure (Module (intercalate "." (x:xs)) file) + +-- | Returns True if the given string is a valid task module name. +-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34) +isValidModuleName :: String -> Bool +isValidModuleName [] = False +isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs + +-- | Returns True if the given Char is a valid taks module character. +isValidModuleChar :: Char -> Bool +isValidModuleChar c = isAlphaNum c || c == '_' || c == '\'' + +-- | Convert a String in camel case to snake case. +casify :: String -> String +casify str = intercalate "_" $ groupBy (\a b -> isUpper a && isLower b) str + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suffix str = + reverse <$> stripPrefix (reverse suffix) (reverse str) diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/Database/Persist/Discover/ExeSpec.hs b/test/Database/Persist/Discover/ExeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/Discover/ExeSpec.hs @@ -0,0 +1,56 @@ +module Database.Persist.Discover.ExeSpec where + +import Test.Hspec +import Database.Persist.Discover.Exe +import System.FilePath + +spec :: Spec +spec = do + describe "Render" do + it "works" do + shouldBe + do render do + "hello" + "world" + do + "hello\nworld\n" + describe "indent" do + it "works" do + shouldBe + do render do + "hello" + indent 4 do + "world" + "goodbye" + do + "hello\n world\ngoodbye\n" + + describe "mkModulePieces" do + let + exPath = + "src/Foo/Bar.hs" + it "works" do + mkModulePieces exPath + `shouldBe` + ["Foo", "Bar"] + + + describe "pathToModule" do + let + exPath = + "./src/Foo/Bar.hs" + (dir, file) = + splitFileName exPath + it "splits how i expect" $ do + dir `shouldBe` "./src/Foo/" + file `shouldBe` "Bar.hs" + it "works" do + pathToModule exPath + `shouldBe` + Just Module + { moduleName = + "Foo.Bar" + , modulePath = + exPath + } + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +