wasp-lang/wasp
1
1
Fork 0
mirror of https://github.com/wasp-lang/wasp.git synced 2024-07-14 18:30:32 +03:00
Code Issues Projects Releases Wiki Activity

Formatted whole codebase with ormolu.

Browse Source
This commit is contained in:
Martin Sosic 2021-04-28 17:36:00 +02:00 committed by Martin Šošić
parent 369ab16586
commit 1219a57bc9
133 changed files with 4841 additions and 4390 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
waspc/Setup.hs
View File

@ -1,2 +1,3 @@
import Distribution.Simple
main = defaultMain

37
waspc/cli/Cli/Common.hs
View File

@ -1,28 +1,27 @@
module Cli.Common
( WaspProjectDir
, DotWaspDir
, CliTemplatesDir
, dotWaspDirInWaspProjectDir
, dotWaspRootFileInWaspProjectDir
, extCodeDirInWaspProjectDir
, generatedCodeDirInDotWaspDir
, buildDirInDotWaspDir
, waspSays
) where
( WaspProjectDir,
DotWaspDir,
CliTemplatesDir,
dotWaspDirInWaspProjectDir,
dotWaspRootFileInWaspProjectDir,
extCodeDirInWaspProjectDir,
generatedCodeDirInDotWaspDir,
buildDirInDotWaspDir,
waspSays,
)
where
import qualified Path as P
import Common (WaspProjectDir)
import ExternalCode (SourceExternalCodeDir)
import Common (WaspProjectDir)
import ExternalCode (SourceExternalCodeDir)
import qualified Generator.Common
import StrongPath (Dir, File, Path, Rel)
import qualified StrongPath as SP
import qualified Util.Terminal as Term
import qualified Path as P
import StrongPath (Dir, File, Path, Rel)
import qualified StrongPath as SP
import qualified Util.Terminal as Term
data DotWaspDir -- Here we put everything that wasp generates.
data CliTemplatesDir
data CliTemplatesDir
-- TODO: SHould this be renamed to include word "root"?
dotWaspDirInWaspProjectDir :: Path (Rel WaspProjectDir) (Dir DotWaspDir)

25
waspc/cli/Command.hs
View File

@ -1,24 +1,25 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Command
( Command
, runCommand
, CommandError(..)
) where
( Command,
runCommand,
CommandError (..),
)
where
import Control.Monad.Except (ExceptT, MonadError, runExceptT)
import Control.Monad.IO.Class (MonadIO)
newtype Command a = Command { _runCommand :: ExceptT CommandError IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadError CommandError)
newtype Command a = Command {_runCommand :: ExceptT CommandError IO a}
deriving (Functor, Applicative, Monad, MonadIO, MonadError CommandError)
runCommand :: Command a -> IO ()
runCommand cmd = do
errorOrResult <- runExceptT $ _runCommand cmd
case errorOrResult of
Left cmdError -> putStrLn $ "Error: " ++ _errorMsg cmdError
Right _ -> return ()
errorOrResult <- runExceptT $ _runCommand cmd
case errorOrResult of
Left cmdError -> putStrLn $ "Error: " ++ _errorMsg cmdError
Right _ -> return ()
-- TODO: What if we want to recognize errors in order to handle them?
-- Should we add _commandErrorType? Should CommandError be parametrized by it, is that even possible?
data CommandError = CommandError { _errorMsg :: !String }
data CommandError = CommandError {_errorMsg :: !String}

63
waspc/cli/Command/Build.hs
View File

@ -1,38 +1,43 @@
module Command.Build
( build
) where
( build,
)
where
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Cli.Common as Common
import Command (Command, CommandError (..))
import Command.Common (alphaWarningMessage,
findWaspProjectRootDirFromCwd)
import Command.Compile (compileIOWithOptions)
import CompileOptions (CompileOptions (..))
import qualified Cli.Common as Common
import Command (Command, CommandError (..))
import Command.Common
( alphaWarningMessage,
findWaspProjectRootDirFromCwd,
)
import Command.Compile (compileIOWithOptions)
import CompileOptions (CompileOptions (..))
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Lib
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
build :: Command ()
build = do
waspProjectDir <- findWaspProjectRootDirFromCwd
let outDir = waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.buildDirInDotWaspDir
waspProjectDir <- findWaspProjectRootDirFromCwd
let outDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.buildDirInDotWaspDir
liftIO $ putStrLn "Building wasp project..."
buildResult <- liftIO $ buildIO waspProjectDir outDir
case buildResult of
Left compileError -> throwError $ CommandError $ "Build failed: " ++ compileError
Right () -> liftIO $ putStrLn "Code has been successfully built! Check it out in .wasp/build directory.\n"
liftIO $ putStrLn alphaWarningMessage
liftIO $ putStrLn "Building wasp project..."
buildResult <- liftIO $ buildIO waspProjectDir outDir
case buildResult of
Left compileError -> throwError $ CommandError $ "Build failed: " ++ compileError
Right () -> liftIO $ putStrLn "Code has been successfully built! Check it out in .wasp/build directory.\n"
liftIO $ putStrLn alphaWarningMessage
buildIO :: Path Abs (Dir Common.WaspProjectDir)
-> Path Abs (Dir Lib.ProjectRootDir)
-> IO (Either String ())
buildIO ::
Path Abs (Dir Common.WaspProjectDir) ->
Path Abs (Dir Lib.ProjectRootDir) ->
IO (Either String ())
buildIO waspProjectDir outDir = compileIOWithOptions options waspProjectDir outDir
where
options = CompileOptions
{ externalCodeDirPath = waspProjectDir </> Common.extCodeDirInWaspProjectDir
, isBuild = True
}
where
options =
CompileOptions
{ externalCodeDirPath = waspProjectDir </> Common.extCodeDirInWaspProjectDir,
isBuild = True
}

19
waspc/cli/Command/Call.hs
View File

@ -1,11 +1,12 @@
module Command.Call where
data Call = New String -- project name
| Start
| Clean
| Compile
| Db [String] -- db args
| Build
| Version
| Telemetry
| Unknown [String] -- all args
data Call
= New String -- project name
| Start
| Clean
| Compile
| Db [String] -- db args
| Build
| Version
| Telemetry
| Unknown [String] -- all args

42
waspc/cli/Command/Clean.hs
View File

@ -1,25 +1,27 @@
module Command.Clean
( clean
) where
( clean,
)
where
import Control.Monad.IO.Class (liftIO)
import System.Directory (doesDirectoryExist,
removeDirectoryRecursive)
import System.IO (hFlush, stdout)
import qualified Cli.Common as Common
import Command (Command)
import Command.Common (findWaspProjectRootDirFromCwd)
import qualified StrongPath as SP
import qualified Cli.Common as Common
import Command (Command)
import Command.Common (findWaspProjectRootDirFromCwd)
import Control.Monad.IO.Class (liftIO)
import qualified StrongPath as SP
import System.Directory
( doesDirectoryExist,
removeDirectoryRecursive,
)
import System.IO (hFlush, stdout)
clean :: Command ()
clean = do
waspProjectDir <- findWaspProjectRootDirFromCwd
let dotWaspDirFp = SP.toFilePath $ waspProjectDir SP.</> Common.dotWaspDirInWaspProjectDir
liftIO $ putStrLn "Deleting .wasp/ directory..." >> hFlush stdout
doesDotWaspDirExist <- liftIO $ doesDirectoryExist dotWaspDirFp
if doesDotWaspDirExist
then liftIO $ do removeDirectoryRecursive dotWaspDirFp
putStrLn "Deleted .wasp/ directory."
else liftIO $ putStrLn "Nothing to delete: .wasp directory does not exist."
waspProjectDir <- findWaspProjectRootDirFromCwd
let dotWaspDirFp = SP.toFilePath $ waspProjectDir SP.</> Common.dotWaspDirInWaspProjectDir
liftIO $ putStrLn "Deleting .wasp/ directory..." >> hFlush stdout
doesDotWaspDirExist <- liftIO $ doesDirectoryExist dotWaspDirFp
if doesDotWaspDirExist
then liftIO $ do
removeDirectoryRecursive dotWaspDirFp
putStrLn "Deleted .wasp/ directory."
else liftIO $ putStrLn "Nothing to delete: .wasp directory does not exist."

85
waspc/cli/Command/Compile.hs
View File

@ -1,55 +1,62 @@
module Command.Compile
( compileIO
, compile
, compileIOWithOptions
) where
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.IO.Class (liftIO)
( compileIO,
compile,
compileIOWithOptions,
)
where
import qualified Cli.Common
import Command (Command, CommandError (..))
import Command.Common (findWaspProjectRootDirFromCwd,
waspSaysC)
import Command.Db.Migrate (MigrationDirCopyDirection (..),
copyDbMigrationsDir)
import Common (WaspProjectDir)
import CompileOptions (CompileOptions (..))
import Command (Command, CommandError (..))
import Command.Common
( findWaspProjectRootDirFromCwd,
waspSaysC,
)
import Command.Db.Migrate
( MigrationDirCopyDirection (..),
copyDbMigrationsDir,
)
import Common (WaspProjectDir)
import CompileOptions (CompileOptions (..))
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Lib
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
compile :: Command ()
compile = do
waspProjectDir <- findWaspProjectRootDirFromCwd
let outDir = waspProjectDir </> Cli.Common.dotWaspDirInWaspProjectDir
</> Cli.Common.generatedCodeDirInDotWaspDir
waspProjectDir <- findWaspProjectRootDirFromCwd
let outDir =
waspProjectDir </> Cli.Common.dotWaspDirInWaspProjectDir
</> Cli.Common.generatedCodeDirInDotWaspDir
waspSaysC "Compiling wasp code..."
compilationResult <- liftIO $ compileIO waspProjectDir outDir
case compilationResult of
Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError
Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n"
waspSaysC "Compiling wasp code..."
compilationResult <- liftIO $ compileIO waspProjectDir outDir
case compilationResult of
Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError
Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n"
-- | Compiles Wasp source code in waspProjectDir directory and generates a project
-- in given outDir directory.
compileIO :: Path Abs (Dir WaspProjectDir)
-> Path Abs (Dir Lib.ProjectRootDir)
-> IO (Either String ())
compileIO ::
Path Abs (Dir WaspProjectDir) ->
Path Abs (Dir Lib.ProjectRootDir) ->
IO (Either String ())
compileIO waspProjectDir outDir = compileIOWithOptions options waspProjectDir outDir
where
options = CompileOptions
{ externalCodeDirPath = waspProjectDir </> Cli.Common.extCodeDirInWaspProjectDir
, isBuild = False
options =
CompileOptions
{ externalCodeDirPath = waspProjectDir </> Cli.Common.extCodeDirInWaspProjectDir,
isBuild = False
}
compileIOWithOptions :: CompileOptions
-> Path Abs (Dir Cli.Common.WaspProjectDir)
-> Path Abs (Dir Lib.ProjectRootDir)
-> IO (Either String ())
compileIOWithOptions ::
CompileOptions ->
Path Abs (Dir Cli.Common.WaspProjectDir) ->
Path Abs (Dir Lib.ProjectRootDir) ->
IO (Either String ())
compileIOWithOptions options waspProjectDir outDir = runExceptT $ do
-- TODO: Use throwIO instead of Either to return exceptions?
liftIO (Lib.compile waspProjectDir outDir options)
>>= either throwError return
liftIO (copyDbMigrationsDir CopyMigDirDown waspProjectDir outDir)
>>= maybe (return ()) (throwError . ("Copying migration folder failed: " ++))
-- TODO: Use throwIO instead of Either to return exceptions?
liftIO (Lib.compile waspProjectDir outDir options)
>>= either throwError return
liftIO (copyDbMigrationsDir CopyMigDirDown waspProjectDir outDir)
>>= maybe (return ()) (throwError . ("Copying migration folder failed: " ++))

82
waspc/cli/Command/Db.hs
View File

@ -1,22 +1,22 @@
module Command.Db
( runDbCommand
, studio
) where
( runDbCommand,
studio,
)
where
import Control.Concurrent.Async (concurrently)
import qualified Cli.Common as Common
import Command (Command, CommandError (..), runCommand)
import Command.Common (findWaspProjectRootDirFromCwd, waspSaysC)
import Command.Compile (compile)
import Control.Concurrent (newChan)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.Async (concurrently)
import Control.Monad.Except (throwError)
import System.Exit (ExitCode (..))
import StrongPath ((</>))
import Generator.ServerGenerator.Setup (setupServer)
import Control.Monad.IO.Class (liftIO)
import Generator.DbGenerator.Jobs (runStudio)
import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed)
import Command (Command, CommandError(..), runCommand)
import Command.Compile (compile)
import Command.Common (findWaspProjectRootDirFromCwd, waspSaysC)
import qualified Cli.Common as Common
import Generator.ServerGenerator.Setup (setupServer)
import StrongPath ((</>))
import System.Exit (ExitCode (..))
runDbCommand :: Command a -> IO ()
runDbCommand = runCommand . makeDbCommand
@ -27,38 +27,40 @@ runDbCommand = runCommand . makeDbCommand
-- All the commands that operate on db should be created using this function.
makeDbCommand :: Command a -> Command a
makeDbCommand cmd = do
waspRoot <- findWaspProjectRootDirFromCwd
let genProjectDir = waspRoot </> Common.dotWaspDirInWaspProjectDir </>
Common.generatedCodeDirInDotWaspDir
waspRoot <- findWaspProjectRootDirFromCwd
let genProjectDir =
waspRoot </> Common.dotWaspDirInWaspProjectDir
</> Common.generatedCodeDirInDotWaspDir
-- NOTE(matija): First we need make sure the code is generated.
compile
-- NOTE(matija): First we need make sure the code is generated.
compile
waspSaysC "\nSetting up database..."
chan <- liftIO newChan
-- NOTE(matija): What we do here is make sure that Prisma CLI is installed because db commands
-- (e.g. migrate) depend on it. We run setupServer which does even more than that, so we could make
-- this function more lightweight if needed.
(_, dbSetupResult) <- liftIO (concurrently (readJobMessagesAndPrintThemPrefixed chan) (setupServer genProjectDir chan))
case dbSetupResult of
ExitSuccess -> waspSaysC "\nDatabase successfully set up!" >> cmd
exitCode -> throwError $ CommandError $ dbSetupFailedMessage exitCode
where
dbSetupFailedMessage exitCode = "\nDatabase setup failed" ++
case exitCode of
ExitFailure code -> ": " ++ show code
_ -> ""
waspSaysC "\nSetting up database..."
chan <- liftIO newChan
-- NOTE(matija): What we do here is make sure that Prisma CLI is installed because db commands
-- (e.g. migrate) depend on it. We run setupServer which does even more than that, so we could make
-- this function more lightweight if needed.
(_, dbSetupResult) <- liftIO (concurrently (readJobMessagesAndPrintThemPrefixed chan) (setupServer genProjectDir chan))
case dbSetupResult of
ExitSuccess -> waspSaysC "\nDatabase successfully set up!" >> cmd
exitCode -> throwError $ CommandError $ dbSetupFailedMessage exitCode
where
dbSetupFailedMessage exitCode =
"\nDatabase setup failed"
++ case exitCode of
ExitFailure code -> ": " ++ show code
_ -> ""
-- TODO(matija): should we extract this into a separate file, like we did for migrate?
studio :: Command ()
studio = do
waspProjectDir <- findWaspProjectRootDirFromCwd
let genProjectDir = waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.generatedCodeDirInDotWaspDir
waspProjectDir <- findWaspProjectRootDirFromCwd
let genProjectDir =
waspProjectDir </> Common.dotWaspDirInWaspProjectDir
</> Common.generatedCodeDirInDotWaspDir
waspSaysC "Running studio..."
chan <- liftIO newChan
waspSaysC "Running studio..."
chan <- liftIO newChan
_ <- liftIO $ concurrently (readJobMessagesAndPrintThemPrefixed chan) (runStudio genProjectDir chan)
error "This should never happen, studio should never stop."
_ <- liftIO $ concurrently (readJobMessagesAndPrintThemPrefixed chan) (runStudio genProjectDir chan)
error "This should never happen, studio should never stop."

159
waspc/cli/Command/Db/Migrate.hs
View File

@ -1,100 +1,107 @@
module Command.Db.Migrate
( migrateDev
, copyDbMigrationsDir
, MigrationDirCopyDirection(..)
) where
( migrateDev,
copyDbMigrationsDir,
MigrationDirCopyDirection (..),
)
where
import Control.Monad.Catch (catch)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Path as P
import qualified Path.IO as PathIO
import Command (Command, CommandError (..))
import Command.Common (findWaspProjectRootDirFromCwd,
waspSaysC)
import Common (WaspProjectDir)
import qualified Cli.Common
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import Command (Command, CommandError (..))
import Command.Common
( findWaspProjectRootDirFromCwd,
waspSaysC,
)
import Common (WaspProjectDir)
import Control.Monad.Catch (catch)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
-- Wasp generator interface.
import Generator.Common (ProjectRootDir)
import Generator.DbGenerator (dbRootDirInProjectRootDir)
import Generator.Common (ProjectRootDir)
import Generator.DbGenerator (dbRootDirInProjectRootDir)
import qualified Generator.DbGenerator.Operations as DbOps
import qualified Path as P
import qualified Path.IO as PathIO
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
migrateDev :: Command ()
migrateDev = do
waspProjectDir <- findWaspProjectRootDirFromCwd
let genProjectRootDir = waspProjectDir
</> Cli.Common.dotWaspDirInWaspProjectDir
</> Cli.Common.generatedCodeDirInDotWaspDir
waspProjectDir <- findWaspProjectRootDirFromCwd
let genProjectRootDir =
waspProjectDir
</> Cli.Common.dotWaspDirInWaspProjectDir
</> Cli.Common.generatedCodeDirInDotWaspDir
-- TODO(matija): It might make sense that this (copying migrations folder from source to
-- the generated proejct) is responsibility of the generator. Since migrations can also be
-- considered part of a "source" code, then generator could take care of it and this command
-- wouldn't have to deal with it. We opened an issue on Github about this.
--
-- NOTE(matija): we need to copy migrations down before running "migrate dev" to make sure
-- all the latest migrations are in the generated project (e.g. Wasp dev checked out something
-- new) - otherwise "dev" would create a new migration for that and we would end up with two
-- migrations doing the same thing (which might result in conflict, e.g. during db creation).
waspSaysC "Copying migrations folder from Wasp to Prisma project..."
copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirDown
-- TODO(matija): It might make sense that this (copying migrations folder from source to
-- the generated proejct) is responsibility of the generator. Since migrations can also be
-- considered part of a "source" code, then generator could take care of it and this command
-- wouldn't have to deal with it. We opened an issue on Github about this.
--
-- NOTE(matija): we need to copy migrations down before running "migrate dev" to make sure
-- all the latest migrations are in the generated project (e.g. Wasp dev checked out something
-- new) - otherwise "dev" would create a new migration for that and we would end up with two
-- migrations doing the same thing (which might result in conflict, e.g. during db creation).
waspSaysC "Copying migrations folder from Wasp to Prisma project..."
copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirDown
waspSaysC "Performing migration..."
migrateResult <- liftIO $ DbOps.migrateDev genProjectRootDir
case migrateResult of
Left migrateError ->
throwError $ CommandError $ "Migrate dev failed: " <> migrateError
Right () -> waspSaysC "Migration done."
waspSaysC "Performing migration..."
migrateResult <- liftIO $ DbOps.migrateDev genProjectRootDir
case migrateResult of
Left migrateError ->
throwError $ CommandError $ "Migrate dev failed: " <> migrateError
Right () -> waspSaysC "Migration done."
waspSaysC "Copying migrations folder from Prisma to Wasp project..."
copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirUp
waspSaysC "Copying migrations folder from Prisma to Wasp project..."
copyDbMigrationDir waspProjectDir genProjectRootDir CopyMigDirUp
waspSaysC "All done!"
waspSaysC "All done!"
where
copyDbMigrationDir waspProjectDir genProjectRootDir copyDirection = do
copyDbMigDirResult <-
liftIO $ copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir
case copyDbMigDirResult of
Nothing -> waspSaysC "Done copying migrations folder."
Just err -> throwError $ CommandError $ "Copying migration folder failed: " ++ err
copyDbMigDirResult <-
liftIO $ copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir
case copyDbMigDirResult of
Nothing -> waspSaysC "Done copying migrations folder."
Just err -> throwError $ CommandError $ "Copying migration folder failed: " ++ err
data MigrationDirCopyDirection = CopyMigDirUp | CopyMigDirDown deriving (Eq)
-- | Copy migrations directory between Wasp source and the generated project.
copyDbMigrationsDir
:: MigrationDirCopyDirection -- ^ Copy direction (source -> gen or gen-> source)
-> Path Abs (Dir WaspProjectDir)
-> Path Abs (Dir ProjectRootDir)
-> IO (Maybe String)
copyDbMigrationsDir ::
-- | Copy direction (source -> gen or gen-> source)
MigrationDirCopyDirection ->
Path Abs (Dir WaspProjectDir) ->
Path Abs (Dir ProjectRootDir) ->
IO (Maybe String)
copyDbMigrationsDir copyDirection waspProjectDir genProjectRootDir = do
let dbMigrationsDirInDbRootDir = SP.fromPathRelDir [P.reldir|migrations|]
let dbMigrationsDirInDbRootDir = SP.fromPathRelDir [P.reldir|migrations|]
-- Migration folder in Wasp source (seen by Wasp dev and versioned).
let dbMigrationsDirInWaspProjectDirAbs = waspProjectDir </> dbMigrationsDirInDbRootDir
-- Migration folder in Wasp source (seen by Wasp dev and versioned).
let dbMigrationsDirInWaspProjectDirAbs = waspProjectDir </> dbMigrationsDirInDbRootDir
-- Migration folder in the generated code.
let dbMigrationsDirInGenProjectDirAbs = genProjectRootDir </> dbRootDirInProjectRootDir
</> dbMigrationsDirInDbRootDir
-- Migration folder in the generated code.
let dbMigrationsDirInGenProjectDirAbs =
genProjectRootDir </> dbRootDirInProjectRootDir
</> dbMigrationsDirInDbRootDir
let src = if copyDirection == CopyMigDirUp
then dbMigrationsDirInGenProjectDirAbs
else dbMigrationsDirInWaspProjectDirAbs
let src =
if copyDirection == CopyMigDirUp
then dbMigrationsDirInGenProjectDirAbs
else dbMigrationsDirInWaspProjectDirAbs
let target = if copyDirection == CopyMigDirUp
then dbMigrationsDirInWaspProjectDirAbs
else dbMigrationsDirInGenProjectDirAbs
doesSrcDirExist <- PathIO.doesDirExist (SP.toPathAbsDir src)
if doesSrcDirExist
then ((PathIO.copyDirRecur (SP.toPathAbsDir src)
(SP.toPathAbsDir target))
>> return Nothing)
`catch` (\e -> return $ Just $ show (e :: P.PathException))
`catch` (\e -> return $ Just $ show (e :: IOError))
else return Nothing
let target =
if copyDirection == CopyMigDirUp
then dbMigrationsDirInWaspProjectDirAbs
else dbMigrationsDirInGenProjectDirAbs
doesSrcDirExist <- PathIO.doesDirExist (SP.toPathAbsDir src)
if doesSrcDirExist
then
( ( PathIO.copyDirRecur
(SP.toPathAbsDir src)
(SP.toPathAbsDir target)
)
>> return Nothing
)
`catch` (\e -> return $ Just $ show (e :: P.PathException))
`catch` (\e -> return $ Just $ show (e :: IOError))
else return Nothing

83
waspc/cli/Command/Start.hs
View File

@ -1,52 +1,53 @@
module Command.Start
( start
) where
( start,
)
where
import Control.Concurrent.Async (race)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Cli.Common as Common
import Command (Command, CommandError (..))
import Command.Common (findWaspProjectRootDirFromCwd,
waspSaysC)
import Command.Compile (compileIO)
import Command.Watch (watch)
import qualified Cli.Common as Common
import Command (Command, CommandError (..))
import Command.Common
( findWaspProjectRootDirFromCwd,
waspSaysC,
)
import Command.Compile (compileIO)
import Command.Watch (watch)
import Control.Concurrent.Async (race)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import qualified Lib
import StrongPath ((</>))
import StrongPath ((</>))
-- | Does initial compile of wasp code and then runs the generated project.
-- It also listens for any file changes and recompiles and restarts generated project accordingly.
start :: Command ()
start = do
waspRoot <- findWaspProjectRootDirFromCwd
let outDir = waspRoot </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir
waspRoot <- findWaspProjectRootDirFromCwd
let outDir = waspRoot </> Common.dotWaspDirInWaspProjectDir </> Common.generatedCodeDirInDotWaspDir
waspSaysC "Compiling wasp code..."
compilationResult <- liftIO $ compileIO waspRoot outDir
case compilationResult of
Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError
Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n"
waspSaysC "Compiling wasp code..."
compilationResult <- liftIO $ compileIO waspRoot outDir
case compilationResult of
Left compileError -> throwError $ CommandError $ "Compilation failed: " ++ compileError
Right () -> waspSaysC "Code has been successfully compiled, project has been generated.\n"
-- TODO: Do smart install -> if we need to install stuff, install it, otherwise don't.
-- This should be responsibility of Generator, it should tell us how to install stuff.
-- But who checks out if stuff needs to be installed at all? That should probably be
-- Generator again. After installation, it should return some kind of data that describes that installation.
-- Then, next time, we give it data we have about last installation, and it uses that
-- to decide if installation needs to happen or not. If it happens, it returnes new data again.
-- Right now we have setup/installation being called, but it has not support for being "smart" yet.
waspSaysC "Setting up generated project..."
setupResult <- liftIO $ Lib.setup outDir
case setupResult of
Left setupError -> throwError $ CommandError $ "\nSetup failed: " ++ setupError
Right () -> waspSaysC "\nSetup successful.\n"
-- TODO: Do smart install -> if we need to install stuff, install it, otherwise don't.
-- This should be responsibility of Generator, it should tell us how to install stuff.
-- But who checks out if stuff needs to be installed at all? That should probably be
-- Generator again. After installation, it should return some kind of data that describes that installation.
-- Then, next time, we give it data we have about last installation, and it uses that
-- to decide if installation needs to happen or not. If it happens, it returnes new data again.
-- Right now we have setup/installation being called, but it has not support for being "smart" yet.
waspSaysC "Setting up generated project..."
setupResult <- liftIO $ Lib.setup outDir
case setupResult of
Left setupError -> throwError $ CommandError $ "\nSetup failed: " ++ setupError
Right () -> waspSaysC "\nSetup successful.\n"
waspSaysC "\nListening for file changes..."
waspSaysC "Starting up generated project..."
watchOrStartResult <- liftIO $ race (watch waspRoot outDir) (Lib.start outDir)
case watchOrStartResult of
Left () -> error "This should never happen, listening for file changes should never end but it did."
Right startResult -> case startResult of
Left startError -> throwError $ CommandError $ "Start failed: " ++ startError
Right () -> error "This should never happen, start should never end but it did."
waspSaysC "\nListening for file changes..."
waspSaysC "Starting up generated project..."
watchOrStartResult <- liftIO $ race (watch waspRoot outDir) (Lib.start outDir)
case watchOrStartResult of
Left () -> error "This should never happen, listening for file changes should never end but it did."
Right startResult -> case startResult of
Left startError -> throwError $ CommandError $ "Start failed: " ++ startError
Right () -> error "This should never happen, start should never end but it did."

77
waspc/cli/Command/Telemetry.hs
View File

@ -1,22 +1,22 @@
module Command.Telemetry
( considerSendingData
, telemetry
) where
( considerSendingData,
telemetry,
)
where
import Control.Monad (when, unless)
import Control.Monad.Except (catchError, throwError)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (isJust)
import Data.Foldable (for_)
import qualified System.Environment as ENV
import Command (Command, CommandError (..))
import Command.Common (waspSaysC)
import Command (Command, CommandError (..))
import qualified Command.Call
import Command.Telemetry.Common (ensureTelemetryCacheDirExists)
import Command.Common (waspSaysC)
import Command.Telemetry.Common (ensureTelemetryCacheDirExists)
import qualified Command.Telemetry.Project as TlmProject
import qualified Command.Telemetry.User as TlmUser
import qualified StrongPath as SP
import qualified Command.Telemetry.User as TlmUser
import Control.Monad (unless, when)
import Control.Monad.Except (catchError, throwError)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (for_)
import Data.Maybe (isJust)
import qualified StrongPath as SP
import qualified System.Environment as ENV
isTelemetryDisabled :: IO Bool
isTelemetryDisabled = isJust <$> ENV.lookupEnv "WASP_TELEMETRY_DISABLE"
@ -24,24 +24,27 @@ isTelemetryDisabled = isJust <$> ENV.lookupEnv "WASP_TELEMETRY_DISABLE"
-- | Prints basic information about the stauts of telemetry.
telemetry :: Command ()
telemetry = do
telemetryDisabled <- liftIO isTelemetryDisabled
waspSaysC $ "Telemetry is currently: " <> (if telemetryDisabled
then "DISABLED"
else "ENABLED")
telemetryDisabled <- liftIO isTelemetryDisabled
waspSaysC $
"Telemetry is currently: "
<> ( if telemetryDisabled
then "DISABLED"
else "ENABLED"
)
unless telemetryDisabled $ do
telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists
waspSaysC $ "Telemetry cache directory: " ++ SP.toFilePath telemetryCacheDirPath
unless telemetryDisabled $ do
telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists
waspSaysC $ "Telemetry cache directory: " ++ SP.toFilePath telemetryCacheDirPath
maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing)
for_ maybeProjectHash $ \projectHash -> do
maybeProjectCache <- liftIO $ TlmProject.readProjectTelemetryFile telemetryCacheDirPath projectHash
for_ maybeProjectCache $ \projectCache -> do
let maybeTimeOfLastSending = TlmProject.getTimeOfLastTelemetryDataSent projectCache
for_ maybeTimeOfLastSending $ \timeOfLastSending -> do
waspSaysC $ "Last time telemetry data was sent for this project: " ++ show timeOfLastSending
maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing)
for_ maybeProjectHash $ \projectHash -> do
maybeProjectCache <- liftIO $ TlmProject.readProjectTelemetryFile telemetryCacheDirPath projectHash
for_ maybeProjectCache $ \projectCache -> do
let maybeTimeOfLastSending = TlmProject.getTimeOfLastTelemetryDataSent projectCache
for_ maybeTimeOfLastSending $ \timeOfLastSending -> do
waspSaysC $ "Last time telemetry data was sent for this project: " ++ show timeOfLastSending
waspSaysC "Our telemetry is anonymized and very limited in its scope: check https://wasp-lang.dev/docs/telemetry for more details."
waspSaysC "Our telemetry is anonymized and very limited in its scope: check https://wasp-lang.dev/docs/telemetry for more details."
-- | Sends telemetry data about the current Wasp project, if conditions are met.
-- If we are not in the Wasp project at the moment, nothing happens.
@ -49,13 +52,13 @@ telemetry = do
-- If env var WASP_TELEMETRY_DISABLE is set, nothing happens.
considerSendingData :: Command.Call.Call -> Command ()
considerSendingData cmdCall = (`catchError` const (return ())) $ do
telemetryDisabled <- liftIO isTelemetryDisabled
when telemetryDisabled $ throwError $ CommandError "Telemetry disabled by user."
telemetryDisabled <- liftIO isTelemetryDisabled
when telemetryDisabled $ throwError $ CommandError "Telemetry disabled by user."
telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists
telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists
userSignature <- liftIO $ TlmUser.readOrCreateUserSignatureFile telemetryCacheDirPath
userSignature <- liftIO $ TlmUser.readOrCreateUserSignatureFile telemetryCacheDirPath
maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing)
for_ maybeProjectHash $ \projectHash -> do
liftIO $ TlmProject.considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall
maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing)
for_ maybeProjectHash $ \projectHash -> do
liftIO $ TlmProject.considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall

29
waspc/cli/Command/Telemetry/Common.hs
View File

@ -1,15 +1,14 @@
module Command.Telemetry.Common
( TelemetryCacheDir
, ensureTelemetryCacheDirExists
, getTelemetryCacheDirPath
) where
import Path (reldir)
import qualified System.Directory as SD
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
( TelemetryCacheDir,
ensureTelemetryCacheDirExists,
getTelemetryCacheDirPath,
)
where
import Path (reldir)
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
import qualified System.Directory as SD
data UserCacheDir
@ -20,11 +19,11 @@ data TelemetryCacheDir
ensureTelemetryCacheDirExists :: IO (Path Abs (Dir TelemetryCacheDir))
ensureTelemetryCacheDirExists = do
userCacheDirPath <- getUserCacheDirPath
SD.createDirectoryIfMissing False $ SP.toFilePath userCacheDirPath
let telemetryCacheDirPath = getTelemetryCacheDirPath userCacheDirPath
SD.createDirectoryIfMissing True $ SP.toFilePath telemetryCacheDirPath
return telemetryCacheDirPath
userCacheDirPath <- getUserCacheDirPath
SD.createDirectoryIfMissing False $ SP.toFilePath userCacheDirPath
let telemetryCacheDirPath = getTelemetryCacheDirPath userCacheDirPath
SD.createDirectoryIfMissing True $ SP.toFilePath telemetryCacheDirPath
return telemetryCacheDirPath
getTelemetryCacheDirPath :: Path Abs (Dir UserCacheDir) -> Path Abs (Dir TelemetryCacheDir)
getTelemetryCacheDirPath userCacheDirPath = userCacheDirPath SP.</> SP.fromPathRelDir [reldir|wasp/telemetry|]

203
waspc/cli/Command/Telemetry/Project.hs
View File

@ -1,73 +1,74 @@
{-# LANGUAGE DeriveGeneric #-}
module Command.Telemetry.Project
( getWaspProjectPathHash
, considerSendingData
, readProjectTelemetryFile
, getTimeOfLastTelemetryDataSent
) where
( getWaspProjectPathHash,
considerSendingData,
readProjectTelemetryFile,
getTimeOfLastTelemetryDataSent,
)
where
import Command.Common (findWaspProjectRootDirFromCwd)
import Control.Monad (void, when)
import Crypto.Hash (SHA256 (..), hashWith)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.UTF8 as ByteStringLazyUTF8
import qualified Data.ByteString.UTF8 as ByteStringUTF8
import Data.Maybe (fromJust)
import qualified Data.Time as T
import Data.Version (showVersion)
import GHC.Generics
import qualified Network.HTTP.Simple as HTTP
import Paths_waspc (version)
import qualified System.Directory as SD
import qualified System.Info
import Command (Command)
import Command (Command)
import qualified Command.Call
import Command.Telemetry.Common (TelemetryCacheDir)
import Command.Telemetry.User (UserSignature (..))
import StrongPath (Abs, Dir, File, Path)
import qualified StrongPath as SP
import Command.Common (findWaspProjectRootDirFromCwd)
import Command.Telemetry.Common (TelemetryCacheDir)
import Command.Telemetry.User (UserSignature (..))
import Control.Monad (void, when)
import Crypto.Hash (SHA256 (..), hashWith)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.UTF8 as ByteStringLazyUTF8
import qualified Data.ByteString.UTF8 as ByteStringUTF8
import Data.Maybe (fromJust)
import qualified Data.Time as T
import Data.Version (showVersion)
import GHC.Generics
import qualified Network.HTTP.Simple as HTTP
import Paths_waspc (version)
import StrongPath (Abs, Dir, File, Path)
import qualified StrongPath as SP
import qualified System.Directory as SD
import qualified System.Info
considerSendingData :: Path Abs (Dir TelemetryCacheDir) -> UserSignature -> ProjectHash -> Command.Call.Call -> IO ()
considerSendingData telemetryCacheDirPath userSignature projectHash cmdCall = do
projectCache <- readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash
projectCache <- readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash
let relevantLastCheckIn = case cmdCall of
Command.Call.Build -> _lastCheckInBuild projectCache
_ -> _lastCheckIn projectCache
let relevantLastCheckIn = case cmdCall of
Command.Call.Build -> _lastCheckInBuild projectCache
_ -> _lastCheckIn projectCache
shouldSendData <- case relevantLastCheckIn of
Nothing -> return True
Just lastCheckIn -> isOlderThan12Hours lastCheckIn
shouldSendData <- case relevantLastCheckIn of
Nothing -> return True
Just lastCheckIn -> isOlderThan12Hours lastCheckIn
when shouldSendData $ do
sendTelemetryData $ getProjectTelemetryData userSignature projectHash cmdCall
projectCache' <- newProjectCache projectCache
writeProjectTelemetryFile telemetryCacheDirPath projectHash projectCache'
when shouldSendData $ do
sendTelemetryData $ getProjectTelemetryData userSignature projectHash cmdCall
projectCache' <- newProjectCache projectCache
writeProjectTelemetryFile telemetryCacheDirPath projectHash projectCache'
where
isOlderThan12Hours :: T.UTCTime -> IO Bool
isOlderThan12Hours time = do
now <- T.getCurrentTime
let secondsSinceLastCheckIn = T.nominalDiffTimeToSeconds (now `T.diffUTCTime` time)
return $ let numSecondsInHour = 3600
in secondsSinceLastCheckIn > 12 * numSecondsInHour
isOlderThan12Hours :: T.UTCTime -> IO Bool
isOlderThan12Hours time = do
now <- T.getCurrentTime
let secondsSinceLastCheckIn = T.nominalDiffTimeToSeconds (now `T.diffUTCTime` time)
return $
let numSecondsInHour = 3600
in secondsSinceLastCheckIn > 12 * numSecondsInHour
newProjectCache :: ProjectTelemetryCache -> IO ProjectTelemetryCache
newProjectCache currentProjectCache = do
now <- T.getCurrentTime
return currentProjectCache
{ _lastCheckIn = Just now
, _lastCheckInBuild = case cmdCall of
Command.Call.Build -> Just now
_ -> _lastCheckInBuild currentProjectCache
}
newProjectCache :: ProjectTelemetryCache -> IO ProjectTelemetryCache
newProjectCache currentProjectCache = do
now <- T.getCurrentTime
return
currentProjectCache
{ _lastCheckIn = Just now,
_lastCheckInBuild = case cmdCall of
Command.Call.Build -> Just now
_ -> _lastCheckInBuild currentProjectCache
}
-- * Project hash.
newtype ProjectHash = ProjectHash { _projectHashValue :: String } deriving (Show)
newtype ProjectHash = ProjectHash {_projectHashValue :: String} deriving (Show)
getWaspProjectPathHash :: Command ProjectHash
getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> findWaspProjectRootDirFromCwd
@ -78,16 +79,17 @@ getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> find
-- * Project telemetry cache.
data ProjectTelemetryCache = ProjectTelemetryCache
{ _lastCheckIn :: Maybe T.UTCTime -- Last time when CLI was called for this project, any command.
, _lastCheckInBuild :: Maybe T.UTCTime -- Last time when CLI was called for this project, with Build command.
}
deriving (Generic, Show)
{ _lastCheckIn :: Maybe T.UTCTime, -- Last time when CLI was called for this project, any command.
_lastCheckInBuild :: Maybe T.UTCTime -- Last time when CLI was called for this project, with Build command.
}
deriving (Generic, Show)
instance Aeson.ToJSON ProjectTelemetryCache
instance Aeson.FromJSON ProjectTelemetryCache
initialCache :: ProjectTelemetryCache
initialCache = ProjectTelemetryCache { _lastCheckIn = Nothing, _lastCheckInBuild = Nothing }
initialCache = ProjectTelemetryCache {_lastCheckIn = Nothing, _lastCheckInBuild = Nothing}
-- * Project telemetry cache file.
@ -96,66 +98,71 @@ getTimeOfLastTelemetryDataSent cache = maximum [_lastCheckIn cache, _lastCheckIn
readProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> IO (Maybe ProjectTelemetryCache)
readProjectTelemetryFile telemetryCacheDirPath projectHash = do
fileExists <- SD.doesFileExist filePathFP
if fileExists then readCacheFile else return Nothing
fileExists <- SD.doesFileExist filePathFP
if fileExists then readCacheFile else return Nothing
where
filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash
readCacheFile = Aeson.decode . ByteStringLazyUTF8.fromString <$> readFile filePathFP
filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash
readCacheFile = Aeson.decode . ByteStringLazyUTF8.fromString <$> readFile filePathFP
readOrCreateProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> IO ProjectTelemetryCache
readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash = do
maybeProjectTelemetryCache <- readProjectTelemetryFile telemetryCacheDirPath projectHash
case maybeProjectTelemetryCache of
Just cache -> return cache
Nothing -> writeProjectTelemetryFile telemetryCacheDirPath projectHash initialCache >> return initialCache
maybeProjectTelemetryCache <- readProjectTelemetryFile telemetryCacheDirPath projectHash
case maybeProjectTelemetryCache of
Just cache -> return cache
Nothing -> writeProjectTelemetryFile telemetryCacheDirPath projectHash initialCache >> return initialCache
writeProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> ProjectTelemetryCache -> IO ()
writeProjectTelemetryFile telemetryCacheDirPath projectHash cache = do
writeFile filePathFP (ByteStringLazyUTF8.toString $ Aeson.encode cache)
writeFile filePathFP (ByteStringLazyUTF8.toString $ Aeson.encode cache)
where
filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash
getProjectTelemetryFilePath :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> Path Abs File
getProjectTelemetryFilePath telemetryCacheDir (ProjectHash projectHash) =
telemetryCacheDir SP.</> fromJust (SP.parseRelFile $ "project-" ++ projectHash)
telemetryCacheDir SP.</> fromJust (SP.parseRelFile $ "project-" ++ projectHash)
-- * Telemetry data.
data ProjectTelemetryData = ProjectTelemetryData
{ _userSignature :: UserSignature
, _projectHash :: ProjectHash
, _waspVersion :: String
, _os :: String
, _isBuild :: Bool
} deriving (Show)
{ _userSignature :: UserSignature,
_projectHash :: ProjectHash,
_waspVersion :: String,
_os :: String,
_isBuild :: Bool
}
deriving (Show)
getProjectTelemetryData :: UserSignature -> ProjectHash -> Command.Call.Call -> ProjectTelemetryData
getProjectTelemetryData userSignature projectHash cmdCall = ProjectTelemetryData
{ _userSignature = userSignature
, _projectHash = projectHash
, _waspVersion = showVersion version
, _os = System.Info.os
, _isBuild = case cmdCall of
Command.Call.Build -> True
_ -> False
getProjectTelemetryData userSignature projectHash cmdCall =
ProjectTelemetryData
{ _userSignature = userSignature,
_projectHash = projectHash,
_waspVersion = showVersion version,
_os = System.Info.os,
_isBuild = case cmdCall of
Command.Call.Build -> True
_ -> False
}
sendTelemetryData :: ProjectTelemetryData -> IO ()
sendTelemetryData telemetryData = do
let reqBodyJson = Aeson.object
[ -- PostHog api_key is public so it is ok that we have it here.
"api_key" .= ("CdDd2A0jKTI2vFAsrI9JWm3MqpOcgHz1bMyogAcwsE4" :: String)
, "event" .= ("cli" :: String)
, "properties" .= Aeson.object
let reqBodyJson =
Aeson.object
[ -- PostHog api_key is public so it is ok that we have it here.
"api_key" .= ("CdDd2A0jKTI2vFAsrI9JWm3MqpOcgHz1bMyogAcwsE4" :: String),
"event" .= ("cli" :: String),
"properties"
.= Aeson.object
[ -- distinct_id is special PostHog value, used as user id.
"distinct_id" .= _userSignatureValue (_userSignature telemetryData)
-- Following are our custom metrics:
, "project_hash" .= _projectHashValue (_projectHash telemetryData)
, "wasp_version" .= _waspVersion telemetryData
, "os" .= _os telemetryData
, "is_build" .= _isBuild telemetryData
"distinct_id" .= _userSignatureValue (_userSignature telemetryData),
-- Following are our custom metrics:
"project_hash" .= _projectHashValue (_projectHash telemetryData),
"wasp_version" .= _waspVersion telemetryData,
"os" .= _os telemetryData,
"is_build" .= _isBuild telemetryData
]
]
request = HTTP.setRequestBodyJSON reqBodyJson $
HTTP.parseRequest_ "POST https://app.posthog.com/capture"
void $ HTTP.httpNoBody request
]
request =
HTTP.setRequestBodyJSON reqBodyJson $
HTTP.parseRequest_ "POST https://app.posthog.com/capture"
void $ HTTP.httpNoBody request

43
waspc/cli/Command/Telemetry/User.hs
View File

@ -1,34 +1,33 @@
{-# LANGUAGE DeriveGeneric #-}
module Command.Telemetry.User
( UserSignature(..)
, readOrCreateUserSignatureFile
) where
import qualified Data.UUID.V4 as UUID
import Path (relfile)
import qualified System.Directory as SD
import Command.Telemetry.Common (TelemetryCacheDir)
import StrongPath (Abs, Dir, File, Path)
import qualified StrongPath as SP
( UserSignature (..),
readOrCreateUserSignatureFile,
)
where
import Command.Telemetry.Common (TelemetryCacheDir)
import qualified Data.UUID.V4 as UUID
import Path (relfile)
import StrongPath (Abs, Dir, File, Path)
import qualified StrongPath as SP
import qualified System.Directory as SD
-- Random, non-identifyable UUID used to represent user in analytics.
newtype UserSignature = UserSignature { _userSignatureValue :: String } deriving (Show)
newtype UserSignature = UserSignature {_userSignatureValue :: String} deriving (Show)
readOrCreateUserSignatureFile :: Path Abs (Dir TelemetryCacheDir) -> IO UserSignature
readOrCreateUserSignatureFile telemetryCacheDirPath = do
let filePath = getUserSignatureFilePath telemetryCacheDirPath
let filePathFP = SP.toFilePath filePath
fileExists <- SD.doesFileExist filePathFP
UserSignature <$> if fileExists
then readFile filePathFP
else do userSignature <- show <$> UUID.nextRandom
writeFile filePathFP userSignature
return userSignature
let filePath = getUserSignatureFilePath telemetryCacheDirPath
let filePathFP = SP.toFilePath filePath
fileExists <- SD.doesFileExist filePathFP
UserSignature
<$> if fileExists
then readFile filePathFP
else do
userSignature <- show <$> UUID.nextRandom
writeFile filePathFP userSignature
return userSignature
getUserSignatureFilePath :: Path Abs (Dir TelemetryCacheDir) -> Path Abs File
getUserSignatureFilePath telemetryCacheDir = telemetryCacheDir SP.</> SP.fromPathRelFile [relfile|signature|]

102
waspc/cli/Command/Watch.hs
View File

@ -1,20 +1,19 @@
module Command.Watch
( watch
) where
( watch,
)
where
import Control.Concurrent.Chan (Chan, newChan, readChan)
import Data.List (isSuffixOf)
import Data.Time.Clock (UTCTime, getCurrentTime)
import qualified System.FilePath as FP
import qualified System.FSNotify as FSN
import Cli.Common (waspSays)
import qualified Cli.Common as Common
import Command.Compile (compileIO)
import Cli.Common (waspSays)
import qualified Cli.Common as Common
import Command.Compile (compileIO)
import Control.Concurrent.Chan (Chan, newChan, readChan)
import Data.List (isSuffixOf)
import Data.Time.Clock (UTCTime, getCurrentTime)
import qualified Lib
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import qualified System.FSNotify as FSN
import qualified System.FilePath as FP
-- TODO: Another possible problem: on re-generation, wasp re-generates a lot of files, even those that should not
-- be generated again, since it is not smart enough yet to know which files do not need to be regenerated.
@ -27,47 +26,48 @@ import qualified StrongPath as SP
-- TODO: Idea: Read .gitignore file, and ignore everything from it. This will then also cover the
-- .wasp dir, and users can easily add any custom stuff they want ignored. But, we also have to
-- be ready for the case when there is no .gitignore, that could be possible.
-- | Forever listens for any file changes in waspProjectDir, and if there is a change,
-- compiles Wasp source files in waspProjectDir and regenerates files in outDir.
watch :: Path Abs (Dir Common.WaspProjectDir) -> Path Abs (Dir Lib.ProjectRootDir) -> IO ()
watch waspProjectDir outDir = FSN.withManager $ \mgr -> do
currentTime <- getCurrentTime
chan <- newChan
_ <- FSN.watchDirChan mgr (SP.toFilePath waspProjectDir) eventFilter chan
_ <- FSN.watchTreeChan mgr (SP.toFilePath $ waspProjectDir </> Common.extCodeDirInWaspProjectDir) eventFilter chan
listenForEvents chan currentTime
currentTime <- getCurrentTime
chan <- newChan
_ <- FSN.watchDirChan mgr (SP.toFilePath waspProjectDir) eventFilter chan
_ <- FSN.watchTreeChan mgr (SP.toFilePath $ waspProjectDir </> Common.extCodeDirInWaspProjectDir) eventFilter chan
listenForEvents chan currentTime
where
listenForEvents :: Chan FSN.Event -> UTCTime -> IO ()
listenForEvents chan lastCompileTime = do
event <- readChan chan
let eventTime = FSN.eventTime event
if eventTime < lastCompileTime
-- If event happened before last compilation started, skip it.
then listenForEvents chan lastCompileTime
else do
currentTime <- getCurrentTime
recompile
listenForEvents chan currentTime
listenForEvents :: Chan FSN.Event -> UTCTime -> IO ()
listenForEvents chan lastCompileTime = do
event <- readChan chan
let eventTime = FSN.eventTime event
if eventTime < lastCompileTime
then -- If event happened before last compilation started, skip it.
listenForEvents chan lastCompileTime
else do
currentTime <- getCurrentTime
recompile
listenForEvents chan currentTime
recompile :: IO ()
recompile = do
waspSays "Recompiling on file change..."
compilationResult <- compileIO waspProjectDir outDir
case compilationResult of
Left err -> waspSays $ "Recompilation on file change failed: " ++ err
Right () -> waspSays "Recompilation on file change succeeded."
return ()
recompile :: IO ()
recompile = do
waspSays "Recompiling on file change..."
compilationResult <- compileIO waspProjectDir outDir
case compilationResult of
Left err -> waspSays $ "Recompilation on file change failed: " ++ err
Right () -> waspSays "Recompilation on file change succeeded."
return ()
-- TODO: This is a hardcoded approach to ignoring most of the common tmp files that editors
-- create next to the source code. Bad thing here is that users can't modify this,
-- so better approach would be probably to use information from .gitignore instead, or
-- maybe combining the two somehow.
eventFilter :: FSN.Event -> Bool
eventFilter event =
let filename = FP.takeFileName $ FSN.eventPath event
in not (null filename)
&& not (take 2 filename == ".#") -- Ignore emacs lock files.
&& not (head filename == '#' && last filename == '#') -- Ignore emacs auto-save files.
&& not (last filename == '~') -- Ignore emacs and vim backup files.
&& not (head filename == '.' && ".swp" `isSuffixOf` filename) -- Ignore vim swp files.
&& not (head filename == '.' && ".un~" `isSuffixOf` filename) -- Ignore vim undo files.
-- TODO: This is a hardcoded approach to ignoring most of the common tmp files that editors
-- create next to the source code. Bad thing here is that users can't modify this,
-- so better approach would be probably to use information from .gitignore instead, or
-- maybe combining the two somehow.
eventFilter :: FSN.Event -> Bool
eventFilter event =
let filename = FP.takeFileName $ FSN.eventPath event
in not (null filename)
&& not (take 2 filename == ".#") -- Ignore emacs lock files.
&& not (head filename == '#' && last filename == '#') -- Ignore emacs auto-save files.
&& not (last filename == '~') -- Ignore emacs and vim backup files.
&& not (head filename == '.' && ".swp" `isSuffixOf` filename) -- Ignore vim swp files.
&& not (head filename == '.' && ".un~" `isSuffixOf` filename) -- Ignore vim undo files.

179
waspc/cli/Main.hs
View File

@ -1,84 +1,85 @@
module Main where
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import Control.Monad (void)
import Data.Char (isSpace)
import Data.Version (showVersion)
import Paths_waspc (version)
import System.Environment
import Command (runCommand)
import Command.Build (build)
import Command (runCommand)
import Command.Build (build)
import qualified Command.Call
import Command.Clean (clean)
import Command.Compile (compile)
import Command.CreateNewProject (createNewProject)
import Command.Db (runDbCommand, studio)
import Command.Clean (clean)
import Command.Compile (compile)
import Command.CreateNewProject (createNewProject)
import Command.Db (runDbCommand, studio)
import qualified Command.Db.Migrate
import Command.Start (start)
import qualified Command.Telemetry as Telemetry
import qualified Util.Terminal as Term
import Command.Start (start)
import qualified Command.Telemetry as Telemetry
import Control.Concurrent (threadDelay)
import qualified Control.Concurrent.Async as Async
import Control.Monad (void)
import Data.Char (isSpace)
import Data.Version (showVersion)
import Paths_waspc (version)
import System.Environment
import qualified Util.Terminal as Term
main :: IO ()
main = do
args <- getArgs
let commandCall = case args of
["new", projectName] -> Command.Call.New projectName
["start"] -> Command.Call.Start
["clean"] -> Command.Call.Clean
["compile"] -> Command.Call.Compile
("db":dbArgs) -> Command.Call.Db dbArgs
["version"] -> Command.Call.Version
["build"] -> Command.Call.Build
["telemetry"] -> Command.Call.Telemetry
_ -> Command.Call.Unknown args
args <- getArgs
let commandCall = case args of
["new", projectName] -> Command.Call.New projectName
["start"] -> Command.Call.Start
["clean"] -> Command.Call.Clean
["compile"] -> Command.Call.Compile
("db" : dbArgs) -> Command.Call.Db dbArgs
["version"] -> Command.Call.Version
["build"] -> Command.Call.Build
["telemetry"] -> Command.Call.Telemetry
_ -> Command.Call.Unknown args
telemetryThread <- Async.async $ runCommand $ Telemetry.considerSendingData commandCall
telemetryThread <- Async.async $ runCommand $ Telemetry.considerSendingData commandCall
case commandCall of
Command.Call.New projectName -> runCommand $ createNewProject projectName
Command.Call.Start -> runCommand start
Command.Call.Clean -> runCommand clean
Command.Call.Compile -> runCommand compile
Command.Call.Db dbArgs -> dbCli dbArgs
Command.Call.Version -> printVersion
Command.Call.Build -> runCommand build
Command.Call.Telemetry -> runCommand Telemetry.telemetry
Command.Call.Unknown _ -> printUsage
case commandCall of
Command.Call.New projectName -> runCommand $ createNewProject projectName
Command.Call.Start -> runCommand start
Command.Call.Clean -> runCommand clean
Command.Call.Compile -> runCommand compile
Command.Call.Db dbArgs -> dbCli dbArgs
Command.Call.Version -> printVersion
Command.Call.Build -> runCommand build
Command.Call.Telemetry -> runCommand Telemetry.telemetry
Command.Call.Unknown _ -> printUsage
-- If sending of telemetry data is still not done 1 second since commmand finished, abort it.
-- We also make sure here to catch all errors that might get thrown and silence them.
void $ Async.race (threadDelaySeconds 1) (Async.waitCatch telemetryThread)
-- If sending of telemetry data is still not done 1 second since commmand finished, abort it.
-- We also make sure here to catch all errors that might get thrown and silence them.
void $ Async.race (threadDelaySeconds 1) (Async.waitCatch telemetryThread)
where
threadDelaySeconds = let microsecondsInASecond = 1000000
in threadDelay . (* microsecondsInASecond)
threadDelaySeconds =
let microsecondsInASecond = 1000000
in threadDelay . (* microsecondsInASecond)
printUsage :: IO ()
printUsage = putStrLn $ unlines
[ title "USAGE"
, " wasp <command> [command-args]"
, ""
, title "COMMANDS"
, title " GENERAL"
, cmd " new <project-name> Creates new Wasp project."
, cmd " version Prints current version of CLI."
, title " IN PROJECT"
, cmd " start Runs Wasp app in development mode, watching for file changes."
, cmd " db <db-cmd> [args] Executes a database command. Run 'wasp db' for more info."
, cmd " clean Deletes all generated code and other cached artifacts. Wasp equivalent of 'have you tried closing and opening it again?'."
, cmd " build Generates full web app code, ready for deployment. Use when deploying or ejecting."
, cmd " telemetry Prints telemetry status."
, ""
, title "EXAMPLES"
, " wasp new MyApp"
, " wasp start"
, " wasp db migrate-dev"
, ""
, Term.applyStyles [Term.Green] "Docs:" ++ " https://wasp-lang.dev/docs"
, Term.applyStyles [Term.Magenta] "Discord (chat):" ++ " https://discord.gg/rzdnErX"
]
printUsage =
putStrLn $
unlines
[ title "USAGE",
" wasp <command> [command-args]",
"",
title "COMMANDS",
title " GENERAL",
cmd " new <project-name> Creates new Wasp project.",
cmd " version Prints current version of CLI.",
title " IN PROJECT",
cmd " start Runs Wasp app in development mode, watching for file changes.",
cmd " db <db-cmd> [args] Executes a database command. Run 'wasp db' for more info.",
cmd " clean Deletes all generated code and other cached artifacts. Wasp equivalent of 'have you tried closing and opening it again?'.",
cmd " build Generates full web app code, ready for deployment. Use when deploying or ejecting.",
cmd " telemetry Prints telemetry status.",
"",
title "EXAMPLES",
" wasp new MyApp",
" wasp start",
" wasp db migrate-dev",
"",
Term.applyStyles [Term.Green] "Docs:" ++ " https://wasp-lang.dev/docs",
Term.applyStyles [Term.Magenta] "Discord (chat):" ++ " https://discord.gg/rzdnErX"
]
printVersion :: IO ()
printVersion = putStrLn $ showVersion version
@ -86,27 +87,29 @@ printVersion = putStrLn $ showVersion version
-- TODO(matija): maybe extract to a separate module, e.g. DbCli.hs?
dbCli :: [String] -> IO ()
dbCli args = case args of
["migrate-dev"] -> runDbCommand Command.Db.Migrate.migrateDev
["studio"] -> runDbCommand studio
_ -> printDbUsage
["migrate-dev"] -> runDbCommand Command.Db.Migrate.migrateDev
["studio"] -> runDbCommand studio
_ -> printDbUsage
printDbUsage :: IO ()
printDbUsage = putStrLn $ unlines
[ title "USAGE"
, " wasp db <command> [command-args]"
, ""
, title "COMMANDS"
, cmd (
" migrate-dev Ensures dev database corresponds to the current state of schema(entities):\n" <>
" - Generates a new migration if there are changes in the schema.\n" <>
" - Applies any pending migrations to the database."
)
, cmd " studio GUI for inspecting your database."
, ""
, title "EXAMPLES"
, " wasp db migrate-dev"
, " wasp db studio"
]
printDbUsage =
putStrLn $
unlines
[ title "USAGE",
" wasp db <command> [command-args]",
"",
title "COMMANDS",
cmd
( " migrate-dev Ensures dev database corresponds to the current state of schema(entities):\n"
<> " - Generates a new migration if there are changes in the schema.\n"
<> " - Applies any pending migrations to the database."
),
cmd " studio GUI for inspecting your database.",
"",
title "EXAMPLES",
" wasp db migrate-dev",
" wasp db studio"
]
title :: String -> String
title = Term.applyStyles [Term.Bold]
@ -118,4 +121,4 @@ mapFirstWord :: (String -> String) -> String -> String
mapFirstWord f s = beforeFirstWord ++ f firstWord ++ afterFirstWord
where
(beforeFirstWord, firstWordAndAfter) = span isSpace s
(firstWord, afterFirstWord) = break isSpace firstWordAndAfter
(firstWord, afterFirstWord) = break isSpace firstWordAndAfter

5
waspc/src/Common.hs
View File

@ -1,5 +1,6 @@
module Common
( WaspProjectDir
) where
( WaspProjectDir,
)
where
data WaspProjectDir -- Root dir of Wasp project, containing source files.

16
waspc/src/CompileOptions.hs
View File

@ -1,15 +1,15 @@
module CompileOptions
( CompileOptions(..)
) where
import StrongPath (Path, Abs, Dir)
import ExternalCode(SourceExternalCodeDir)
( CompileOptions (..),
)
where
import ExternalCode (SourceExternalCodeDir)
import StrongPath (Abs, Dir, Path)
-- TODO(martin): Should these be merged with Wasp data? Is it really a separate thing or not?
-- It would be easier to pass around if it is part of Wasp data. But is it semantically correct?
-- Maybe it is, even more than this!
data CompileOptions = CompileOptions
{ externalCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir))
, isBuild :: !Bool
}
{ externalCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)),
isBuild :: !Bool
}

13
waspc/src/Data.hs
View File

@ -1,13 +1,12 @@
module Data
( DataDir
, getAbsDataDirPath
) where
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
( DataDir,
getAbsDataDirPath,
)
where
import qualified Paths_waspc
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
data DataDir

108
waspc/src/ExternalCode.hs
View File

@ -1,39 +1,40 @@
module ExternalCode
( File
, filePathInExtCodeDir
, fileAbsPath
, fileText
, readFiles
, SourceExternalCodeDir
) where
( File,
filePathInExtCodeDir,
fileAbsPath,
fileText,
readFiles,
SourceExternalCodeDir,
)
where
import UnliftIO.Exception (catch, throwIO)
import System.IO.Error (isDoesNotExistError)
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.IO as TextL.IO
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.IO as TextL.IO
import qualified Path as P
import qualified Util.IO
import StrongPath (Path, Abs, Rel, Dir, (</>))
import StrongPath (Abs, Dir, Path, Rel, (</>))
import qualified StrongPath as SP
import WaspignoreFile (readWaspignoreFile, ignores)
import System.IO.Error (isDoesNotExistError)
import UnliftIO.Exception (catch, throwIO)
import qualified Util.IO
import WaspignoreFile (ignores, readWaspignoreFile)
-- | External code directory in Wasp source, from which external code files are read.
data SourceExternalCodeDir
data File = File
{ _pathInExtCodeDir :: !(Path (Rel SourceExternalCodeDir) SP.File)
, _extCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir))
, _text :: TextL.Text -- ^ File content. It will throw error when evaluated if file is not textual file.
}
{ _pathInExtCodeDir :: !(Path (Rel SourceExternalCodeDir) SP.File),
_extCodeDirPath :: !(Path Abs (Dir SourceExternalCodeDir)),
-- | File content. It will throw error when evaluated if file is not textual file.
_text :: TextL.Text
}
instance Show File where
show = show . _pathInExtCodeDir
show = show . _pathInExtCodeDir
instance Eq File where
f1 == f2 = _pathInExtCodeDir f1 == _pathInExtCodeDir f2
f1 == f2 = _pathInExtCodeDir f1 == _pathInExtCodeDir f2
-- | Returns path relative to the external code directory.
filePathInExtCodeDir :: File -> Path (Rel SourceExternalCodeDir) SP.File
@ -54,33 +55,38 @@ waspignorePathInExtCodeDir = SP.fromPathRelFile [P.relfile|.waspignore|]
-- except files ignores by the specified waspignore file.
readFiles :: Path Abs (Dir SourceExternalCodeDir) -> IO [File]
readFiles extCodeDirPath = do
let waspignoreFilePath = extCodeDirPath </> waspignorePathInExtCodeDir
waspignoreFile <- readWaspignoreFile waspignoreFilePath
relFilePaths <- filter (not . ignores waspignoreFile . SP.toFilePath) .
map SP.fromPathRelFile <$>
Util.IO.listDirectoryDeep (SP.toPathAbsDir extCodeDirPath)
let absFilePaths = map (extCodeDirPath </>) relFilePaths
-- NOTE: We read text from all the files, regardless if they are text files or not, because
-- we don't know if they are a text file or not.
-- Since we do lazy reading (Text.Lazy), this is not a problem as long as we don't try to use
-- text of a file that is actually not a text file -> then we will get an error when Haskell
-- actually tries to read that file.
-- TODO: We are doing lazy IO here, and there is an idea of it being a thing to avoid, due to no
-- control over when resources are released and similar.
-- If we do figure out that this is causing us problems, we could do the following refactoring:
-- Don't read files at this point, just list them, and Wasp will contain just list of filepaths.
-- Modify TextFileDraft so that it also takes text transformation function (Text -> Text),
-- or create new file draft that will support that.
-- In generator, when creating TextFileDraft, give it function/logic for text transformation,
-- and it will be taken care of when draft will be written to the disk.
fileTexts <- catMaybes <$> mapM (tryReadFile . SP.toFilePath) absFilePaths
let files = map (\(path, text) -> File path extCodeDirPath text) (zip relFilePaths fileTexts)
return files
where
-- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed
-- but then got deleted before actual reading was invoked.
-- That would make this function crash, so we just ignore those errors.
tryReadFile :: FilePath -> IO (Maybe TextL.Text)
tryReadFile fp = (Just <$> TextL.IO.readFile fp) `catch` (\e -> if isDoesNotExistError e
then return Nothing
else throwIO e)
let waspignoreFilePath = extCodeDirPath </> waspignorePathInExtCodeDir
waspignoreFile <- readWaspignoreFile waspignoreFilePath
relFilePaths <-
filter (not . ignores waspignoreFile . SP.toFilePath)
. map SP.fromPathRelFile
<$> Util.IO.listDirectoryDeep (SP.toPathAbsDir extCodeDirPath)
let absFilePaths = map (extCodeDirPath </>) relFilePaths
-- NOTE: We read text from all the files, regardless if they are text files or not, because
-- we don't know if they are a text file or not.
-- Since we do lazy reading (Text.Lazy), this is not a problem as long as we don't try to use
-- text of a file that is actually not a text file -> then we will get an error when Haskell
-- actually tries to read that file.
-- TODO: We are doing lazy IO here, and there is an idea of it being a thing to avoid, due to no
-- control over when resources are released and similar.
-- If we do figure out that this is causing us problems, we could do the following refactoring:
-- Don't read files at this point, just list them, and Wasp will contain just list of filepaths.
-- Modify TextFileDraft so that it also takes text transformation function (Text -> Text),
-- or create new file draft that will support that.
-- In generator, when creating TextFileDraft, give it function/logic for text transformation,
-- and it will be taken care of when draft will be written to the disk.
fileTexts <- catMaybes <$> mapM (tryReadFile . SP.toFilePath) absFilePaths
let files = map (\(path, text) -> File path extCodeDirPath text) (zip relFilePaths fileTexts)
return files
where
-- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed
-- but then got deleted before actual reading was invoked.
-- That would make this function crash, so we just ignore those errors.
tryReadFile :: FilePath -> IO (Maybe TextL.Text)
tryReadFile fp =
(Just <$> TextL.IO.readFile fp)
`catch` ( \e ->
if isDoesNotExistError e
then return Nothing
else throwIO e
)

59
waspc/src/Generator.hs
View File

@ -1,30 +1,29 @@
module Generator
( writeWebAppCode
, Generator.Setup.setup
, Generator.Start.start
) where
( writeWebAppCode,
Generator.Setup.setup,
Generator.Start.start,
)
where
import CompileOptions (CompileOptions)
import qualified Data.Text
import qualified Data.Text.IO
import Data.Time.Clock
import Data.Time.Clock
import qualified Data.Version
import qualified Path as P
import qualified Paths_waspc
import CompileOptions (CompileOptions)
import Generator.Common (ProjectRootDir)
import Generator.DbGenerator (genDb)
import Generator.FileDraft (FileDraft, write)
import Generator.ServerGenerator (genServer)
import Generator.Common (ProjectRootDir)
import Generator.DbGenerator (genDb)
import Generator.DockerGenerator (genDockerFiles)
import Generator.FileDraft (FileDraft, write)
import Generator.ServerGenerator (genServer)
import qualified Generator.ServerGenerator as ServerGenerator
import Generator.DockerGenerator (genDockerFiles)
import qualified Generator.Setup
import qualified Generator.Start
import Generator.WebAppGenerator (generateWebApp)
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import Generator.WebAppGenerator (generateWebApp)
import qualified Path as P
import qualified Paths_waspc
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
-- | Generates web app code from given Wasp and writes it to given destination directory.
-- If dstDir does not exist yet, it will be created.
@ -33,12 +32,12 @@ import Wasp (Wasp)
-- from user's machine. Maybe we just overwrite and we are good?
writeWebAppCode :: Wasp -> Path Abs (Dir ProjectRootDir) -> CompileOptions -> IO ()
writeWebAppCode wasp dstDir compileOptions = do
writeFileDrafts dstDir (generateWebApp wasp compileOptions)
ServerGenerator.preCleanup wasp dstDir compileOptions
writeFileDrafts dstDir (genServer wasp compileOptions)
writeFileDrafts dstDir (genDb wasp compileOptions)
writeFileDrafts dstDir (genDockerFiles wasp compileOptions)
writeDotWaspInfo dstDir
writeFileDrafts dstDir (generateWebApp wasp compileOptions)
ServerGenerator.preCleanup wasp dstDir compileOptions
writeFileDrafts dstDir (genServer wasp compileOptions)
writeFileDrafts dstDir (genDb wasp compileOptions)
writeFileDrafts dstDir (genDockerFiles wasp compileOptions)
writeDotWaspInfo dstDir
-- | Writes file drafts while using given destination dir as root dir.
-- TODO(martin): We could/should parallelize this.
@ -49,8 +48,8 @@ writeFileDrafts dstDir = mapM_ (write dstDir)
-- | Writes .waspinfo, which contains some basic metadata about how/when wasp generated the code.
writeDotWaspInfo :: Path Abs (Dir ProjectRootDir) -> IO ()
writeDotWaspInfo dstDir = do
currentTime <- getCurrentTime
let version = Data.Version.showVersion Paths_waspc.version
let content = "Generated on " ++ (show currentTime) ++ " by waspc version " ++ (show version) ++ " ."
let dstPath = dstDir </> SP.fromPathRelFile [P.relfile|.waspinfo|]
Data.Text.IO.writeFile (SP.toFilePath dstPath) (Data.Text.pack content)
currentTime <- getCurrentTime
let version = Data.Version.showVersion Paths_waspc.version
let content = "Generated on " ++ (show currentTime) ++ " by waspc version " ++ (show version) ++ " ."
let dstPath = dstDir </> SP.fromPathRelFile [P.relfile|.waspinfo|]
Data.Text.IO.writeFile (SP.toFilePath dstPath) (Data.Text.pack content)

12
waspc/src/Generator/Common.hs
View File

@ -1,8 +1,9 @@
module Generator.Common
( ProjectRootDir
, nodeVersion
, nodeVersionAsText
) where
( ProjectRootDir,
nodeVersion,
nodeVersionAsText,
)
where
import Text.Printf (printf)
@ -16,4 +17,5 @@ nodeVersion = (12, 18, 0) -- Latest LTS version.
nodeVersionAsText :: String
nodeVersionAsText = printf "%d.%d.%d" major minor patch
where (major, minor, patch) = nodeVersion
where
(major, minor, patch) = nodeVersion

76
waspc/src/Generator/DbGenerator.hs
View File

@ -1,30 +1,31 @@
module Generator.DbGenerator
( genDb
, dbRootDirInProjectRootDir
, dbSchemaFileInProjectRootDir
) where
( genDb,
dbRootDirInProjectRootDir,
dbSchemaFileInProjectRootDir,
)
where
import Data.Aeson (object, (.=))
import qualified Path as P
import Data.Maybe (fromMaybe)
import CompileOptions (CompileOptions)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import CompileOptions (CompileOptions)
import Data.Aeson (object, (.=))
import Data.Maybe (fromMaybe)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import qualified Path as P
import qualified Psl.Ast.Model
import qualified Psl.Generator.Model
import StrongPath (Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import StrongPath (Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Wasp
import qualified Wasp.Db
import Wasp.Entity (Entity)
import Wasp.Entity (Entity)
import qualified Wasp.Entity
-- * Path definitions
data DbRootDir
data DbTemplatesDir
dbRootDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir DbRootDir)
@ -48,29 +49,32 @@ dbSchemaFileInProjectRootDir = dbRootDirInProjectRootDir </> dbSchemaFileInDbRoo
genDb :: Wasp -> CompileOptions -> [FileDraft]
genDb wasp _ =
[ genPrismaSchema wasp
]
[ genPrismaSchema wasp
]
genPrismaSchema :: Wasp -> FileDraft
genPrismaSchema wasp = createTemplateFileDraft dstPath tmplSrcPath (Just templateData)
where
dstPath = dbSchemaFileInProjectRootDir
tmplSrcPath = dbTemplatesDirInTemplatesDir </> dbSchemaFileInDbTemplatesDir
where
dstPath = dbSchemaFileInProjectRootDir
tmplSrcPath = dbTemplatesDirInTemplatesDir </> dbSchemaFileInDbTemplatesDir
templateData = object
[ "modelSchemas" .= map entityToPslModelSchema (Wasp.getPSLEntities wasp)
, "datasourceProvider" .= (datasourceProvider :: String)
, "datasourceUrl" .= (datasourceUrl :: String)
]
templateData =
object
[ "modelSchemas" .= map entityToPslModelSchema (Wasp.getPSLEntities wasp),
"datasourceProvider" .= (datasourceProvider :: String),
"datasourceUrl" .= (datasourceUrl :: String)
]
dbSystem = fromMaybe Wasp.Db.SQLite $ Wasp.Db._system <$> Wasp.getDb wasp
(datasourceProvider, datasourceUrl) = case dbSystem of
Wasp.Db.PostgreSQL -> ("postgresql", "env(\"DATABASE_URL\")")
-- TODO: Report this error with some better mechanism, not `error`.
Wasp.Db.SQLite -> if Wasp.getIsBuild wasp
then error "SQLite is not supported in production. Set db.system to smth else."
else ("sqlite", "\"file:./dev.db\"")
dbSystem = fromMaybe Wasp.Db.SQLite $ Wasp.Db._system <$> Wasp.getDb wasp
(datasourceProvider, datasourceUrl) = case dbSystem of
Wasp.Db.PostgreSQL -> ("postgresql", "env(\"DATABASE_URL\")")
-- TODO: Report this error with some better mechanism, not `error`.
Wasp.Db.SQLite ->
if Wasp.getIsBuild wasp
then error "SQLite is not supported in production. Set db.system to smth else."
else ("sqlite", "\"file:./dev.db\"")
entityToPslModelSchema :: Entity -> String
entityToPslModelSchema entity = Psl.Generator.Model.generateModel $
Psl.Ast.Model.Model (Wasp.Entity._name entity) (Wasp.Entity._pslModelBody entity)
entityToPslModelSchema :: Entity -> String
entityToPslModelSchema entity =
Psl.Generator.Model.generateModel $
Psl.Ast.Model.Model (Wasp.Entity._name entity) (Wasp.Entity._pslModelBody entity)

61
waspc/src/Generator/DbGenerator/Jobs.hs
View File

@ -1,36 +1,47 @@
module Generator.DbGenerator.Jobs
( migrateDev
, runStudio
) where
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
import Generator.ServerGenerator.Common (serverRootDirInProjectRootDir)
import Generator.DbGenerator (dbSchemaFileInProjectRootDir)
( migrateDev,
runStudio,
)
where
import Generator.Common (ProjectRootDir)
import Generator.DbGenerator (dbSchemaFileInProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import Generator.ServerGenerator.Common (serverRootDirInProjectRootDir)
import StrongPath (Abs, Dir, Path, (</>))
import qualified StrongPath as SP
migrateDev :: Path Abs (Dir ProjectRootDir) -> J.Job
migrateDev projectDir = do
let serverDir = projectDir </> serverRootDirInProjectRootDir
let schemaFile = projectDir </> dbSchemaFileInProjectRootDir
let serverDir = projectDir </> serverRootDirInProjectRootDir
let schemaFile = projectDir </> dbSchemaFileInProjectRootDir
-- NOTE(matija): We are running this command from server's root dir since that is where
-- Prisma packages (cli and client) are currently installed.
runNodeCommandAsJob serverDir "npx"
[ "prisma", "migrate", "dev"
, "--schema", SP.toFilePath schemaFile
] J.Db
-- NOTE(matija): We are running this command from server's root dir since that is where
-- Prisma packages (cli and client) are currently installed.
runNodeCommandAsJob
serverDir
"npx"
[ "prisma",
"migrate",
"dev",
"--schema",
SP.toFilePath schemaFile
]
J.Db
-- | Runs `prisma studio` - Prisma's db inspector.
runStudio :: Path Abs (Dir ProjectRootDir) -> J.Job
runStudio projectDir = do
let serverDir = projectDir </> serverRootDirInProjectRootDir
let schemaFile = projectDir </> dbSchemaFileInProjectRootDir
let serverDir = projectDir </> serverRootDirInProjectRootDir
let schemaFile = projectDir </> dbSchemaFileInProjectRootDir
runNodeCommandAsJob serverDir "npx"
[ "prisma", "studio"
, "--schema", SP.toFilePath schemaFile
] J.Db
runNodeCommandAsJob
serverDir
"npx"
[ "prisma",
"studio",
"--schema",
SP.toFilePath schemaFile
]
J.Db

38
waspc/src/Generator/DbGenerator/Operations.hs
View File

@ -1,30 +1,32 @@
module Generator.DbGenerator.Operations
( migrateDev
) where
( migrateDev,
)
where
import Control.Concurrent (Chan, newChan, readChan)
import Control.Concurrent.Async (concurrently)
import System.Exit (ExitCode (..))
import StrongPath (Abs, Dir, Path)
import Generator.Common (ProjectRootDir)
import Generator.Job.IO (printJobMessage)
import qualified Generator.Job as J
import Generator.Job (JobMessage)
import qualified Generator.DbGenerator.Jobs as DbJobs
import Generator.Job (JobMessage)
import qualified Generator.Job as J
import Generator.Job.IO (printJobMessage)
import StrongPath (Abs, Dir, Path)
import System.Exit (ExitCode (..))
printJobMsgsUntilExitReceived :: Chan JobMessage -> IO ()
printJobMsgsUntilExitReceived chan = do
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} -> printJobMessage jobMsg >> printJobMsgsUntilExitReceived chan
J.JobExit {} -> return ()
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} -> printJobMessage jobMsg >> printJobMsgsUntilExitReceived chan
J.JobExit {} -> return ()
migrateDev :: Path Abs (Dir ProjectRootDir) -> IO (Either String ())
migrateDev projectDir = do
chan <- newChan
(_, dbExitCode) <- concurrently (printJobMsgsUntilExitReceived chan)
(DbJobs.migrateDev projectDir chan)
case dbExitCode of
ExitSuccess -> return (Right ())
ExitFailure code -> return $ Left $ "Migrate (dev) failed with exit code: " ++ show code
chan <- newChan
(_, dbExitCode) <-
concurrently
(printJobMsgsUntilExitReceived chan)
(DbJobs.migrateDev projectDir chan)
case dbExitCode of
ExitSuccess -> return (Right ())
ExitFailure code -> return $ Left $ "Migrate (dev) failed with exit code: " ++ show code

45
waspc/src/Generator/DockerGenerator.hs
View File

@ -1,36 +1,41 @@
module Generator.DockerGenerator
( genDockerFiles
) where
( genDockerFiles,
)
where
import Data.Aeson (object, (.=))
import qualified Path as P
import StrongPath (File, Path, Rel)
import qualified StrongPath as SP
import CompileOptions (CompileOptions)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import Wasp (Wasp)
import CompileOptions (CompileOptions)
import Data.Aeson (object, (.=))
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import qualified Path as P
import StrongPath (File, Path, Rel)
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Wasp
genDockerFiles :: Wasp -> CompileOptions -> [FileDraft]
genDockerFiles wasp _ = concat
[ [genDockerfile wasp]
, [genDockerignore wasp]
genDockerFiles wasp _ =
concat
[ [genDockerfile wasp],
[genDockerignore wasp]
]
-- TODO: Inject paths to server and db files/dirs, right now they are hardcoded in the templates.
genDockerfile :: Wasp -> FileDraft
genDockerfile wasp = createTemplateFileDraft
genDockerfile wasp =
createTemplateFileDraft
(SP.fromPathRelFile [P.relfile|Dockerfile|] :: Path (Rel ProjectRootDir) File)
(SP.fromPathRelFile [P.relfile|Dockerfile|] :: Path (Rel TemplatesDir) File)
(Just $ object
[ "usingPrisma" .= not (null $ Wasp.getPSLEntities wasp)
])
( Just $
object
[ "usingPrisma" .= not (null $ Wasp.getPSLEntities wasp)
]
)
genDockerignore :: Wasp -> FileDraft
genDockerignore _ = createTemplateFileDraft
genDockerignore _ =
createTemplateFileDraft
(SP.fromPathRelFile [P.relfile|.dockerignore|] :: Path (Rel ProjectRootDir) File)
(SP.fromPathRelFile [P.relfile|dockerignore|] :: Path (Rel TemplatesDir) File)
Nothing

43
waspc/src/Generator/ExternalCodeGenerator.hs
View File

@ -1,39 +1,38 @@
module Generator.ExternalCodeGenerator
( generateExternalCodeDir
) where
( generateExternalCodeDir,
)
where
import qualified System.FilePath as FP
import StrongPath (Path, Rel, File, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Wasp
import qualified ExternalCode as EC
import qualified Generator.FileDraft as FD
import qualified Generator.ExternalCodeGenerator.Common as C
import Generator.ExternalCodeGenerator.Js (generateJsFile)
import qualified Generator.FileDraft as FD
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
import qualified System.FilePath as FP
import Wasp (Wasp)
import qualified Wasp
-- | Takes external code files from Wasp and generates them in new location as part of the generated project.
-- It might not just copy them but also do some changes on them, as needed.
generateExternalCodeDir :: C.ExternalCodeGeneratorStrategy
-> Wasp
-> [FD.FileDraft]
generateExternalCodeDir ::
C.ExternalCodeGeneratorStrategy ->
Wasp ->
[FD.FileDraft]
generateExternalCodeDir strategy wasp =
map (generateFile strategy) (Wasp.getExternalCodeFiles wasp)
map (generateFile strategy) (Wasp.getExternalCodeFiles wasp)
generateFile :: C.ExternalCodeGeneratorStrategy -> EC.File -> FD.FileDraft
generateFile strategy file
| extension `elem` [".js", ".jsx"] = generateJsFile strategy file
| otherwise = let relDstPath = (C._extCodeDirInProjectRootDir strategy)
</> dstPathInGenExtCodeDir
absSrcPath = EC.fileAbsPath file
in FD.createCopyFileDraft relDstPath absSrcPath
| extension `elem` [".js", ".jsx"] = generateJsFile strategy file
| otherwise =
let relDstPath =
(C._extCodeDirInProjectRootDir strategy)
</> dstPathInGenExtCodeDir
absSrcPath = EC.fileAbsPath file
in FD.createCopyFileDraft relDstPath absSrcPath
where
dstPathInGenExtCodeDir :: Path (Rel C.GeneratedExternalCodeDir) File
dstPathInGenExtCodeDir = C.castRelPathFromSrcToGenExtCodeDir $ EC.filePathInExtCodeDir file
extension = FP.takeExtension $ SP.toFilePath $ EC.filePathInExtCodeDir file

32
waspc/src/Generator/ExternalCodeGenerator/Common.hs
View File

@ -1,17 +1,17 @@
module Generator.ExternalCodeGenerator.Common
( ExternalCodeGeneratorStrategy(..)
, GeneratedExternalCodeDir
, castRelPathFromSrcToGenExtCodeDir
, asGenExtFile
) where
( ExternalCodeGeneratorStrategy (..),
GeneratedExternalCodeDir,
castRelPathFromSrcToGenExtCodeDir,
asGenExtFile,
)
where
import Data.Text (Text)
import qualified Path as P
import StrongPath (Path, Rel, File, Dir)
import qualified StrongPath as SP
import Generator.Common (ProjectRootDir)
import ExternalCode (SourceExternalCodeDir)
import Generator.Common (ProjectRootDir)
import qualified Path as P
import StrongPath (Dir, File, Path, Rel)
import qualified StrongPath as SP
-- | Path to the directory where ext code will be generated.
data GeneratedExternalCodeDir
@ -23,9 +23,9 @@ castRelPathFromSrcToGenExtCodeDir :: Path (Rel SourceExternalCodeDir) a -> Path
castRelPathFromSrcToGenExtCodeDir = SP.castRel
data ExternalCodeGeneratorStrategy = ExternalCodeGeneratorStrategy
{ -- | Takes a path where the external code js file will be generated.
-- Also takes text of the file. Returns text where special @wasp imports have been replaced with
-- imports that will work.
_resolveJsFileWaspImports :: Path (Rel GeneratedExternalCodeDir) File -> Text -> Text
, _extCodeDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir GeneratedExternalCodeDir)
}
{ -- | Takes a path where the external code js file will be generated.
-- Also takes text of the file. Returns text where special @wasp imports have been replaced with
-- imports that will work.
_resolveJsFileWaspImports :: Path (Rel GeneratedExternalCodeDir) File -> Text -> Text,
_extCodeDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir GeneratedExternalCodeDir)
}

39
waspc/src/Generator/ExternalCodeGenerator/Js.hs
View File

@ -1,20 +1,19 @@
module Generator.ExternalCodeGenerator.Js
( generateJsFile
, resolveJsFileWaspImportsForExtCodeDir
) where
( generateJsFile,
resolveJsFileWaspImportsForExtCodeDir,
)
where
import qualified Data.Text as T
import qualified Text.Regex.TDFA as TR
import Data.Text (Text, unpack)
import StrongPath (Path, Rel, File, Dir, (</>))
import qualified StrongPath as SP
import Path.Extra (reversePosixPath, toPosixFilePath)
import qualified Generator.FileDraft as FD
import qualified Data.Text as T
import qualified ExternalCode as EC
import Generator.ExternalCodeGenerator.Common (GeneratedExternalCodeDir)
import qualified Generator.ExternalCodeGenerator.Common as C
import qualified Generator.FileDraft as FD
import Path.Extra (reversePosixPath, toPosixFilePath)
import StrongPath (Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import qualified Text.Regex.TDFA as TR
generateJsFile :: C.ExternalCodeGeneratorStrategy -> EC.File -> FD.FileDraft
generateJsFile strategy file = FD.createTextFileDraft dstPath text'
@ -29,14 +28,18 @@ generateJsFile strategy file = FD.createTextFileDraft dstPath text'
dstPath = (C._extCodeDirInProjectRootDir strategy) </> filePathInGenExtCodeDir
-- | Replaces imports that start with "@wasp/" with imports that start from the src dir of the app.
resolveJsFileWaspImportsForExtCodeDir
:: Path (Rel ()) (Dir GeneratedExternalCodeDir) -- ^ Relative path of ext code dir in src dir of app (web app, server (app), ...)
-> Path (Rel GeneratedExternalCodeDir) File -- ^ Path where this JS file will be generated.
-> Text -- ^ Original text of the file.
-> Text -- ^ Text of the file with special "@wasp" imports resolved (replaced with normal JS imports).
resolveJsFileWaspImportsForExtCodeDir ::
-- | Relative path of ext code dir in src dir of app (web app, server (app), ...)
Path (Rel ()) (Dir GeneratedExternalCodeDir) ->
-- | Path where this JS file will be generated.
Path (Rel GeneratedExternalCodeDir) File ->
-- | Original text of the file.
Text ->
-- | Text of the file with special "@wasp" imports resolved (replaced with normal JS imports).
Text
resolveJsFileWaspImportsForExtCodeDir extCodeDirInAppSrcDir jsFileDstPathInExtCodeDir jsFileText =
let matches = concat (unpack jsFileText TR.=~ ("(from +['\"]@wasp/)" :: String) :: [[String]])
in foldr replaceFromWasp jsFileText matches
let matches = concat (unpack jsFileText TR.=~ ("(from +['\"]@wasp/)" :: String) :: [[String]])
in foldr replaceFromWasp jsFileText matches
where
replaceFromWasp fromWasp = T.replace (T.pack fromWasp) (T.pack $ transformFromWasp fromWasp)
transformFromWasp fromWasp = (reverse $ drop (length ("@wasp/" :: String)) $ reverse fromWasp) ++ pathPrefix ++ "/"

83
waspc/src/Generator/FileDraft.hs
View File

@ -1,65 +1,68 @@
module Generator.FileDraft
( FileDraft(..)
, Writeable(..)
, createTemplateFileDraft
, createCopyFileDraft
, createCopyFileDraftIfExists
, createTextFileDraft
) where
( FileDraft (..),
Writeable (..),
createTemplateFileDraft,
createCopyFileDraft,
createCopyFileDraftIfExists,
createTextFileDraft,
)
where
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import StrongPath (Path, Abs, Rel, File)
import Generator.Templates (TemplatesDir)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.Writeable
import qualified Generator.FileDraft.TemplateFileDraft as TmplFD
import qualified Generator.FileDraft.CopyFileDraft as CopyFD
import qualified Generator.FileDraft.TemplateFileDraft as TmplFD
import qualified Generator.FileDraft.TextFileDraft as TextFD
import Generator.FileDraft.Writeable
import Generator.Templates (TemplatesDir)
import StrongPath (Abs, File, Path, Rel)
-- | FileDraft unites different file draft types into a single type,
-- so that in the rest of the system they can be passed around as heterogeneous
-- collection when needed.
data FileDraft
= FileDraftTemplateFd TmplFD.TemplateFileDraft
| FileDraftCopyFd CopyFD.CopyFileDraft
| FileDraftTextFd TextFD.TextFileDraft
deriving (Show, Eq)
= FileDraftTemplateFd TmplFD.TemplateFileDraft
| FileDraftCopyFd CopyFD.CopyFileDraft
| FileDraftTextFd TextFD.TextFileDraft
deriving (Show, Eq)
instance Writeable FileDraft where
write dstDir (FileDraftTemplateFd draft) = write dstDir draft
write dstDir (FileDraftCopyFd draft) = write dstDir draft
write dstDir (FileDraftTextFd draft) = write dstDir draft
write dstDir (FileDraftTemplateFd draft) = write dstDir draft
write dstDir (FileDraftCopyFd draft) = write dstDir draft
write dstDir (FileDraftTextFd draft) = write dstDir draft
createTemplateFileDraft :: Path (Rel ProjectRootDir) File
-> Path (Rel TemplatesDir) File
-> Maybe Aeson.Value
-> FileDraft
createTemplateFileDraft ::
Path (Rel ProjectRootDir) File ->
Path (Rel TemplatesDir) File ->
Maybe Aeson.Value ->
FileDraft
createTemplateFileDraft dstPath tmplSrcPath tmplData =
FileDraftTemplateFd $ TmplFD.TemplateFileDraft { TmplFD._dstPath = dstPath
, TmplFD._srcPathInTmplDir = tmplSrcPath
, TmplFD._tmplData = tmplData
}
FileDraftTemplateFd $
TmplFD.TemplateFileDraft
{ TmplFD._dstPath = dstPath,
TmplFD._srcPathInTmplDir = tmplSrcPath,
TmplFD._tmplData = tmplData
}
createCopyFileDraft :: Path (Rel ProjectRootDir) File -> Path Abs File -> FileDraft
createCopyFileDraft dstPath srcPath =
FileDraftCopyFd $ CopyFD.CopyFileDraft
{ CopyFD._dstPath = dstPath
, CopyFD._srcPath = srcPath
, CopyFD._failIfSrcDoesNotExist = True
}
FileDraftCopyFd $
CopyFD.CopyFileDraft
{ CopyFD._dstPath = dstPath,
CopyFD._srcPath = srcPath,
CopyFD._failIfSrcDoesNotExist = True
}
createCopyFileDraftIfExists :: Path (Rel ProjectRootDir) File -> Path Abs File -> FileDraft
createCopyFileDraftIfExists dstPath srcPath =
FileDraftCopyFd $ CopyFD.CopyFileDraft
{ CopyFD._dstPath = dstPath
, CopyFD._srcPath = srcPath
, CopyFD._failIfSrcDoesNotExist = False
}
FileDraftCopyFd $
CopyFD.CopyFileDraft
{ CopyFD._dstPath = dstPath,
CopyFD._srcPath = srcPath,
CopyFD._failIfSrcDoesNotExist = False
}
createTextFileDraft :: Path (Rel ProjectRootDir) File -> Text -> FileDraft
createTextFileDraft dstPath content =
FileDraftTextFd $ TextFD.TextFileDraft { TextFD._dstPath = dstPath, TextFD._content = content}
FileDraftTextFd $ TextFD.TextFileDraft {TextFD._dstPath = dstPath, TextFD._content = content}

79
waspc/src/Generator/FileDraft/CopyFileDraft.hs
View File

@ -1,44 +1,49 @@
module Generator.FileDraft.CopyFileDraft
( CopyFileDraft(..)
) where
import Control.Monad (when)
import System.IO.Error (doesNotExistErrorType, mkIOError)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.Writeable
import Generator.FileDraft.WriteableMonad
import StrongPath (Abs, File, Path, Rel,
(</>))
import qualified StrongPath as SP
( CopyFileDraft (..),
)
where
import Control.Monad (when)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.Writeable
import Generator.FileDraft.WriteableMonad
import StrongPath
( Abs,
File,
Path,
Rel,
(</>),
)
import qualified StrongPath as SP
import System.IO.Error (doesNotExistErrorType, mkIOError)
-- | File draft based purely on another file, that is just copied.
data CopyFileDraft = CopyFileDraft
{ -- | Path where the file will be copied to.
_dstPath :: !(Path (Rel ProjectRootDir) File)
-- | Absolute path of source file to copy.
, _srcPath :: !(Path Abs File)
, _failIfSrcDoesNotExist :: Bool
}
deriving (Show, Eq)
{ -- | Path where the file will be copied to.
_dstPath :: !(Path (Rel ProjectRootDir) File),
-- | Absolute path of source file to copy.
_srcPath :: !(Path Abs File),
_failIfSrcDoesNotExist :: Bool
}
deriving (Show, Eq)
instance Writeable CopyFileDraft where
write absDstDirPath draft = do
srcFileExists <- doesFileExist srcFilePath
if srcFileExists
then do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
copyFile srcFilePath (SP.toFilePath absDraftDstPath)
else
when
(_failIfSrcDoesNotExist draft)
(throwIO $ mkIOError
doesNotExistErrorType
"Source file of CopyFileDraft does not exist."
Nothing
(Just srcFilePath)
)
where
srcFilePath = SP.toFilePath $ _srcPath draft
absDraftDstPath = absDstDirPath </> _dstPath draft
write absDstDirPath draft = do
srcFileExists <- doesFileExist srcFilePath
if srcFileExists
then do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
copyFile srcFilePath (SP.toFilePath absDraftDstPath)
else
when
(_failIfSrcDoesNotExist draft)
( throwIO $
mkIOError
doesNotExistErrorType
"Source file of CopyFileDraft does not exist."
Nothing
(Just srcFilePath)
)
where
srcFilePath = SP.toFilePath $ _srcPath draft
absDraftDstPath = absDstDirPath </> _dstPath draft

47
waspc/src/Generator/FileDraft/TemplateFileDraft.hs
View File

@ -1,34 +1,37 @@
module Generator.FileDraft.TemplateFileDraft
( TemplateFileDraft(..)
) where
( TemplateFileDraft (..),
)
where
import qualified Data.Aeson as Aeson
import StrongPath (Path, Abs, Rel, File, (</>))
import qualified StrongPath as SP
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.Writeable
import Generator.FileDraft.WriteableMonad
import Generator.Templates (TemplatesDir)
import StrongPath (Abs, File, Path, Rel, (</>))
import qualified StrongPath as SP
-- | File draft based on template file that gets combined with data.
data TemplateFileDraft = TemplateFileDraft
{ _dstPath :: !(Path (Rel ProjectRootDir) File) -- ^ Path where file will be generated.
, _srcPathInTmplDir :: !(Path (Rel TemplatesDir) File) -- ^ Path of template source file.
, _tmplData :: Maybe Aeson.Value -- ^ Data to be fed to the template while rendering it.
}
deriving (Show, Eq)
{ -- | Path where file will be generated.
_dstPath :: !(Path (Rel ProjectRootDir) File),
-- | Path of template source file.
_srcPathInTmplDir :: !(Path (Rel TemplatesDir) File),
-- | Data to be fed to the template while rendering it.
_tmplData :: Maybe Aeson.Value
}
deriving (Show, Eq)
instance Writeable TemplateFileDraft where
write absDstDirPath draft = do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
case _tmplData draft of
Nothing -> do
absDraftSrcPath <- getTemplateFileAbsPath (_srcPathInTmplDir draft)
copyFile (SP.toFilePath absDraftSrcPath) (SP.toFilePath absDraftDstPath)
Just tmplData -> do
content <- compileAndRenderTemplate (_srcPathInTmplDir draft) tmplData
writeFileFromText (SP.toFilePath absDraftDstPath) content
where
absDraftDstPath :: Path Abs File
absDraftDstPath = absDstDirPath </> (_dstPath draft)
write absDstDirPath draft = do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
case _tmplData draft of
Nothing -> do
absDraftSrcPath <- getTemplateFileAbsPath (_srcPathInTmplDir draft)
copyFile (SP.toFilePath absDraftSrcPath) (SP.toFilePath absDraftDstPath)
Just tmplData -> do
content <- compileAndRenderTemplate (_srcPathInTmplDir draft) tmplData
writeFileFromText (SP.toFilePath absDraftDstPath) content
where
absDraftDstPath :: Path Abs File
absDraftDstPath = absDstDirPath </> (_dstPath draft)

30
waspc/src/Generator/FileDraft/TextFileDraft.hs
View File

@ -1,26 +1,26 @@
module Generator.FileDraft.TextFileDraft
( TextFileDraft(..)
) where
( TextFileDraft (..),
)
where
import Data.Text (Text)
import StrongPath (Path, Rel, File, (</>))
import qualified StrongPath as SP
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.Writeable
import Generator.FileDraft.WriteableMonad
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
-- | File draft based on text, that is to be written to file when time comes.
data TextFileDraft = TextFileDraft
{ _dstPath :: !(Path (Rel ProjectRootDir) File) -- ^ Path where file will be generated.
, _content :: Text
}
deriving (Show, Eq)
{ -- | Path where file will be generated.
_dstPath :: !(Path (Rel ProjectRootDir) File),
_content :: Text
}
deriving (Show, Eq)
instance Writeable TextFileDraft where
write dstDir draft = do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
writeFileFromText (SP.toFilePath absDraftDstPath) (_content draft)
where
absDraftDstPath = dstDir </> (_dstPath draft)
write dstDir draft = do
createDirectoryIfMissing True (SP.toFilePath $ SP.parent absDraftDstPath)
writeFileFromText (SP.toFilePath absDraftDstPath) (_content draft)
where
absDraftDstPath = dstDir </> (_dstPath draft)

19
waspc/src/Generator/FileDraft/Writeable.hs
View File

@ -1,15 +1,16 @@
module Generator.FileDraft.Writeable
( Writeable(..)
) where
( Writeable (..),
)
where
import StrongPath (Path, Abs, Dir)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft.WriteableMonad
import StrongPath (Abs, Dir, Path)
class Writeable w where
-- | Write file somewhere in the provided project root directory.
write :: (WriteableMonad m)
=> Path Abs (Dir ProjectRootDir)
-> w
-> m ()
-- | Write file somewhere in the provided project root directory.
write ::
(WriteableMonad m) =>
Path Abs (Dir ProjectRootDir) ->
w ->
m ()

104
waspc/src/Generator/FileDraft/WriteableMonad.hs
View File

@ -1,67 +1,77 @@
module Generator.FileDraft.WriteableMonad
( WriteableMonad(..)
) where
( WriteableMonad (..),
)
where
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson as Aeson
import Data.Text (Text)
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson as Aeson
import Data.Text (Text)
import qualified Data.Text.IO
import qualified Generator.Templates as Templates
import StrongPath (Abs, Dir, File, Path, Rel)
import qualified System.Directory
import System.IO.Error (isDoesNotExistError)
import UnliftIO.Exception (Exception, catch)
import qualified UnliftIO.Exception as E
import qualified Generator.Templates as Templates
import StrongPath (Abs, Dir, File, Path, Rel)
import System.IO.Error (isDoesNotExistError)
import UnliftIO.Exception (Exception, catch)
import qualified UnliftIO.Exception as E
-- TODO: Should we use DI via data instead of typeclasses?
-- https://news.ycombinator.com/item?id=10392044
-- | Describes effects needed by File Drafts.
class (MonadIO m) => WriteableMonad m where
createDirectoryIfMissing
:: Bool -- ^ True if parents should also be created.
-> FilePath -- ^ Path to the directory to create.
-> m ()
createDirectoryIfMissing ::
-- | True if parents should also be created.
Bool ->
-- | Path to the directory to create.
FilePath ->
m ()
copyFile
:: FilePath -- ^ Src path.
-> FilePath -- ^ Dst path.
-> m ()
copyFile ::
-- | Src path.
FilePath ->
-- | Dst path.
FilePath ->
m ()
doesFileExist :: FilePath -> m Bool
doesFileExist :: FilePath -> m Bool
writeFileFromText :: FilePath -> Text -> m ()
writeFileFromText :: FilePath -> Text -> m ()
getTemplateFileAbsPath
:: Path (Rel Templates.TemplatesDir) File -- ^ Template file path.
-> m (Path Abs File)
getTemplateFileAbsPath ::
-- | Template file path.
Path (Rel Templates.TemplatesDir) File ->
m (Path Abs File)
getTemplatesDirAbsPath :: m (Path Abs (Dir Templates.TemplatesDir))
getTemplatesDirAbsPath :: m (Path Abs (Dir Templates.TemplatesDir))
compileAndRenderTemplate
:: Path (Rel Templates.TemplatesDir) File -- ^ Template file path.
-> Aeson.Value -- ^ JSON to be provided as template data.
-> m Text
compileAndRenderTemplate ::
-- | Template file path.
Path (Rel Templates.TemplatesDir) File ->
-- | JSON to be provided as template data.
Aeson.Value ->
m Text
throwIO :: (Exception e) => e -> m a
throwIO :: (Exception e) => e -> m a
instance WriteableMonad IO where
createDirectoryIfMissing = System.Directory.createDirectoryIfMissing
-- TODO(matija): we should rename this function to make it clear it won't throw an exception when
-- a file does not exist.
copyFile src dst = do
-- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed
-- when the filedraft was created but then got deleted before actual copying was invoked.
-- That would make this function crash, so we just ignore those errors.
System.Directory.copyFile src dst `catch` (\e -> if isDoesNotExistError e
then return ()
else throwIO e)
createDirectoryIfMissing = System.Directory.createDirectoryIfMissing
doesFileExist = System.Directory.doesFileExist
writeFileFromText = Data.Text.IO.writeFile
getTemplateFileAbsPath = Templates.getTemplateFileAbsPath
getTemplatesDirAbsPath = Templates.getTemplatesDirAbsPath
compileAndRenderTemplate = Templates.compileAndRenderTemplate
throwIO = E.throwIO
-- TODO(matija): we should rename this function to make it clear it won't throw an exception when
-- a file does not exist.
copyFile src dst = do
-- NOTE(matija): we had cases (e.g. tmp Vim files) where a file initially existed
-- when the filedraft was created but then got deleted before actual copying was invoked.
-- That would make this function crash, so we just ignore those errors.
System.Directory.copyFile src dst
`catch` ( \e ->
if isDoesNotExistError e
then return ()
else throwIO e
)
doesFileExist = System.Directory.doesFileExist
writeFileFromText = Data.Text.IO.writeFile
getTemplateFileAbsPath = Templates.getTemplateFileAbsPath
getTemplatesDirAbsPath = Templates.getTemplatesDirAbsPath
compileAndRenderTemplate = Templates.compileAndRenderTemplate
throwIO = E.throwIO

35
waspc/src/Generator/Job.hs
View File

@ -1,29 +1,30 @@
module Generator.Job
( Job
, JobMessage (..)
, JobMessageData (..)
, JobOutputType (..)
, JobType (..)
) where
import Control.Concurrent (Chan)
import Data.Text (Text)
import System.Exit (ExitCode)
( Job,
JobMessage (..),
JobMessageData (..),
JobOutputType (..),
JobType (..),
)
where
import Control.Concurrent (Chan)
import Data.Text (Text)
import System.Exit (ExitCode)
-- | Job is an IO action that communicates progress by writing messages to given channel
-- until it is done, when it returns exit code.
type Job = Chan JobMessage -> IO ExitCode
data JobMessage = JobMessage
{ _data :: JobMessageData
, _jobType :: JobType
}
deriving (Show)
{ _data :: JobMessageData,
_jobType :: JobType
}
deriving (Show)
data JobMessageData = JobOutput Text JobOutputType
| JobExit ExitCode
deriving (Show)
data JobMessageData
= JobOutput Text JobOutputType
| JobExit ExitCode
deriving (Show)
data JobOutputType = Stdout | Stderr deriving (Show, Eq)

86
waspc/src/Generator/Job/IO.hs
View File

@ -1,67 +1,67 @@
module Generator.Job.IO
( readJobMessagesAndPrintThemPrefixed
, printPrefixedJobMessage
, printJobMessage
) where
( readJobMessagesAndPrintThemPrefixed,
printPrefixedJobMessage,
printJobMessage,
)
where
import Control.Concurrent (Chan, readChan)
import qualified Data.Text as T
import qualified Data.Text.IO as T.IO
import System.Exit (ExitCode (..))
import System.IO (Handle, hFlush, stderr, stdout)
import qualified Generator.Job as J
import qualified Util.Terminal as Term
import Control.Concurrent (Chan, readChan)
import qualified Data.Text as T
import qualified Data.Text.IO as T.IO
import qualified Generator.Job as J
import System.Exit (ExitCode (..))
import System.IO (Handle, hFlush, stderr, stdout)
import qualified Util.Terminal as Term
readJobMessagesAndPrintThemPrefixed :: Chan J.JobMessage -> IO ()
readJobMessagesAndPrintThemPrefixed =
let go prevJobMsg chan = do
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg >> go (Just jobMsg) chan
J.JobExit {} -> return ()
in go Nothing
let go prevJobMsg chan = do
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg >> go (Just jobMsg) chan
J.JobExit {} -> return ()
in go Nothing
printPrefixedJobMessage :: Maybe J.JobMessage -> J.JobMessage -> IO ()
printPrefixedJobMessage maybePrevJobMessage jobMessage = do
let outHandle = getJobMessageOutHandle jobMessage
prefix = makeJobMessagePrefix jobMessage
content = getJobMessageContent jobMessage
let outHandle = getJobMessageOutHandle jobMessage
prefix = makeJobMessagePrefix jobMessage
content = getJobMessageContent jobMessage
let maybeAddPrefixAtStart =
((if (J._jobType <$> maybePrevJobMessage) /= Just (J._jobType jobMessage) then "\n" <> prefix else "") <>)
addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr
addPrefix = maybeAddPrefixAtStart . addPrefixAfterSubstr "\n" . addPrefixAfterSubstr "\r"
let maybeAddPrefixAtStart =
((if (J._jobType <$> maybePrevJobMessage) /= Just (J._jobType jobMessage) then "\n" <> prefix else "") <>)
addPrefixAfterSubstr substr = T.intercalate (substr <> prefix) . T.splitOn substr
addPrefix = maybeAddPrefixAtStart . addPrefixAfterSubstr "\n" . addPrefixAfterSubstr "\r"
T.IO.hPutStr outHandle $ addPrefix content
hFlush outHandle
T.IO.hPutStr outHandle $ addPrefix content
hFlush outHandle
printJobMessage :: J.JobMessage -> IO ()
printJobMessage jobMsg = do
let outHandle = getJobMessageOutHandle jobMsg
let message = getJobMessageContent jobMsg
T.IO.hPutStr outHandle message
hFlush outHandle
let outHandle = getJobMessageOutHandle jobMsg
let message = getJobMessageContent jobMsg
T.IO.hPutStr outHandle message
hFlush outHandle
makeJobMessagePrefix :: J.JobMessage -> T.Text
makeJobMessagePrefix jobMsg =
case J._jobType jobMsg of
J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server"
J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app"
J.Db -> T.pack $ Term.applyStyles [Term.White] "Db"
case J._jobType jobMsg of
J.Server -> T.pack $ Term.applyStyles [Term.Magenta] "Server"
J.WebApp -> T.pack $ Term.applyStyles [Term.Cyan] "Web app"
J.Db -> T.pack $ Term.applyStyles [Term.White] "Db"
<> (if getJobMessageOutHandle jobMsg == stderr then " (stderr)" else "")
<> ": "
getJobMessageOutHandle :: J.JobMessage -> Handle
getJobMessageOutHandle jobMsg = case J._data jobMsg of
J.JobOutput _ outputType ->
case outputType of
J.Stdout -> stdout
J.Stderr -> stderr
J.JobExit _ -> stdout
J.JobOutput _ outputType ->
case outputType of
J.Stdout -> stdout
J.Stderr -> stderr
J.JobExit _ -> stdout
getJobMessageContent :: J.JobMessage -> T.Text
getJobMessageContent jobMsg = case J._data jobMsg of
J.JobOutput output _ -> output
J.JobExit ExitSuccess -> "Job exited successfully."
J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode
J.JobOutput output _ -> output
J.JobExit ExitSuccess -> "Job exited successfully."
J.JobExit (ExitFailure exitCode) -> T.pack $ "Job failed with exit code " <> show exitCode

194
waspc/src/Generator/Job/Process.hs
View File

@ -1,28 +1,28 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Generator.Job.Process
( runProcessAsJob
, runNodeCommandAsJob
) where
( runProcessAsJob,
runNodeCommandAsJob,
)
where
import Control.Concurrent (writeChan)
import Control.Concurrent.Async (Concurrently (..))
import UnliftIO.Exception (bracket)
import Data.Conduit (runConduit, (.|))
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Process as CP
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import System.Exit (ExitCode (..))
import System.IO.Error (catchIOError, isDoesNotExistError)
import qualified System.Process as P
import Text.Read (readMaybe)
import qualified Text.Regex.TDFA as R
import qualified Generator.Common as C
import qualified Generator.Job as J
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
import Control.Concurrent (writeChan)
import Control.Concurrent.Async (Concurrently (..))
import Data.Conduit (runConduit, (.|))
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Process as CP
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Generator.Common as C
import qualified Generator.Job as J
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
import System.Exit (ExitCode (..))
import System.IO.Error (catchIOError, isDoesNotExistError)
import qualified System.Process as P
import Text.Read (readMaybe)
import qualified Text.Regex.TDFA as R
import UnliftIO.Exception (bracket)
-- TODO:
-- Switch from Data.Conduit.Process to Data.Conduit.Process.Typed.
@ -32,78 +32,118 @@ import qualified StrongPath as SP
-- Returns exit code of the process once it finishes, and also sends it to the channel.
-- Makes sure to terminate the process if exception occurs.
runProcessAsJob :: P.CreateProcess -> J.JobType -> J.Job
runProcessAsJob process jobType chan = bracket
runProcessAsJob process jobType chan =
bracket
(CP.streamingProcess process)
(\(_, _, _, sph) -> terminateStreamingProcess sph)
runStreamingProcessAsJob
where
runStreamingProcessAsJob (CP.Inherited, stdoutStream, stderrStream, processHandle) = do
let forwardStdoutToChan = runConduit $ stdoutStream .| CL.mapM_
(\bs -> writeChan chan $ J.JobMessage { J._data = J.JobOutput (decodeUtf8 bs) J.Stdout
, J._jobType = jobType })
let forwardStdoutToChan =
runConduit $
stdoutStream
.| CL.mapM_
( \bs ->
writeChan chan $
J.JobMessage
{ J._data = J.JobOutput (decodeUtf8 bs) J.Stdout,
J._jobType = jobType
}
)
let forwardStderrToChan = runConduit $ stderrStream .| CL.mapM_
(\bs -> writeChan chan $ J.JobMessage { J._data = J.JobOutput (decodeUtf8 bs) J.Stderr
, J._jobType = jobType })
let forwardStderrToChan =
runConduit $
stderrStream
.| CL.mapM_
( \bs ->
writeChan chan $
J.JobMessage
{ J._data = J.JobOutput (decodeUtf8 bs) J.Stderr,
J._jobType = jobType
}
)
exitCode <- runConcurrently $
Concurrently forwardStdoutToChan *>
Concurrently forwardStderrToChan *>
Concurrently (CP.waitForStreamingProcess processHandle)
exitCode <-
runConcurrently $
Concurrently forwardStdoutToChan
*> Concurrently forwardStderrToChan
*> Concurrently (CP.waitForStreamingProcess processHandle)
writeChan chan $ J.JobMessage { J._data = J.JobExit exitCode
, J._jobType = jobType }
writeChan chan $
J.JobMessage
{ J._data = J.JobExit exitCode,
J._jobType = jobType
}
return exitCode
terminateStreamingProcess streamingProcessHandle = do
let processHandle = CP.streamingProcessHandleRaw streamingProcessHandle
P.terminateProcess processHandle
return $ ExitFailure 1
let processHandle = CP.streamingProcessHandleRaw streamingProcessHandle
P.terminateProcess processHandle
return $ ExitFailure 1
runNodeCommandAsJob :: Path Abs (Dir a) -> String -> [String] -> J.JobType -> J.Job
runNodeCommandAsJob fromDir command args jobType chan = do
errorOrNodeVersion <- getNodeVersion
case errorOrNodeVersion of
Left errorMsg -> exitWithError (ExitFailure 1) (T.pack errorMsg)
Right nodeVersion -> if nodeVersion < C.nodeVersion
then exitWithError (ExitFailure 1)
(T.pack $ "Your node version is too low. " ++ waspNodeRequirementMessage)
else do
let process = (P.proc command args) { P.cwd = Just $ SP.toFilePath fromDir }
runProcessAsJob process jobType chan
errorOrNodeVersion <- getNodeVersion
case errorOrNodeVersion of
Left errorMsg -> exitWithError (ExitFailure 1) (T.pack errorMsg)
Right nodeVersion ->
if nodeVersion < C.nodeVersion
then
exitWithError
(ExitFailure 1)
(T.pack $ "Your node version is too low. " ++ waspNodeRequirementMessage)
else do
let process = (P.proc command args) {P.cwd = Just $ SP.toFilePath fromDir}
runProcessAsJob process jobType chan
where
exitWithError exitCode errorMsg = do
writeChan chan $ J.JobMessage
{ J._data = J.JobOutput errorMsg J.Stderr
, J._jobType = jobType }
writeChan chan $ J.JobMessage { J._data = J.JobExit exitCode
, J._jobType = jobType }
return exitCode
exitWithError exitCode errorMsg = do
writeChan chan $
J.JobMessage
{ J._data = J.JobOutput errorMsg J.Stderr,
J._jobType = jobType
}
writeChan chan $
J.JobMessage
{ J._data = J.JobExit exitCode,
J._jobType = jobType
}
return exitCode
getNodeVersion :: IO (Either String (Int, Int, Int))
getNodeVersion = do
(exitCode, stdout, stderr) <- P.readProcessWithExitCode "node" ["--version"] ""
`catchIOError` (\e -> if isDoesNotExistError e
then return (ExitFailure 1, "", "Command 'node' not found.")
else ioError e)
return $ case exitCode of
ExitFailure _ -> Left ("Running 'node --version' failed: " ++ stderr
++ " " ++ waspNodeRequirementMessage)
ExitSuccess -> case parseNodeVersion stdout of
Nothing -> Left ("Wasp failed to parse node version."
++ " This is most likely a bug in Wasp, please file an issue.")
Just version -> Right version
getNodeVersion :: IO (Either String (Int, Int, Int))
getNodeVersion = do
(exitCode, stdout, stderr) <-
P.readProcessWithExitCode "node" ["--version"] ""
`catchIOError` ( \e ->
if isDoesNotExistError e
then return (ExitFailure 1, "", "Command 'node' not found.")
else ioError e
)
return $ case exitCode of
ExitFailure _ ->
Left
( "Running 'node --version' failed: " ++ stderr
++ " "
++ waspNodeRequirementMessage
)
ExitSuccess -> case parseNodeVersion stdout of
Nothing ->
Left
( "Wasp failed to parse node version."
++ " This is most likely a bug in Wasp, please file an issue."
)
Just version -> Right version
parseNodeVersion :: String -> Maybe (Int, Int, Int)
parseNodeVersion nodeVersionStr =
case nodeVersionStr R.=~ ("v([^\\.]+).([^\\.]+).(.+)" :: String) of
((_ , _, _, [majorStr, minorStr, patchStr]) :: (String, String, String, [String])) -> do
major <- readMaybe majorStr
minor <- readMaybe minorStr
patch <- readMaybe patchStr
return (major, minor, patch)
_ -> Nothing
parseNodeVersion :: String -> Maybe (Int, Int, Int)
parseNodeVersion nodeVersionStr =
case nodeVersionStr R.=~ ("v([^\\.]+).([^\\.]+).(.+)" :: String) of
((_, _, _, [majorStr, minorStr, patchStr]) :: (String, String, String, [String])) -> do
major <- readMaybe majorStr
minor <- readMaybe minorStr
patch <- readMaybe patchStr
return (major, minor, patch)
_ -> Nothing
waspNodeRequirementMessage = "Wasp requires node >= " ++ C.nodeVersionAsText ++ " ."
++ " Check Wasp docs for more details: https://wasp-lang.dev/docs#requirements ."
waspNodeRequirementMessage =
"Wasp requires node >= " ++ C.nodeVersionAsText ++ " ."
++ " Check Wasp docs for more details: https://wasp-lang.dev/docs#requirements ."

59
waspc/src/Generator/PackageJsonGenerator.hs
View File

@ -1,14 +1,13 @@
module Generator.PackageJsonGenerator
( resolveNpmDeps
, toPackageJsonDependenciesString
) where
import Data.List (find, intercalate)
import Data.Maybe (fromJust, isJust)
( resolveNpmDeps,
toPackageJsonDependenciesString,
)
where
import Data.List (find, intercalate)
import Data.Maybe (fromJust, isJust)
import qualified NpmDependency as ND
type NpmDependenciesConflictError = String
-- | Takes wasp npm dependencies and user npm dependencies and figures out how to
@ -18,41 +17,49 @@ type NpmDependenciesConflictError = String
-- be different.
-- On error (Left), returns list of conflicting user deps together with the error message
-- explaining what the error is.
resolveNpmDeps
:: [ND.NpmDependency]
-> [ND.NpmDependency]
-> Either [(ND.NpmDependency, NpmDependenciesConflictError)]
([ND.NpmDependency], [ND.NpmDependency])
resolveNpmDeps waspDeps userDeps = if null conflictingUserDeps
resolveNpmDeps ::
[ND.NpmDependency] ->
[ND.NpmDependency] ->
Either
[(ND.NpmDependency, NpmDependenciesConflictError)]
([ND.NpmDependency], [ND.NpmDependency])
resolveNpmDeps waspDeps userDeps =
if null conflictingUserDeps
then Right (waspDeps, userDepsNotInWaspDeps)
else Left conflictingUserDeps
where
conflictingUserDeps :: [(ND.NpmDependency, NpmDependenciesConflictError)]
conflictingUserDeps = map (\(dep, err) -> (dep, fromJust err))
$ filter (isJust . snd)
$ map (\dep -> (dep, checkIfConflictingUserDep dep)) userDeps
conflictingUserDeps =
map (\(dep, err) -> (dep, fromJust err)) $
filter (isJust . snd) $
map (\dep -> (dep, checkIfConflictingUserDep dep)) userDeps
checkIfConflictingUserDep :: ND.NpmDependency -> Maybe NpmDependenciesConflictError
checkIfConflictingUserDep userDep =
let attachErrorMessage dep = "Error: Dependency conflict for user npm dependency ("
++ ND._name dep ++ ", " ++ ND._version dep ++ "): "
++ "Version must be set to the exactly the same version as"
++ " the one wasp is using: "
++ ND._version dep
in attachErrorMessage <$> find (areTwoDepsInConflict userDep) waspDeps
let attachErrorMessage dep =
"Error: Dependency conflict for user npm dependency ("
++ ND._name dep
++ ", "
++ ND._version dep
++ "): "
++ "Version must be set to the exactly the same version as"
++ " the one wasp is using: "
++ ND._version dep
in attachErrorMessage <$> find (areTwoDepsInConflict userDep) waspDeps
areTwoDepsInConflict :: ND.NpmDependency -> ND.NpmDependency -> Bool
areTwoDepsInConflict d1 d2 = ND._name d1 == ND._name d2
&& ND._version d1 /= ND._version d2
areTwoDepsInConflict d1 d2 =
ND._name d1 == ND._name d2
&& ND._version d1 /= ND._version d2
userDepsNotInWaspDeps :: [ND.NpmDependency]
userDepsNotInWaspDeps = filter (not . isDepWithNameInWaspDeps . ND._name) userDeps
isDepWithNameInWaspDeps :: String -> Bool
isDepWithNameInWaspDeps name = any ((name ==). ND._name) waspDeps
isDepWithNameInWaspDeps name = any ((name ==) . ND._name) waspDeps
toPackageJsonDependenciesString :: [ND.NpmDependency] -> String
toPackageJsonDependenciesString deps =
"\"dependencies\": {"
"\"dependencies\": {"
++ intercalate ",\n " (map (\dep -> "\"" ++ ND._name dep ++ "\": \"" ++ ND._version dep ++ "\"") deps)
++ "\n}"

258
waspc/src/Generator/ServerGenerator.hs
View File

@ -1,52 +1,58 @@
module Generator.ServerGenerator
( genServer
, preCleanup
, operationsRouteInRootRouter
) where
( genServer,
preCleanup,
operationsRouteInRootRouter,
)
where
import Data.Aeson (object, (.=))
import Data.List (intercalate)
import Data.Maybe (fromJust,
isJust)
import qualified Path as P
import StrongPath ((</>), Path, Rel, File, Abs, Dir)
import qualified StrongPath as SP
import System.Directory (removeFile)
import UnliftIO.Exception (catch, throwIO)
import System.IO.Error (isDoesNotExistError)
import Control.Monad (when)
import CompileOptions (CompileOptions)
import Generator.Common (nodeVersionAsText, ProjectRootDir)
import Generator.ExternalCodeGenerator (generateExternalCodeDir)
import Generator.FileDraft (FileDraft, createCopyFileDraft)
import Generator.PackageJsonGenerator (resolveNpmDeps,
toPackageJsonDependenciesString)
import Generator.ServerGenerator.AuthG (genAuth)
import Generator.ServerGenerator.Common (asServerFile,
asTmplFile)
import qualified Generator.ServerGenerator.Common as C
import Generator.ServerGenerator.ConfigG (genConfigFile)
import CompileOptions (CompileOptions)
import Control.Monad (when)
import Data.Aeson (object, (.=))
import Data.List (intercalate)
import Data.Maybe
( fromJust,
isJust,
)
import Generator.Common (ProjectRootDir, nodeVersionAsText)
import Generator.ExternalCodeGenerator (generateExternalCodeDir)
import Generator.FileDraft (FileDraft, createCopyFileDraft)
import Generator.PackageJsonGenerator
( resolveNpmDeps,
toPackageJsonDependenciesString,
)
import Generator.ServerGenerator.AuthG (genAuth)
import Generator.ServerGenerator.Common
( asServerFile,
asTmplFile,
)
import qualified Generator.ServerGenerator.Common as C
import Generator.ServerGenerator.ConfigG (genConfigFile)
import qualified Generator.ServerGenerator.ExternalCodeGenerator as ServerExternalCodeGenerator
import Generator.ServerGenerator.OperationsG (genOperations)
import Generator.ServerGenerator.OperationsRoutesG (genOperationsRoutes)
import qualified NpmDependency as ND
import Wasp (Wasp, getAuth)
import Generator.ServerGenerator.OperationsG (genOperations)
import Generator.ServerGenerator.OperationsRoutesG (genOperationsRoutes)
import qualified NpmDependency as ND
import qualified Path as P
import StrongPath (Abs, Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import System.Directory (removeFile)
import System.IO.Error (isDoesNotExistError)
import UnliftIO.Exception (catch, throwIO)
import Wasp (Wasp, getAuth)
import qualified Wasp
import qualified Wasp.Auth
import qualified Wasp.NpmDependencies as WND
import qualified Wasp.NpmDependencies as WND
genServer :: Wasp -> CompileOptions -> [FileDraft]
genServer wasp _ = concat
[ [genReadme wasp]
, [genPackageJson wasp waspNpmDeps]
, [genNpmrc wasp]
, [genNvmrc wasp]
, [genGitignore wasp]
, genSrcDir wasp
, generateExternalCodeDir ServerExternalCodeGenerator.generatorStrategy wasp
, genDotEnv wasp
genServer wasp _ =
concat
[ [genReadme wasp],
[genPackageJson wasp waspNpmDeps],
[genNpmrc wasp],
[genNvmrc wasp],
[genGitignore wasp],
genSrcDir wasp,
generateExternalCodeDir ServerExternalCodeGenerator.generatorStrategy wasp,
genDotEnv wasp
]
-- Cleanup to be performed before generating new server code.
@ -56,22 +62,22 @@ genServer wasp _ = concat
-- for progress of this.
preCleanup :: Wasp -> Path Abs (Dir ProjectRootDir) -> CompileOptions -> IO ()
preCleanup _ outDir _ = do
-- If .env gets removed but there is old .env file in generated project from previous attempts,
-- we need to make sure we remove it.
removeFile dotEnvAbsFilePath
`catch` \e -> when (not $ isDoesNotExistError e) $ throwIO e
-- If .env gets removed but there is old .env file in generated project from previous attempts,
-- we need to make sure we remove it.
removeFile dotEnvAbsFilePath
`catch` \e -> when (not $ isDoesNotExistError e) $ throwIO e
where
dotEnvAbsFilePath = SP.toFilePath $ outDir </> C.serverRootDirInProjectRootDir </> dotEnvInServerRootDir
dotEnvAbsFilePath = SP.toFilePath $ outDir </> C.serverRootDirInProjectRootDir </> dotEnvInServerRootDir
genDotEnv :: Wasp -> [FileDraft]
genDotEnv wasp =
case Wasp.getDotEnvFile wasp of
Just srcFilePath ->
[ createCopyFileDraft
(C.serverRootDirInProjectRootDir </> dotEnvInServerRootDir)
srcFilePath
]
Nothing -> []
case Wasp.getDotEnvFile wasp of
Just srcFilePath ->
[ createCopyFileDraft
(C.serverRootDirInProjectRootDir </> dotEnvInServerRootDir)
srcFilePath
]
Nothing -> []
dotEnvInServerRootDir :: Path (Rel C.ServerRootDir) File
dotEnvInServerRootDir = asServerFile [P.relfile|.env|]
@ -80,101 +86,115 @@ genReadme :: Wasp -> FileDraft
genReadme _ = C.copyTmplAsIs (asTmplFile [P.relfile|README.md|])
genPackageJson :: Wasp -> [ND.NpmDependency] -> FileDraft
genPackageJson wasp waspDeps = C.makeTemplateFD
genPackageJson wasp waspDeps =
C.makeTemplateFD
(asTmplFile [P.relfile|package.json|])
(asServerFile [P.relfile|package.json|])
(Just $ object
[ "wasp" .= wasp
, "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps)
, "nodeVersion" .= nodeVersionAsText
, "startProductionScript" .= concat
[ if not (null $ Wasp.getPSLEntities wasp) then "npm run db-migrate-prod && " else ""
, "NODE_ENV=production node ./src/server.js"
]
])
( Just $
object
[ "wasp" .= wasp,
"depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps),
"nodeVersion" .= nodeVersionAsText,
"startProductionScript"
.= concat
[ if not (null $ Wasp.getPSLEntities wasp) then "npm run db-migrate-prod && " else "",
"NODE_ENV=production node ./src/server.js"
]
]
)
where
(resolvedWaspDeps, resolvedUserDeps) =
case resolveNpmDeps waspDeps userDeps of
Right deps -> deps
Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors
case resolveNpmDeps waspDeps userDeps of
Right deps -> deps
Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors
userDeps :: [ND.NpmDependency]
userDeps = WND._dependencies $ Wasp.getNpmDependencies wasp
waspNpmDeps :: [ND.NpmDependency]
waspNpmDeps = ND.fromList
[ ("cookie-parser", "~1.4.4")
, ("cors", "^2.8.5")
, ("debug", "~2.6.9")
, ("express", "~4.16.1")
, ("morgan", "~1.9.1")
, ("@prisma/client", "2.21.0")
, ("jsonwebtoken", "^8.5.1")
, ("secure-password", "^4.0.0")
, ("dotenv", "8.2.0")
waspNpmDeps =
ND.fromList
[ ("cookie-parser", "~1.4.4"),
("cors", "^2.8.5"),
("debug", "~2.6.9"),
("express", "~4.16.1"),
("morgan", "~1.9.1"),
("@prisma/client", "2.21.0"),
("jsonwebtoken", "^8.5.1"),
("secure-password", "^4.0.0"),
("dotenv", "8.2.0")
]
-- TODO: Also extract devDependencies like we did dependencies (waspNpmDeps).
genNpmrc :: Wasp -> FileDraft
genNpmrc _ = C.makeTemplateFD (asTmplFile [P.relfile|npmrc|])
(asServerFile [P.relfile|.npmrc|])
Nothing
genNpmrc _ =
C.makeTemplateFD
(asTmplFile [P.relfile|npmrc|])
(asServerFile [P.relfile|.npmrc|])
Nothing
genNvmrc :: Wasp -> FileDraft
genNvmrc _ = C.makeTemplateFD (asTmplFile [P.relfile|nvmrc|])
(asServerFile [P.relfile|.nvmrc|])
(Just (object ["nodeVersion" .= ('v' : nodeVersionAsText)]))
genNvmrc _ =
C.makeTemplateFD
(asTmplFile [P.relfile|nvmrc|])
(asServerFile [P.relfile|.nvmrc|])
(Just (object ["nodeVersion" .= ('v' : nodeVersionAsText)]))
genGitignore :: Wasp -> FileDraft
genGitignore _ = C.makeTemplateFD (asTmplFile [P.relfile|gitignore|])
(asServerFile [P.relfile|.gitignore|])
Nothing
genGitignore _ =
C.makeTemplateFD
(asTmplFile [P.relfile|gitignore|])
(asServerFile [P.relfile|.gitignore|])
Nothing
genSrcDir :: Wasp -> [FileDraft]
genSrcDir wasp = concat
[ [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|app.js|]]
, [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|server.js|]]
, [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|utils.js|]]
, [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|core/HttpError.js|]]
, [genDbClient wasp]
, [genConfigFile wasp]
, genRoutesDir wasp
, genOperationsRoutes wasp
, genOperations wasp
, genAuth wasp
genSrcDir wasp =
concat
[ [C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|app.js|]],
[C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|server.js|]],
[C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|utils.js|]],
[C.copySrcTmplAsIs $ C.asTmplSrcFile [P.relfile|core/HttpError.js|]],
[genDbClient wasp],
[genConfigFile wasp],
genRoutesDir wasp,
genOperationsRoutes wasp,
genOperations wasp,
genAuth wasp
]
genDbClient :: Wasp -> FileDraft
genDbClient wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
maybeAuth = getAuth wasp
where
maybeAuth = getAuth wasp
dbClientRelToSrcP = [P.relfile|dbClient.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> dbClientRelToSrcP
dstFile = C.serverSrcDirInServerRootDir </> C.asServerSrcFile dbClientRelToSrcP
dbClientRelToSrcP = [P.relfile|dbClient.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> dbClientRelToSrcP
dstFile = C.serverSrcDirInServerRootDir </> C.asServerSrcFile dbClientRelToSrcP
tmplData =
if isJust maybeAuth
then object
[ "isAuthEnabled" .= True
, "userEntityUpper" .= Wasp.Auth._userEntity (fromJust maybeAuth)
]
else object []
tmplData =
if isJust maybeAuth
then
object
[ "isAuthEnabled" .= True,
"userEntityUpper" .= Wasp.Auth._userEntity (fromJust maybeAuth)
]
else object []
genRoutesDir :: Wasp -> [FileDraft]
genRoutesDir wasp =
-- TODO(martin): We will probably want to extract "routes" path here same as we did with "src", to avoid hardcoding,
-- but I did not bother with it yet since it is used only here for now.
[ C.makeTemplateFD
(asTmplFile [P.relfile|src/routes/index.js|])
(asServerFile [P.relfile|src/routes/index.js|])
(Just $ object
[ "operationsRouteInRootRouter" .= operationsRouteInRootRouter
, "isAuthEnabled" .= isJust (getAuth wasp)
-- TODO(martin): We will probably want to extract "routes" path here same as we did with "src", to avoid hardcoding,
-- but I did not bother with it yet since it is used only here for now.
[ C.makeTemplateFD
(asTmplFile [P.relfile|src/routes/index.js|])
(asServerFile [P.relfile|src/routes/index.js|])
( Just $
object
[ "operationsRouteInRootRouter" .= operationsRouteInRootRouter,
"isAuthEnabled" .= isJust (getAuth wasp)
]
)
]
)
]
operationsRouteInRootRouter :: String
operationsRouteInRootRouter = "operations"

97
waspc/src/Generator/ServerGenerator/AuthG.hs
View File

@ -1,41 +1,44 @@
module Generator.ServerGenerator.AuthG
( genAuth
) where
( genAuth,
)
where
import Data.Aeson (object, (.=))
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import qualified Path as P
import Data.Aeson (object, (.=))
import StrongPath ((</>))
import qualified Util
import Wasp (Wasp, getAuth)
import qualified Wasp.Auth
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import StrongPath ((</>))
genAuth :: Wasp -> [FileDraft]
genAuth wasp = case maybeAuth of
Just auth -> [ genCoreAuth auth
-- Auth routes
, genAuthRoutesIndex
, genLoginRoute auth
, genSignupRoute auth
, genMeRoute auth
]
Nothing -> []
where
maybeAuth = getAuth wasp
Just auth ->
[ genCoreAuth auth,
-- Auth routes
genAuthRoutesIndex,
genLoginRoute auth,
genSignupRoute auth,
genMeRoute auth
]
Nothing -> []
where
maybeAuth = getAuth wasp
-- | Generates core/auth file which contains auth middleware and createUser() function.
genCoreAuth :: Wasp.Auth.Auth -> FileDraft
genCoreAuth auth = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
coreAuthRelToSrc = [P.relfile|core/auth.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> coreAuthRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile coreAuthRelToSrc)
where
coreAuthRelToSrc = [P.relfile|core/auth.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> coreAuthRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile coreAuthRelToSrc)
tmplData = let userEntity = (Wasp.Auth._userEntity auth) in object
[ "userEntityUpper" .= userEntity
, "userEntityLower" .= Util.toLowerFirst userEntity
tmplData =
let userEntity = (Wasp.Auth._userEntity auth)
in object
[ "userEntityUpper" .= userEntity,
"userEntityLower" .= Util.toLowerFirst userEntity
]
genAuthRoutesIndex :: FileDraft
@ -43,34 +46,38 @@ genAuthRoutesIndex = C.copySrcTmplAsIs (C.asTmplSrcFile [P.relfile|routes/auth/i
genLoginRoute :: Wasp.Auth.Auth -> FileDraft
genLoginRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
loginRouteRelToSrc = [P.relfile|routes/auth/login.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> loginRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile loginRouteRelToSrc)
where
loginRouteRelToSrc = [P.relfile|routes/auth/login.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> loginRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile loginRouteRelToSrc)
tmplData = let userEntity = (Wasp.Auth._userEntity auth) in object
[ "userEntityUpper" .= userEntity
, "userEntityLower" .= Util.toLowerFirst userEntity
tmplData =
let userEntity = (Wasp.Auth._userEntity auth)
in object
[ "userEntityUpper" .= userEntity,
"userEntityLower" .= Util.toLowerFirst userEntity
]
genSignupRoute :: Wasp.Auth.Auth -> FileDraft
genSignupRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
signupRouteRelToSrc = [P.relfile|routes/auth/signup.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> signupRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile signupRouteRelToSrc)
where
signupRouteRelToSrc = [P.relfile|routes/auth/signup.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> signupRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile signupRouteRelToSrc)
tmplData = object
[ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth)
]
tmplData =
object
[ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth)
]
genMeRoute :: Wasp.Auth.Auth -> FileDraft
genMeRoute auth = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
meRouteRelToSrc = [P.relfile|routes/auth/me.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> meRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile meRouteRelToSrc)
where
meRouteRelToSrc = [P.relfile|routes/auth/me.js|]
tmplFile = C.asTmplFile $ [P.reldir|src|] P.</> meRouteRelToSrc
dstFile = C.serverSrcDirInServerRootDir </> (C.asServerSrcFile meRouteRelToSrc)
tmplData = object
[ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth)
]
tmplData =
object
[ "userEntityLower" .= Util.toLowerFirst (Wasp.Auth._userEntity auth)
]

85
waspc/src/Generator/ServerGenerator/Common.hs
View File

@ -1,38 +1,39 @@
module Generator.ServerGenerator.Common
( serverRootDirInProjectRootDir
, serverSrcDirInServerRootDir
, serverSrcDirInProjectRootDir
, copyTmplAsIs
, makeSimpleTemplateFD
, makeTemplateFD
, copySrcTmplAsIs
, srcDirInServerTemplatesDir
, asTmplFile
, asTmplSrcFile
, asServerFile
, asServerSrcFile
, ServerRootDir
, ServerSrcDir
, ServerTemplatesDir
, ServerTemplatesSrcDir
) where
( serverRootDirInProjectRootDir,
serverSrcDirInServerRootDir,
serverSrcDirInProjectRootDir,
copyTmplAsIs,
makeSimpleTemplateFD,
makeTemplateFD,
copySrcTmplAsIs,
srcDirInServerTemplatesDir,
asTmplFile,
asTmplSrcFile,
asServerFile,
asServerSrcFile,
ServerRootDir,
ServerSrcDir,
ServerTemplatesDir,
ServerTemplatesSrcDir,
)
where
import qualified Data.Aeson as Aeson
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import qualified Path as P
import StrongPath (Path, Rel, File, Dir, (</>))
import StrongPath (Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Common (ProjectRootDir)
import Generator.Templates (TemplatesDir)
data ServerRootDir
data ServerSrcDir
data ServerTemplatesDir
data ServerTemplatesSrcDir
data ServerSrcDir
data ServerTemplatesDir
data ServerTemplatesSrcDir
asTmplFile :: P.Path P.Rel P.File -> Path (Rel ServerTemplatesDir) File
asTmplFile = SP.fromPathRelFile
@ -59,32 +60,36 @@ serverSrcDirInServerRootDir = SP.fromPathRelDir [P.reldir|src|]
serverSrcDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir ServerSrcDir)
serverSrcDirInProjectRootDir = serverRootDirInProjectRootDir </> serverSrcDirInServerRootDir
-- * Templates
copyTmplAsIs :: Path (Rel ServerTemplatesDir) File -> FileDraft
copyTmplAsIs srcPath = makeTemplateFD srcPath dstPath Nothing
where dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File
where
dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File
makeSimpleTemplateFD :: Path (Rel ServerTemplatesDir) File -> Wasp -> FileDraft
makeSimpleTemplateFD srcPath wasp = makeTemplateFD srcPath dstPath (Just $ Aeson.toJSON wasp)
where dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File
where
dstPath = (SP.castRel srcPath) :: Path (Rel ServerRootDir) File
makeTemplateFD :: Path (Rel ServerTemplatesDir) File
-> Path (Rel ServerRootDir) File
-> Maybe Aeson.Value
-> FileDraft
makeTemplateFD ::
Path (Rel ServerTemplatesDir) File ->
Path (Rel ServerRootDir) File ->
Maybe Aeson.Value ->
FileDraft
makeTemplateFD relSrcPath relDstPath tmplData =
createTemplateFileDraft
(serverRootDirInProjectRootDir </> relDstPath)
(serverTemplatesDirInTemplatesDir </> relSrcPath)
tmplData
createTemplateFileDraft
(serverRootDirInProjectRootDir </> relDstPath)
(serverTemplatesDirInTemplatesDir </> relSrcPath)
tmplData
copySrcTmplAsIs :: Path (Rel ServerTemplatesSrcDir) File -> FileDraft
copySrcTmplAsIs pathInTemplatesSrcDir = makeTemplateFD srcPath dstPath Nothing
where srcPath = srcDirInServerTemplatesDir </> pathInTemplatesSrcDir
dstPath = serverSrcDirInServerRootDir
</> ((SP.castRel pathInTemplatesSrcDir) :: Path (Rel ServerSrcDir) File)
where
srcPath = srcDirInServerTemplatesDir </> pathInTemplatesSrcDir
dstPath =
serverSrcDirInServerRootDir
</> ((SP.castRel pathInTemplatesSrcDir) :: Path (Rel ServerSrcDir) File)
-- | Path where server app templates reside.
serverTemplatesDirInTemplatesDir :: Path (Rel TemplatesDir) (Dir ServerTemplatesDir)

26
waspc/src/Generator/ServerGenerator/ConfigG.hs
View File

@ -1,25 +1,25 @@
module Generator.ServerGenerator.ConfigG
( genConfigFile
, configFileInSrcDir
) where
( genConfigFile,
configFileInSrcDir,
)
where
import Data.Aeson (object, (.=))
import Data.Maybe (isJust)
import qualified Path as P
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
import Generator.FileDraft (FileDraft)
import Data.Aeson (object, (.=))
import Data.Maybe (isJust)
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import Wasp (Wasp, getAuth)
import qualified Path as P
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp, getAuth)
genConfigFile :: Wasp -> FileDraft
genConfigFile wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
tmplFile = C.srcDirInServerTemplatesDir </> SP.castRel configFileInSrcDir
dstFile = C.serverSrcDirInServerRootDir </> configFileInSrcDir
tmplData = object
tmplData =
object
[ "isAuthEnabled" .= isJust (getAuth wasp)
]

30
waspc/src/Generator/ServerGenerator/ExternalCodeGenerator.hs
View File

@ -1,24 +1,26 @@
module Generator.ServerGenerator.ExternalCodeGenerator
( extCodeDirInServerSrcDir
, generatorStrategy
) where
( extCodeDirInServerSrcDir,
generatorStrategy,
)
where
import qualified Path as P
import StrongPath (Path, Rel, Dir, (</>))
import qualified StrongPath as SP
import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy(..), GeneratedExternalCodeDir)
import qualified Generator.ServerGenerator.Common as C
import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy (..), GeneratedExternalCodeDir)
import Generator.ExternalCodeGenerator.Js (resolveJsFileWaspImportsForExtCodeDir)
import qualified Generator.ServerGenerator.Common as C
import qualified Path as P
import StrongPath (Dir, Path, Rel, (</>))
import qualified StrongPath as SP
-- | Relative path to directory where external code will be generated.
extCodeDirInServerSrcDir :: Path (Rel C.ServerSrcDir) (Dir GeneratedExternalCodeDir)
extCodeDirInServerSrcDir = SP.fromPathRelDir [P.reldir|ext-src|]
generatorStrategy :: ExternalCodeGeneratorStrategy
generatorStrategy = ExternalCodeGeneratorStrategy
{ _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInServerSrcDir)
, _extCodeDirInProjectRootDir = C.serverRootDirInProjectRootDir
</> C.serverSrcDirInServerRootDir
</> extCodeDirInServerSrcDir
generatorStrategy =
ExternalCodeGeneratorStrategy
{ _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInServerSrcDir),
_extCodeDirInProjectRootDir =
C.serverRootDirInProjectRootDir
</> C.serverSrcDirInServerRootDir
</> extCodeDirInServerSrcDir
}

100
waspc/src/Generator/ServerGenerator/OperationsG.hs
View File

@ -1,41 +1,43 @@
module Generator.ServerGenerator.OperationsG
( genOperations
, queryFileInSrcDir
, actionFileInSrcDir
, operationFileInSrcDir
) where
( genOperations,
queryFileInSrcDir,
actionFileInSrcDir,
operationFileInSrcDir,
)
where
import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import Data.Char (toLower)
import Data.Maybe (fromJust, fromMaybe)
import qualified Path as P
import Generator.FileDraft (FileDraft)
import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import Data.Char (toLower)
import Data.Maybe (fromJust, fromMaybe)
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Path as P
import StrongPath (File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Wasp
import qualified Wasp.Action
import qualified Wasp.JsImport
import qualified Wasp.Operation
import qualified Wasp.Query
genOperations :: Wasp -> [FileDraft]
genOperations wasp = concat
[ genQueries wasp
, genActions wasp
genOperations wasp =
concat
[ genQueries wasp,
genActions wasp
]
genQueries :: Wasp -> [FileDraft]
genQueries wasp = concat
genQueries wasp =
concat
[ map (genQuery wasp) (Wasp.getQueries wasp)
]
genActions :: Wasp -> [FileDraft]
genActions wasp = concat
genActions wasp =
concat
[ map (genAction wasp) (Wasp.getActions wasp)
]
@ -60,16 +62,18 @@ genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData)
tmplData = operationTmplData operation
queryFileInSrcDir :: Wasp.Query.Query -> Path (Rel C.ServerSrcDir) File
queryFileInSrcDir query = SP.fromPathRelFile $
queryFileInSrcDir query =
SP.fromPathRelFile $
[P.reldir|queries|]
-- TODO: fromJust here could fail if there is some problem with the name, we should handle this.
P.</> fromJust (P.parseRelFile $ Wasp.Query._name query ++ ".js")
-- TODO: fromJust here could fail if there is some problem with the name, we should handle this.
P.</> fromJust (P.parseRelFile $ Wasp.Query._name query ++ ".js")
actionFileInSrcDir :: Wasp.Action.Action -> Path (Rel C.ServerSrcDir) File
actionFileInSrcDir action = SP.fromPathRelFile $
actionFileInSrcDir action =
SP.fromPathRelFile $
[P.reldir|actions|]
-- TODO: fromJust here could fail if there is some problem with the name, we should handle this.
P.</> fromJust (P.parseRelFile $ Wasp.Action._name action ++ ".js")
-- TODO: fromJust here could fail if there is some problem with the name, we should handle this.
P.</> fromJust (P.parseRelFile $ Wasp.Action._name action ++ ".js")
operationFileInSrcDir :: Wasp.Operation.Operation -> Path (Rel C.ServerSrcDir) File
operationFileInSrcDir (Wasp.Operation.QueryOp query) = queryFileInSrcDir query
@ -80,35 +84,39 @@ relPosixPathFromOperationFileToExtSrcDir :: FilePath -- Posix
relPosixPathFromOperationFileToExtSrcDir = "../ext-src/"
operationTmplData :: Wasp.Operation.Operation -> Aeson.Value
operationTmplData operation = object
[ "jsFnImportStatement" .= importStmt
, "jsFnIdentifier" .= importIdentifier
, "entities" .= map buildEntityData (fromMaybe [] $ Wasp.Operation.getEntities operation)
operationTmplData operation =
object
[ "jsFnImportStatement" .= importStmt,
"jsFnIdentifier" .= importIdentifier,
"entities" .= map buildEntityData (fromMaybe [] $ Wasp.Operation.getEntities operation)
]
where
(importIdentifier, importStmt) =
getImportDetailsForOperationUserJsFn operation relPosixPathFromOperationFileToExtSrcDir
getImportDetailsForOperationUserJsFn operation relPosixPathFromOperationFileToExtSrcDir
buildEntityData :: String -> Aeson.Value
buildEntityData entityName = object [ "name" .= entityName
, "prismaIdentifier" .= (toLower (head entityName) : tail entityName)
]
buildEntityData entityName =
object
[ "name" .= entityName,
"prismaIdentifier" .= (toLower (head entityName) : tail entityName)
]
-- | Given Wasp operation, it returns details on how to import its user js function and use it,
-- "user js function" meaning the one provided by user directly to wasp, untouched.
getImportDetailsForOperationUserJsFn
:: Wasp.Operation.Operation
-> FilePath -- ^ Relative posix path from js file where you want to do importing to generated ext code dir.
-- | (importIdentifier, importStmt)
-- - importIdentifier -> Identifier via which you can access js function after you import it with importStmt.
-- - importStmt -> Import statement via which you should do the import.
-> (String, String)
getImportDetailsForOperationUserJsFn ::
Wasp.Operation.Operation ->
-- | Relative posix path from js file where you want to do importing to generated ext code dir.
-- | (importIdentifier, importStmt)
-- - importIdentifier -> Identifier via which you can access js function after you import it with importStmt.
-- - importStmt -> Import statement via which you should do the import.
FilePath ->
(String, String)
getImportDetailsForOperationUserJsFn operation relPosixPathToExtCodeDir = (importIdentifier, importStmt)
where
importStmt = "import " ++ importWhat ++ " from '" ++ importFrom ++ "'"
importFrom = relPosixPathToExtCodeDir ++ SP.toFilePath (Wasp.JsImport._from jsImport)
(importIdentifier, importWhat) =
case (Wasp.JsImport._defaultImport jsImport, Wasp.JsImport._namedImports jsImport) of
(Just defaultImport, []) -> (defaultImport, defaultImport)
(Nothing, [namedImport]) -> (namedImport, "{ " ++ namedImport ++ " }")
_ -> error "Expected either default import or single named import for operation (query/action) js function."
case (Wasp.JsImport._defaultImport jsImport, Wasp.JsImport._namedImports jsImport) of
(Just defaultImport, []) -> (defaultImport, defaultImport)
(Nothing, [namedImport]) -> (namedImport, "{ " ++ namedImport ++ " }")
_ -> error "Expected either default import or single named import for operation (query/action) js function."
jsImport = Wasp.Operation.getJsFn operation

104
waspc/src/Generator/ServerGenerator/OperationsRoutesG.hs
View File

@ -1,63 +1,74 @@
module Generator.ServerGenerator.OperationsRoutesG
( genOperationsRoutes
, operationRouteInOperationsRouter
) where
( genOperationsRoutes,
operationRouteInOperationsRouter,
)
where
import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import Data.Maybe (fromJust, isJust)
import qualified Path as P
import Data.Aeson (object, (.=))
import qualified Data.Aeson as Aeson
import Data.Maybe (fromJust, isJust)
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import Generator.ServerGenerator.OperationsG (operationFileInSrcDir)
import qualified Path as P
import StrongPath
( Dir,
File,
Path,
Rel,
(</>),
)
import qualified StrongPath as SP
import qualified System.FilePath.Posix as FPPosix
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator.Common as C
import Generator.ServerGenerator.OperationsG (operationFileInSrcDir)
import StrongPath (Dir, File, Path, Rel,
(</>))
import qualified StrongPath as SP
import qualified Util as U
import Wasp (Wasp, getAuth)
import qualified Util as U
import Wasp (Wasp, getAuth)
import qualified Wasp
import qualified Wasp.Action
import qualified Wasp.Auth
import qualified Wasp.Operation
import qualified Wasp.Query
import qualified Wasp.Auth
genOperationsRoutes :: Wasp -> [FileDraft]
genOperationsRoutes wasp = concat
[ map (genActionRoute wasp) (Wasp.getActions wasp)
, map (genQueryRoute wasp) (Wasp.getQueries wasp)
, [genOperationsRouter wasp]
genOperationsRoutes wasp =
concat
[ map (genActionRoute wasp) (Wasp.getActions wasp),
map (genQueryRoute wasp) (Wasp.getQueries wasp),
[genOperationsRouter wasp]
]
genActionRoute :: Wasp -> Wasp.Action.Action -> FileDraft
genActionRoute wasp action = genOperationRoute wasp op tmplFile
where op = Wasp.Operation.ActionOp action
tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_action.js|]
where
op = Wasp.Operation.ActionOp action
tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_action.js|]
genQueryRoute :: Wasp -> Wasp.Query.Query -> FileDraft
genQueryRoute wasp query = genOperationRoute wasp op tmplFile
where op = Wasp.Operation.QueryOp query
tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_query.js|]
where
op = Wasp.Operation.QueryOp query
tmplFile = C.asTmplFile [P.relfile|src/routes/operations/_query.js|]
genOperationRoute :: Wasp -> Wasp.Operation.Operation -> Path (Rel C.ServerTemplatesDir) File -> FileDraft
genOperationRoute wasp operation tmplFile = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
dstFile = operationsRoutesDirInServerRootDir </> operationRouteFileInOperationsRoutesDir operation
baseTmplData = object
[ "operationImportPath" .= operationImportPath
, "operationName" .= Wasp.Operation.getName operation
baseTmplData =
object
[ "operationImportPath" .= operationImportPath,
"operationName" .= Wasp.Operation.getName operation
]
tmplData = case (Wasp.getAuth wasp) of
Nothing -> baseTmplData
Just auth -> U.jsonSet ("userEntityLower")
(Aeson.toJSON (U.toLowerFirst $ Wasp.Auth._userEntity auth))
baseTmplData
Nothing -> baseTmplData
Just auth ->
U.jsonSet
("userEntityLower")
(Aeson.toJSON (U.toLowerFirst $ Wasp.Auth._userEntity auth))
baseTmplData
operationImportPath = relPosixPathFromOperationsRoutesDirToSrcDir
operationImportPath =
relPosixPathFromOperationsRoutesDirToSrcDir
FPPosix.</> SP.toFilePath (SP.relFileToPosix' $ operationFileInSrcDir operation)
data OperationsRoutesDir
@ -75,25 +86,26 @@ operationRouteFileInOperationsRoutesDir operation = fromJust $ SP.parseRelFile $
relPosixPathFromOperationsRoutesDirToSrcDir :: FilePath -- Posix
relPosixPathFromOperationsRoutesDirToSrcDir = "../.."
genOperationsRouter :: Wasp -> FileDraft
genOperationsRouter wasp = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
tmplFile = C.asTmplFile [P.relfile|src/routes/operations/index.js|]
dstFile = operationsRoutesDirInServerRootDir </> SP.fromPathRelFile [P.relfile|index.js|]
operations = map Wasp.Operation.ActionOp (Wasp.getActions wasp)
++ map Wasp.Operation.QueryOp (Wasp.getQueries wasp)
tmplData = object
[ "operationRoutes" .= map makeOperationRoute operations
, "isAuthEnabled" .= (isJust $ getAuth wasp)
operations =
map Wasp.Operation.ActionOp (Wasp.getActions wasp)
++ map Wasp.Operation.QueryOp (Wasp.getQueries wasp)
tmplData =
object
[ "operationRoutes" .= map makeOperationRoute operations,
"isAuthEnabled" .= (isJust $ getAuth wasp)
]
makeOperationRoute operation =
let operationName = Wasp.Operation.getName operation
in object
[ "importIdentifier" .= operationName
, "importPath" .= ("./" ++ SP.toFilePath (SP.relFileToPosix' $ operationRouteFileInOperationsRoutesDir operation))
, "routePath" .= ("/" ++ operationRouteInOperationsRouter operation)
]
let operationName = Wasp.Operation.getName operation
in object
[ "importIdentifier" .= operationName,
"importPath" .= ("./" ++ SP.toFilePath (SP.relFileToPosix' $ operationRouteFileInOperationsRoutesDir operation)),
"routePath" .= ("/" ++ operationRouteInOperationsRouter operation)
]
operationRouteInOperationsRouter :: Wasp.Operation.Operation -> String
operationRouteInOperationsRouter = U.camelToKebabCase . Wasp.Operation.getName

18
waspc/src/Generator/ServerGenerator/Setup.hs
View File

@ -1,15 +1,15 @@
module Generator.ServerGenerator.Setup
( setupServer
) where
( setupServer,
)
where
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import qualified Generator.ServerGenerator.Common as Common
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
setupServer :: Path Abs (Dir ProjectRootDir) -> J.Job
setupServer projectDir = do
let serverDir = projectDir </> Common.serverRootDirInProjectRootDir
runNodeCommandAsJob serverDir "npm" ["install"] J.Server
let serverDir = projectDir </> Common.serverRootDirInProjectRootDir
runNodeCommandAsJob serverDir "npm" ["install"] J.Server

18
waspc/src/Generator/ServerGenerator/Start.hs
View File

@ -1,15 +1,15 @@
module Generator.ServerGenerator.Start
( startServer
) where
( startServer,
)
where
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import qualified Generator.ServerGenerator.Common as Common
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
startServer :: Path Abs (Dir ProjectRootDir) -> J.Job
startServer projectDir = do
let serverDir = projectDir </> Common.serverRootDirInProjectRootDir
runNodeCommandAsJob serverDir "npm" ["start"] J.Server
let serverDir = projectDir </> Common.serverRootDirInProjectRootDir
runNodeCommandAsJob serverDir "npm" ["start"] J.Server

80
waspc/src/Generator/Setup.hs
View File

@ -1,47 +1,47 @@
module Generator.Setup
( setup
) where
import Control.Concurrent (Chan, newChan, readChan)
import Control.Concurrent.Async (concurrently)
import System.Exit (ExitCode (..))
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.IO (printPrefixedJobMessage)
import Generator.ServerGenerator.Setup (setupServer)
import Generator.WebAppGenerator.Setup (setupWebApp)
import StrongPath (Abs, Dir, Path)
( setup,
)
where
import Control.Concurrent (Chan, newChan, readChan)
import Control.Concurrent.Async (concurrently)
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.IO (printPrefixedJobMessage)
import Generator.ServerGenerator.Setup (setupServer)
import Generator.WebAppGenerator.Setup (setupWebApp)
import StrongPath (Abs, Dir, Path)
import System.Exit (ExitCode (..))
setup :: Path Abs (Dir ProjectRootDir) -> IO (Either String ())
setup projectDir = do
chan <- newChan
let runSetupJobs = concurrently (setupServer projectDir chan) (setupWebApp projectDir chan)
(_, result) <- concurrently (handleJobMessages chan) runSetupJobs
case result of
(ExitSuccess, ExitSuccess) -> return $ Right ()
exitCodes -> return $ Left $ setupFailedMessage exitCodes
chan <- newChan
let runSetupJobs = concurrently (setupServer projectDir chan) (setupWebApp projectDir chan)
(_, result) <- concurrently (handleJobMessages chan) runSetupJobs
case result of
(ExitSuccess, ExitSuccess) -> return $ Right ()
exitCodes -> return $ Left $ setupFailedMessage exitCodes
where
handleJobMessages = go Nothing (False, False)
where
go :: Maybe J.JobMessage -> (Bool, Bool) -> Chan J.JobMessage -> IO ()
go _ (True, True) _ = return ()
go prevJobMsg (isWebAppDone, isServerDone) chan = do
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} -> printPrefixedJobMessage prevJobMsg jobMsg
>> go (Just jobMsg) (isWebAppDone, isServerDone) chan
J.JobExit {} -> case J._jobType jobMsg of
J.WebApp -> go (Just jobMsg) (True, isServerDone) chan
J.Server -> go (Just jobMsg) (isWebAppDone, True) chan
J.Db -> error "This should never happen. No db job should be active."
handleJobMessages = go Nothing (False, False)
where
go :: Maybe J.JobMessage -> (Bool, Bool) -> Chan J.JobMessage -> IO ()
go _ (True, True) _ = return ()
go prevJobMsg (isWebAppDone, isServerDone) chan = do
jobMsg <- readChan chan
case J._data jobMsg of
J.JobOutput {} ->
printPrefixedJobMessage prevJobMsg jobMsg
>> go (Just jobMsg) (isWebAppDone, isServerDone) chan
J.JobExit {} -> case J._jobType jobMsg of
J.WebApp -> go (Just jobMsg) (True, isServerDone) chan
J.Server -> go (Just jobMsg) (isWebAppDone, True) chan
J.Db -> error "This should never happen. No db job should be active."
setupFailedMessage (serverExitCode, webAppExitCode) =
let serverErrorMessage = case serverExitCode of
ExitFailure code -> " Server setup failed with exit code " ++ show code ++ "."
_ -> ""
webAppErrorMessage = case webAppExitCode of
ExitFailure code -> " Web app setup failed with exit code " ++ show code ++ "."
_ -> ""
in "Setup failed!" ++ serverErrorMessage ++ webAppErrorMessage
setupFailedMessage (serverExitCode, webAppExitCode) =
let serverErrorMessage = case serverExitCode of
ExitFailure code -> " Server setup failed with exit code " ++ show code ++ "."
_ -> ""
webAppErrorMessage = case webAppExitCode of
ExitFailure code -> " Web app setup failed with exit code " ++ show code ++ "."
_ -> ""
in "Setup failed!" ++ serverErrorMessage ++ webAppErrorMessage

33
waspc/src/Generator/Start.hs
View File

@ -1,24 +1,23 @@
module Generator.Start
( start
) where
import Control.Concurrent (newChan)
import Control.Concurrent.Async (race, concurrently)
import Generator.Common (ProjectRootDir)
import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed)
import Generator.ServerGenerator.Start (startServer)
import Generator.WebAppGenerator.Start (startWebApp)
import StrongPath (Abs, Dir, Path)
( start,
)
where
import Control.Concurrent (newChan)
import Control.Concurrent.Async (concurrently, race)
import Generator.Common (ProjectRootDir)
import Generator.Job.IO (readJobMessagesAndPrintThemPrefixed)
import Generator.ServerGenerator.Start (startServer)
import Generator.WebAppGenerator.Start (startWebApp)
import StrongPath (Abs, Dir, Path)
-- | This is a blocking action, that will start the processes that run web app and server.
-- It will run as long as one of those processes does not fail.
start :: Path Abs (Dir ProjectRootDir) -> IO (Either String ())
start projectDir = do
chan <- newChan
let runStartJobs = race (startServer projectDir chan) (startWebApp projectDir chan)
(_, serverOrWebExitCode) <- concurrently (readJobMessagesAndPrintThemPrefixed chan) runStartJobs
case serverOrWebExitCode of
Left serverExitCode -> return $ Left $ "Server failed with exit code " ++ show serverExitCode ++ "."
Right webAppExitCode -> return $ Left $ "Web app failed with exit code " ++ show webAppExitCode ++ "."
chan <- newChan
let runStartJobs = race (startServer projectDir chan) (startWebApp projectDir chan)
(_, serverOrWebExitCode) <- concurrently (readJobMessagesAndPrintThemPrefixed chan) runStartJobs
case serverOrWebExitCode of
Left serverExitCode -> return $ Left $ "Server failed with exit code " ++ show serverExitCode ++ "."
Right webAppExitCode -> return $ Left $ "Web app failed with exit code " ++ show webAppExitCode ++ "."

86
waspc/src/Generator/Templates.hs
View File

@ -1,21 +1,20 @@
module Generator.Templates
( getTemplatesDirAbsPath
, getTemplateFileAbsPath
, compileAndRenderTemplate
, TemplatesDir
) where
import qualified Text.Mustache as Mustache
import Text.Mustache.Render (SubstitutionError(..))
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import Text.Printf (printf)
import qualified Path as P
( getTemplatesDirAbsPath,
getTemplateFileAbsPath,
compileAndRenderTemplate,
TemplatesDir,
)
where
import qualified Data
import StrongPath (Path, File, Dir, Abs, Rel, (</>))
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import qualified Path as P
import StrongPath (Abs, Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import qualified Text.Mustache as Mustache
import Text.Mustache.Render (SubstitutionError (..))
import Text.Printf (printf)
-- TODO: Write tests for this file! But first we need to decouple logic from IO
-- so that we can mock it.
@ -34,44 +33,49 @@ getTemplateFileAbsPath relTmplFilePath = (</> relTmplFilePath) <$> getTemplatesD
templatesDirPathInDataDir :: Path (Rel Data.DataDir) (Dir TemplatesDir)
templatesDirPathInDataDir = SP.fromPathRelDir [P.reldir|Generator/templates|]
compileAndRenderTemplate
:: Path (Rel TemplatesDir) File -- ^ Path to the template file.
-> Aeson.Value -- ^ JSON to be provided as template data.
-> IO Text
compileAndRenderTemplate ::
-- | Path to the template file.
Path (Rel TemplatesDir) File ->
-- | JSON to be provided as template data.
Aeson.Value ->
IO Text
compileAndRenderTemplate relTmplPath tmplData = do
mustacheTemplate <- compileMustacheTemplate relTmplPath
renderMustacheTemplate mustacheTemplate tmplData
mustacheTemplate <- compileMustacheTemplate relTmplPath
renderMustacheTemplate mustacheTemplate tmplData
compileMustacheTemplate
:: Path (Rel TemplatesDir) File -- ^ Path to the template file.
-> IO Mustache.Template
compileMustacheTemplate ::
-- | Path to the template file.
Path (Rel TemplatesDir) File ->
IO Mustache.Template
compileMustacheTemplate relTmplPath = do
templatesDirAbsPath <- getTemplatesDirAbsPath
absTmplPath <- getTemplateFileAbsPath relTmplPath
eitherTemplate <- Mustache.automaticCompile [SP.toFilePath templatesDirAbsPath]
(SP.toFilePath absTmplPath)
return $ either raiseCompileError id eitherTemplate
templatesDirAbsPath <- getTemplatesDirAbsPath
absTmplPath <- getTemplateFileAbsPath relTmplPath
eitherTemplate <-
Mustache.automaticCompile
[SP.toFilePath templatesDirAbsPath]
(SP.toFilePath absTmplPath)
return $ either raiseCompileError id eitherTemplate
where
raiseCompileError err = error $ -- TODO: Handle these errors better?
raiseCompileError err =
error $ -- TODO: Handle these errors better?
printf "Compilation of template %s failed. %s" (show relTmplPath) (show err)
areAllErrorsSectionDataNotFound :: [SubstitutionError] -> Bool
areAllErrorsSectionDataNotFound = all isSectionDataNotFoundError
where
isSectionDataNotFoundError e = case e of
SectionTargetNotFound _ -> True
_ -> False
SectionTargetNotFound _ -> True
_ -> False
renderMustacheTemplate :: Mustache.Template -> Aeson.Value -> IO Text
renderMustacheTemplate mustacheTemplate templateData = do
let mustacheTemplateData = Mustache.toMustache templateData
let (errors, fileText) =
Mustache.checkedSubstituteValue mustacheTemplate mustacheTemplateData
let mustacheTemplateData = Mustache.toMustache templateData
let (errors, fileText) =
Mustache.checkedSubstituteValue mustacheTemplate mustacheTemplateData
-- NOTE(matija): Mustache reports errors when object does
-- not have a property specified in the template, which we use to implement
-- conditionals. This is why we ignore these errors.
if null errors || areAllErrorsSectionDataNotFound errors
then return fileText
else error $ "Unexpected errors occured while rendering template: " ++ show errors
-- NOTE(matija): Mustache reports errors when object does
-- not have a property specified in the template, which we use to implement
-- conditionals. This is why we ignore these errors.
if null errors || areAllErrorsSectionDataNotFound errors
then return fileText
else error $ "Unexpected errors occured while rendering template: " ++ show errors

192
waspc/src/Generator/WebAppGenerator.hs
View File

@ -1,103 +1,123 @@
module Generator.WebAppGenerator
( generateWebApp
) where
( generateWebApp,
)
where
import Data.Aeson (ToJSON (..),
object, (.=))
import Data.List (intercalate)
import qualified Path as P
import CompileOptions (CompileOptions)
import Generator.ExternalCodeGenerator (generateExternalCodeDir)
import Generator.FileDraft
import Generator.PackageJsonGenerator (resolveNpmDeps,
toPackageJsonDependenciesString)
import qualified Generator.WebAppGenerator.AuthG as AuthG
import Generator.WebAppGenerator.Common (asTmplFile,
asWebAppFile,
asWebAppSrcFile)
import qualified Generator.WebAppGenerator.Common as C
import CompileOptions (CompileOptions)
import Data.Aeson
( ToJSON (..),
object,
(.=),
)
import Data.List (intercalate)
import Generator.ExternalCodeGenerator (generateExternalCodeDir)
import Generator.FileDraft
import Generator.PackageJsonGenerator
( resolveNpmDeps,
toPackageJsonDependenciesString,
)
import qualified Generator.WebAppGenerator.AuthG as AuthG
import Generator.WebAppGenerator.Common
( asTmplFile,
asWebAppFile,
asWebAppSrcFile,
)
import qualified Generator.WebAppGenerator.Common as C
import qualified Generator.WebAppGenerator.ExternalCodeGenerator as WebAppExternalCodeGenerator
import Generator.WebAppGenerator.OperationsGenerator (genOperations)
import qualified Generator.WebAppGenerator.RouterGenerator as RouterGenerator
import qualified NpmDependency as ND
import StrongPath (Dir, Path,
Rel, (</>))
import Generator.WebAppGenerator.OperationsGenerator (genOperations)
import qualified Generator.WebAppGenerator.RouterGenerator as RouterGenerator
import qualified NpmDependency as ND
import qualified Path as P
import StrongPath
( Dir,
Path,
Rel,
(</>),
)
import qualified StrongPath as SP
import Wasp
import Wasp
import qualified Wasp.App
import qualified Wasp.NpmDependencies as WND
import qualified Wasp.NpmDependencies as WND
generateWebApp :: Wasp -> CompileOptions -> [FileDraft]
generateWebApp wasp _ = concat
[ [generateReadme wasp]
, [genPackageJson wasp waspNpmDeps]
, [generateGitignore wasp]
, generatePublicDir wasp
, generateSrcDir wasp
, generateExternalCodeDir WebAppExternalCodeGenerator.generatorStrategy wasp
, [C.makeSimpleTemplateFD (asTmplFile [P.relfile|netlify.toml|]) wasp]
generateWebApp wasp _ =
concat
[ [generateReadme wasp],
[genPackageJson wasp waspNpmDeps],
[generateGitignore wasp],
generatePublicDir wasp,
generateSrcDir wasp,
generateExternalCodeDir WebAppExternalCodeGenerator.generatorStrategy wasp,
[C.makeSimpleTemplateFD (asTmplFile [P.relfile|netlify.toml|]) wasp]
]
generateReadme :: Wasp -> FileDraft
generateReadme wasp = C.makeSimpleTemplateFD (asTmplFile [P.relfile|README.md|]) wasp
genPackageJson :: Wasp -> [ND.NpmDependency] -> FileDraft
genPackageJson wasp waspDeps = C.makeTemplateFD
genPackageJson wasp waspDeps =
C.makeTemplateFD
(C.asTmplFile [P.relfile|package.json|])
(C.asWebAppFile [P.relfile|package.json|])
(Just $ object
[ "wasp" .= wasp
, "depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps)
])
( Just $
object
[ "wasp" .= wasp,
"depsChunk" .= toPackageJsonDependenciesString (resolvedWaspDeps ++ resolvedUserDeps)
]
)
where
(resolvedWaspDeps, resolvedUserDeps) =
case resolveNpmDeps waspDeps userDeps of
Right deps -> deps
Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors
case resolveNpmDeps waspDeps userDeps of
Right deps -> deps
Left depsAndErrors -> error $ intercalate " ; " $ map snd depsAndErrors
userDeps :: [ND.NpmDependency]
userDeps = WND._dependencies $ Wasp.getNpmDependencies wasp
waspNpmDeps :: [ND.NpmDependency]
waspNpmDeps = ND.fromList
[ ("axios", "^0.21.1")
, ("lodash", "^4.17.15")
, ("react", "^16.12.0")
, ("react-dom", "^16.12.0")
, ("react-query", "^2.14.1")
, ("react-router-dom", "^5.1.2")
, ("react-scripts", "4.0.3")
, ("uuid", "^3.4.0")
waspNpmDeps =
ND.fromList
[ ("axios", "^0.21.1"),
("lodash", "^4.17.15"),
("react", "^16.12.0"),
("react-dom", "^16.12.0"),
("react-query", "^2.14.1"),
("react-router-dom", "^5.1.2"),
("react-scripts", "4.0.3"),
("uuid", "^3.4.0")
]
-- TODO: Also extract devDependencies like we did dependencies (waspNpmDeps).
generateGitignore :: Wasp -> FileDraft
generateGitignore wasp = C.makeTemplateFD (asTmplFile [P.relfile|gitignore|])
(asWebAppFile [P.relfile|.gitignore|])
(Just $ toJSON wasp)
generateGitignore wasp =
C.makeTemplateFD
(asTmplFile [P.relfile|gitignore|])
(asWebAppFile [P.relfile|.gitignore|])
(Just $ toJSON wasp)
generatePublicDir :: Wasp -> [FileDraft]
generatePublicDir wasp =
C.copyTmplAsIs (asTmplFile [P.relfile|public/favicon.ico|])
: generatePublicIndexHtml wasp
: map (\path -> C.makeSimpleTemplateFD (asTmplFile $ [P.reldir|public|] P.</> path) wasp)
[ [P.relfile|manifest.json|]
]
C.copyTmplAsIs (asTmplFile [P.relfile|public/favicon.ico|]) :
generatePublicIndexHtml wasp :
map
(\path -> C.makeSimpleTemplateFD (asTmplFile $ [P.reldir|public|] P.</> path) wasp)
[ [P.relfile|manifest.json|]
]
generatePublicIndexHtml :: Wasp -> FileDraft
generatePublicIndexHtml wasp = C.makeTemplateFD
(asTmplFile $ [P.relfile|public/index.html|])
generatePublicIndexHtml wasp =
C.makeTemplateFD
(asTmplFile $ [P.relfile|public/index.html|])
targetPath
(Just templateData)
where
targetPath = SP.fromPathRelFile [P.relfile|public/index.html|]
templateData = object
[ "title" .= (Wasp.App.appTitle $ getApp wasp)
, "head" .= (maybe "" (intercalate "\n") (Wasp.App.appHead $ getApp wasp))
]
where
targetPath = SP.fromPathRelFile [P.relfile|public/index.html|]
templateData =
object
[ "title" .= (Wasp.App.appTitle $ getApp wasp),
"head" .= (maybe "" (intercalate "\n") (Wasp.App.appHead $ getApp wasp))
]
-- * Src dir
@ -108,28 +128,34 @@ srcDir = C.webAppSrcDirInWebAppRootDir
-- although they are not used anywhere outside.
-- We could further "templatize" this file so only what is needed is generated.
--
-- | Generates api.js file which contains token management and configured api (e.g. axios) instance.
genApi :: FileDraft
genApi = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/api.js|])
generateSrcDir :: Wasp -> [FileDraft]
generateSrcDir wasp
= generateLogo
: RouterGenerator.generateRouter wasp
: genApi
: map makeSimpleSrcTemplateFD
[ [P.relfile|index.js|]
, [P.relfile|index.css|]
, [P.relfile|serviceWorker.js|]
, [P.relfile|config.js|]
, [P.relfile|queryCache.js|]
]
generateSrcDir wasp =
generateLogo :
RouterGenerator.generateRouter wasp :
genApi :
map
makeSimpleSrcTemplateFD
[ [P.relfile|index.js|],
[P.relfile|index.css|],
[P.relfile|serviceWorker.js|],
[P.relfile|config.js|],
[P.relfile|queryCache.js|]
]
++ genOperations wasp
++ AuthG.genAuth wasp
where
generateLogo = C.makeTemplateFD (asTmplFile [P.relfile|src/logo.png|])
(srcDir </> asWebAppSrcFile [P.relfile|logo.png|])
Nothing
makeSimpleSrcTemplateFD path = C.makeTemplateFD (asTmplFile $ [P.reldir|src|] P.</> path)
(srcDir </> asWebAppSrcFile path)
(Just $ toJSON wasp)
generateLogo =
C.makeTemplateFD
(asTmplFile [P.relfile|src/logo.png|])
(srcDir </> asWebAppSrcFile [P.relfile|logo.png|])
Nothing
makeSimpleSrcTemplateFD path =
C.makeTemplateFD
(asTmplFile $ [P.reldir|src|] P.</> path)
(srcDir </> asWebAppSrcFile path)
(Just $ toJSON wasp)

48
waspc/src/Generator/WebAppGenerator/AuthG.hs
View File

@ -1,28 +1,29 @@
module Generator.WebAppGenerator.AuthG
( genAuth
) where
( genAuth,
)
where
import Data.Aeson (object, (.=))
import Generator.FileDraft (FileDraft)
import Generator.WebAppGenerator.Common as C
import qualified Path as P
import StrongPath ((</>))
import Wasp (Wasp, getAuth)
import qualified Wasp.Auth
import Generator.FileDraft (FileDraft)
import Generator.WebAppGenerator.Common as C
genAuth :: Wasp -> [FileDraft]
genAuth wasp = case maybeAuth of
Just auth -> [ genSignup
, genLogin
, genLogout
, genUseAuth
, genCreateAuthRequiredPage auth
]
++ genAuthForms
Nothing -> []
where
maybeAuth = getAuth wasp
Just auth ->
[ genSignup,
genLogin,
genLogout,
genUseAuth,
genCreateAuthRequiredPage auth
]
++ genAuthForms
Nothing -> []
where
maybeAuth = getAuth wasp
-- | Generates file with signup function to be used by Wasp developer.
genSignup :: FileDraft
@ -38,14 +39,15 @@ genLogout = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/logout.js|])
-- | Generates HOC that handles auth for the given page.
genCreateAuthRequiredPage :: Wasp.Auth.Auth -> FileDraft
genCreateAuthRequiredPage auth = C.makeTemplateFD
genCreateAuthRequiredPage auth =
C.makeTemplateFD
(asTmplFile $ [P.reldir|src|] P.</> authReqPagePath)
targetPath
(Just templateData)
where
authReqPagePath = [P.relfile|auth/pages/createAuthRequiredPage.js|]
targetPath = C.webAppSrcDirInWebAppRootDir </> (asWebAppSrcFile authReqPagePath)
templateData = object [ "onAuthFailedRedirectTo" .= (Wasp.Auth._onAuthFailedRedirectTo auth) ]
where
authReqPagePath = [P.relfile|auth/pages/createAuthRequiredPage.js|]
targetPath = C.webAppSrcDirInWebAppRootDir </> (asWebAppSrcFile authReqPagePath)
templateData = object ["onAuthFailedRedirectTo" .= (Wasp.Auth._onAuthFailedRedirectTo auth)]
-- | Generates React hook that Wasp developer can use in a component to get
-- access to the currently logged in user (and check whether user is logged in
@ -55,9 +57,9 @@ genUseAuth = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/useAuth.js|])
genAuthForms :: [FileDraft]
genAuthForms =
[ genLoginForm
, genSignupForm
]
[ genLoginForm,
genSignupForm
]
genLoginForm :: FileDraft
genLoginForm = C.copyTmplAsIs (C.asTmplFile [P.relfile|src/auth/forms/Login.js|])

64
waspc/src/Generator/WebAppGenerator/Common.hs
View File

@ -1,34 +1,34 @@
module Generator.WebAppGenerator.Common
( webAppRootDirInProjectRootDir
, webAppSrcDirInWebAppRootDir
, copyTmplAsIs
, makeSimpleTemplateFD
, makeTemplateFD
, webAppSrcDirInProjectRootDir
, webAppTemplatesDirInTemplatesDir
, asTmplFile
, asWebAppFile
, asWebAppSrcFile
, WebAppRootDir
, WebAppSrcDir
, WebAppTemplatesDir
) where
( webAppRootDirInProjectRootDir,
webAppSrcDirInWebAppRootDir,
copyTmplAsIs,
makeSimpleTemplateFD,
makeTemplateFD,
webAppSrcDirInProjectRootDir,
webAppTemplatesDirInTemplatesDir,
asTmplFile,
asWebAppFile,
asWebAppSrcFile,
WebAppRootDir,
WebAppSrcDir,
WebAppTemplatesDir,
)
where
import qualified Data.Aeson as Aeson
import qualified Path as P
import StrongPath (Path, Rel, Dir, File, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import Generator.Common (ProjectRootDir)
import Generator.FileDraft (FileDraft, createTemplateFileDraft)
import Generator.Templates (TemplatesDir)
import qualified Path as P
import StrongPath (Dir, File, Path, Rel, (</>))
import qualified StrongPath as SP
import Wasp (Wasp)
data WebAppRootDir
data WebAppSrcDir
data WebAppTemplatesDir
data WebAppSrcDir
data WebAppTemplatesDir
asTmplFile :: P.Path P.Rel P.File -> Path (Rel WebAppTemplatesDir) File
asTmplFile = SP.fromPathRelFile
@ -39,7 +39,6 @@ asWebAppFile = SP.fromPathRelFile
asWebAppSrcFile :: P.Path P.Rel P.File -> Path (Rel WebAppSrcDir) File
asWebAppSrcFile = SP.fromPathRelFile
-- * Paths
-- | Path where web app root dir is generated, relative to the root directory of the whole generated project.
@ -53,7 +52,6 @@ webAppSrcDirInWebAppRootDir = SP.fromPathRelDir [P.reldir|src|]
webAppSrcDirInProjectRootDir :: Path (Rel ProjectRootDir) (Dir WebAppSrcDir)
webAppSrcDirInProjectRootDir = webAppRootDirInProjectRootDir </> webAppSrcDirInWebAppRootDir
-- * Templates
-- | Path in templates directory where web app templates reside.
@ -66,13 +64,13 @@ copyTmplAsIs path = makeTemplateFD path (SP.castRel path) Nothing
makeSimpleTemplateFD :: Path (Rel WebAppTemplatesDir) File -> Wasp -> FileDraft
makeSimpleTemplateFD path wasp = makeTemplateFD path (SP.castRel path) (Just $ Aeson.toJSON wasp)
makeTemplateFD
:: Path (Rel WebAppTemplatesDir) File
-> Path (Rel WebAppRootDir) File
-> Maybe Aeson.Value
-> FileDraft
makeTemplateFD ::
Path (Rel WebAppTemplatesDir) File ->
Path (Rel WebAppRootDir) File ->
Maybe Aeson.Value ->
FileDraft
makeTemplateFD srcPathInWebAppTemplatesDir dstPathInWebAppRootDir tmplData =
createTemplateFileDraft
(webAppRootDirInProjectRootDir </> dstPathInWebAppRootDir)
(webAppTemplatesDirInTemplatesDir </> srcPathInWebAppTemplatesDir)
tmplData
createTemplateFileDraft
(webAppRootDirInProjectRootDir </> dstPathInWebAppRootDir)
(webAppTemplatesDirInTemplatesDir </> srcPathInWebAppTemplatesDir)
tmplData

30
waspc/src/Generator/WebAppGenerator/ExternalCodeGenerator.hs
View File

@ -1,15 +1,15 @@
module Generator.WebAppGenerator.ExternalCodeGenerator
( extCodeDirInWebAppSrcDir
, generatorStrategy
) where
( extCodeDirInWebAppSrcDir,
generatorStrategy,
)
where
import qualified Path as P
import StrongPath (Path, Rel, Dir, (</>))
import qualified StrongPath as SP
import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy(..), GeneratedExternalCodeDir)
import qualified Generator.WebAppGenerator.Common as C
import Generator.ExternalCodeGenerator.Common (ExternalCodeGeneratorStrategy (..), GeneratedExternalCodeDir)
import Generator.ExternalCodeGenerator.Js (resolveJsFileWaspImportsForExtCodeDir)
import qualified Generator.WebAppGenerator.Common as C
import qualified Path as P
import StrongPath (Dir, Path, Rel, (</>))
import qualified StrongPath as SP
-- | Relative path to directory where external code will be generated.
-- Relative to web app src dir.
@ -17,9 +17,11 @@ extCodeDirInWebAppSrcDir :: Path (Rel C.WebAppSrcDir) (Dir GeneratedExternalCode
extCodeDirInWebAppSrcDir = SP.fromPathRelDir [P.reldir|ext-src|]
generatorStrategy :: ExternalCodeGeneratorStrategy
generatorStrategy = ExternalCodeGeneratorStrategy
{ _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInWebAppSrcDir)
, _extCodeDirInProjectRootDir = C.webAppRootDirInProjectRootDir
</> C.webAppSrcDirInWebAppRootDir
</> extCodeDirInWebAppSrcDir
generatorStrategy =
ExternalCodeGeneratorStrategy
{ _resolveJsFileWaspImports = resolveJsFileWaspImportsForExtCodeDir (SP.castRel extCodeDirInWebAppSrcDir),
_extCodeDirInProjectRootDir =
C.webAppRootDirInProjectRootDir
</> C.webAppSrcDirInWebAppRootDir
</> extCodeDirInWebAppSrcDir
}

91
waspc/src/Generator/WebAppGenerator/OperationsGenerator.hs
View File

@ -1,42 +1,48 @@
module Generator.WebAppGenerator.OperationsGenerator
( genOperations
) where
( genOperations,
)
where
import Data.Aeson (object,
(.=))
import Data.List (intercalate)
import Data.Maybe (fromJust,
fromMaybe)
import qualified Path as P
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator as ServerGenerator
import qualified Generator.ServerGenerator.OperationsRoutesG as ServerOperationsRoutesG
import qualified Generator.WebAppGenerator.Common as C
import Data.Aeson
( object,
(.=),
)
import Data.List (intercalate)
import Data.Maybe
( fromJust,
fromMaybe,
)
import Generator.FileDraft (FileDraft)
import qualified Generator.ServerGenerator as ServerGenerator
import qualified Generator.ServerGenerator.OperationsRoutesG as ServerOperationsRoutesG
import qualified Generator.WebAppGenerator.Common as C
import qualified Generator.WebAppGenerator.OperationsGenerator.ResourcesG as Resources
import Wasp (Wasp)
import qualified Path as P
import Wasp (Wasp)
import qualified Wasp
import qualified Wasp.Action
import qualified Wasp.Operation
import qualified Wasp.Query
genOperations :: Wasp -> [FileDraft]
genOperations wasp = concat
[ genQueries wasp
, genActions wasp
, [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/operations/index.js|]) wasp]
, Resources.genResources wasp
genOperations wasp =
concat
[ genQueries wasp,
genActions wasp,
[C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/operations/index.js|]) wasp],
Resources.genResources wasp
]
genQueries :: Wasp -> [FileDraft]
genQueries wasp = concat
[ map (genQuery wasp) (Wasp.getQueries wasp)
, [C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/queries/index.js|]) wasp]
genQueries wasp =
concat
[ map (genQuery wasp) (Wasp.getQueries wasp),
[C.makeSimpleTemplateFD (C.asTmplFile [P.relfile|src/queries/index.js|]) wasp]
]
genActions :: Wasp -> [FileDraft]
genActions wasp = concat
genActions wasp =
concat
[ map (genAction wasp) (Wasp.getActions wasp)
]
@ -44,14 +50,17 @@ genQuery :: Wasp -> Wasp.Query.Query -> FileDraft
genQuery _ query = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
tmplFile = C.asTmplFile [P.relfile|src/queries/_query.js|]
-- | TODO: fromJust here could fail if there is some problem with the name, we should handle this.
dstFile = C.asWebAppFile $ [P.reldir|src/queries/|] P.</> fromJust (getOperationDstFileName operation)
tmplData = object
[ "queryFnName" .= Wasp.Query._name query
, "queryRoute" .=
(ServerGenerator.operationsRouteInRootRouter
++ "/" ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation)
, "entitiesArray" .= makeJsArrayOfEntityNames operation
tmplData =
object
[ "queryFnName" .= Wasp.Query._name query,
"queryRoute"
.= ( ServerGenerator.operationsRouteInRootRouter
++ "/"
++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation
),
"entitiesArray" .= makeJsArrayOfEntityNames operation
]
operation = Wasp.Operation.QueryOp query
@ -59,14 +68,17 @@ genAction :: Wasp -> Wasp.Action.Action -> FileDraft
genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData)
where
tmplFile = C.asTmplFile [P.relfile|src/actions/_action.js|]
-- | TODO: fromJust here could fail if there is some problem with the name, we should handle this.
dstFile = C.asWebAppFile $ [P.reldir|src/actions/|] P.</> fromJust (getOperationDstFileName operation)
tmplData = object
[ "actionFnName" .= Wasp.Action._name action
, "actionRoute" .=
(ServerGenerator.operationsRouteInRootRouter
++ "/" ++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation)
, "entitiesArray" .= makeJsArrayOfEntityNames operation
tmplData =
object
[ "actionFnName" .= Wasp.Action._name action,
"actionRoute"
.= ( ServerGenerator.operationsRouteInRootRouter
++ "/"
++ ServerOperationsRoutesG.operationRouteInOperationsRouter operation
),
"entitiesArray" .= makeJsArrayOfEntityNames operation
]
operation = Wasp.Operation.ActionOp action
@ -74,7 +86,8 @@ genAction _ action = C.makeTemplateFD tmplFile dstFile (Just tmplData)
-- E.g. "['Task', 'Project']"
makeJsArrayOfEntityNames :: Wasp.Operation.Operation -> String
makeJsArrayOfEntityNames operation = "[" ++ intercalate ", " entityStrings ++ "]"
where entityStrings = map (\x -> "'" ++ x ++ "'") $ fromMaybe [] $ Wasp.Operation.getEntities operation
where
entityStrings = map (\x -> "'" ++ x ++ "'") $ fromMaybe [] $ Wasp.Operation.getEntities operation
getOperationDstFileName :: Wasp.Operation.Operation -> Maybe (P.Path P.Rel P.File)
getOperationDstFileName operation = P.parseRelFile (Wasp.Operation.getName operation ++ ".js")

17
waspc/src/Generator/WebAppGenerator/OperationsGenerator/ResourcesG.hs
View File

@ -1,14 +1,13 @@
module Generator.WebAppGenerator.OperationsGenerator.ResourcesG
( genResources
) where
import Data.Aeson (object)
import qualified Path as P
import Generator.FileDraft (FileDraft)
import qualified Generator.WebAppGenerator.Common as C
import Wasp (Wasp)
( genResources,
)
where
import Data.Aeson (object)
import Generator.FileDraft (FileDraft)
import qualified Generator.WebAppGenerator.Common as C
import qualified Path as P
import Wasp (Wasp)
genResources :: Wasp -> [FileDraft]
genResources _ = [C.makeTemplateFD tmplFile dstFile (Just tmplData)]

165
waspc/src/Generator/WebAppGenerator/RouterGenerator.hs
View File

@ -1,118 +1,123 @@
module Generator.WebAppGenerator.RouterGenerator
( generateRouter
) where
( generateRouter,
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Maybe (isJust)
import qualified Path as P
import Generator.FileDraft (FileDraft)
import Generator.WebAppGenerator.Common (asTmplFile, asWebAppSrcFile)
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Maybe (isJust)
import Generator.FileDraft (FileDraft)
import Generator.WebAppGenerator.Common (asTmplFile, asWebAppSrcFile)
import qualified Generator.WebAppGenerator.Common as C
import StrongPath ((</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Path as P
import StrongPath ((</>))
import qualified StrongPath as SP
import Wasp (Wasp)
import qualified Wasp
import qualified Wasp.JsImport
import qualified Wasp.Page
import qualified Wasp.Route
data RouterTemplateData = RouterTemplateData
{ _routes :: ![RouteTemplateData]
, _pagesToImport :: ![PageTemplateData]
, _isAuthEnabled :: Bool
}
{ _routes :: ![RouteTemplateData],
_pagesToImport :: ![PageTemplateData],
_isAuthEnabled :: Bool
}
instance ToJSON RouterTemplateData where
toJSON routerTD = object
[ "routes" .= _routes routerTD
, "pagesToImport" .= _pagesToImport routerTD
, "isAuthEnabled" .= _isAuthEnabled routerTD
]
toJSON routerTD =
object
[ "routes" .= _routes routerTD,
"pagesToImport" .= _pagesToImport routerTD,
"isAuthEnabled" .= _isAuthEnabled routerTD
]
data RouteTemplateData = RouteTemplateData
{ _urlPath :: !String
, _targetComponent :: !String
}
{ _urlPath :: !String,
_targetComponent :: !String
}
instance ToJSON RouteTemplateData where
toJSON routeTD = object
[ "urlPath" .= _urlPath routeTD
, "targetComponent" .= _targetComponent routeTD
]
toJSON routeTD =
object
[ "urlPath" .= _urlPath routeTD,
"targetComponent" .= _targetComponent routeTD
]
data PageTemplateData = PageTemplateData
{ _importWhat :: !String
, _importFrom :: !String
} deriving (Show, Eq)
{ _importWhat :: !String,
_importFrom :: !String
}
deriving (Show, Eq)
instance ToJSON PageTemplateData where
toJSON pageTD = object
[ "importWhat" .= _importWhat pageTD
, "importFrom" .= _importFrom pageTD
]
toJSON pageTD =
object
[ "importWhat" .= _importWhat pageTD,
"importFrom" .= _importFrom pageTD
]
generateRouter :: Wasp -> FileDraft
generateRouter wasp = C.makeTemplateFD
generateRouter wasp =
C.makeTemplateFD
(asTmplFile $ [P.reldir|src|] P.</> routerPath)
targetPath
(Just $ toJSON templateData)
where
routerPath = [P.relfile|router.js|]
templateData = createRouterTemplateData wasp
targetPath = C.webAppSrcDirInWebAppRootDir </> asWebAppSrcFile routerPath
where
routerPath = [P.relfile|router.js|]
templateData = createRouterTemplateData wasp
targetPath = C.webAppSrcDirInWebAppRootDir </> asWebAppSrcFile routerPath
createRouterTemplateData :: Wasp -> RouterTemplateData
createRouterTemplateData wasp = RouterTemplateData
{ _routes = routes
, _pagesToImport = pages
, _isAuthEnabled = isJust $ Wasp.getAuth wasp
createRouterTemplateData wasp =
RouterTemplateData
{ _routes = routes,
_pagesToImport = pages,
_isAuthEnabled = isJust $ Wasp.getAuth wasp
}
where
routes = map (createRouteTemplateData wasp) $ Wasp.getRoutes wasp
pages = map createPageTemplateData $ Wasp.getPages wasp
where
routes = map (createRouteTemplateData wasp) $ Wasp.getRoutes wasp
pages = map createPageTemplateData $ Wasp.getPages wasp
createRouteTemplateData :: Wasp -> Wasp.Route.Route -> RouteTemplateData
createRouteTemplateData wasp route = RouteTemplateData
{ _urlPath = Wasp.Route._urlPath route
, _targetComponent = determineRouteTargetComponent wasp route
createRouteTemplateData wasp route =
RouteTemplateData
{ _urlPath = Wasp.Route._urlPath route,
_targetComponent = determineRouteTargetComponent wasp route
}
determineRouteTargetComponent :: Wasp -> Wasp.Route.Route -> String
determineRouteTargetComponent wasp route =
maybe
targetPageName
determineRouteTargetComponent'
(Wasp.Page._authRequired targetPage)
where
targetPageName = Wasp.Route._targetPage route
-- NOTE(matija): if no page with the name specified in the route, head will fail.
targetPage = head $ filter ((==) targetPageName . Wasp.Page._name) (Wasp.getPages wasp)
-- | Applied if authRequired property is present.
determineRouteTargetComponent' :: Bool -> String
determineRouteTargetComponent' authRequired =
if authRequired
-- TODO(matija): would be nicer if this function name wasn't hardcoded here.
then "createAuthRequiredPage(" ++ targetPageName ++ ")"
else targetPageName
maybe
targetPageName
determineRouteTargetComponent'
(Wasp.Page._authRequired targetPage)
where
targetPageName = Wasp.Route._targetPage route
-- NOTE(matija): if no page with the name specified in the route, head will fail.
targetPage = head $ filter ((==) targetPageName . Wasp.Page._name) (Wasp.getPages wasp)
determineRouteTargetComponent' :: Bool -> String
determineRouteTargetComponent' authRequired =
if authRequired
then -- TODO(matija): would be nicer if this function name wasn't hardcoded here.
"createAuthRequiredPage(" ++ targetPageName ++ ")"
else targetPageName
createPageTemplateData :: Wasp.Page.Page -> PageTemplateData
createPageTemplateData page = PageTemplateData
{ _importFrom = relPathToExtSrcDir ++
SP.toFilePath (SP.relFileToPosix' $ Wasp.JsImport._from pageComponent)
, _importWhat = case Wasp.JsImport._namedImports pageComponent of
-- If no named imports, we go with the default import.
[] -> pageName
[namedImport] -> "{ " ++ namedImport ++ " as " ++ pageName ++ " }"
_ -> error "Only one named import can be provided for a page."
createPageTemplateData page =
PageTemplateData
{ _importFrom =
relPathToExtSrcDir
++ SP.toFilePath (SP.relFileToPosix' $ Wasp.JsImport._from pageComponent),
_importWhat = case Wasp.JsImport._namedImports pageComponent of
-- If no named imports, we go with the default import.
[] -> pageName
[namedImport] -> "{ " ++ namedImport ++ " as " ++ pageName ++ " }"
_ -> error "Only one named import can be provided for a page."
}
where
relPathToExtSrcDir :: FilePath
relPathToExtSrcDir = "./ext-src/"
where
relPathToExtSrcDir :: FilePath
relPathToExtSrcDir = "./ext-src/"
pageName = Wasp.Page._name page
pageComponent = Wasp.Page._component page
pageName = Wasp.Page._name page
pageComponent = Wasp.Page._component page

18
waspc/src/Generator/WebAppGenerator/Setup.hs
View File

@ -1,15 +1,15 @@
module Generator.WebAppGenerator.Setup
( setupWebApp
) where
( setupWebApp,
)
where
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import qualified Generator.WebAppGenerator.Common as Common
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
setupWebApp :: Path Abs (Dir ProjectRootDir) -> J.Job
setupWebApp projectDir = do
let webAppDir = projectDir </> Common.webAppRootDirInProjectRootDir
runNodeCommandAsJob webAppDir "npm" ["install"] J.WebApp
let webAppDir = projectDir </> Common.webAppRootDirInProjectRootDir
runNodeCommandAsJob webAppDir "npm" ["install"] J.WebApp

18
waspc/src/Generator/WebAppGenerator/Start.hs
View File

@ -1,15 +1,15 @@
module Generator.WebAppGenerator.Start
( startWebApp
) where
( startWebApp,
)
where
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import Generator.Common (ProjectRootDir)
import qualified Generator.Job as J
import Generator.Job.Process (runNodeCommandAsJob)
import qualified Generator.WebAppGenerator.Common as Common
import StrongPath (Abs, Dir, Path, (</>))
import StrongPath (Abs, Dir, Path, (</>))
startWebApp :: Path Abs (Dir ProjectRootDir) -> J.Job
startWebApp projectDir = do
let webAppDir = projectDir </> Common.webAppRootDirInProjectRootDir
runNodeCommandAsJob webAppDir "npm" ["start"] J.WebApp
let webAppDir = projectDir </> Common.webAppRootDirInProjectRootDir
runNodeCommandAsJob webAppDir "npm" ["start"] J.WebApp

49
waspc/src/Lexer.hs
View File

@ -1,8 +1,8 @@
module Lexer where
import Text.Parsec (letter, alphaNum, (<|>), char, between)
import Text.Parsec.String (Parser)
import Text.Parsec (alphaNum, between, char, letter, (<|>))
import Text.Parsec.Language (emptyDef)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as Token
reservedNameImport :: String
@ -56,32 +56,33 @@ reservedNameBooleanFalse = "false"
reservedNames :: [String]
reservedNames =
[ reservedNameImport
, reservedNameFrom
[ reservedNameImport,
reservedNameFrom,
-- Wasp element types
, reservedNameApp
, reservedNameDependencies
, reservedNamePage
, reservedNameRoute
, reservedNameEntity
, reservedNameAuth
, reservedNameQuery
, reservedNameAction
reservedNameApp,
reservedNameDependencies,
reservedNamePage,
reservedNameRoute,
reservedNameEntity,
reservedNameAuth,
reservedNameQuery,
reservedNameAction,
-- Data types
, reservedNameString
, reservedNameBoolean
, reservedNameBooleanTrue
, reservedNameBooleanFalse
]
reservedNameString,
reservedNameBoolean,
reservedNameBooleanTrue,
reservedNameBooleanFalse
]
waspLanguageDef :: Token.LanguageDef ()
waspLanguageDef = emptyDef
{ Token.commentLine = "//"
, Token.reservedNames = reservedNames
, Token.caseSensitive = True
-- Identifier
, Token.identStart = letter
, Token.identLetter = alphaNum <|> char '_'
waspLanguageDef =
emptyDef
{ Token.commentLine = "//",
Token.reservedNames = reservedNames,
Token.caseSensitive = True,
-- Identifier
Token.identStart = letter,
Token.identLetter = alphaNum <|> char '_'
}
waspLexer :: Token.TokenParser ()

97
waspc/src/Lib.hs
View File

@ -1,72 +1,75 @@
module Lib
( compile
, Generator.setup
, Generator.start
, ProjectRootDir
) where
( compile,
Generator.setup,
Generator.start,
ProjectRootDir,
)
where
import qualified Path as P
import System.Directory (doesFileExist)
import Common (WaspProjectDir)
import CompileOptions (CompileOptions)
import Common (WaspProjectDir)
import CompileOptions (CompileOptions)
import qualified CompileOptions
import Control.Monad.IO.Class (liftIO)
import Data.List (find, isSuffixOf)
import Control.Monad.IO.Class (liftIO)
import Data.List (find, isSuffixOf)
import qualified ExternalCode
import qualified Generator
import Generator.Common (ProjectRootDir)
import Generator.Common (ProjectRootDir)
import qualified Parser
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
import qualified Path as P
import StrongPath (Abs, Dir, Path)
import qualified StrongPath as SP
import System.Directory (doesFileExist)
import qualified Util.IO
import Wasp (Wasp)
import Wasp (Wasp)
import qualified Wasp
type CompileError = String
compile :: Path Abs (Dir WaspProjectDir)
-> Path Abs (Dir ProjectRootDir)
-> CompileOptions
-> IO (Either CompileError ())
compile ::
Path Abs (Dir WaspProjectDir) ->
Path Abs (Dir ProjectRootDir) ->
CompileOptions ->
IO (Either CompileError ())
compile waspDir outDir options = do
maybeWaspFile <- findWaspFile waspDir
case maybeWaspFile of
Nothing -> return $ Left "Couldn't find a single *.wasp file."
Just waspFile -> do
waspStr <- readFile (SP.toFilePath waspFile)
maybeWaspFile <- findWaspFile waspDir
case maybeWaspFile of
Nothing -> return $ Left "Couldn't find a single *.wasp file."
Just waspFile -> do
waspStr <- readFile (SP.toFilePath waspFile)
case Parser.parseWasp waspStr of
Left err -> return $ Left (show err)
Right wasp -> do
maybeDotEnvFile <- findDotEnvFile waspDir
(wasp
`Wasp.setDotEnvFile` maybeDotEnvFile
`enrichWaspASTBasedOnCompileOptions` options
) >>= generateCode
case Parser.parseWasp waspStr of
Left err -> return $ Left (show err)
Right wasp -> do
maybeDotEnvFile <- findDotEnvFile waspDir
( wasp
`Wasp.setDotEnvFile` maybeDotEnvFile
`enrichWaspASTBasedOnCompileOptions` options
)
>>= generateCode
where
generateCode wasp = Generator.writeWebAppCode wasp outDir options >> return (Right ())
enrichWaspASTBasedOnCompileOptions :: Wasp -> CompileOptions -> IO Wasp
enrichWaspASTBasedOnCompileOptions wasp options = do
externalCodeFiles <- ExternalCode.readFiles (CompileOptions.externalCodeDirPath options)
return (wasp
`Wasp.setExternalCodeFiles` externalCodeFiles
`Wasp.setIsBuild` CompileOptions.isBuild options
)
externalCodeFiles <- ExternalCode.readFiles (CompileOptions.externalCodeDirPath options)
return
( wasp
`Wasp.setExternalCodeFiles` externalCodeFiles
`Wasp.setIsBuild` CompileOptions.isBuild options
)
findWaspFile :: Path Abs (Dir WaspProjectDir) -> IO (Maybe (Path Abs SP.File))
findWaspFile waspDir = do
(files, _) <- liftIO $ Util.IO.listDirectory (SP.toPathAbsDir waspDir)
return $ (waspDir SP.</>) . SP.fromPathRelFile <$> find isWaspFile files
(files, _) <- liftIO $ Util.IO.listDirectory (SP.toPathAbsDir waspDir)
return $ (waspDir SP.</>) . SP.fromPathRelFile <$> find isWaspFile files
where
isWaspFile :: P.Path P.Rel P.File -> Bool
isWaspFile path = ".wasp" `isSuffixOf` P.toFilePath path
&& (length (P.toFilePath path) > length (".wasp" :: String))
isWaspFile :: P.Path P.Rel P.File -> Bool
isWaspFile path =
".wasp" `isSuffixOf` P.toFilePath path
&& (length (P.toFilePath path) > length (".wasp" :: String))
findDotEnvFile :: Path Abs (Dir WaspProjectDir) -> IO (Maybe (Path Abs SP.File))
findDotEnvFile waspDir = do
let dotEnvAbsPath = waspDir SP.</> SP.fromPathRelFile [P.relfile|.env|]
dotEnvExists <- doesFileExist (SP.toFilePath dotEnvAbsPath)
return $ if dotEnvExists then Just dotEnvAbsPath else Nothing
let dotEnvAbsPath = waspDir SP.</> SP.fromPathRelFile [P.relfile|.env|]
dotEnvExists <- doesFileExist (SP.toFilePath dotEnvAbsPath)
return $ if dotEnvExists then Just dotEnvAbsPath else Nothing

26
waspc/src/NpmDependency.hs
View File

@ -1,21 +1,23 @@
module NpmDependency
( NpmDependency (..)
, fromList
) where
import Data.Aeson (ToJSON (..), object, (.=))
( NpmDependency (..),
fromList,
)
where
import Data.Aeson (ToJSON (..), object, (.=))
data NpmDependency = NpmDependency
{ _name :: !String
, _version :: !String }
{ _name :: !String,
_version :: !String
}
deriving (Show, Eq)
fromList :: [(String, String)] -> [NpmDependency]
fromList = map (\(name, version) -> NpmDependency { _name = name, _version = version })
fromList = map (\(name, version) -> NpmDependency {_name = name, _version = version})
instance ToJSON NpmDependency where
toJSON npmDep = object
[ "name" .= _name npmDep
, "version" .= _version npmDep
]
toJSON npmDep =
object
[ "name" .= _name npmDep,
"version" .= _version npmDep
]

57
waspc/src/Parser.hs
View File

@ -1,30 +1,27 @@
module Parser
( parseWasp
) where
import Text.Parsec (ParseError, (<|>), many1, eof, many)
import Text.Parsec.String (Parser)
import qualified Wasp
( parseWasp,
)
where
import Lexer
import qualified Parser.Action
import Parser.App (app)
import Parser.Auth (auth)
import Parser.Db (db)
import Parser.Route (route)
import Parser.Page (page)
import Parser.Entity (entity)
import Parser.JsImport (jsImport)
import Parser.Common (runWaspParser)
import qualified Parser.Query
import qualified Parser.Action
import Parser.Db (db)
import Parser.Entity (entity)
import Parser.JsImport (jsImport)
import qualified Parser.NpmDependencies
import Parser.Page (page)
import qualified Parser.Query
import Parser.Route (route)
import Text.Parsec (ParseError, eof, many, many1, (<|>))
import Text.Parsec.String (Parser)
import qualified Wasp
waspElement :: Parser Wasp.WaspElement
waspElement
= waspElementApp
waspElement =
waspElementApp
<|> waspElementAuth
<|> waspElementPage
<|> waspElementDb
@ -52,7 +49,6 @@ waspElementRoute = Wasp.WaspElementRoute <$> route
waspElementEntity :: Parser Wasp.WaspElement
waspElementEntity = Wasp.WaspElementEntity <$> entity
waspElementQuery :: Parser Wasp.WaspElement
waspElementQuery = Wasp.WaspElementQuery <$> Parser.Query.query
@ -62,26 +58,25 @@ waspElementAction = Wasp.WaspElementAction <$> Parser.Action.action
waspElementNpmDependencies :: Parser Wasp.WaspElement
waspElementNpmDependencies = Wasp.WaspElementNpmDependencies <$> Parser.NpmDependencies.npmDependencies
-- | Top level parser, produces Wasp.
waspParser :: Parser Wasp.Wasp
waspParser = do
-- NOTE(matija): this is the only place we need to use whiteSpace, to skip empty lines
-- and comments in the beginning of file. All other used parsers are lexeme parsers
-- so they do it themselves.
whiteSpace
-- NOTE(matija): this is the only place we need to use whiteSpace, to skip empty lines
-- and comments in the beginning of file. All other used parsers are lexeme parsers
-- so they do it themselves.
whiteSpace
jsImports <- many jsImport
jsImports <- many jsImport
waspElems <- many1 waspElement
waspElems <- many1 waspElement
eof
eof
-- TODO(matija): after we parsed everything, we should do semantic analysis
-- e.g. check there is only 1 title - if not, throw a meaningful error.
-- Also, check there is at least one Page defined.
-- TODO(matija): after we parsed everything, we should do semantic analysis
-- e.g. check there is only 1 title - if not, throw a meaningful error.
-- Also, check there is at least one Page defined.
return $ Wasp.fromWaspElems waspElems `Wasp.setJsImports` jsImports
return $ Wasp.fromWaspElems waspElems `Wasp.setJsImports` jsImports
-- | Top level parser executor.
parseWasp :: String -> Either ParseError Wasp.Wasp

36
waspc/src/Parser/Action.hs
View File

@ -1,23 +1,23 @@
module Parser.Action
( action
) where
import Data.Maybe (fromMaybe)
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified Parser.Common as C
import qualified Parser.Operation as Operation
import Wasp.Action (Action)
import qualified Wasp.Action as Action
( action,
)
where
import Data.Maybe (fromMaybe)
import qualified Lexer as L
import qualified Parser.Common as C
import qualified Parser.Operation as Operation
import Text.Parsec.String (Parser)
import Wasp.Action (Action)
import qualified Wasp.Action as Action
action :: Parser Action
action = do
(name, props) <- C.waspElementNameAndClosureContent L.reservedNameAction Operation.properties
return Action.Action
{ Action._name = name
, Action._jsFunction =
fromMaybe (error "Action js function is missing.") (Operation.getJsFunctionFromProps props)
, Action._entities = Operation.getEntitiesFromProps props
}
(name, props) <- C.waspElementNameAndClosureContent L.reservedNameAction Operation.properties
return
Action.Action
{ Action._name = name,
Action._jsFunction =
fromMaybe (error "Action js function is missing.") (Operation.getJsFunctionFromProps props),
Action._entities = Operation.getEntitiesFromProps props
}

46
waspc/src/Parser/App.hs
View File

@ -1,29 +1,30 @@
module Parser.App
( app
) where
( app,
)
where
import Data.Maybe (listToMaybe)
import Lexer
import qualified Lexer as L
import Parser.Common
import Text.Parsec
import Text.Parsec.String (Parser)
import Data.Maybe (listToMaybe)
import Lexer
import qualified Wasp.App as App
import Parser.Common
import qualified Lexer as L
-- | A type that describes supported app properties.
data AppProperty
= Title !String
| Favicon !String
| Head [String]
deriving (Show, Eq)
= Title !String
| Favicon !String
| Head [String]
deriving (Show, Eq)
-- | Parses supported app properties, expects format "key1: value1, key2: value2, ..."
appProperties :: Parser [AppProperty]
appProperties = commaSep1
$ appPropertyTitle
<|> appPropertyFavicon
<|> appPropertyHead
appProperties =
commaSep1 $
appPropertyTitle
<|> appPropertyFavicon
<|> appPropertyHead
appPropertyTitle :: Parser AppProperty
appPropertyTitle = Title <$> waspPropertyStringLiteral "title"
@ -45,11 +46,12 @@ getAppHead ps = listToMaybe [hs | Head hs <- ps]
-- | Top level parser, parses App.
app :: Parser App.App
app = do
(appName, appProps) <- waspElementNameAndClosureContent reservedNameApp appProperties
(appName, appProps) <- waspElementNameAndClosureContent reservedNameApp appProperties
return App.App
{ App.appName = appName
, App.appTitle = getAppTitle appProps
, App.appHead = getAppHead appProps
-- TODO(matija): add favicon.
}
return
App.App
{ App.appName = appName,
App.appTitle = getAppTitle appProps,
App.appHead = getAppHead appProps
-- TODO(matija): add favicon.
}

56
waspc/src/Parser/Auth.hs
View File

@ -1,45 +1,47 @@
module Parser.Auth
( auth
) where
( auth,
)
where
import Text.Parsec.String (Parser)
import Text.Parsec ((<|>))
import Control.Monad (when)
import qualified Wasp.Auth
import qualified Parser.Common as P
import qualified Lexer as L
import qualified Parser.Common as P
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Wasp.Auth
auth :: Parser Wasp.Auth.Auth
auth = do
L.reserved L.reservedNameAuth
authProperties <- P.waspClosure (L.commaSep1 authProperty)
L.reserved L.reservedNameAuth
authProperties <- P.waspClosure (L.commaSep1 authProperty)
let userEntityProps = [s | AuthPropertyUserEntity s <- authProperties]
failIfPropMissing propUserEntityName userEntityProps
let userEntityProps = [s | AuthPropertyUserEntity s <- authProperties]
failIfPropMissing propUserEntityName userEntityProps
let methodsProps = [ms | AuthPropertyMethods ms <- authProperties]
failIfPropMissing propMethodsName methodsProps
let methodsProps = [ms | AuthPropertyMethods ms <- authProperties]
failIfPropMissing propMethodsName methodsProps
let redirectProps = [r | AuthPropertyOnAuthFailedRedirectTo r <- authProperties]
failIfPropMissing propOnAuthFailedRedirectToName redirectProps
let redirectProps = [r | AuthPropertyOnAuthFailedRedirectTo r <- authProperties]
failIfPropMissing propOnAuthFailedRedirectToName redirectProps
return Wasp.Auth.Auth
{ Wasp.Auth._userEntity = head userEntityProps
, Wasp.Auth._methods = head methodsProps
, Wasp.Auth._onAuthFailedRedirectTo = head redirectProps
}
return
Wasp.Auth.Auth
{ Wasp.Auth._userEntity = head userEntityProps,
Wasp.Auth._methods = head methodsProps,
Wasp.Auth._onAuthFailedRedirectTo = head redirectProps
}
-- TODO(matija): this should be extracted if we want to use in other places too.
failIfPropMissing :: (Applicative m, MonadFail m) => String -> [p] -> m ()
failIfPropMissing propName ps = when (null ps) $ fail errorMsg
where errorMsg = propName ++ " is required!"
where
errorMsg = propName ++ " is required!"
-- Auxiliary data structure used by parser.
data AuthProperty
= AuthPropertyUserEntity String
| AuthPropertyMethods [Wasp.Auth.AuthMethod]
| AuthPropertyOnAuthFailedRedirectTo String
= AuthPropertyUserEntity String
| AuthPropertyMethods [Wasp.Auth.AuthMethod]
| AuthPropertyOnAuthFailedRedirectTo String
propUserEntityName :: String
propUserEntityName = "userEntity"
@ -53,14 +55,14 @@ propOnAuthFailedRedirectToName = "onAuthFailedRedirectTo"
-- Sub-parsers
authProperty :: Parser AuthProperty
authProperty
= authPropertyUserEntity
authProperty =
authPropertyUserEntity
<|> authPropertyMethods
<|> authPropertyOnAuthFailedRedirectTo
authPropertyOnAuthFailedRedirectTo :: Parser AuthProperty
authPropertyOnAuthFailedRedirectTo =
AuthPropertyOnAuthFailedRedirectTo <$> (P.waspPropertyStringLiteral "onAuthFailedRedirectTo")
AuthPropertyOnAuthFailedRedirectTo <$> (P.waspPropertyStringLiteral "onAuthFailedRedirectTo")
authPropertyUserEntity :: Parser AuthProperty
authPropertyUserEntity = AuthPropertyUserEntity <$> (P.waspProperty "userEntity" L.identifier)

127
waspc/src/Parser/Common.hs
View File

@ -4,15 +4,19 @@
module Parser.Common where
import qualified Data.Text as T
import qualified Path as P
import qualified Path.Posix as PPosix
import Text.Parsec (ParseError, anyChar, manyTill, parse, try,
unexpected)
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified Data.Text as T
import qualified Lexer as L
import qualified Path as P
import qualified Path.Posix as PPosix
import Text.Parsec
( ParseError,
anyChar,
manyTill,
parse,
try,
unexpected,
)
import Text.Parsec.String (Parser)
-- | Runs given wasp parser on a specified input.
runWaspParser :: Parser a -> String -> Either ParseError a
@ -24,33 +28,40 @@ runWaspParser waspParser input = parse waspParser sourceName input
sourceName = ""
-- TODO(matija): rename to just "waspElement"?
-- | Parses declaration of a wasp element (e.g. App or Page) and the closure content.
waspElementNameAndClosureContent
:: String -- ^ Type of the wasp element (e.g. "app" or "page").
-> Parser a -- ^ Parser to be used for parsing closure content of the wasp element.
-> Parser (String, a) -- ^ Name of the element and parsed closure content.
waspElementNameAndClosureContent ::
-- | Type of the wasp element (e.g. "app" or "page").
String ->
-- | Parser to be used for parsing closure content of the wasp element.
Parser a ->
-- | Name of the element and parsed closure content.
Parser (String, a)
waspElementNameAndClosureContent elementType closureContent =
waspElementNameAndClosure elementType (waspClosure closureContent)
waspElementNameAndClosure elementType (waspClosure closureContent)
-- | Parses declaration of a wasp element (e.g. App or Page) and the belonging closure.
waspElementNameAndClosure
:: String -- ^ Element type
-> Parser a -- ^ Closure parser (needs to parse braces as well, not just the content)
-> Parser (String, a) -- ^ Name of the element and parsed closure content.
waspElementNameAndClosure ::
-- | Element type
String ->
-- | Closure parser (needs to parse braces as well, not just the content)
Parser a ->
-- | Name of the element and parsed closure content.
Parser (String, a)
waspElementNameAndClosure elementType closure =
-- NOTE(matija): It is important to have `try` here because we don't want to consume the
-- content intended for other parsers.
-- E.g. if we tried to parse "entity-form" this parser would have been tried first for
-- "entity" and would consume "entity", so entity-form parser would also fail.
-- This way when entity parser fails, it will backtrack and allow
-- entity-form parser to succeed.
--
-- TODO(matija): should I push this try higher, to the specific case of entity parser
-- which is causing the trouble?
-- This way try will be executed in more cases where it is not neccessary, this
-- might not be the best for the performance and the clarity of error messages.
-- On the other hand, it is safer?
try $ do
-- NOTE(matija): It is important to have `try` here because we don't want to consume the
-- content intended for other parsers.
-- E.g. if we tried to parse "entity-form" this parser would have been tried first for
-- "entity" and would consume "entity", so entity-form parser would also fail.
-- This way when entity parser fails, it will backtrack and allow
-- entity-form parser to succeed.
--
-- TODO(matija): should I push this try higher, to the specific case of entity parser
-- which is causing the trouble?
-- This way try will be executed in more cases where it is not neccessary, this
-- might not be the best for the performance and the clarity of error messages.
-- On the other hand, it is safer?
try $ do
L.reserved elementType
elementName <- L.identifier
closureContent <- closure
@ -59,16 +70,19 @@ waspElementNameAndClosure elementType closure =
-- | Parses declaration of a wasp element linked to an entity.
-- E.g. "entity-form<Task> ..." or "action<Task> ..."
waspElementLinkedToEntity
:: String -- ^ Type of the linked wasp element (e.g. "entity-form").
-> Parser a -- ^ Parser to be used for parsing body of the wasp element.
-> Parser (String, String, a) -- ^ Name of the linked entity, element name and body.
waspElementLinkedToEntity ::
-- | Type of the linked wasp element (e.g. "entity-form").
String ->
-- | Parser to be used for parsing body of the wasp element.
Parser a ->
-- | Name of the linked entity, element name and body.
Parser (String, String, a)
waspElementLinkedToEntity elementType bodyParser = do
L.reserved elementType
linkedEntityName <- L.angles L.identifier
elementName <- L.identifier
body <- bodyParser
return (linkedEntityName, elementName, body)
L.reserved elementType
linkedEntityName <- L.angles L.identifier
elementName <- L.identifier
body <- bodyParser
return (linkedEntityName, elementName, body)
-- | Parses wasp property along with the key, "key: value".
waspProperty :: String -> Parser a -> Parser a
@ -88,10 +102,10 @@ waspPropertyBool key = waspProperty key L.bool
-- form "FIELD_NAME: {...}" -> FIELD_NAME is then an identifier we need.
waspPropertyWithIdentifierAsKey :: Parser a -> Parser (String, a)
waspPropertyWithIdentifierAsKey valueP = do
identifier <- L.identifier <* L.colon
value <- valueP
identifier <- L.identifier <* L.colon
value <- valueP
return (identifier, value)
return (identifier, value)
-- | Parses wasp closure, which is {...}. Returns parsed content within the closure.
waspClosure :: Parser a -> Parser a
@ -128,14 +142,15 @@ waspCssClosure :: Parser String
waspCssClosure = waspNamedClosure "css"
-- TODO(martin): write tests and comments.
-- | Parses named wasp closure, which is {=name...name=}. Returns content within the closure.
waspNamedClosure :: String -> Parser String
waspNamedClosure name = do
_ <- closureStart
strip <$> manyTill anyChar (try closureEnd)
_ <- closureStart
strip <$> manyTill anyChar (try closureEnd)
where
closureStart = L.symbol ("{=" ++ name)
closureEnd = L.symbol (name ++ "=}")
closureStart = L.symbol ("{=" ++ name)
closureEnd = L.symbol (name ++ "=}")
-- | Parses a list of items that can be parsed with given parser.
-- For example, `waspList L.identifier` will parse "[foo, bar, t]" into ["foo", "bar", "t"].
@ -149,15 +164,17 @@ strip = T.unpack . T.strip . T.pack
-- | Parses relative file path, e.g. "my/file.txt".
relFilePathString :: Parser (P.Path P.Rel P.File)
relFilePathString = do
path <- L.stringLiteral
maybe (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.")
return
(P.parseRelFile path)
path <- L.stringLiteral
maybe
(unexpected $ "string \"" ++ path ++ "\": Expected relative file path.")
return
(P.parseRelFile path)
-- | Parses relative posix file path, e.g. "my/file.txt".
relPosixFilePathString :: Parser (PPosix.Path PPosix.Rel PPosix.File)
relPosixFilePathString = do
path <- L.stringLiteral
maybe (unexpected $ "string \"" ++ path ++ "\": Expected relative file path.")
return
(PPosix.parseRelFile path)
path <- L.stringLiteral
maybe
(unexpected $ "string \"" ++ path ++ "\": Expected relative file path.")
return
(PPosix.parseRelFile path)

44
waspc/src/Parser/Db.hs
View File

@ -1,36 +1,40 @@
module Parser.Db
( db
) where
( db,
)
where
import Text.Parsec.String (Parser)
import Text.Parsec ((<|>), try)
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Wasp.Db
import qualified Parser.Common as P
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Lexer as L
import qualified Parser.Common as P
import Text.Parsec (try, (<|>))
import Text.Parsec.String (Parser)
import qualified Wasp.Db
db :: Parser Wasp.Db.Db
db = do
L.reserved L.reservedNameDb
dbProperties <- P.waspClosure (L.commaSep1 dbProperty)
L.reserved L.reservedNameDb
dbProperties <- P.waspClosure (L.commaSep1 dbProperty)
system <- fromMaybe (fail "'system' property is required!") $ return <$>
listToMaybe [p | DbPropertySystem p <- dbProperties]
system <-
fromMaybe (fail "'system' property is required!") $
return
<$> listToMaybe [p | DbPropertySystem p <- dbProperties]
return Wasp.Db.Db
{ Wasp.Db._system = system
}
return
Wasp.Db.Db
{ Wasp.Db._system = system
}
data DbProperty
= DbPropertySystem Wasp.Db.DbSystem
= DbPropertySystem Wasp.Db.DbSystem
dbProperty :: Parser DbProperty
dbProperty
= dbPropertySystem
dbProperty =
dbPropertySystem
dbPropertySystem :: Parser DbProperty
dbPropertySystem = DbPropertySystem <$> (P.waspProperty "system" dbPropertySystemValue)
where
dbPropertySystemValue = try (L.symbol "PostgreSQL" >> return Wasp.Db.PostgreSQL)
<|> try (L.symbol "SQLite" >> return Wasp.Db.SQLite)
dbPropertySystemValue =
try (L.symbol "PostgreSQL" >> return Wasp.Db.PostgreSQL)
<|> try (L.symbol "SQLite" >> return Wasp.Db.SQLite)

89
waspc/src/Parser/Entity.hs
View File

@ -1,27 +1,28 @@
module Parser.Entity
( entity
) where
( entity,
)
where
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified Psl.Ast.Model as PslModel
import qualified Lexer as L
import qualified Psl.Ast.Model as PslModel
import qualified Psl.Parser.Model
import qualified Wasp.Entity as Entity
import Text.Parsec.String (Parser)
import qualified Wasp.Entity as Entity
entity :: Parser Entity.Entity
entity = do
_ <- L.reserved L.reservedNameEntity
name <- L.identifier
_ <- L.symbol "{=psl"
pslModelBody <- Psl.Parser.Model.body
_ <- L.symbol "psl=}"
_ <- L.reserved L.reservedNameEntity
name <- L.identifier
_ <- L.symbol "{=psl"
pslModelBody <- Psl.Parser.Model.body
_ <- L.symbol "psl=}"
return Entity.Entity
{ Entity._name = name
, Entity._fields = getEntityFields pslModelBody
, Entity._pslModelBody = pslModelBody
}
return
Entity.Entity
{ Entity._name = name,
Entity._fields = getEntityFields pslModelBody,
Entity._pslModelBody = pslModelBody
}
getEntityFields :: PslModel.Body -> [Entity.Field]
getEntityFields (PslModel.Body pslElements) = map pslFieldToEntityField pslFields
@ -29,35 +30,37 @@ getEntityFields (PslModel.Body pslElements) = map pslFieldToEntityField pslField
pslFields = [field | (PslModel.ElementField field) <- pslElements]
pslFieldToEntityField :: PslModel.Field -> Entity.Field
pslFieldToEntityField pslField = Entity.Field
{ Entity._fieldName = PslModel._name pslField
, Entity._fieldType = pslFieldTypeToEntityFieldType
(PslModel._type pslField)
(PslModel._typeModifiers pslField)
pslFieldToEntityField pslField =
Entity.Field
{ Entity._fieldName = PslModel._name pslField,
Entity._fieldType =
pslFieldTypeToEntityFieldType
(PslModel._type pslField)
(PslModel._typeModifiers pslField)
}
pslFieldTypeToEntityFieldType
:: PslModel.FieldType
-> [PslModel.FieldTypeModifier]
-> Entity.FieldType
pslFieldTypeToEntityFieldType ::
PslModel.FieldType ->
[PslModel.FieldTypeModifier] ->
Entity.FieldType
pslFieldTypeToEntityFieldType fType fTypeModifiers =
let scalar = pslFieldTypeToScalar fType
in case fTypeModifiers of
[] -> Entity.FieldTypeScalar scalar
[PslModel.List] -> Entity.FieldTypeComposite $ Entity.List scalar
[PslModel.Optional] -> Entity.FieldTypeComposite $ Entity.Optional scalar
_ -> error "Not a valid list of modifiers."
let scalar = pslFieldTypeToScalar fType
in case fTypeModifiers of
[] -> Entity.FieldTypeScalar scalar
[PslModel.List] -> Entity.FieldTypeComposite $ Entity.List scalar
[PslModel.Optional] -> Entity.FieldTypeComposite $ Entity.Optional scalar
_ -> error "Not a valid list of modifiers."
pslFieldTypeToScalar :: PslModel.FieldType -> Entity.Scalar
pslFieldTypeToScalar fType = case fType of
PslModel.String -> Entity.String
PslModel.Boolean -> Entity.Boolean
PslModel.Int -> Entity.Int
PslModel.BigInt -> Entity.BigInt
PslModel.Float -> Entity.Float
PslModel.Decimal -> Entity.Decimal
PslModel.DateTime -> Entity.DateTime
PslModel.Json -> Entity.Json
PslModel.Bytes -> Entity.Bytes
PslModel.UserType typeName -> Entity.UserType typeName
PslModel.Unsupported typeName -> Entity.Unsupported typeName
PslModel.String -> Entity.String
PslModel.Boolean -> Entity.Boolean
PslModel.Int -> Entity.Int
PslModel.BigInt -> Entity.BigInt
PslModel.Float -> Entity.Float
PslModel.Decimal -> Entity.Decimal
PslModel.DateTime -> Entity.DateTime
PslModel.Json -> Entity.Json
PslModel.Bytes -> Entity.Bytes
PslModel.UserType typeName -> Entity.UserType typeName
PslModel.Unsupported typeName -> Entity.Unsupported typeName

28
waspc/src/Parser/ExternalCode.hs
View File

@ -1,23 +1,23 @@
module Parser.ExternalCode
( extCodeFilePathString
) where
( extCodeFilePathString,
)
where
import qualified Path.Posix as PPosix
import Text.Parsec (unexpected)
import Text.Parsec.String (Parser)
import ExternalCode (SourceExternalCodeDir)
import ExternalCode (SourceExternalCodeDir)
import qualified Parser.Common
import StrongPath (File, Path', Posix, Rel)
import qualified StrongPath as SP
import qualified Path.Posix as PPosix
import StrongPath (File, Path', Posix, Rel)
import qualified StrongPath as SP
import Text.Parsec (unexpected)
import Text.Parsec.String (Parser)
-- Parses string literal that is file path to file in source external code dir.
-- Returns file path relative to the external code dir.
-- Example of input: "@ext/some/file.txt". Output would be: "some/file.txt".
extCodeFilePathString :: Parser (Path' Posix (Rel SourceExternalCodeDir) File)
extCodeFilePathString = do
path <- Parser.Common.relPosixFilePathString
maybe (unexpected $ "string \"" ++ show path ++ "\": External code file path should start with \"@ext/\".")
(return . SP.fromPathRelFileP)
(PPosix.stripProperPrefix [PPosix.reldir|@ext|] path)
path <- Parser.Common.relPosixFilePathString
maybe
(unexpected $ "string \"" ++ show path ++ "\": External code file path should start with \"@ext/\".")
(return . SP.fromPathRelFileP)
(PPosix.stripProperPrefix [PPosix.reldir|@ext|] path)

8
waspc/src/Parser/JsCode.hs
View File

@ -1,11 +1,11 @@
module Parser.JsCode
( jsCode
) where
( jsCode,
)
where
import Text.Parsec.String (Parser)
import qualified Data.Text as Text
import qualified Parser.Common as P
import Text.Parsec.String (Parser)
import qualified Wasp.JsCode as WJS
jsCode :: Parser WJS.JsCode

41
waspc/src/Parser/JsImport.hs
View File

@ -1,31 +1,32 @@
module Parser.JsImport
( jsImport
) where
( jsImport,
)
where
import qualified Lexer as L
import qualified Parser.ExternalCode
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Parser.ExternalCode
import qualified Lexer as L
import qualified Wasp.JsImport
-- | Parses subset of JS import statement (only default or single named import, and only external code files):
-- import <identifier> from "@ext/..."
-- import { <identifier> } from "@ext/..."
jsImport :: Parser Wasp.JsImport.JsImport
jsImport = do
L.whiteSpace
_ <- L.reserved L.reservedNameImport
-- For now we support only default import or one named import.
(defaultImport, namedImports) <- ((\i -> (Just i, [])) <$> L.identifier)
<|> ((\i -> (Nothing, [i])) <$> L.braces L.identifier)
_ <- L.reserved L.reservedNameFrom
-- TODO: For now we only support double quotes here, we should also support single quotes.
-- We would need to write this from scratch, with single quote escaping enabled.
from <- Parser.ExternalCode.extCodeFilePathString
return Wasp.JsImport.JsImport
{ Wasp.JsImport._defaultImport = defaultImport
, Wasp.JsImport._namedImports = namedImports
, Wasp.JsImport._from = from
}
L.whiteSpace
_ <- L.reserved L.reservedNameImport
-- For now we support only default import or one named import.
(defaultImport, namedImports) <-
((\i -> (Just i, [])) <$> L.identifier)
<|> ((\i -> (Nothing, [i])) <$> L.braces L.identifier)
_ <- L.reserved L.reservedNameFrom
-- TODO: For now we only support double quotes here, we should also support single quotes.
-- We would need to write this from scratch, with single quote escaping enabled.
from <- Parser.ExternalCode.extCodeFilePathString
return
Wasp.JsImport.JsImport
{ Wasp.JsImport._defaultImport = defaultImport,
Wasp.JsImport._namedImports = namedImports,
Wasp.JsImport._from = from
}

46
waspc/src/Parser/NpmDependencies.hs
View File

@ -1,31 +1,31 @@
module Parser.NpmDependencies
( npmDependencies
) where
( npmDependencies,
)
where
import qualified Data.Aeson as Aeson
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.UTF8 as BLU
import qualified Data.HashMap.Strict as M
import Text.Parsec (try)
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified NpmDependency as ND
import qualified Parser.Common as P
import Wasp.NpmDependencies (NpmDependencies)
import qualified Wasp.NpmDependencies as NpmDependencies
import qualified Data.HashMap.Strict as M
import qualified Lexer as L
import qualified NpmDependency as ND
import qualified Parser.Common as P
import Text.Parsec (try)
import Text.Parsec.String (Parser)
import Wasp.NpmDependencies (NpmDependencies)
import qualified Wasp.NpmDependencies as NpmDependencies
npmDependencies :: Parser NpmDependencies
npmDependencies = try $ do
L.reserved L.reservedNameDependencies
closureContent <- P.waspNamedClosure "json"
let jsonBytestring = BLU.fromString $ "{ " ++ closureContent ++ " }"
npmDeps <- case Aeson.eitherDecode' jsonBytestring :: Either String (M.HashMap String String) of
Left errorMessage -> fail $ "Failed to parse dependencies JSON: " ++ errorMessage
Right rawDeps -> return $ map rawDepToNpmDep (M.toList rawDeps)
return NpmDependencies.NpmDependencies
{ NpmDependencies._dependencies = npmDeps
}
L.reserved L.reservedNameDependencies
closureContent <- P.waspNamedClosure "json"
let jsonBytestring = BLU.fromString $ "{ " ++ closureContent ++ " }"
npmDeps <- case Aeson.eitherDecode' jsonBytestring :: Either String (M.HashMap String String) of
Left errorMessage -> fail $ "Failed to parse dependencies JSON: " ++ errorMessage
Right rawDeps -> return $ map rawDepToNpmDep (M.toList rawDeps)
return
NpmDependencies.NpmDependencies
{ NpmDependencies._dependencies = npmDeps
}
where
rawDepToNpmDep :: (String, String) -> ND.NpmDependency
rawDepToNpmDep (name, version) = ND.NpmDependency { ND._name = name, ND._version = version }
rawDepToNpmDep (name, version) = ND.NpmDependency {ND._name = name, ND._version = version}

39
waspc/src/Parser/Operation.hs
View File

@ -1,31 +1,32 @@
module Parser.Operation
( jsFunctionPropParser
, entitiesPropParser
, getJsFunctionFromProps
, getEntitiesFromProps
, properties
( jsFunctionPropParser,
entitiesPropParser,
getJsFunctionFromProps,
getEntitiesFromProps,
properties,
-- FOR TESTS:
, Property(..)
) where
Property (..),
)
where
import Data.Maybe (listToMaybe)
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified Parser.Common as C
import Data.Maybe (listToMaybe)
import qualified Lexer as L
import qualified Parser.Common as C
import qualified Parser.JsImport
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Wasp.JsImport
data Property = JsFunction !Wasp.JsImport.JsImport
| Entities ![String]
deriving (Show, Eq)
data Property
= JsFunction !Wasp.JsImport.JsImport
| Entities ![String]
deriving (Show, Eq)
properties :: Parser [Property]
properties = L.commaSep1 $
properties =
L.commaSep1 $
jsFunctionPropParser
<|> entitiesPropParser
<|> entitiesPropParser
jsFunctionPropParser :: Parser Property
jsFunctionPropParser = JsFunction <$> C.waspProperty "fn" Parser.JsImport.jsImport

45
waspc/src/Parser/Page.hs
View File

@ -1,30 +1,30 @@
module Parser.Page
( page
) where
import Text.Parsec
import Text.Parsec.String (Parser)
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Wasp.Page as Page
import Wasp.JsImport (JsImport)
( page,
)
where
import Data.Maybe (fromMaybe, listToMaybe)
import Lexer
import Parser.Common
import qualified Parser.JsImport
import Text.Parsec
import Text.Parsec.String (Parser)
import Wasp.JsImport (JsImport)
import qualified Wasp.Page as Page
data PageProperty
= Title !String
| Component !JsImport
| AuthRequired !Bool
deriving (Show, Eq)
= Title !String
| Component !JsImport
| AuthRequired !Bool
deriving (Show, Eq)
-- | Parses Page properties, separated by a comma.
pageProperties :: Parser [PageProperty]
pageProperties = commaSep1 $
pageProperties =
commaSep1 $
pagePropertyTitle
<|> pagePropertyComponent
<|> pagePropertyAuthRequired
<|> pagePropertyComponent
<|> pagePropertyAuthRequired
-- NOTE(matija): this is currently unused?
pagePropertyTitle :: Parser PageProperty
@ -45,10 +45,11 @@ getPageComponent ps = listToMaybe [c | Component c <- ps]
-- | Top level parser, parses Page.
page :: Parser Page.Page
page = do
(pageName, pageProps) <- waspElementNameAndClosureContent reservedNamePage pageProperties
(pageName, pageProps) <- waspElementNameAndClosureContent reservedNamePage pageProperties
return Page.Page
{ Page._name = pageName
, Page._component = fromMaybe (error "Page component is missing.") (getPageComponent pageProps)
, Page._authRequired = getPageAuthRequired pageProps
}
return
Page.Page
{ Page._name = pageName,
Page._component = fromMaybe (error "Page component is missing.") (getPageComponent pageProps),
Page._authRequired = getPageAuthRequired pageProps
}

36
waspc/src/Parser/Query.hs
View File

@ -1,23 +1,23 @@
module Parser.Query
( query
) where
import Data.Maybe (fromMaybe)
import Text.Parsec.String (Parser)
import qualified Lexer as L
import qualified Parser.Common as C
import qualified Parser.Operation as Operation
import Wasp.Query (Query)
import qualified Wasp.Query as Query
( query,
)
where
import Data.Maybe (fromMaybe)
import qualified Lexer as L
import qualified Parser.Common as C
import qualified Parser.Operation as Operation
import Text.Parsec.String (Parser)
import Wasp.Query (Query)
import qualified Wasp.Query as Query
query :: Parser Query
query = do
(name, props) <- C.waspElementNameAndClosureContent L.reservedNameQuery Operation.properties
return Query.Query
{ Query._name = name
, Query._jsFunction =
fromMaybe (error "Query js function is missing.") (Operation.getJsFunctionFromProps props)
, Query._entities = Operation.getEntitiesFromProps props
}
(name, props) <- C.waspElementNameAndClosureContent L.reservedNameQuery Operation.properties
return
Query.Query
{ Query._name = name,
Query._jsFunction =
fromMaybe (error "Query js function is missing.") (Operation.getJsFunctionFromProps props),
Query._entities = Operation.getEntitiesFromProps props
}

32
waspc/src/Parser/Route.hs
View File

@ -1,26 +1,26 @@
module Parser.Route
( route
) where
import Text.Parsec.String (Parser)
( route,
)
where
import qualified Lexer as L
import Text.Parsec.String (Parser)
import qualified Wasp.Route as Route
-- | Top level parser, parses route Wasp element.
route :: Parser Route.Route
route = do
-- route "some/url/path"
L.reserved L.reservedNameRoute
urlPath <- L.stringLiteral
-- route "some/url/path"
L.reserved L.reservedNameRoute
urlPath <- L.stringLiteral
-- -> page somePage
L.reserved "->"
L.reserved L.reservedNamePage
targetPage <- L.identifier
return Route.Route
{ Route._urlPath = urlPath
, Route._targetPage = targetPage
}
-- -> page somePage
L.reserved "->"
L.reserved L.reservedNamePage
targetPage <- L.identifier
return
Route.Route
{ Route._urlPath = urlPath,
Route._targetPage = targetPage
}

11
waspc/src/Parser/Style.hs
View File

@ -1,16 +1,15 @@
module Parser.Style
( style
) where
( style,
)
where
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Data.Text as Text
import qualified Parser.Common
import qualified Parser.ExternalCode
import Text.Parsec ((<|>))
import Text.Parsec.String (Parser)
import qualified Wasp.Style
style :: Parser Wasp.Style.Style
style = cssFile <|> cssCode

16
waspc/src/Path/Extra.hs
View File

@ -1,11 +1,12 @@
module Path.Extra
( reversePosixPath
, toPosixFilePath
) where
( reversePosixPath,
toPosixFilePath,
)
where
import Control.Exception (assert)
import qualified System.FilePath.Posix as FPP
import Path
import qualified System.FilePath.Posix as FPP
-- | For given posix path P, returns posix path P', such that (terminal pseudocode incoming)
-- `pwd == (cd P && cd P' && pwd)`, or to put it differently, such that
@ -14,9 +15,10 @@ import Path
-- (e.g. reversePath "foo/bar" == "../..").
reversePosixPath :: FilePath -> FilePath
reversePosixPath path
| null parts = "."
| otherwise = assert (".." `notElem` parts) $
FPP.joinPath $ map (const "..") parts
| null parts = "."
| otherwise =
assert (".." `notElem` parts) $
FPP.joinPath $ map (const "..") parts
where
parts :: [String]
parts = filter (/= ".") $ FPP.splitDirectories path

77
waspc/src/Psl/Ast/Model.hs
View File

@ -1,42 +1,45 @@
module Psl.Ast.Model where
data Model = Model
String -- ^ Name of the model
Body
deriving (Show, Eq)
data Model
= Model
String
-- ^ Name of the model
Body
deriving (Show, Eq)
newtype Body = Body [Element]
deriving (Show, Eq)
deriving (Show, Eq)
data Element = ElementField Field | ElementBlockAttribute Attribute
deriving (Show, Eq)
deriving (Show, Eq)
-- TODO: To support attributes before the field,
-- we could just have `attrsBefore :: [[Attr]]`,
-- which represents lines, each one with list of attributes.
data Field = Field
{ _name :: String
, _type :: FieldType
, _typeModifiers :: [FieldTypeModifier]
, _attrs :: [Attribute]
}
deriving (Show, Eq)
{ _name :: String,
_type :: FieldType,
_typeModifiers :: [FieldTypeModifier],
_attrs :: [Attribute]
}
deriving (Show, Eq)
data FieldType = String
| Boolean
| Int
| BigInt
| Float
| Decimal
| DateTime
| Json
| Bytes
| Unsupported String
| UserType String
deriving (Show, Eq)
data FieldType
= String
| Boolean
| Int
| BigInt
| Float
| Decimal
| DateTime
| Json
| Bytes
| Unsupported String
| UserType String
deriving (Show, Eq)
data FieldTypeModifier = List | Optional
deriving (Show, Eq)
deriving (Show, Eq)
-- NOTE: We don't differentiate "native database type" attributes from normal attributes right now,
-- they are all represented with `data Attribute`.
@ -44,19 +47,19 @@ data FieldTypeModifier = List | Optional
-- TODO: In the future, we might want to be "smarter" about this and actually have a special representation
-- for them -> but let's see if that will be needed.
data Attribute = Attribute
{ _attrName :: String
, _attrArgs :: [AttributeArg]
}
deriving (Show, Eq)
{ _attrName :: String,
_attrArgs :: [AttributeArg]
}
deriving (Show, Eq)
data AttributeArg = AttrArgNamed String AttrArgValue | AttrArgUnnamed AttrArgValue
deriving (Show, Eq)
deriving (Show, Eq)
data AttrArgValue
= AttrArgString String
| AttrArgIdentifier String
| AttrArgFunc String
| AttrArgFieldRefList [String]
| AttrArgNumber String
| AttrArgUnknown String
deriving (Show, Eq)
= AttrArgString String
| AttrArgIdentifier String
| AttrArgFunc String
| AttrArgFieldRefList [String]
| AttrArgNumber String
| AttrArgUnknown String
deriving (Show, Eq)

60
waspc/src/Psl/Generator/Model.hs
View File

@ -1,12 +1,11 @@
module Psl.Generator.Model
( generateModel
) where
import Data.List (intercalate)
( generateModel,
)
where
import Data.List (intercalate)
import qualified Psl.Ast.Model as Ast
generateModel :: Ast.Model -> String
generateModel (Ast.Model name body) = "model " ++ name ++ " {\n" ++ generateBody body ++ "\n}"
@ -15,37 +14,38 @@ generateBody (Ast.Body elements) = unlines $ map ((" " ++) . generateElement) e
generateElement :: Ast.Element -> String
generateElement (Ast.ElementField field) =
Ast._name field ++ " "
++ generateFieldType (Ast._type field) ++ concatMap generateFieldTypeModifier (Ast._typeModifiers field)
Ast._name field ++ " "
++ generateFieldType (Ast._type field)
++ concatMap generateFieldTypeModifier (Ast._typeModifiers field)
++ concatMap ((" " ++) . generateAttribute) (Ast._attrs field)
generateElement (Ast.ElementBlockAttribute attribute) =
"@" ++ generateAttribute attribute
"@" ++ generateAttribute attribute
generateFieldType :: Ast.FieldType -> String
generateFieldType fieldType = case fieldType of
Ast.String -> "String"
Ast.Boolean -> "Boolean"
Ast.Int -> "Int"
Ast.BigInt -> "BigInt"
Ast.Float -> "Float"
Ast.Decimal -> "Decimal"
Ast.DateTime -> "DateTime"
Ast.Json -> "Json"
Ast.Bytes -> "Bytes"
Ast.UserType label -> label
Ast.Unsupported typeName -> "Unsupported(" ++ show typeName ++ ")"
Ast.String -> "String"
Ast.Boolean -> "Boolean"
Ast.Int -> "Int"
Ast.BigInt -> "BigInt"
Ast.Float -> "Float"
Ast.Decimal -> "Decimal"
Ast.DateTime -> "DateTime"
Ast.Json -> "Json"
Ast.Bytes -> "Bytes"
Ast.UserType label -> label
Ast.Unsupported typeName -> "Unsupported(" ++ show typeName ++ ")"
generateFieldTypeModifier :: Ast.FieldTypeModifier -> String
generateFieldTypeModifier typeModifier = case typeModifier of
Ast.List -> "[]"
Ast.Optional -> "?"
Ast.List -> "[]"
Ast.Optional -> "?"
generateAttribute :: Ast.Attribute -> String
generateAttribute attribute =
"@" ++ Ast._attrName attribute
"@" ++ Ast._attrName attribute
++ if null (Ast._attrArgs attribute)
then ""
else "(" ++ intercalate ", " (map generateAttributeArg (Ast._attrArgs attribute)) ++ ")"
then ""
else "(" ++ intercalate ", " (map generateAttributeArg (Ast._attrArgs attribute)) ++ ")"
generateAttributeArg :: Ast.AttributeArg -> String
generateAttributeArg (Ast.AttrArgNamed name value) = name ++ ": " ++ generateAttrArgValue value
@ -53,12 +53,12 @@ generateAttributeArg (Ast.AttrArgUnnamed value) = generateAttrArgValue value
generateAttrArgValue :: Ast.AttrArgValue -> String
generateAttrArgValue value = case value of
Ast.AttrArgString strValue -> show strValue
Ast.AttrArgIdentifier identifier -> identifier
Ast.AttrArgFunc funcName -> funcName ++ "()"
Ast.AttrArgFieldRefList refs -> "[" ++ intercalate ", " refs ++ "]"
Ast.AttrArgNumber numberStr -> numberStr
Ast.AttrArgUnknown unknownStr -> unknownStr
Ast.AttrArgString strValue -> show strValue
Ast.AttrArgIdentifier identifier -> identifier
Ast.AttrArgFunc funcName -> funcName ++ "()"
Ast.AttrArgFieldRefList refs -> "[" ++ intercalate ", " refs ++ "]"
Ast.AttrArgNumber numberStr -> numberStr
Ast.AttrArgUnknown unknownStr -> unknownStr
-- TODO: I should make sure to skip attributes that are not known in prisma.
-- Or maybe it would be better if that was done in previous step, where

219
waspc/src/Psl/Parser/Model.hs
View File

@ -1,19 +1,30 @@
module Psl.Parser.Model
( model
, body
( model,
body,
-- NOTE: Only for testing:
, attrArgument
) where
attrArgument,
)
where
import Data.Maybe (fromMaybe, maybeToList)
import Text.Parsec (alphaNum, char, choice, letter,
lookAhead, many, many1, noneOf, oneOf,
optionMaybe, try, (<|>))
import Text.Parsec.Language (emptyDef)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as T
import qualified Psl.Ast.Model as Model
import Data.Maybe (fromMaybe, maybeToList)
import qualified Psl.Ast.Model as Model
import Text.Parsec
( alphaNum,
char,
choice,
letter,
lookAhead,
many,
many1,
noneOf,
oneOf,
optionMaybe,
try,
(<|>),
)
import Text.Parsec.Language (emptyDef)
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as T
-- | Parses PSL (Prisma Schema Language model).
-- Example of PSL model:
@ -24,123 +35,133 @@ import qualified Psl.Ast.Model as Model
-- }
model :: Parser Model.Model
model = do
T.whiteSpace lexer
_ <- T.symbol lexer "model"
modelName <- T.identifier lexer
Model.Model modelName <$> T.braces lexer body
T.whiteSpace lexer
_ <- T.symbol lexer "model"
modelName <- T.identifier lexer
Model.Model modelName <$> T.braces lexer body
-- | Parses body of the PSL (Prisma Schema Language) model,
-- which is everything besides model keyword, name and braces:
-- `model User { <body> }`.
body :: Parser Model.Body
body = do
T.whiteSpace lexer
Model.Body <$> many1 element
T.whiteSpace lexer
Model.Body <$> many1 element
element :: Parser Model.Element
element = try (Model.ElementField <$> field) <|>
try (Model.ElementBlockAttribute <$> blockAttribute)
element =
try (Model.ElementField <$> field)
<|> try (Model.ElementBlockAttribute <$> blockAttribute)
field :: Parser Model.Field
field = do
name <- T.identifier lexer
type' <- fieldType
maybeTypeModifier <- fieldTypeModifier
attrs <- many (try attribute)
return $ Model.Field
{ Model._name = name
, Model._type = type'
, Model._typeModifiers = maybeToList maybeTypeModifier
, Model._attrs = attrs
}
name <- T.identifier lexer
type' <- fieldType
maybeTypeModifier <- fieldTypeModifier
attrs <- many (try attribute)
return $
Model.Field
{ Model._name = name,
Model._type = type',
Model._typeModifiers = maybeToList maybeTypeModifier,
Model._attrs = attrs
}
where
fieldType :: Parser Model.FieldType
fieldType =
(foldl1 (<|>) $
map (\(s, t) -> try (T.symbol lexer s) >> return t)
[ ("String", Model.String)
, ("Boolean", Model.Boolean)
, ("Int", Model.Int)
, ("BigInt", Model.BigInt)
, ("Float", Model.Float)
, ("Decimal", Model.Decimal)
, ("DateTime", Model.DateTime)
, ("Json", Model.Json)
, ("Bytes", Model.Bytes)
]
)
( foldl1 (<|>) $
map
(\(s, t) -> try (T.symbol lexer s) >> return t)
[ ("String", Model.String),
("Boolean", Model.Boolean),
("Int", Model.Int),
("BigInt", Model.BigInt),
("Float", Model.Float),
("Decimal", Model.Decimal),
("DateTime", Model.DateTime),
("Json", Model.Json),
("Bytes", Model.Bytes)
]
)
<|> (try $ Model.Unsupported <$> (T.symbol lexer "Unsupported" >> T.parens lexer (T.stringLiteral lexer)))
<|> Model.UserType <$> T.identifier lexer
-- NOTE: As is Prisma currently implemented, there can be only one type modifier at one time: [] or ?.
fieldTypeModifier :: Parser (Maybe Model.FieldTypeModifier)
fieldTypeModifier = optionMaybe
( (try (T.brackets lexer (T.whiteSpace lexer)) >> return Model.List) <|>
(try (T.symbol lexer "?") >> return Model.Optional)
fieldTypeModifier =
optionMaybe
( (try (T.brackets lexer (T.whiteSpace lexer)) >> return Model.List)
<|> (try (T.symbol lexer "?") >> return Model.Optional)
)
attribute :: Parser Model.Attribute
attribute = do
_ <- char '@'
name <- T.identifier lexer
-- NOTE: we support potential "selector" in order to support native database type attributes.
-- These have names with single . in them, like this: @db.VarChar(200), @db.TinyInt(1), ... .
-- We are not trying to be very smart here though: we don't check that "db" part matches
-- the name of the datasource block name (as it should), and we don't check that "VarChar" part is PascalCase
-- (as it should be) or that it is one of the valid values.
-- We just treat it as any other attribute, where "db.VarChar" becomes an attribute name.
-- In case that we wanted to be smarter, we could expand the AST to have special representation for it.
-- Also, we could do some additional checks here in parser (PascalCase), and some additional checks
-- in th generator ("db" matching the datasource block name).
maybeSelector <- optionMaybe $ try $ char '.' >> T.identifier lexer
_ <- char '@'
name <- T.identifier lexer
-- NOTE: we support potential "selector" in order to support native database type attributes.
-- These have names with single . in them, like this: @db.VarChar(200), @db.TinyInt(1), ... .
-- We are not trying to be very smart here though: we don't check that "db" part matches
-- the name of the datasource block name (as it should), and we don't check that "VarChar" part is PascalCase
-- (as it should be) or that it is one of the valid values.
-- We just treat it as any other attribute, where "db.VarChar" becomes an attribute name.
-- In case that we wanted to be smarter, we could expand the AST to have special representation for it.
-- Also, we could do some additional checks here in parser (PascalCase), and some additional checks
-- in th generator ("db" matching the datasource block name).
maybeSelector <- optionMaybe $ try $ char '.' >> T.identifier lexer
maybeArgs <- optionMaybe (T.parens lexer (T.commaSep1 lexer (try attrArgument)))
return $ Model.Attribute
{ Model._attrName = case maybeSelector of
Just selector -> name ++ "." ++ selector
Nothing -> name
, Model._attrArgs = fromMaybe [] maybeArgs
}
maybeArgs <- optionMaybe (T.parens lexer (T.commaSep1 lexer (try attrArgument)))
return $
Model.Attribute
{ Model._attrName = case maybeSelector of
Just selector -> name ++ "." ++ selector
Nothing -> name,
Model._attrArgs = fromMaybe [] maybeArgs
}
-- Parses attribute argument that ends with delimiter: , or ).
-- Doesn't parse the delimiter.
attrArgument :: Parser Model.AttributeArg
attrArgument = do
arg <- try namedArg <|> try unnamedArg
return arg
arg <- try namedArg <|> try unnamedArg
return arg
where
namedArg :: Parser Model.AttributeArg
namedArg = do
name <- T.identifier lexer
_ <- T.colon lexer
Model.AttrArgNamed name <$> argValue
name <- T.identifier lexer
_ <- T.colon lexer
Model.AttrArgNamed name <$> argValue
unnamedArg :: Parser Model.AttributeArg
unnamedArg = Model.AttrArgUnnamed <$> argValue
argValue :: Parser Model.AttrArgValue
argValue = choice $ map (try . delimitedArgValue)
[ argValueString
, argValueFunc
, argValueFieldReferenceList
, argValueNumberFloat
, argValueNumberInt
, argValueIdentifier
, argValueUnknown
]
argValue =
choice $
map
(try . delimitedArgValue)
[ argValueString,
argValueFunc,
argValueFieldReferenceList,
argValueNumberFloat,
argValueNumberInt,
argValueIdentifier,
argValueUnknown
]
argValueString :: Parser Model.AttrArgValue
argValueString = Model.AttrArgString <$> T.stringLiteral lexer
argValueFunc :: Parser Model.AttrArgValue
argValueFunc = do -- TODO: Could I implement this with applicative?
name <- T.identifier lexer
T.parens lexer $ T.whiteSpace lexer
return $ Model.AttrArgFunc name
argValueFunc = do
-- TODO: Could I implement this with applicative?
name <- T.identifier lexer
T.parens lexer $ T.whiteSpace lexer
return $ Model.AttrArgFunc name
argValueFieldReferenceList :: Parser Model.AttrArgValue
argValueFieldReferenceList = Model.AttrArgFieldRefList <$>
(T.brackets lexer $ T.commaSep1 lexer $ T.identifier lexer)
argValueFieldReferenceList =
Model.AttrArgFieldRefList
<$> (T.brackets lexer $ T.commaSep1 lexer $ T.identifier lexer)
-- NOTE: For now we are not supporting negative numbers.
-- I couldn't figure out from Prisma docs if there could be the case
@ -157,16 +178,16 @@ attrArgument = do
argValueIdentifier :: Parser Model.AttrArgValue
argValueIdentifier = Model.AttrArgIdentifier <$> T.identifier lexer
-- | Our "wildcard" -> tries to capture anything.
argValueUnknown :: Parser Model.AttrArgValue
argValueUnknown = Model.AttrArgUnknown <$>
(many1 $ try $ noneOf argDelimiters)
argValueUnknown =
Model.AttrArgUnknown
<$> (many1 $ try $ noneOf argDelimiters)
delimitedArgValue :: Parser Model.AttrArgValue -> Parser Model.AttrArgValue
delimitedArgValue argValueP = do
value <- argValueP
_ <- lookAhead $ oneOf argDelimiters
return value
value <- argValueP
_ <- lookAhead $ oneOf argDelimiters
return value
argDelimiters = [',', ')']
@ -174,9 +195,11 @@ blockAttribute :: Parser Model.Attribute
blockAttribute = char '@' >> attribute
lexer :: T.TokenParser ()
lexer = T.makeTokenParser emptyDef
{ T.commentLine = "//"
, T.caseSensitive = True
, T.identStart = letter
, T.identLetter = alphaNum <|> char '_'
}
lexer =
T.makeTokenParser
emptyDef
{ T.commentLine = "//",
T.caseSensitive = True,
T.identStart = letter,
T.identLetter = alphaNum <|> char '_'
}

495
waspc/src/StrongPath.hs
View File

@ -1,49 +1,87 @@
{-# LANGUAGE PartialTypeSignatures #-}
module StrongPath
( Path, Path'
, Abs, Rel, Dir, File, File'
, System, Windows, Posix
( Path,
Path',
Abs,
Rel,
Dir,
File,
File',
System,
Windows,
Posix,
parseRelDir,
parseRelFile,
parseAbsDir,
parseAbsFile,
parseRelDirW,
parseRelFileW,
parseAbsDirW,
parseAbsFileW,
parseRelDirP,
parseRelFileP,
parseAbsDirP,
parseAbsFileP,
fromPathRelDir,
fromPathRelFile,
fromPathAbsDir,
fromPathAbsFile,
fromPathRelDirW,
fromPathRelFileW,
fromPathAbsDirW,
fromPathAbsFileW,
fromPathRelDirP,
fromPathRelFileP,
fromPathAbsDirP,
fromPathAbsFileP,
toPathRelDir,
toPathRelFile,
toPathAbsDir,
toPathAbsFile,
toPathRelDirW,
toPathRelFileW,
toPathAbsDirW,
toPathAbsFileW,
toPathRelDirP,
toPathRelFileP,
toPathAbsDirP,
toPathAbsFileP,
fromRelDir,
fromRelFile,
fromAbsDir,
fromAbsFile,
fromRelDirP,
fromRelFileP,
fromAbsDirP,
fromAbsFileP,
fromRelDirW,
fromRelFileW,
fromAbsDirW,
fromAbsFileW,
toFilePath,
(</>),
castRel,
castDir,
parent,
relDirToPosix,
relFileToPosix,
relDirToPosix',
relFileToPosix',
)
where
, parseRelDir, parseRelFile, parseAbsDir, parseAbsFile
, parseRelDirW, parseRelFileW, parseAbsDirW, parseAbsFileW
, parseRelDirP, parseRelFileP, parseAbsDirP, parseAbsFileP
, fromPathRelDir, fromPathRelFile, fromPathAbsDir, fromPathAbsFile
, fromPathRelDirW, fromPathRelFileW, fromPathAbsDirW, fromPathAbsFileW
, fromPathRelDirP, fromPathRelFileP, fromPathAbsDirP, fromPathAbsFileP
, toPathRelDir, toPathRelFile, toPathAbsDir, toPathAbsFile
, toPathRelDirW, toPathRelFileW, toPathAbsDirW, toPathAbsFileW
, toPathRelDirP, toPathRelFileP, toPathAbsDirP, toPathAbsFileP
, fromRelDir, fromRelFile, fromAbsDir, fromAbsFile
, fromRelDirP, fromRelFileP, fromAbsDirP, fromAbsFileP
, fromRelDirW, fromRelFileW, fromAbsDirW, fromAbsFileW
, toFilePath
, (</>)
, castRel, castDir
, parent
, relDirToPosix, relFileToPosix, relDirToPosix', relFileToPosix'
) where
import Control.Monad.Catch (MonadThrow)
import Data.List (intercalate)
import Data.Maybe (fromJust)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW
import qualified System.FilePath as FP
import qualified System.FilePath.Posix as FPP
import Control.Monad.Catch (MonadThrow)
import Data.List (intercalate)
import Data.Maybe (fromJust)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW
import StrongPath.Internal
import qualified System.FilePath as FP
import qualified System.FilePath.Posix as FPP
import qualified System.FilePath.Windows as FPW
import StrongPath.Internal
-- TODO: We still depend on Path for creating hardcoded paths via generics. Any way to go around that?
-- Maybe implement our own mechanism for that, so that people don't have to know about / use Path?
-- This means we would implement our own [reldir|foobar|] stuff.
@ -78,87 +116,109 @@ import StrongPath.Internal
-- so compiler does not differentiate them (because they are all exporting the same module containing Path),
-- but Path.Windows.Rel and Path.Posix.Rel (and same for Abs/Dir/File) are not the same,
-- because they are done via Include mechanism.
fromPathRelDir :: P.Path P.Rel P.Dir -> Path' System (Rel a) (Dir b)
fromPathRelFile :: P.Path P.Rel P.File -> Path' System (Rel a) (File' f)
fromPathAbsDir :: P.Path P.Abs P.Dir -> Path' System Abs (Dir a)
fromPathAbsFile :: P.Path P.Abs P.File -> Path' System Abs (File' f)
fromPathRelDirW :: PW.Path PW.Rel PW.Dir -> Path' Windows (Rel a) (Dir b)
fromPathRelDir :: P.Path P.Rel P.Dir -> Path' System (Rel a) (Dir b)
fromPathRelFile :: P.Path P.Rel P.File -> Path' System (Rel a) (File' f)
fromPathAbsDir :: P.Path P.Abs P.Dir -> Path' System Abs (Dir a)
fromPathAbsFile :: P.Path P.Abs P.File -> Path' System Abs (File' f)
fromPathRelDirW :: PW.Path PW.Rel PW.Dir -> Path' Windows (Rel a) (Dir b)
fromPathRelFileW :: PW.Path PW.Rel PW.File -> Path' Windows (Rel a) (File' f)
fromPathAbsDirW :: PW.Path PW.Abs PW.Dir -> Path' Windows Abs (Dir a)
fromPathAbsFileW :: PW.Path PW.Abs PW.File -> Path' Windows Abs (File' f)
fromPathRelDirP :: PP.Path PP.Rel PP.Dir -> Path' Posix (Rel a) (Dir b)
fromPathRelFileP :: PP.Path PP.Rel PP.File -> Path' Posix (Rel a) (File' f)
fromPathAbsDirP :: PP.Path PP.Abs PP.Dir -> Path' Posix Abs (Dir a)
fromPathAbsFileP :: PP.Path PP.Abs PP.File -> Path' Posix Abs (File' f)
fromPathAbsDirW :: PW.Path PW.Abs PW.Dir -> Path' Windows Abs (Dir a)
fromPathAbsFileW :: PW.Path PW.Abs PW.File -> Path' Windows Abs (File' f)
fromPathRelDirP :: PP.Path PP.Rel PP.Dir -> Path' Posix (Rel a) (Dir b)
fromPathRelFileP :: PP.Path PP.Rel PP.File -> Path' Posix (Rel a) (File' f)
fromPathAbsDirP :: PP.Path PP.Abs PP.Dir -> Path' Posix Abs (Dir a)
fromPathAbsFileP :: PP.Path PP.Abs PP.File -> Path' Posix Abs (File' f)
---- System
fromPathRelDir p = RelDir p NoPrefix
fromPathRelFile p = RelFile p NoPrefix
fromPathAbsDir = AbsDir
fromPathAbsFile = AbsFile
fromPathRelDir p = RelDir p NoPrefix
fromPathRelFile p = RelFile p NoPrefix
fromPathAbsDir = AbsDir
fromPathAbsFile = AbsFile
---- Windows
fromPathRelDirW p = RelDirW p NoPrefix
fromPathRelFileW p = RelFileW p NoPrefix
fromPathAbsDirW = AbsDirW
fromPathAbsDirW = AbsDirW
fromPathAbsFileW = AbsFileW
---- Posix
fromPathRelDirP p = RelDirP p NoPrefix
fromPathRelFileP p = RelFileP p NoPrefix
fromPathAbsDirP = AbsDirP
fromPathAbsDirP = AbsDirP
fromPathAbsFileP = AbsFileP
-- TODO: Should I go with MonadThrow here instead of just throwing error? Probably!
-- I could, as error, return actual Path + info on how many ../ were there in StrongPath,
-- so user can recover from error and continue, if they wish.
-- Deconstructors
toPathRelDir :: Path' System (Rel a) (Dir b) -> P.Path P.Rel P.Dir
toPathRelFile :: Path' System (Rel a) (File' f) -> P.Path P.Rel P.File
toPathAbsDir :: Path' System Abs (Dir a) -> P.Path P.Abs P.Dir
toPathAbsFile :: Path' System Abs (File' f) -> P.Path P.Abs P.File
toPathRelDirW :: Path' Windows (Rel a) (Dir b) -> PW.Path PW.Rel PW.Dir
toPathRelDir :: Path' System (Rel a) (Dir b) -> P.Path P.Rel P.Dir
toPathRelFile :: Path' System (Rel a) (File' f) -> P.Path P.Rel P.File
toPathAbsDir :: Path' System Abs (Dir a) -> P.Path P.Abs P.Dir
toPathAbsFile :: Path' System Abs (File' f) -> P.Path P.Abs P.File
toPathRelDirW :: Path' Windows (Rel a) (Dir b) -> PW.Path PW.Rel PW.Dir
toPathRelFileW :: Path' Windows (Rel a) (File' f) -> PW.Path PW.Rel PW.File
toPathAbsDirW :: Path' Windows Abs (Dir a) -> PW.Path PW.Abs PW.Dir
toPathAbsFileW :: Path' Windows Abs (File' f) -> PW.Path PW.Abs PW.File
toPathRelDirP :: Path' Posix (Rel a) (Dir b) -> PP.Path PP.Rel PP.Dir
toPathRelFileP :: Path' Posix (Rel a) (File' f) -> PP.Path PP.Rel PP.File
toPathAbsDirP :: Path' Posix Abs (Dir a) -> PP.Path PP.Abs PP.Dir
toPathAbsFileP :: Path' Posix Abs (File' f) -> PP.Path PP.Abs PP.File
toPathAbsDirW :: Path' Windows Abs (Dir a) -> PW.Path PW.Abs PW.Dir
toPathAbsFileW :: Path' Windows Abs (File' f) -> PW.Path PW.Abs PW.File
toPathRelDirP :: Path' Posix (Rel a) (Dir b) -> PP.Path PP.Rel PP.Dir
toPathRelFileP :: Path' Posix (Rel a) (File' f) -> PP.Path PP.Rel PP.File
toPathAbsDirP :: Path' Posix Abs (Dir a) -> PP.Path PP.Abs PP.Dir
toPathAbsFileP :: Path' Posix Abs (File' f) -> PP.Path PP.Abs PP.File
---- System
toPathRelDir (RelDir p NoPrefix) = p
toPathRelDir (RelDir _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDir _ = impossible
toPathRelDir (RelDir _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDir _ = impossible
toPathRelFile (RelFile p NoPrefix) = p
toPathRelFile (RelFile _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFile _ = impossible
toPathRelFile (RelFile _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFile _ = impossible
toPathAbsDir (AbsDir p) = p
toPathAbsDir _ = impossible
toPathAbsDir _ = impossible
toPathAbsFile (AbsFile p) = p
toPathAbsFile _ = impossible
toPathAbsFile _ = impossible
---- Windows
toPathRelDirW (RelDirW p NoPrefix) = p
toPathRelDirW (RelDirW _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDirW _ = impossible
toPathRelDirW (RelDirW _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDirW _ = impossible
toPathRelFileW (RelFileW p NoPrefix) = p
toPathRelFileW (RelFileW _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFileW _ = impossible
toPathRelFileW (RelFileW _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFileW _ = impossible
toPathAbsDirW (AbsDirW p) = p
toPathAbsDirW _ = impossible
toPathAbsDirW _ = impossible
toPathAbsFileW (AbsFileW p) = p
toPathAbsFileW _ = impossible
toPathAbsFileW _ = impossible
---- Posix
toPathRelDirP (RelDirP p NoPrefix) = p
toPathRelDirP (RelDirP _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDirP _ = impossible
toPathRelDirP (RelDirP _ _) = relativeStrongPathWithPrefixToPathError
toPathRelDirP _ = impossible
toPathRelFileP (RelFileP p NoPrefix) = p
toPathRelFileP (RelFileP _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFileP _ = impossible
toPathRelFileP (RelFileP _ _) = relativeStrongPathWithPrefixToPathError
toPathRelFileP _ = impossible
toPathAbsDirP (AbsDirP p) = p
toPathAbsDirP _ = impossible
toPathAbsDirP _ = impossible
toPathAbsFileP (AbsFileP p) = p
toPathAbsFileP _ = impossible
toPathAbsFileP _ = impossible
relativeStrongPathWithPrefixToPathError :: a
relativeStrongPathWithPrefixToPathError =
error "Relative StrongPath.Path with prefix can't be converted into Path.Path."
error "Relative StrongPath.Path with prefix can't be converted into Path.Path."
-- | Parsers.
-- How parsers work:
@ -173,60 +233,70 @@ relativeStrongPathWithPrefixToPathError =
-- NOTE: System/Posix* means that path has to be System with exception of separators
-- that can be Posix besides being System (but e.g. root can't be Posix).
-- Win/Posix* is analogous to System/Posix*.
parseRelDir :: MonadThrow m => FilePath -> m (Path' System (Rel d1) (Dir d2))
parseRelFile :: MonadThrow m => FilePath -> m (Path' System (Rel d) (File' f))
parseAbsDir :: MonadThrow m => FilePath -> m (Path' System Abs (Dir d))
parseAbsFile :: MonadThrow m => FilePath -> m (Path' System Abs (File' f))
parseRelDirW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d1) (Dir d2))
parseRelFileW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d) (File' f))
parseAbsDirW :: MonadThrow m => FilePath -> m (Path' Windows Abs (Dir d))
parseAbsFileW :: MonadThrow m => FilePath -> m (Path' Windows Abs (File' f))
parseRelDirP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d1) (Dir d2))
parseRelFileP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d) (File' f))
parseAbsDirP :: MonadThrow m => FilePath -> m (Path' Posix Abs (Dir d))
parseAbsFileP :: MonadThrow m => FilePath -> m (Path' Posix Abs (File' f))
parseRelDir :: MonadThrow m => FilePath -> m (Path' System (Rel d1) (Dir d2))
parseRelFile :: MonadThrow m => FilePath -> m (Path' System (Rel d) (File' f))
parseAbsDir :: MonadThrow m => FilePath -> m (Path' System Abs (Dir d))
parseAbsFile :: MonadThrow m => FilePath -> m (Path' System Abs (File' f))
parseRelDirW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d1) (Dir d2))
parseRelFileW :: MonadThrow m => FilePath -> m (Path' Windows (Rel d) (File' f))
parseAbsDirW :: MonadThrow m => FilePath -> m (Path' Windows Abs (Dir d))
parseAbsFileW :: MonadThrow m => FilePath -> m (Path' Windows Abs (File' f))
parseRelDirP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d1) (Dir d2))
parseRelFileP :: MonadThrow m => FilePath -> m (Path' Posix (Rel d) (File' f))
parseAbsDirP :: MonadThrow m => FilePath -> m (Path' Posix Abs (Dir d))
parseAbsFileP :: MonadThrow m => FilePath -> m (Path' Posix Abs (File' f))
---- System
parseRelDir = parseRelFP RelDir [FP.pathSeparator, FPP.pathSeparator] P.parseRelDir
parseRelDir = parseRelFP RelDir [FP.pathSeparator, FPP.pathSeparator] P.parseRelDir
parseRelFile = parseRelFP RelFile [FP.pathSeparator, FPP.pathSeparator] P.parseRelFile
parseAbsDir fp = fromPathAbsDir <$> P.parseAbsDir fp
parseAbsFile fp = fromPathAbsFile <$> P.parseAbsFile fp
---- Windows
parseRelDirW = parseRelFP RelDirW [FPW.pathSeparator, FPP.pathSeparator] PW.parseRelDir
parseRelFileW = parseRelFP RelFileW [FPW.pathSeparator, FPP.pathSeparator] PW.parseRelFile
parseAbsDirW fp = fromPathAbsDirW <$> PW.parseAbsDir fp
parseAbsFileW fp = fromPathAbsFileW <$> PW.parseAbsFile fp
---- Posix
parseRelDirP = parseRelFP RelDirP [FPP.pathSeparator] PP.parseRelDir
parseRelFileP = parseRelFP RelFileP [FPP.pathSeparator] PP.parseRelFile
parseAbsDirP fp = fromPathAbsDirP <$> PP.parseAbsDir fp
parseAbsFileP fp = fromPathAbsFileP <$> PP.parseAbsFile fp
parseRelFileP = parseRelFP RelFileP [FPP.pathSeparator] PP.parseRelFile
parseAbsDirP fp = fromPathAbsDirP <$> PP.parseAbsDir fp
parseAbsFileP fp = fromPathAbsFileP <$> PP.parseAbsFile fp
toFilePath :: Path' s b t -> FilePath
toFilePath sp = case sp of
---- System
RelDir p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p
RelFile p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p
AbsDir p -> P.toFilePath p
AbsFile p -> P.toFilePath p
---- Windows
RelDirW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p
RelFileW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p
AbsDirW p -> PW.toFilePath p
AbsFileW p -> PW.toFilePath p
---- Posix
RelDirP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p
RelFileP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p
AbsDirP p -> PP.toFilePath p
AbsFileP p -> PP.toFilePath p
---- System
RelDir p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p
RelFile p prefix -> relPathToFilePath P.toFilePath FP.pathSeparator prefix p
AbsDir p -> P.toFilePath p
AbsFile p -> P.toFilePath p
---- Windows
RelDirW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p
RelFileW p prefix -> relPathToFilePath PW.toFilePath FPW.pathSeparator prefix p
AbsDirW p -> PW.toFilePath p
AbsFileW p -> PW.toFilePath p
---- Posix
RelDirP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p
RelFileP p prefix -> relPathToFilePath PP.toFilePath FPP.pathSeparator prefix p
AbsDirP p -> PP.toFilePath p
AbsFileP p -> PP.toFilePath p
where
relPathToFilePath pathToFilePath sep prefix path =
combinePrefixWithPath sep (relPathPrefixToFilePath sep prefix) (pathToFilePath path)
combinePrefixWithPath sep (relPathPrefixToFilePath sep prefix) (pathToFilePath path)
relPathPrefixToFilePath :: Char -> RelPathPrefix -> FilePath
relPathPrefixToFilePath _ NoPrefix = ""
relPathPrefixToFilePath sep (ParentDir n) =
intercalate [sep] (replicate n "..") ++ [sep]
intercalate [sep] (replicate n "..") ++ [sep]
-- TODO: This function and helper functions above are somewhat too loose and hard to
-- follow, implement them in better way.
@ -234,56 +304,67 @@ toFilePath sp = case sp of
-- and it could also be empty.
combinePrefixWithPath :: Char -> String -> FilePath -> FilePath
combinePrefixWithPath sep prefix path
| path `elem` [".", ['.', sep], "./"] && not (null prefix) = prefix
| path `elem` [".", ['.', sep], "./"] && not (null prefix) = prefix
combinePrefixWithPath _ prefix path = prefix ++ path
-- These functions just call toFilePath, but their value is in
-- their type: they allow you to capture expected type of the strong path
-- that you want to convert into FilePath.
fromRelDir :: Path' System (Rel r) (Dir d) -> FilePath
fromRelDir = toFilePath
fromRelFile :: Path' System (Rel r) (File' f) -> FilePath
fromRelFile = toFilePath
fromAbsDir :: Path' System Abs (Dir d) -> FilePath
fromAbsDir = toFilePath
fromAbsFile :: Path' System Abs (File' f) -> FilePath
fromAbsFile = toFilePath
fromRelDirP :: Path' Posix (Rel r) (Dir d) -> FilePath
fromRelDirP = toFilePath
fromRelFileP :: Path' Posix (Rel r) (File' f) -> FilePath
fromRelDir :: Path' System (Rel r) (Dir d) -> FilePath
fromRelDir = toFilePath
fromRelFile :: Path' System (Rel r) (File' f) -> FilePath
fromRelFile = toFilePath
fromAbsDir :: Path' System Abs (Dir d) -> FilePath
fromAbsDir = toFilePath
fromAbsFile :: Path' System Abs (File' f) -> FilePath
fromAbsFile = toFilePath
fromRelDirP :: Path' Posix (Rel r) (Dir d) -> FilePath
fromRelDirP = toFilePath
fromRelFileP :: Path' Posix (Rel r) (File' f) -> FilePath
fromRelFileP = toFilePath
fromAbsDirP :: Path' Posix Abs (Dir d) -> FilePath
fromAbsDirP = toFilePath
fromAbsFileP :: Path' Posix Abs (File' f) -> FilePath
fromAbsDirP :: Path' Posix Abs (Dir d) -> FilePath
fromAbsDirP = toFilePath
fromAbsFileP :: Path' Posix Abs (File' f) -> FilePath
fromAbsFileP = toFilePath
fromRelDirW :: Path' Windows (Rel r) (Dir d) -> FilePath
fromRelDirW = toFilePath
fromRelDirW :: Path' Windows (Rel r) (Dir d) -> FilePath
fromRelDirW = toFilePath
fromRelFileW :: Path' Windows (Rel r) (File' f) -> FilePath
fromRelFileW = toFilePath
fromAbsDirW :: Path' Windows Abs (Dir d) -> FilePath
fromAbsDirW = toFilePath
fromAbsFileW :: Path' Windows Abs (File' f) -> FilePath
fromAbsDirW :: Path' Windows Abs (Dir d) -> FilePath
fromAbsDirW = toFilePath
fromAbsFileW :: Path' Windows Abs (File' f) -> FilePath
fromAbsFileW = toFilePath
-- | Either removes last entry or if there are no entries and just "../"s, adds one more "../".
-- If path is absolute root and it has no parent, it will return unchanged path, same like Path.
parent :: Path' s b t -> Path' s b (Dir d)
parent path = case path of
---- System
RelDir p prefix -> relDirPathParent RelDir P.parent p prefix
RelFile p prefix -> RelDir (P.parent p) prefix
AbsDir p -> AbsDir $ P.parent p
AbsFile p -> AbsDir $ P.parent p
---- Windows
RelDirW p prefix -> relDirPathParent RelDirW PW.parent p prefix
RelFileW p prefix -> RelDirW (PW.parent p) prefix
AbsDirW p -> AbsDirW $ PW.parent p
AbsFileW p -> AbsDirW $ PW.parent p
---- Posix
RelDirP p prefix -> relDirPathParent RelDirP PP.parent p prefix
RelFileP p prefix -> RelDirP (PP.parent p) prefix
AbsDirP p -> AbsDirP $ PP.parent p
AbsFileP p -> AbsDirP $ PP.parent p
---- System
RelDir p prefix -> relDirPathParent RelDir P.parent p prefix
RelFile p prefix -> RelDir (P.parent p) prefix
AbsDir p -> AbsDir $ P.parent p
AbsFile p -> AbsDir $ P.parent p
---- Windows
RelDirW p prefix -> relDirPathParent RelDirW PW.parent p prefix
RelFileW p prefix -> RelDirW (PW.parent p) prefix
AbsDirW p -> AbsDirW $ PW.parent p
AbsFileW p -> AbsDirW $ PW.parent p
---- Posix
RelDirP p prefix -> relDirPathParent RelDirP PP.parent p prefix
RelFileP p prefix -> RelDirP (PP.parent p) prefix
AbsDirP p -> AbsDirP $ PP.parent p
AbsFileP p -> AbsDirP $ PP.parent p
where
-- NOTE: We need this special logic for RelDir, because if we have RelDir Path,
-- it is possible that it is "." or smth like that and no parent can be obtained,
@ -291,14 +372,15 @@ parent path = case path of
-- For file though, we don't have that concern, because it will always be possible to
-- get a parent, as per current Path implementation.
relDirPathParent constructor pathParent p prefix =
if pathParent p == p
then let prefix' = case prefix of
ParentDir n -> ParentDir (n + 1)
NoPrefix -> ParentDir 1
in constructor p prefix'
else let p' = pathParent p
in constructor p' prefix
if pathParent p == p
then
let prefix' = case prefix of
ParentDir n -> ParentDir (n + 1)
NoPrefix -> ParentDir 1
in constructor p prefix'
else
let p' = pathParent p
in constructor p' prefix
-- | How "../"s are resolved:
-- For each "../" at the start of the right hand path, one most right entry is removed
@ -313,92 +395,95 @@ parent path = case path of
(</>) :: Path' s a (Dir d) -> Path' s (Rel d) c -> Path' s a c
---- System
lsp@(RelDir _ _) </> (RelFile rp rprefix) =
let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFile (lp' P.</> rp) lprefix'
let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFile (lp' P.</> rp) lprefix'
lsp@(RelDir _ _) </> (RelDir rp rprefix) =
let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDir (lp' P.</> rp) lprefix'
let (RelDir lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDir (lp' P.</> rp) lprefix'
lsp@(AbsDir _) </> (RelFile rp rprefix) =
let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFile (lp' P.</> rp)
let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFile (lp' P.</> rp)
lsp@(AbsDir _) </> (RelDir rp rprefix) =
let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDir (lp' P.</> rp)
let (AbsDir lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDir (lp' P.</> rp)
---- Windows
lsp@(RelDirW _ _) </> (RelFileW rp rprefix) =
let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFileW (lp' `pathWinCombineRelDirAndRelFile` rp) lprefix'
let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFileW (lp' `pathWinCombineRelDirAndRelFile` rp) lprefix'
lsp@(RelDirW _ _) </> (RelDirW rp rprefix) =
let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDirW (lp' `pathWinCombineRelDirAndRelDir` rp) lprefix'
let (RelDirW lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDirW (lp' `pathWinCombineRelDirAndRelDir` rp) lprefix'
lsp@(AbsDirW _) </> (RelFileW rp rprefix) =
let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFileW (lp' PW.</> rp)
let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFileW (lp' PW.</> rp)
lsp@(AbsDirW _) </> (RelDirW rp rprefix) =
let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDirW (lp' `pathWinCombineAbsDirAndRelDir` rp)
let (AbsDirW lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDirW (lp' `pathWinCombineAbsDirAndRelDir` rp)
---- Posix
lsp@(RelDirP _ _) </> (RelFileP rp rprefix) =
let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFileP (lp' `pathPosixCombineRelDirAndRelFile` rp) lprefix'
let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelFileP (lp' `pathPosixCombineRelDirAndRelFile` rp) lprefix'
lsp@(RelDirP _ _) </> (RelDirP rp rprefix) =
let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDirP (lp' `pathPosixCombineRelDirAndRelDir` rp) lprefix'
let (RelDirP lp' lprefix') = iterate parent lsp !! prefixNumParentDirs rprefix
in RelDirP (lp' `pathPosixCombineRelDirAndRelDir` rp) lprefix'
lsp@(AbsDirP _) </> (RelFileP rp rprefix) =
let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFileP (lp' PP.</> rp)
let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsFileP (lp' PP.</> rp)
lsp@(AbsDirP _) </> (RelDirP rp rprefix) =
let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDirP (lp' `pathPosixCombineAbsDirAndRelDir` rp)
let (AbsDirP lp') = iterate parent lsp !! prefixNumParentDirs rprefix
in AbsDirP (lp' `pathPosixCombineAbsDirAndRelDir` rp)
_ </> _ = impossible
castRel :: Path' s (Rel d1) a -> Path' s (Rel d2) a
---- System
castRel (RelDir p pr) = RelDir p pr
castRel (RelFile p pr) = RelFile p pr
castRel (RelDir p pr) = RelDir p pr
castRel (RelFile p pr) = RelFile p pr
---- Windows
castRel (RelDirW p pr) = RelDirW p pr
castRel (RelDirW p pr) = RelDirW p pr
castRel (RelFileW p pr) = RelFileW p pr
---- Posix
castRel (RelDirP p pr) = RelDirP p pr
castRel (RelDirP p pr) = RelDirP p pr
castRel (RelFileP p pr) = RelFileP p pr
castRel _ = impossible
castRel _ = impossible
castDir :: Path' s a (Dir d1) -> Path' s a (Dir d2)
---- System
castDir (AbsDir p) = AbsDir p
castDir (RelDir p pr) = RelDir p pr
castDir (AbsDir p) = AbsDir p
castDir (RelDir p pr) = RelDir p pr
---- Windows
castDir (AbsDirW p) = AbsDirW p
castDir (AbsDirW p) = AbsDirW p
castDir (RelDirW p pr) = RelDirW p pr
---- Posix
castDir (AbsDirP p) = AbsDirP p
castDir (AbsDirP p) = AbsDirP p
castDir (RelDirP p pr) = RelDirP p pr
castDir _ = impossible
castDir _ = impossible
-- TODO: I was not able to unite these two functions (`relDirToPosix` and `relFileToPosix`) into just `toPosix``
-- because Haskell did not believe me that I would be returning same "t" (Dir/File) in Path
-- as was in first argument. I wonder if there is easy way to go around that or if
-- we have to redo significant part of the StrongPath to be able to do smth like this.
-- | Converts relative path to posix by replacing current path separators with posix path separators.
-- Works well for "normal" relative paths like "a\b\c" (Win) or "a/b/c" (Posix).
-- If path is weird but still considered relative, like just "C:" on Win,
-- results can be unxpected, most likely resulting with error thrown.
-- If path is already Posix, it will not change.
relDirToPosix :: MonadThrow m => Path' s (Rel d1) (Dir d2) -> m (Path' Posix (Rel d1) (Dir d2))
relDirToPosix sp@(RelDir _ _) = parseRelDirP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp
relDirToPosix sp@(RelDir _ _) = parseRelDirP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp
relDirToPosix sp@(RelDirW _ _) = parseRelDirP $ FPP.joinPath $ FPW.splitDirectories $ toFilePath sp
relDirToPosix (RelDirP p pr) = return $ RelDirP p pr
relDirToPosix _ = impossible
relDirToPosix (RelDirP p pr) = return $ RelDirP p pr
relDirToPosix _ = impossible
relFileToPosix :: MonadThrow m => Path' s (Rel d1) (File' f) -> m (Path' Posix (Rel d1) (File' f))
relFileToPosix sp@(RelFile _ _) = parseRelFileP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp
relFileToPosix sp@(RelFile _ _) = parseRelFileP $ FPP.joinPath $ FP.splitDirectories $ toFilePath sp
relFileToPosix sp@(RelFileW _ _) = parseRelFileP $ FPP.joinPath $ FPW.splitDirectories $ toFilePath sp
relFileToPosix (RelFileP p pr) = return $ RelFileP p pr
relFileToPosix _ = impossible
relFileToPosix (RelFileP p pr) = return $ RelFileP p pr
relFileToPosix _ = impossible
-- TODO: Should I name these unsafe versions differently? Maybe relDirToPosixU?
-- Unsafe versions:
relDirToPosix' :: Path' s (Rel d1) (Dir d2) -> Path' Posix (Rel d1) (Dir d2)
relDirToPosix' = fromJust . relDirToPosix
relFileToPosix' :: Path' s (Rel d1) (File' f) -> Path' Posix (Rel d1) (File' f)
relFileToPosix' = fromJust . relFileToPosix

140
waspc/src/StrongPath/Internal.hs
View File

@ -1,85 +1,91 @@
module StrongPath.Internal where
import Control.Monad.Catch (MonadThrow)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW
import qualified System.FilePath.Posix as FPP
import Control.Monad.Catch (MonadThrow)
import qualified Path as P
import qualified Path.Posix as PP
import qualified Path.Windows as PW
import qualified System.FilePath.Posix as FPP
import qualified System.FilePath.Windows as FPW
-- | s -> standard, b -> base, t -> type
data Path' s b t
-- System
= RelDir (P.Path P.Rel P.Dir) RelPathPrefix
| RelFile (P.Path P.Rel P.File) RelPathPrefix
| AbsDir (P.Path P.Abs P.Dir)
| AbsFile (P.Path P.Abs P.File)
-- Windows
| RelDirW (PW.Path PW.Rel PW.Dir) RelPathPrefix
| RelFileW (PW.Path PW.Rel PW.File) RelPathPrefix
| AbsDirW (PW.Path PW.Abs PW.Dir)
| AbsFileW (PW.Path PW.Abs PW.File)
-- Posix
| RelDirP (PP.Path PP.Rel PP.Dir) RelPathPrefix
| RelFileP (PP.Path PP.Rel PP.File) RelPathPrefix
| AbsDirP (PP.Path PP.Abs PP.Dir)
| AbsFileP (PP.Path PP.Abs PP.File)
deriving (Show, Eq)
= -- System
RelDir (P.Path P.Rel P.Dir) RelPathPrefix
| RelFile (P.Path P.Rel P.File) RelPathPrefix
| AbsDir (P.Path P.Abs P.Dir)
| AbsFile (P.Path P.Abs P.File)
| -- Windows
RelDirW (PW.Path PW.Rel PW.Dir) RelPathPrefix
| RelFileW (PW.Path PW.Rel PW.File) RelPathPrefix
| AbsDirW (PW.Path PW.Abs PW.Dir)
| AbsFileW (PW.Path PW.Abs PW.File)
| -- Posix
RelDirP (PP.Path PP.Rel PP.Dir) RelPathPrefix
| RelFileP (PP.Path PP.Rel PP.File) RelPathPrefix
| AbsDirP (PP.Path PP.Abs PP.Dir)
| AbsFileP (PP.Path PP.Abs PP.File)
deriving (Show, Eq)
data RelPathPrefix = ParentDir Int -- ^ ../, Int saying how many times it repeats.
| NoPrefix
deriving (Show, Eq)
data RelPathPrefix
= -- | ../, Int saying how many times it repeats.
ParentDir Int
| NoPrefix
deriving (Show, Eq)
type Path = Path' System
-- | base
data Abs
data Rel dir
-- | type
data Dir dir
data File' file
type File = File' ()
-- | standard
data System -- Depends on the platform, it is either Posix or Windows.
data Windows
data Posix
parseRelFP :: MonadThrow m
=> (P.Path pb pt -> RelPathPrefix -> Path' s (Rel d) t)
-> [Char]
-> (FilePath -> m (P.Path pb pt))
-> FilePath
-> m (Path' s (Rel d) t)
parseRelFP ::
MonadThrow m =>
(P.Path pb pt -> RelPathPrefix -> Path' s (Rel d) t) ->
[Char] ->
(FilePath -> m (P.Path pb pt)) ->
FilePath ->
m (Path' s (Rel d) t)
parseRelFP constructor validSeparators pathParser fp =
let (prefix, fp') = extractRelPathPrefix validSeparators fp
fp'' = if fp' == "" then "." else fp' -- Because Path Rel parsers can't handle just "".
in (\p -> constructor p prefix) <$> pathParser fp''
let (prefix, fp') = extractRelPathPrefix validSeparators fp
fp'' = if fp' == "" then "." else fp' -- Because Path Rel parsers can't handle just "".
in (\p -> constructor p prefix) <$> pathParser fp''
-- | Extracts a multiple "../" from start of the file path.
-- If path is completely ../../.., also handles the last one.
-- NOTE: We don't normalize path in any way.
extractRelPathPrefix :: [Char] -> FilePath -> (RelPathPrefix, FilePath)
extractRelPathPrefix validSeparators path =
let (n, path') = dropParentDirs path
in (if n == 0 then NoPrefix else ParentDir n, path')
let (n, path') = dropParentDirs path
in (if n == 0 then NoPrefix else ParentDir n, path')
where
parentDirStrings :: [String]
parentDirStrings = [['.', '.', s] | s <- validSeparators]
parentDirStrings = [['.', '.', s] | s <- validSeparators]
pathStartsWithParentDir :: FilePath -> Bool
pathStartsWithParentDir p = take 3 p `elem` parentDirStrings
pathStartsWithParentDir p = take 3 p `elem` parentDirStrings
dropParentDirs :: FilePath -> (Int, FilePath)
dropParentDirs p
| pathStartsWithParentDir p = let (n, p') = dropParentDirs (drop 3 p)
in (1 + n, p')
| p == ".." = (1, "")
| otherwise = (0, p)
| pathStartsWithParentDir p =
let (n, p') = dropParentDirs (drop 3 p)
in (1 + n, p')
| p == ".." = (1, "")
| otherwise = (0, p)
-- NOTE: These three funtions, pathWinCombine... exist only to fix
-- Path.Windows.</> behaviour regarding concatenating '.' rel dirs
@ -102,35 +108,39 @@ extractRelPathPrefix validSeparators path =
-- do the rest of the work.
pathWinCombineRelDirAndRelFile :: PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.File -> PW.Path PW.Rel PW.File
pathWinCombineRelDirAndRelFile lp rp
| PW.toFilePath lp == ['.', FPW.pathSeparator] = rp
| otherwise = lp PW.</> rp
| PW.toFilePath lp == ['.', FPW.pathSeparator] = rp
| otherwise = lp PW.</> rp
pathWinCombineRelDirAndRelDir :: PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.Dir -> PW.Path PW.Rel PW.Dir
pathWinCombineRelDirAndRelDir lp rp
| PW.toFilePath lp == ['.', FPW.pathSeparator] = rp
| PW.toFilePath rp == ['.', FPW.pathSeparator] = lp
| otherwise = lp PW.</> rp
| PW.toFilePath lp == ['.', FPW.pathSeparator] = rp
| PW.toFilePath rp == ['.', FPW.pathSeparator] = lp
| otherwise = lp PW.</> rp
pathWinCombineAbsDirAndRelDir :: PW.Path PW.Abs PW.Dir -> PW.Path PW.Rel PW.Dir -> PW.Path PW.Abs PW.Dir
pathWinCombineAbsDirAndRelDir lp rp
| PW.toFilePath rp == ['.', FPW.pathSeparator] = lp
| otherwise = lp PW.</> rp
| PW.toFilePath rp == ['.', FPW.pathSeparator] = lp
| otherwise = lp PW.</> rp
-- NOTE: Same as pathWinCombineRelDirAndRelFile but for Posix (Path has the same problem).
pathPosixCombineRelDirAndRelFile :: PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.File -> PP.Path PP.Rel PP.File
pathPosixCombineRelDirAndRelFile lp rp
| PP.toFilePath lp == ['.', FPP.pathSeparator] = rp
| otherwise = lp PP.</> rp
| PP.toFilePath lp == ['.', FPP.pathSeparator] = rp
| otherwise = lp PP.</> rp
pathPosixCombineRelDirAndRelDir :: PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.Dir -> PP.Path PP.Rel PP.Dir
pathPosixCombineRelDirAndRelDir lp rp
| PP.toFilePath lp == ['.', FPP.pathSeparator] = rp
| PP.toFilePath rp == ['.', FPP.pathSeparator] = lp
| otherwise = lp PP.</> rp
| PP.toFilePath lp == ['.', FPP.pathSeparator] = rp
| PP.toFilePath rp == ['.', FPP.pathSeparator] = lp
| otherwise = lp PP.</> rp
pathPosixCombineAbsDirAndRelDir :: PP.Path PP.Abs PP.Dir -> PP.Path PP.Rel PP.Dir -> PP.Path PP.Abs PP.Dir
pathPosixCombineAbsDirAndRelDir lp rp
| PP.toFilePath rp == ['.', FPP.pathSeparator] = lp
| otherwise = lp PP.</> rp
| PP.toFilePath rp == ['.', FPP.pathSeparator] = lp
| otherwise = lp PP.</> rp
prefixNumParentDirs :: RelPathPrefix -> Int
prefixNumParentDirs NoPrefix = 0
prefixNumParentDirs NoPrefix = 0
prefixNumParentDirs (ParentDir n) = n
relPathNumParentDirs :: Path' s (Rel r) t -> Int
@ -138,13 +148,13 @@ relPathNumParentDirs = prefixNumParentDirs . relPathPrefix
relPathPrefix :: Path' s (Rel r) t -> RelPathPrefix
relPathPrefix sp = case sp of
RelDir _ pr -> pr
RelFile _ pr -> pr
RelDirW _ pr -> pr
RelFileW _ pr -> pr
RelDirP _ pr -> pr
RelFileP _ pr -> pr
_ -> impossible
RelDir _ pr -> pr
RelFile _ pr -> pr
RelDirW _ pr -> pr
RelFileW _ pr -> pr
RelDirP _ pr -> pr
RelFileP _ pr -> pr
_ -> impossible
impossible :: a
impossible = error "This should be impossible."

32
waspc/src/Util.hs
View File

@ -1,33 +1,35 @@
module Util
( camelToKebabCase
, onFirst
, toLowerFirst
, toUpperFirst
, headSafe
, jsonSet
) where
( camelToKebabCase,
onFirst,
toLowerFirst,
toUpperFirst,
headSafe,
jsonSet,
)
where
import Data.Char (isUpper, toLower, toUpper)
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import Data.Char (isUpper, toLower, toUpper)
import qualified Data.HashMap.Strict as M
import qualified Data.Text as Text
camelToKebabCase :: String -> String
camelToKebabCase "" = ""
camelToKebabCase camel@(camelHead:camelTail) = kebabHead:kebabTail
camelToKebabCase camel@(camelHead : camelTail) = kebabHead : kebabTail
where
kebabHead = toLower camelHead
kebabTail = concat $ map
(\(a, b) -> (if (isCamelHump (a, b)) then ['-'] else []) ++ [toLower b])
(zip camel camelTail)
kebabTail =
concat $
map
(\(a, b) -> (if (isCamelHump (a, b)) then ['-'] else []) ++ [toLower b])
(zip camel camelTail)
isCamelHump (a, b) = (not . isUpper) a && isUpper b
-- | Applies given function to the first element of the list.
-- If list is empty, returns empty list.
onFirst :: (a -> a) -> [a] -> [a]
onFirst _ [] = []
onFirst f (x:xs) = (f x):xs
onFirst f (x : xs) = (f x) : xs
toLowerFirst :: String -> String
toLowerFirst = onFirst toLower

7
waspc/src/Util/Fib.hs
View File

@ -1,6 +1,7 @@
module Util.Fib (
fibonacci
) where
module Util.Fib
( fibonacci,
)
where
fibonacci :: Int -> Int
fibonacci 0 = 0

59
waspc/src/Util/IO.hs
View File

@ -1,17 +1,18 @@
module Util.IO
( listDirectoryDeep
, listDirectory
) where
( listDirectoryDeep,
listDirectory,
)
where
import Control.Monad (filterM)
import qualified Path as P
import qualified System.Directory as Dir
import qualified System.FilePath as FilePath
import System.IO.Error (isDoesNotExistError)
import UnliftIO.Exception (catch, throwIO)
import Control.Monad (filterM)
import qualified Path as P
-- TODO: write tests.
-- | Lists all files in the directory recursively.
-- All paths are relative to the directory we are listing.
-- If directory does not exist, returns empty list.
@ -23,34 +24,36 @@ import qualified Path as P
-- >>> ["test.txt", "bar/text2.txt"]
listDirectoryDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File]
listDirectoryDeep absDirPath = do
(relFilePaths, relSubDirPaths) <- listDirectory absDirPath
`catch` \e -> if isDoesNotExistError e then return ([], []) else throwIO e
relSubDirFilesPaths <- mapM (listSubDirDeep . (absDirPath P.</>)) relSubDirPaths
return $ relFilePaths ++ concat relSubDirFilesPaths
(relFilePaths, relSubDirPaths) <-
listDirectory absDirPath
`catch` \e -> if isDoesNotExistError e then return ([], []) else throwIO e
relSubDirFilesPaths <- mapM (listSubDirDeep . (absDirPath P.</>)) relSubDirPaths
return $ relFilePaths ++ concat relSubDirFilesPaths
where
-- | NOTE: Here, returned paths are relative to the main dir whose sub dir we are listing,
-- which is one level above what you might intuitively expect.
listSubDirDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File]
listSubDirDeep subDirPath = do
files <- listDirectoryDeep subDirPath
return $ map (P.dirname subDirPath P.</>) files
listSubDirDeep :: P.Path P.Abs P.Dir -> IO [P.Path P.Rel P.File]
listSubDirDeep subDirPath = do
files <- listDirectoryDeep subDirPath
return $ map (P.dirname subDirPath P.</>) files
-- TODO: write tests.
-- | Lists files and directories at top lvl of the directory.
listDirectory :: P.Path P.Abs P.Dir -> IO ([P.Path P.Rel P.File], [P.Path P.Rel P.Dir])
listDirectory absDirPath = do
fpRelItemPaths <- Dir.listDirectory fpAbsDirPath
relFilePaths <- filterFiles fpAbsDirPath fpRelItemPaths
relDirPaths <- filterDirs fpAbsDirPath fpRelItemPaths
return (relFilePaths, relDirPaths)
fpRelItemPaths <- Dir.listDirectory fpAbsDirPath
relFilePaths <- filterFiles fpAbsDirPath fpRelItemPaths
relDirPaths <- filterDirs fpAbsDirPath fpRelItemPaths
return (relFilePaths, relDirPaths)
where
fpAbsDirPath :: FilePath
fpAbsDirPath = P.toFilePath absDirPath
fpAbsDirPath :: FilePath
fpAbsDirPath = P.toFilePath absDirPath
filterFiles :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.File]
filterFiles absDir relItems = filterM (Dir.doesFileExist . (absDir FilePath.</>)) relItems
>>= mapM P.parseRelFile
filterFiles :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.File]
filterFiles absDir relItems =
filterM (Dir.doesFileExist . (absDir FilePath.</>)) relItems
>>= mapM P.parseRelFile
filterDirs :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.Dir]
filterDirs absDir relItems = filterM (Dir.doesDirectoryExist . (absDir FilePath.</>)) relItems
>>= mapM P.parseRelDir
filterDirs :: FilePath -> [FilePath] -> IO [P.Path P.Rel P.Dir]
filterDirs absDir relItems =
filterM (Dir.doesDirectoryExist . (absDir FilePath.</>)) relItems
>>= mapM P.parseRelDir

49
waspc/src/Util/Terminal.hs
View File

@ -1,18 +1,20 @@
module Util.Terminal
( Style(..)
, applyStyles
) where
( Style (..),
applyStyles,
)
where
data Style = Black
| Red
| Green
| Yellow
| Blue
| Magenta
| Cyan
| White
| Bold
| Underline
data Style
= Black
| Red
| Green
| Yellow
| Blue
| Magenta
| Cyan
| White
| Bold
| Underline
-- | Given a string, returns decorated string that when printed in terminal
-- will have same content as original string but will also exibit specified styles.
@ -20,18 +22,19 @@ applyStyles :: [Style] -> String -> String
applyStyles [] str = str
applyStyles _ "" = ""
applyStyles styles str = foldl applyStyle str styles ++ escapeCode ++ resetCode
where applyStyle s style = escapeCode ++ styleCode style ++ s
where
applyStyle s style = escapeCode ++ styleCode style ++ s
styleCode :: Style -> String
styleCode Black = "[30m"
styleCode Red = "[31m"
styleCode Green = "[32m"
styleCode Yellow = "[33m"
styleCode Blue = "[34m"
styleCode Magenta = "[35m"
styleCode Cyan = "[36m"
styleCode White = "[37m"
styleCode Bold = "[1m"
styleCode Black = "[30m"
styleCode Red = "[31m"
styleCode Green = "[32m"
styleCode Yellow = "[33m"
styleCode Blue = "[34m"
styleCode Magenta = "[35m"
styleCode Cyan = "[36m"
styleCode White = "[37m"
styleCode Bold = "[1m"
styleCode Underline = "[4m"
escapeCode :: String

222
waspc/src/Wasp.hs
View File

@ -1,95 +1,85 @@
module Wasp
( Wasp
, WaspElement (..)
, fromWaspElems
, module Wasp.JsImport
, getJsImports
, setJsImports
, module Wasp.App
, fromApp
, getApp
, setApp
, getAuth
, getPSLEntities
, getDb
, module Wasp.Page
, getPages
, addPage
, getRoutes
, getQueries
, addQuery
, getQueryByName
, getActions
, addAction
, getActionByName
, setExternalCodeFiles
, getExternalCodeFiles
, setDotEnvFile
, getDotEnvFile
, setIsBuild
, getIsBuild
, setNpmDependencies
, getNpmDependencies
) where
import Data.Aeson (ToJSON (..), object, (.=))
import StrongPath (Path, Abs, File)
( Wasp,
WaspElement (..),
fromWaspElems,
module Wasp.JsImport,
getJsImports,
setJsImports,
module Wasp.App,
fromApp,
getApp,
setApp,
getAuth,
getPSLEntities,
getDb,
module Wasp.Page,
getPages,
addPage,
getRoutes,
getQueries,
addQuery,
getQueryByName,
getActions,
addAction,
getActionByName,
setExternalCodeFiles,
getExternalCodeFiles,
setDotEnvFile,
getDotEnvFile,
setIsBuild,
getIsBuild,
setNpmDependencies,
getNpmDependencies,
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import qualified ExternalCode
import qualified Util as U
import StrongPath (Abs, File, Path)
import qualified Util as U
import qualified Wasp.Action
import Wasp.App
import Wasp.App
import qualified Wasp.Auth
import qualified Wasp.Db
import Wasp.Entity
import Wasp.JsImport
import Wasp.NpmDependencies (NpmDependencies)
import Wasp.Entity
import Wasp.JsImport
import Wasp.NpmDependencies (NpmDependencies)
import qualified Wasp.NpmDependencies
import Wasp.Page
import Wasp.Page
import qualified Wasp.Query
import Wasp.Route
import Wasp.Route
-- * Wasp
data Wasp = Wasp
{ waspElements :: [WaspElement]
, waspJsImports :: [JsImport]
, externalCodeFiles :: [ExternalCode.File]
, dotEnvFile :: Maybe (Path Abs File)
, isBuild :: Bool
} deriving (Show, Eq)
{ waspElements :: [WaspElement],
waspJsImports :: [JsImport],
externalCodeFiles :: [ExternalCode.File],
dotEnvFile :: Maybe (Path Abs File),
isBuild :: Bool
}
deriving (Show, Eq)
data WaspElement
= WaspElementApp !App
| WaspElementAuth !Wasp.Auth.Auth
| WaspElementDb !Wasp.Db.Db
| WaspElementPage !Page
| WaspElementNpmDependencies !NpmDependencies
| WaspElementRoute !Route
| WaspElementEntity !Wasp.Entity.Entity
| WaspElementQuery !Wasp.Query.Query
| WaspElementAction !Wasp.Action.Action
deriving (Show, Eq)
= WaspElementApp !App
| WaspElementAuth !Wasp.Auth.Auth
| WaspElementDb !Wasp.Db.Db
| WaspElementPage !Page
| WaspElementNpmDependencies !NpmDependencies
| WaspElementRoute !Route
| WaspElementEntity !Wasp.Entity.Entity
| WaspElementQuery !Wasp.Query.Query
| WaspElementAction !Wasp.Action.Action
deriving (Show, Eq)
fromWaspElems :: [WaspElement] -> Wasp
fromWaspElems elems = Wasp
{ waspElements = elems
, waspJsImports = []
, externalCodeFiles = []
, dotEnvFile = Nothing
, isBuild = False
fromWaspElems elems =
Wasp
{ waspElements = elems,
waspJsImports = [],
externalCodeFiles = [],
dotEnvFile = Nothing,
isBuild = False
}
-- * Build
@ -98,7 +88,7 @@ getIsBuild :: Wasp -> Bool
getIsBuild = isBuild
setIsBuild :: Wasp -> Bool -> Wasp
setIsBuild wasp isBuildNew = wasp { isBuild = isBuildNew }
setIsBuild wasp isBuildNew = wasp {isBuild = isBuildNew}
-- * External code files
@ -106,7 +96,7 @@ getExternalCodeFiles :: Wasp -> [ExternalCode.File]
getExternalCodeFiles = externalCodeFiles
setExternalCodeFiles :: Wasp -> [ExternalCode.File] -> Wasp
setExternalCodeFiles wasp files = wasp { externalCodeFiles = files }
setExternalCodeFiles wasp files = wasp {externalCodeFiles = files}
-- * Dot env files
@ -114,7 +104,7 @@ getDotEnvFile :: Wasp -> Maybe (Path Abs File)
getDotEnvFile = dotEnvFile
setDotEnvFile :: Wasp -> Maybe (Path Abs File) -> Wasp
setDotEnvFile wasp file = wasp { dotEnvFile = file }
setDotEnvFile wasp file = wasp {dotEnvFile = file}
-- * Js imports
@ -122,25 +112,26 @@ getJsImports :: Wasp -> [JsImport]
getJsImports = waspJsImports
setJsImports :: Wasp -> [JsImport] -> Wasp
setJsImports wasp jsImports = wasp { waspJsImports = jsImports }
setJsImports wasp jsImports = wasp {waspJsImports = jsImports}
-- * App
getApp :: Wasp -> App
getApp wasp = let apps = getApps wasp in
if (length apps /= 1)
then error "Wasp has to contain exactly one WaspElementApp element!"
else head apps
getApp wasp =
let apps = getApps wasp
in if (length apps /= 1)
then error "Wasp has to contain exactly one WaspElementApp element!"
else head apps
isAppElem :: WaspElement -> Bool
isAppElem WaspElementApp{} = True
isAppElem _ = False
isAppElem WaspElementApp {} = True
isAppElem _ = False
getApps :: Wasp -> [App]
getApps wasp = [app | (WaspElementApp app) <- waspElements wasp]
setApp :: Wasp -> App -> Wasp
setApp wasp app = wasp { waspElements = (WaspElementApp app) : (filter (not . isAppElem) (waspElements wasp)) }
setApp wasp app = wasp {waspElements = (WaspElementApp app) : (filter (not . isAppElem) (waspElements wasp))}
fromApp :: App -> Wasp
fromApp app = fromWaspElems [WaspElementApp app]
@ -148,37 +139,40 @@ fromApp app = fromWaspElems [WaspElementApp app]
-- * Auth
getAuth :: Wasp -> Maybe Wasp.Auth.Auth
getAuth wasp = let auths = [a | WaspElementAuth a <- waspElements wasp] in
case auths of
[] -> Nothing
getAuth wasp =
let auths = [a | WaspElementAuth a <- waspElements wasp]
in case auths of
[] -> Nothing
[a] -> Just a
_ -> error "Wasp can't contain more than one WaspElementAuth element!"
_ -> error "Wasp can't contain more than one WaspElementAuth element!"
-- * Db
getDb :: Wasp -> Maybe Wasp.Db.Db
getDb wasp = let dbs = [db | WaspElementDb db <- waspElements wasp] in
case dbs of
[] -> Nothing
getDb wasp =
let dbs = [db | WaspElementDb db <- waspElements wasp]
in case dbs of
[] -> Nothing
[db] -> Just db
_ -> error "Wasp can't contain more than one Db element!"
_ -> error "Wasp can't contain more than one Db element!"
-- * NpmDependencies
getNpmDependencies :: Wasp -> NpmDependencies
getNpmDependencies wasp
= let depses = [d | (WaspElementNpmDependencies d) <- waspElements wasp]
in case depses of
[] -> Wasp.NpmDependencies.empty
[deps] -> deps
_ -> error "Wasp can't contain more than one NpmDependencies element!"
getNpmDependencies wasp =
let depses = [d | (WaspElementNpmDependencies d) <- waspElements wasp]
in case depses of
[] -> Wasp.NpmDependencies.empty
[deps] -> deps
_ -> error "Wasp can't contain more than one NpmDependencies element!"
isNpmDependenciesElem :: WaspElement -> Bool
isNpmDependenciesElem WaspElementNpmDependencies{} = True
isNpmDependenciesElem _ = False
isNpmDependenciesElem WaspElementNpmDependencies {} = True
isNpmDependenciesElem _ = False
setNpmDependencies :: Wasp -> NpmDependencies -> Wasp
setNpmDependencies wasp deps = wasp
setNpmDependencies wasp deps =
wasp
{ waspElements = WaspElementNpmDependencies deps : filter (not . isNpmDependenciesElem) (waspElements wasp)
}
@ -193,7 +187,7 @@ getPages :: Wasp -> [Page]
getPages wasp = [page | (WaspElementPage page) <- waspElements wasp]
addPage :: Wasp -> Page -> Wasp
addPage wasp page = wasp { waspElements = (WaspElementPage page):(waspElements wasp) }
addPage wasp page = wasp {waspElements = (WaspElementPage page) : (waspElements wasp)}
-- * Query
@ -201,7 +195,7 @@ getQueries :: Wasp -> [Wasp.Query.Query]
getQueries wasp = [query | (WaspElementQuery query) <- waspElements wasp]
addQuery :: Wasp -> Wasp.Query.Query -> Wasp
addQuery wasp query = wasp { waspElements = WaspElementQuery query : waspElements wasp }
addQuery wasp query = wasp {waspElements = WaspElementQuery query : waspElements wasp}
-- | Gets query with a specified name from wasp, if such an action exists.
-- We assume here that there are no two queries with same name.
@ -214,7 +208,7 @@ getActions :: Wasp -> [Wasp.Action.Action]
getActions wasp = [action | (WaspElementAction action) <- waspElements wasp]
addAction :: Wasp -> Wasp.Action.Action -> Wasp
addAction wasp action = wasp { waspElements = WaspElementAction action : waspElements wasp }
addAction wasp action = wasp {waspElements = WaspElementAction action : waspElements wasp}
-- | Gets action with a specified name from wasp, if such an action exists.
-- We assume here that there are no two actions with same name.
@ -226,13 +220,13 @@ getActionByName wasp name = U.headSafe $ filter (\a -> Wasp.Action._name a == na
getPSLEntities :: Wasp -> [Wasp.Entity.Entity]
getPSLEntities wasp = [entity | (WaspElementEntity entity) <- (waspElements wasp)]
-- * ToJSON instances.
instance ToJSON Wasp where
toJSON wasp = object
[ "app" .= getApp wasp
, "pages" .= getPages wasp
, "routes" .= getRoutes wasp
, "jsImports" .= getJsImports wasp
]
toJSON wasp =
object
[ "app" .= getApp wasp,
"pages" .= getPages wasp,
"routes" .= getRoutes wasp,
"jsImports" .= getJsImports wasp
]

29
waspc/src/Wasp/Action.hs
View File

@ -1,21 +1,24 @@
module Wasp.Action
( Action(..)
) where
( Action (..),
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import Wasp.JsImport (JsImport)
import Data.Aeson (ToJSON (..), object, (.=))
import Wasp.JsImport (JsImport)
-- TODO: Very similar to Wasp.Query, consider extracting duplication.
data Action = Action
{ _name :: !String
, _jsFunction :: !JsImport
, _entities :: !(Maybe [String])
} deriving (Show, Eq)
{ _name :: !String,
_jsFunction :: !JsImport,
_entities :: !(Maybe [String])
}
deriving (Show, Eq)
instance ToJSON Action where
toJSON action = object
[ "name" .= _name action
, "jsFunction" .= _jsFunction action
, "entities" .= _entities action
]
toJSON action =
object
[ "name" .= _name action,
"jsFunction" .= _jsFunction action,
"entities" .= _entities action
]

26
waspc/src/Wasp/App.hs
View File

@ -1,18 +1,20 @@
module Wasp.App
( App(..)
) where
import Data.Aeson ((.=), object, ToJSON(..))
( App (..),
)
where
import Data.Aeson (ToJSON (..), object, (.=))
data App = App
{ appName :: !String -- Identifier
, appTitle :: !String
, appHead :: !(Maybe [String])
} deriving (Show, Eq)
{ appName :: !String, -- Identifier
appTitle :: !String,
appHead :: !(Maybe [String])
}
deriving (Show, Eq)
instance ToJSON App where
toJSON app = object
[ "name" .= appName app
, "title" .= appTitle app
]
toJSON app =
object
[ "name" .= appName app,
"title" .= appTitle app
]

20
waspc/src/Wasp/Auth.hs
View File

@ -1,14 +1,16 @@
module Wasp.Auth
( Auth (..)
, AuthMethod (..)
) where
( Auth (..),
AuthMethod (..),
)
where
data Auth = Auth
{ _userEntity :: !String
, _methods :: [AuthMethod]
, _onAuthFailedRedirectTo :: !String
} deriving (Show, Eq)
{ _userEntity :: !String,
_methods :: [AuthMethod],
_onAuthFailedRedirectTo :: !String
}
deriving (Show, Eq)
data AuthMethod
= EmailAndPassword
deriving (Show, Eq)
= EmailAndPassword
deriving (Show, Eq)

18
waspc/src/Wasp/Db.hs
View File

@ -1,13 +1,15 @@
module Wasp.Db
( Db (..)
, DbSystem (..)
) where
( Db (..),
DbSystem (..),
)
where
data Db = Db
{ _system :: !DbSystem
} deriving (Show, Eq)
{ _system :: !DbSystem
}
deriving (Show, Eq)
data DbSystem
= PostgreSQL
| SQLite
deriving (Show, Eq)
= PostgreSQL
| SQLite
deriving (Show, Eq)

76
waspc/src/Wasp/Entity.hs
View File

@ -1,55 +1,55 @@
module Wasp.Entity
( Entity (..)
, Field (..)
, FieldType (..)
, Scalar (..)
, Composite (..)
) where
import Data.Aeson (ToJSON(..), (.=), object)
( Entity (..),
Field (..),
FieldType (..),
Scalar (..),
Composite (..),
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import qualified Psl.Ast.Model
data Entity = Entity
{ _name :: !String
, _fields :: ![Field]
, _pslModelBody :: !Psl.Ast.Model.Body
}
deriving (Show, Eq)
{ _name :: !String,
_fields :: ![Field],
_pslModelBody :: !Psl.Ast.Model.Body
}
deriving (Show, Eq)
data Field = Field
{ _fieldName :: !String
, _fieldType :: !FieldType
}
deriving (Show, Eq)
{ _fieldName :: !String,
_fieldType :: !FieldType
}
deriving (Show, Eq)
data FieldType = FieldTypeScalar Scalar | FieldTypeComposite Composite
deriving (Show, Eq)
deriving (Show, Eq)
data Composite = Optional Scalar | List Scalar
deriving (Show, Eq)
deriving (Show, Eq)
data Scalar
= String
| Boolean
| Int
| BigInt
| Float
| Decimal
| DateTime
| Json
| Bytes
-- | Name of the user-defined type.
= String
| Boolean
| Int
| BigInt
| Float
| Decimal
| DateTime
| Json
| Bytes
| -- | Name of the user-defined type.
-- This could be another entity, or maybe an enum,
-- we don't know here yet.
| UserType String
| Unsupported String
deriving (Show, Eq)
UserType String
| Unsupported String
deriving (Show, Eq)
instance ToJSON Entity where
toJSON entity = object
[ "name" .= _name entity
, "fields" .= show (_fields entity)
, "pslModelBody" .= show (_pslModelBody entity)
]
toJSON entity =
object
[ "name" .= _name entity,
"fields" .= show (_fields entity),
"pslModelBody" .= show (_pslModelBody entity)
]

9
waspc/src/Wasp/JsCode.hs
View File

@ -1,8 +1,9 @@
module Wasp.JsCode
( JsCode(..)
) where
( JsCode (..),
)
where
import Data.Aeson (ToJSON(..))
import Data.Aeson (ToJSON (..))
import Data.Text (Text)
data JsCode = JsCode !Text deriving (Show, Eq)
@ -11,4 +12,4 @@ data JsCode = JsCode !Text deriving (Show, Eq)
-- ideal. Ideally all the generation logic would be in the generator. But for now this was
-- the simplest way to implement it.
instance ToJSON JsCode where
toJSON (JsCode code) = toJSON code
toJSON (JsCode code) = toJSON code

35
waspc/src/Wasp/JsImport.hs
View File

@ -1,24 +1,25 @@
module Wasp.JsImport
( JsImport(..)
) where
import Data.Aeson (ToJSON (..), object, (.=))
import ExternalCode (SourceExternalCodeDir)
import StrongPath (File, Path', Posix, Rel)
import qualified StrongPath as SP
( JsImport (..),
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import ExternalCode (SourceExternalCodeDir)
import StrongPath (File, Path', Posix, Rel)
import qualified StrongPath as SP
-- | Represents javascript import -> "import <what> from <from>".
data JsImport = JsImport
{ _defaultImport :: !(Maybe String)
, _namedImports :: ![String]
, _from :: Path' Posix (Rel SourceExternalCodeDir) File
} deriving (Show, Eq)
{ _defaultImport :: !(Maybe String),
_namedImports :: ![String],
_from :: Path' Posix (Rel SourceExternalCodeDir) File
}
deriving (Show, Eq)
instance ToJSON JsImport where
toJSON jsImport = object
[ "defaultImport" .= _defaultImport jsImport
, "namedImports" .= _namedImports jsImport
, "from" .= SP.toFilePath (_from jsImport)
]
toJSON jsImport =
object
[ "defaultImport" .= _defaultImport jsImport,
"namedImports" .= _namedImports jsImport,
"from" .= SP.toFilePath (_from jsImport)
]

26
waspc/src/Wasp/NpmDependencies.hs
View File

@ -1,20 +1,22 @@
module Wasp.NpmDependencies
( NpmDependencies(..)
, empty
) where
import Data.Aeson (ToJSON (..), object, (.=))
import NpmDependency
( NpmDependencies (..),
empty,
)
where
import Data.Aeson (ToJSON (..), object, (.=))
import NpmDependency
data NpmDependencies = NpmDependencies
{ _dependencies :: ![NpmDependency]
} deriving (Show, Eq)
{ _dependencies :: ![NpmDependency]
}
deriving (Show, Eq)
empty :: NpmDependencies
empty = NpmDependencies { _dependencies = [] }
empty = NpmDependencies {_dependencies = []}
instance ToJSON NpmDependencies where
toJSON deps = object
[ "dependencies" .= _dependencies deps
]
toJSON deps =
object
[ "dependencies" .= _dependencies deps
]

20
waspc/src/Wasp/Operation.hs
View File

@ -1,21 +1,23 @@
module Wasp.Operation
( Operation(..)
, getName
, getJsFn
, getEntities
) where
( Operation (..),
getName,
getJsFn,
getEntities,
)
where
-- TODO: Is this ok approach, should I instead use typeclass?
-- So far, all usages in the codebase could be easily replaced with the Typeclass.
import Wasp.Action (Action)
import qualified Wasp.Action as Action
import Wasp.JsImport (JsImport)
import Wasp.Query (Query)
import qualified Wasp.Query as Query
import Wasp.Action (Action)
import qualified Wasp.Action as Action
data Operation = QueryOp Query
| ActionOp Action
data Operation
= QueryOp Query
| ActionOp Action
getName :: Operation -> String
getName (QueryOp query) = Query._name query

26
waspc/src/Wasp/Page.hs
View File

@ -1,19 +1,21 @@
module Wasp.Page
( Page(..)
) where
( Page (..),
)
where
import Data.Aeson ((.=), object, ToJSON(..))
import Data.Aeson (ToJSON (..), object, (.=))
import Wasp.JsImport (JsImport)
data Page = Page
{ _name :: !String
, _component :: !JsImport
, _authRequired :: Maybe Bool
} deriving (Show, Eq)
{ _name :: !String,
_component :: !JsImport,
_authRequired :: Maybe Bool
}
deriving (Show, Eq)
instance ToJSON Page where
toJSON page = object
[ "name" .= _name page
, "component" .= _component page
]
toJSON page =
object
[ "name" .= _name page,
"component" .= _component page
]

Some files were not shown because too many files have changed in this diff Show More