From 69e046f9497b29424d36e0e9918a94b3d5e2a1f3 Mon Sep 17 00:00:00 2001 From: NStack Team Date: Thu, 24 Aug 2017 00:41:53 +0100 Subject: [PATCH] Commit for release 0.0.8 --- nstack-cli/app/NStackCLI.hs | 32 ++-- .../client/templates/init/common/nstack.yaml | 8 +- .../templates/init/framework/nstack.yaml | 3 +- nstack-cli/nstack-cli.cabal | 4 +- nstack-cli/src/NStack/CLI/Commands.hs | 146 +++++++++++------- nstack-cli/src/NStack/CLI/Parser.hs | 57 ++++--- nstack-prelude/nstack-prelude.cabal | 3 +- .../src/NStack/Prelude/Exception.hs | 9 ++ nstack-prelude/src/NStack/Prelude/Map.hs | 14 ++ nstack-prelude/src/NStack/Prelude/Shell.hs | 6 +- nstack/nstack.cabal | 5 +- nstack/src/NStack/Common/Environment.hs | 6 + nstack/src/NStack/Comms/TypeRepresentation.hs | 40 +++++ nstack/src/NStack/Comms/Types.hs | 118 ++++++++++---- nstack/src/NStack/Module/ConfigFile.hs | 71 ++++++--- nstack/src/NStack/Module/Parser.hs | 4 +- nstack/src/NStack/Module/QMap.hs | 53 +++++++ nstack/src/NStack/Module/Types.hs | 65 ++++---- nstack/src/NStack/Module/Types/Aeson.hs | 27 ++++ nstack/src/NStack/Settings.hs | 2 + nstack/src/NStack/Settings/Types.hs | 23 ++- nstack/test/TestSuite.hs | 30 +++- nstack/test_output.xml | 2 +- 23 files changed, 539 insertions(+), 189 deletions(-) create mode 100644 nstack-prelude/src/NStack/Prelude/Map.hs create mode 100644 nstack/src/NStack/Comms/TypeRepresentation.hs create mode 100644 nstack/src/NStack/Module/QMap.hs create mode 100644 nstack/src/NStack/Module/Types/Aeson.hs diff --git a/nstack-cli/app/NStackCLI.hs b/nstack-cli/app/NStackCLI.hs index 6624e2d..b9d4aee 100644 --- a/nstack-cli/app/NStackCLI.hs +++ b/nstack-cli/app/NStackCLI.hs @@ -38,8 +38,7 @@ import qualified Network.WebSockets as WS import NStack.CLI.Auth (signRequest, allowSelfSigned) import NStack.CLI.Parser (cmds) import NStack.CLI.Types -import NStack.CLI.Commands -import qualified NStack.CLI.Commands as CLI +import NStack.CLI.Commands as CLI import NStack.Common.Environment (httpApiPort) import NStack.Comms.Types import NStack.Comms.ApiHashValue (apiHashValue) @@ -91,7 +90,7 @@ formatNotebook module_name fn_name = DSLSource $ run :: Command -> CCmd () -run (InitCommand initStack mBase gitRepo) = CLI.initCommand initStack mBase gitRepo +run (InitCommand initStack gitRepo) = CLI.initCommand initStack gitRepo run (StartCommand debugOpt module_name fn_name) = callServer startCommand (formatNotebook module_name fn_name, debugOpt) CLI.showStartMessage run (NotebookCommand debugOpt mDsl) = do liftInput . HL.outputStrLn $ "NStack Notebook - import modules, write a workflow, and press " <> endStream <> " when finished to start it: " @@ -99,16 +98,19 @@ run (NotebookCommand debugOpt mDsl) = do liftInput . HL.outputStrLn $ "Building and running NStack Workflow. Please wait. This may take some time." callServer startCommand (dsl, debugOpt) CLI.showStartMessage where endStream = if os == "mingw32" then "" else "" -run (StopCommand pId) = callServer stopCommand pId CLI.showStopMessage -run (LogsCommand pId) = callServer logsCommand pId catLogs -run ServerLogsCommand = callServer serverLogsCommand () catLogs -run (InfoCommand fAll) = callServer infoCommand fAll CLI.printInfo -run (ListCommand mType fAll) = callServer listCommand (mType, fAll) CLI.printMethods -run (ListModulesCommand fAll) = callServer listModulesCommand fAll (`prettyLinesOr` "No registered images") -run (DeleteModuleCommand m) = callServer deleteModuleCommand m (const $ "Module deleted: " <> pprT m) -run (ListProcessesCommand) = callServer listProcessesCommand () CLI.printProcesses -run (GarbageCollectCommand) = callServer gcCommand () (`prettyLinesOr` "Nothing removed") -run (ConnectCommand pId) = connectStdInOut pId + +run (StopCommand pId) = callServer stopCommand pId CLI.showStopMessage +run (LogsCommand pId) = callServer logsCommand pId catLogs +run ServerLogsCommand = callServer serverLogsCommand () catLogs +run (InfoCommand fAll) = callServer infoCommand fAll CLI.printInfo +run (ListCommand mType fAll) = callServer listCommand (mType, fAll) CLI.printMethods +run (ListModulesCommand fAll) = callServer listModulesCommand fAll (`prettyLinesOr` "No registered images") +run (DeleteModuleCommand m) = callServer deleteModuleCommand m (const $ "Module deleted: " <> pprT m) +run ListProcessesCommand = callServer listProcessesCommand () CLI.printProcesses +run (ListStoppedCommand mStart mEnd) = callServer listStoppedCommand (mStart, mEnd) CLI.printProcesses +run GarbageCollectCommand = callServer gcCommand () (`prettyLinesOr` "Nothing removed") +run ListScheduled = callServer listScheduledCommand () CLI.printScheduledProcesses +run (ConnectCommand pId) = connectStdInOut pId run (BuildCommand dropBadModules) = ifM (R.testfile projectFile) projectBuild (ifM (R.testfile configFile ||^ R.testfile workflowFile) workflowModule @@ -130,7 +132,7 @@ run (TestCommand mod' fn snippet) = do path' <- liftIO randomPath (Transport t) <- ask r <- t testCommand ((Qualified mod' fn), HttpPath path') - (ProcessInfo pId _ _) <- case r of + (ProcessInfo pId _ _ _) <- case r of (ServerError e) -> throwError $ unpack e (ClientError e)-> throwError $ unpack e (Result v) -> return v @@ -228,7 +230,7 @@ serverPath = do callWithHttp :: CCmdEff m => Manager -> String -> ApiCall a b -> a -> m (Result b) callWithHttp manager hostname (ApiCall name) args = do auth <- (^. authSettings) <$> settings - timeout <- (^. cliTimeout) <$> settings + timeout <- getCliTimeout <$> settings liftIO $ maybe (return err) (doCall manager path' (encode args) timeout) auth where path' = hostname <> unpack name err = ClientError "Missing or invalid credentials. Please run the 'nstack set-server' command as described in your email." diff --git a/nstack-cli/data/client/templates/init/common/nstack.yaml b/nstack-cli/data/client/templates/init/common/nstack.yaml index 36ad384..265dc2e 100644 --- a/nstack-cli/data/client/templates/init/common/nstack.yaml +++ b/nstack-cli/data/client/templates/init/common/nstack.yaml @@ -1,9 +1,5 @@ -# The language stack to use -stack: {{ stack }} - -# Parent Image -parent: {{ parent }} - +# The language stack or parent image to use +{{ stackOrParent }} # (Optional) System-level packages needed packages: [] diff --git a/nstack-cli/data/client/templates/init/framework/nstack.yaml b/nstack-cli/data/client/templates/init/framework/nstack.yaml index 16b4287..0dac35e 100644 --- a/nstack-cli/data/client/templates/init/framework/nstack.yaml +++ b/nstack-cli/data/client/templates/init/framework/nstack.yaml @@ -2,8 +2,7 @@ name: {{ name }} # Parent Image -parent: {{ parent }} - +{{ stackOrParent }} # (Optional) System-level packages needed packages: [] diff --git a/nstack-cli/nstack-cli.cabal b/nstack-cli/nstack-cli.cabal index 7226e59..8377f62 100644 --- a/nstack-cli/nstack-cli.cabal +++ b/nstack-cli/nstack-cli.cabal @@ -1,5 +1,5 @@ name: nstack-cli -version: 0.0.7.1 +version: 0.0.8 cabal-version: >=1.22 build-type: Simple license: BSD3 @@ -57,8 +57,10 @@ library process, system-filepath, text, + thyme, tree-view, turtle, + yaml, nstack -any, nstack-prelude -any other-modules: diff --git a/nstack-cli/src/NStack/CLI/Commands.hs b/nstack-cli/src/NStack/CLI/Commands.hs index 680216b..483247a 100644 --- a/nstack-cli/src/NStack/CLI/Commands.hs +++ b/nstack-cli/src/NStack/CLI/Commands.hs @@ -7,10 +7,10 @@ module NStack.CLI.Commands ( loginSettings, showStartMessage, showStopMessage, - localModName, printInfo, printMethods, printProcesses, + printScheduledProcesses, showModuleBuild, registerCommand, sendCommand, @@ -30,19 +30,22 @@ import Data.Char (toLower) import Data.Foldable (traverse_) import Data.Functor (($>)) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (isNothing) import Data.Monoid ((<>)) +import Data.Proxy (Proxy(..)) import Data.Text (Text, unpack) +import Data.Thyme (UTCTime) import Data.Tree (Forest, unfoldForest) import Data.Tree.View (showTree) import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Yaml as Y import Data.Coerce (coerce) import qualified Filesystem.Path.CurrentOS as FP -- system-filepath -import Network.HTTP.Client hiding (responseStatus) +import Network.HTTP.Client hiding (responseStatus, Proxy) import Network.HTTP.Client.TLS (mkManagerSettings) -import Network.Wreq hiding (responseCookieJar) +import Network.Wreq hiding (responseCookieJar, Proxy) import Util ((<||>)) -- ghc import System.Directory (getXdgDirectory, XdgDirectory(..), createDirectoryIfMissing) import System.IO.Error (isDoesNotExistError) @@ -56,11 +59,11 @@ import NStack.Auth import NStack.CLI.Auth (allowSelfSigned) import NStack.CLI.Types import NStack.CLI.Templates (createFromTemplate) -import NStack.Comms.Types (GitRepo(..), ProcessId(..), ProcessInfo(..), ModuleInfo(..), ServerInfo(..), EntityType, TypeSignature(..), DSLSource(..), DropBadModules) -import NStack.Module.Types (Stack, BaseImage(..), DebugOpt(..), ModuleName(..), FnName(..), Qualified(..), showShortModuleName) +import NStack.Comms.Types +import NStack.Module.Types import NStack.Module.Parser (parseModuleName) import qualified NStack.Utils.Archive as Archive -import NStack.Module.ConfigFile (configFile, workflowFile) +import NStack.Module.ConfigFile (configFile, workflowFile, ConfigStack(..), mkStackParent) import NStack.Prelude.Applicative ((<&>)) import NStack.Prelude.FilePath (fpToText, fromFP, directory) import NStack.Prelude.Shell (runCmd_) @@ -74,7 +77,7 @@ type Snippet = String -- | Available sub commands data Command - = InitCommand InitStack (Maybe BaseImage) GitRepo + = InitCommand InitStack GitRepo | NotebookCommand DebugOpt (Maybe DSLSource) | StartCommand DebugOpt ModuleName FnName | StopCommand ProcessId @@ -86,55 +89,56 @@ data Command | ListModulesCommand Bool | DeleteModuleCommand ModuleName | ListProcessesCommand + | ListStoppedCommand (Maybe StoppedFrom) (Maybe StoppedAmount) | GarbageCollectCommand | BuildCommand DropBadModules | RegisterCommand UserName Email ServerAddr | SendCommand Path Snippet | TestCommand ModuleName FnName Snippet | LoginCommand HostName Int UserId SecretKey + | ListScheduled -data InitProject = InitProject Text (Maybe Stack) (Maybe ModuleName) -- Name, Stack, Parent Module - -instance M.ToMustache InitProject where - toMustache (InitProject name stack parent) = M.object - [ "name" ~> pprT name - , "stack" ~> maybe "" show stack - , "parent" ~> maybe "" pprT parent - ] -- Parser for Init command options -data InitStack = InitWorkflow | InitFramework | InitStack Stack +data InitStack = InitWorkflow | InitStack Language | InitFramework BaseImage +data TemplateOut = TemplateOut ModuleName (Maybe Y.Value) + +instance M.ToMustache TemplateOut where + toMustache (TemplateOut name stackOrParent) = M.object [ "name" ~> localModName name + , "stackOrParent" ~> maybe "" (decodeUtf8 . Y.encode) stackOrParent ] + +-- TODO - these should be moved to the server +snapshot :: (FedoraVersion, FedoraSnapshot) +snapshot = (25, 0) -initCommand :: CCmdEff m => InitStack -> Maybe BaseImage -> GitRepo -> m () -initCommand initStack mBase (GitRepo wantGitRepo) = do +langStacks :: Language -> APIVersion +langStacks _ = 1 + +initCommand :: CCmdEff m => InitStack -> GitRepo -> m () +initCommand initStack (GitRepo wantGitRepo) = do curDir <- R.pwd tModuleName <- moduleNameFromDir curDir _ <- whenNotExistingProject (templateDirs, initProj) <- case initStack of - InitWorkflow -> return (["workflow"], InitProject tModuleName Nothing Nothing) - InitFramework -> do - iParentName <- parseModuleName . _baseImage $ baseImage - return (["framework"], InitProject tModuleName Nothing (Just iParentName)) - (InitStack stack) -> do + InitWorkflow -> return (["workflow"], Nothing) + InitFramework baseImage -> do iParentName <- parseModuleName . _baseImage $ baseImage - return (["common", map toLower . show $ stack], InitProject tModuleName (Just stack) (Just iParentName)) + return (["framework"], Just . mkStackParent . Right $ iParentName) + InitStack lang -> do + let cfgStack = ConfigStack lang (langStacks lang) snapshot + return (["common", map toLower . show $ lang], Just . mkStackParent . Left $ cfgStack) -- copy the init files into the module dir liftIO $ mapM_ (createFromTemplate (fromFP curDir)) templateDirs -- run the template over them - runTemplates curDir initProj + runTemplates curDir tModuleName initProj when wantGitRepo initGitRepo - liftIO . TIO.putStrLn $ "Module '" <> pprT tModuleName <> "' successfully initialised at " <> T.pack (fromFP curDir) - where - -- hardcode the default image and version number temporarily - baseImage = flip fromMaybe mBase $ case initStack of - (InitStack stack) -> BaseImage . T.pack $ "NStack."++show stack++":0.25.0" - _ -> BaseImage . T.pack $ "NStack.Python:0.25.0" + liftIO . TIO.putStrLn $ "Module '" <> localModName tModuleName <> "' successfully initialised at " <> T.pack (fromFP curDir) -- | Extract the module name from the current directory -moduleNameFromDir :: CCmdEff m => R.FilePath -> m Text +moduleNameFromDir :: CCmdEff m => R.FilePath -> m ModuleName moduleNameFromDir curDir = ((fmap capitaliseT . fpToText . FP.filename $ curDir) <&> (<> ":0.0.1-SNAPSHOT") >>= parseModuleName) `catchError` (\err -> throwError ( "Your directory name, " <> FP.encodeString curDir <> ", is not a valid module name.\n" - <> err)) >>= return . localModName + <> err)) -- | Run project git/dir check whenNotExistingProject :: CCmdEff m => m () @@ -142,18 +146,25 @@ whenNotExistingProject = whenM (liftIO $ R.testdir ".git" <||> R.testfile configFile) (throwError "Found existing project, cancelling") --- | process the initial module file using templates -runTemplates :: CCmdEff m => R.FilePath -> InitProject -> m () -runTemplates curDir projInfo = do +-- | process the initial module files using templates +runTemplates :: CCmdEff m => R.FilePath -> ModuleName -> Maybe Y.Value -> m () +runTemplates curDir modName stackOrParent = do files <- R.fold (R.ls curDir) L.list traverse_ (runTemplate . fromFP) files where runTemplate :: CCmdEff m => FilePath -> m () runTemplate inFile = do template <- eitherToExcept =<< liftIO (first show <$> M.localAutomaticCompile inFile) - let newText = M.substitute template projInfo + let newText = M.substitute template (TemplateOut modName stackOrParent) liftIO $ TIO.writeFile inFile newText + +-- HACK - to remove once we have username on CLI / remove modulename parsing +-- Currently used to display the ModuleName on the CLI without the default `nstack` author +localModName :: ModuleName -> Text +localModName = last . T.splitOn "nstack/" . T.pack . showShortModuleName + + -- | init the module using Git initGitRepo :: CCmdEff m => m () initGitRepo = liftIO $ do @@ -173,12 +184,15 @@ buildArtefacts dir globs = do liftIO $ Archive.expandCheckPack dir std_files globs printInfo :: ServerInfo -> Text -printInfo (ServerInfo ps meths ms) = prettyT' $ +printInfo (ServerInfo ps stopped meths ms) = prettyT' $ block "Running processes:" (map M.ppr ps) - block "Available functions:" (prettyPrintMethods $ coerce . Map.toList $ meths) + block "Stopped processes:" (map M.ppr stopped) + block "Available functions:" (prettyPrintMethods $ coerce . Map.toList . fmap typeSignature $ meths) M.text "Container modules:" showModules ms where + typeSignature (MethodInfo t _) = t + showModules :: Map.Map ModuleName ModuleInfo -> M.Doc showModules = M.stack . fmap M.text . renderTree . mkTree . Map.toList @@ -206,26 +220,46 @@ prettyPrintMethods = moduleMethodBlocks . fmap (fmap printMethod) . fmap Map.to nest = foldr (\((Qualified c d), a) m -> Map.unionWith (<>) m (newMap c d a)) Map.empty newMap c d a = Map.singleton c (Map.singleton d a) -printProcesses :: [ProcessInfo] -> Text -printProcesses [] = "No running processes" -printProcesses xs = prettyT' $ M.text "pid" <> M.spaces 4 <> M.text "time" <> M.spaces 21 <> M.text "command" - M.text (replicate 40 '=') - M.stack (map M.ppr xs) - +printProcesses :: forall a. ProcPrintable a => [ProcessInfo a] -> Text +printProcesses = \case + [] -> emptyMessage p + xs -> prettyT' $ M.text "pid" <> M.spaces 4 <> M.text "time" <> M.spaces 21 <> columnHeader p <> M.text "command" + M.text (replicate (40 + columnWidth p) '=') + M.stack (map M.ppr xs) + where p = Proxy @a + +class (M.Pretty (ProcessInfo a)) => ProcPrintable a where + emptyMessage :: Proxy a -> Text + columnHeader :: Proxy a -> M.Doc + columnWidth :: Proxy a -> Int + +instance ProcPrintable () where + emptyMessage _ = "No running processes" + columnHeader _ = mempty + columnWidth _ = 0 + +instance ProcPrintable StopTime where + emptyMessage _ = "No stopped processes in range" + columnHeader _ = M.text "stop time" <> M.spaces 16 + columnWidth _ = 25 + +printScheduledProcesses :: [(ProcessInfo (), [UTCTime])] -> Text +printScheduledProcesses [] = "No scheduled processes" +printScheduledProcesses xs = prettyT' $ + M.stack items + where + items = fmap (\(pInfo, datetimes) -> + M.text "Process " <> M.ppr pInfo + M.text "Next scheduled times: " <> M.stack (M.ppr <$> datetimes) M.text (replicate 10 '-')) xs block :: String -> [M.Doc] -> M.Doc block label stack = M.text label M.indent 4 (M.stack stack) M.empty -showStartMessage :: ProcessInfo -> Text -showStartMessage (ProcessInfo (ProcessId pId) _ _) = "Successfully started as process " <> pId +showStartMessage :: ProcessInfo () -> Text +showStartMessage (ProcessInfo (ProcessId pId) _ _ _) = "Successfully started as process " <> pId -showStopMessage :: ProcessId -> Text -showStopMessage (ProcessId pId) = "Successfully stopped process " <> pId - --- HACK - to remove once we have username on CLI / remove modulename parsing --- Currently used to display the ModuleName on the CLI without the default `nstack` author -localModName :: ModuleName -> T.Text -localModName = last . T.splitOn "nstack/" . T.pack . showShortModuleName +showStopMessage :: (ProcessInfo a) -> Text +showStopMessage (ProcessInfo (ProcessId pId) _ _ _) = "Successfully stopped process " <> pId showModuleBuild :: ModuleName -> Text showModuleBuild mName = "Module " <> pprT mName <> " built successfully. Use `nstack list functions` to see all available functions." @@ -254,7 +288,7 @@ sendCommand path snippet = do eitherToExcept =<< liftIO (callServer serverHost event `E.catch` wreqErrorHandler) liftIO . TIO.putStrLn $ "Event sent successfully" where - mkServerAddr serverHost = "http://" <> T.unpack serverHost <> ":8080" <> path + mkServerAddr serverHost = "https://" <> T.unpack serverHost <> ":8083" <> path -- convert snippet to json event we can send mkEvent = do p <- eitherToExcept (eitherDecodeStrict' (encodeUtf8 . T.pack $ snippet) :: Either String Value) diff --git a/nstack-cli/src/NStack/CLI/Parser.hs b/nstack-cli/src/NStack/CLI/Parser.hs index 00ba704..a610485 100644 --- a/nstack-cli/src/NStack/CLI/Parser.hs +++ b/nstack-cli/src/NStack/CLI/Parser.hs @@ -2,22 +2,20 @@ module NStack.CLI.Parser ( cmds ) where import Control.Lens ((^?)) -import Control.Monad.Except (MonadError, runExcept) +import Control.Monad.Except (runExcept) import Data.Monoid ((<>)) import Data.String -import Data.Text (Text, pack) -import Text.Megaparsec (try, ()) -- from: megaparsec -import Text.Megaparsec.Char (string) -- from: megaparsec +import Data.Text (pack) +import Options.Applicative -- optparse-applicative +import Text.Megaparsec (try) -- from: megaparsec import NStack.Auth (hexUserId, textSecretKey, UserName(..), validEmail) import NStack.CLI.Commands (Command(..), InitStack(..)) import NStack.Comms.Types -import NStack.Module.Parser (pStack, inlineParser) +import NStack.Module.Parser (pLanguage, inlineParser, parseModuleName) import NStack.Module.Types (DebugOpt(..), BaseImage(..), ModuleName(..), FnName(..)) -import NStack.Module.Parser (parseModuleName) import NStack.Prelude.Monad (maybeToRight) -import Options.Applicative -- optparse-applicative -- Combinators pModuleName :: Parser ModuleName @@ -32,6 +30,14 @@ pFnName = (FnName . pack) <$> strArgument (metavar "function_name" <> help "Func pDSL :: Parser DSLSource pDSL = DSLSource . pack <$> argument str (metavar "code" <> help "DSL code. If omitted, will be read from standard input.") +pStartPoint :: Parser StoppedFrom +pStartPoint = StoppedFrom <$> argument auto (metavar "from" <> + help "Where to start in the stopped processes. If omitted, will default to 0.") + +pAmount :: Parser StoppedAmount +pAmount = StoppedAmount <$> argument auto (metavar "n" <> + help "How many stopped processses to display. If omitted, will default to 10.") + pProcessId :: Parser ProcessId pProcessId = ProcessId . pack <$> argument str (metavar "process" <> help "Process Id") @@ -46,6 +52,10 @@ startOpts = StartCommand <$> debugFlag <*> pModuleName <*> pFnName notebookOpts :: Parser Command notebookOpts = NotebookCommand <$> debugFlag <*> optional pDSL +-- | Parser for Stopped command options +stoppedOpts :: Parser Command +stoppedOpts = ListStoppedCommand <$> optional pStartPoint <*> optional pAmount + debugFlag :: Parser DebugOpt debugFlag = flag NoDebug Debug (long "debug" <> help "enable debug logging") @@ -62,21 +72,26 @@ connectOpts = ConnectCommand <$> pProcessId -- Parser for Init command options -pInitStack :: MonadError String m => Text -> m InitStack -pInitStack = inlineParser $ try (pW <|> pF <|> pS) - where - pW = InitWorkflow <$ string "workflow" "workflow" - pF = InitFramework <$ string "framework" "framework" - pS = InitStack <$> pStack "a valid stack" +-- pInitStack :: MonadError String m => Text -> m InitStack +-- pInitStack = inlineParser $ try (pW <|> pS <|> pF) +-- where +-- pW = InitWorkflow <$ string "workflow" "workflow" +-- pF = InitFramework <$ string "framework" "framework" +-- pS = InitStack <$> pLanguage "a valid stack" initOpts :: Parser Command initOpts = InitCommand - <$> argument pInitStack' (metavar "stack" <> help "Module Stack") - <*> optional (BaseImage . pack <$> argument str (metavar "base-image" <> help "Base Image to use (e.g. NStack.Python:0.24.0")) - <*> (GitRepo <$> switch (long "git-repo" <> help "Initialise Git Repository")) + <$> pInit + <*> (GitRepo <$> switch (long "git-repo" <> help "Initialise with a git repository")) where - pInitStack' :: ReadM InitStack - pInitStack' = eitherReader (runExcept . pInitStack . pack) + pInit :: Parser InitStack + pInit = pWorkflow <|> option pInitStack (short 'l' <> long "language" <> metavar "LANGUAGE" <> help "Initialise a module in the given language") <|> pFramework + + pInitStack :: ReadM InitStack + pInitStack = eitherReader (runExcept . inlineParser (try $ InitStack <$> pLanguage) . pack) + + pWorkflow = flag' InitWorkflow (short 'w' <> long "workflow" <> help "Initialise a new workflow") + pFramework = InitFramework . BaseImage . pack <$> strOption (short 'f' <> long "framework" <> metavar "MODULENAME" <> help "Initialise a module inheriting from the given parent framework (e.g. NStack.BigQuery:0.3.0)") -- | Parser for the register command options regOpts :: Parser Command @@ -84,11 +99,11 @@ regOpts = RegisterCommand <$> (UserName . pack <$> argument str (metavar "userna <*> argument pEmail (metavar "email" <> help "Email to register with") <*> serverFlag where - pEmail = eitherReader $ (\x -> maybeToRight "Not a valid email address" (pack x ^? validEmail)) + pEmail = eitherReader (\x -> maybeToRight "Not a valid email address" (pack x ^? validEmail)) serverFlag = option str (long "server" <> short 's' <> help "NStack Registry Server" <> showDefault <> value "demo-register.nstack.com:8443" <> metavar "SERVER") sendOpts :: Parser Command -sendOpts = SendCommand <$> (argument str (metavar "path" <> help "Path the source was created on")) +sendOpts = SendCommand <$> argument str (metavar "path" <> help "Path the source was created on") <*> argument str (metavar "event" <> help "JSON Snippet to send as an event") testOpts :: Parser Command @@ -126,12 +141,14 @@ cmds :: Parser Command cmds = hsubparser ( command "info" (info (InfoCommand <$> allSwitch) (progDesc "Show the server status")) <> command "init" (info initOpts (progDesc "Initialise a new module/workflow")) <> command "list" (info (helper <*> listOpts) (progDesc "List registered modules or functions")) + <> command "list-scheduled" (info (pure ListScheduled) (progDesc "List scheduled processes")) <> command "build" (info buildOpts (progDesc "Build module")) <> command "delete" (info (DeleteModuleCommand <$> pModuleName) (progDesc "Delete a module")) <> command "start" (info startOpts (progDesc "Start a workflow")) <> command "notebook" (info notebookOpts (progDesc "Enter some DSL interactively")) <> command "stop" (info stopOpts (progDesc "Stop a process")) <> command "ps" (info (pure ListProcessesCommand) (progDesc "List all running processes")) + <> command "stopped" (info stoppedOpts (progDesc "List all stopped processes")) <> command "logs" (info logsOpts (progDesc "Show the logs of a running process")) <> command "connect" (info connectOpts (progDesc "Connect stdin/stdout to a process")) <> command "server-logs" (info (pure ServerLogsCommand) (progDesc "Show the nstack server's logs")) diff --git a/nstack-prelude/nstack-prelude.cabal b/nstack-prelude/nstack-prelude.cabal index 0200ec7..1c0e92b 100644 --- a/nstack-prelude/nstack-prelude.cabal +++ b/nstack-prelude/nstack-prelude.cabal @@ -1,5 +1,5 @@ name: nstack-prelude -version: 0.0.7.1 +version: 0.0.8 cabal-version: >=1.22 build-type: Simple license: BSD3 @@ -22,6 +22,7 @@ library NStack.Prelude.FilePath NStack.Prelude.Format NStack.Prelude.Parsec + NStack.Prelude.Map NStack.Prelude.Monad NStack.Prelude.Pipes NStack.Prelude.Shell diff --git a/nstack-prelude/src/NStack/Prelude/Exception.hs b/nstack-prelude/src/NStack/Prelude/Exception.hs index 238dc67..34a4abb 100644 --- a/nstack-prelude/src/NStack/Prelude/Exception.hs +++ b/nstack-prelude/src/NStack/Prelude/Exception.hs @@ -1,5 +1,7 @@ module NStack.Prelude.Exception ( TransientError(..) + , throwTransientError + , throwTransientErrorT , PermanentError(..) , throwPermanentError , throwPermanentErrorT @@ -17,6 +19,13 @@ data TransientError = TransientError String instance Exception TransientError where displayException (TransientError msg) = msg +-- | A shortcut for commonly-occurring @liftIO . throwIO . PermanentError@. +throwTransientError :: MonadIO m => String -> m a +throwTransientError = liftIO . throwIO . TransientError + +throwTransientErrorT :: MonadIO m => Text -> m a +throwTransientErrorT = throwTransientError . unpack + data PermanentError = PermanentError String deriving (Show, Typeable) diff --git a/nstack-prelude/src/NStack/Prelude/Map.hs b/nstack-prelude/src/NStack/Prelude/Map.hs new file mode 100644 index 0000000..4b450b5 --- /dev/null +++ b/nstack-prelude/src/NStack/Prelude/Map.hs @@ -0,0 +1,14 @@ +module NStack.Prelude.Map where + +import Data.Map (Map) +import qualified Data.Map as Map + +-- Retain only elements in m whose keys are in the list ks +selectKeys :: Ord k => [k] -> Map k a -> Map k a +selectKeys ks m = Map.intersection m keep + where keep = Map.fromList $ zip ks (repeat ()) + +-- Remove elements in m whose keys are in the list ks +removeKeys :: Ord k => [k] -> Map k a -> Map k a +removeKeys ks m = Map.difference m remove + where remove = Map.fromList $ zip ks (repeat ()) diff --git a/nstack-prelude/src/NStack/Prelude/Shell.hs b/nstack-prelude/src/NStack/Prelude/Shell.hs index e1cde43..9902c10 100644 --- a/nstack-prelude/src/NStack/Prelude/Shell.hs +++ b/nstack-prelude/src/NStack/Prelude/Shell.hs @@ -7,14 +7,14 @@ import Control.Monad.Trans (MonadIO) import Data.Text (Text) import qualified Turtle as R --- | Run commands as blocking subprocesses +-- | Run as blocking subprocesses, printing stdout and returning exit code runCmd :: (MonadIO io) => Text -> [Text] -> io R.ExitCode runCmd cmd args = R.proc cmd args R.empty --- | Run commands as blocking subprocesses +-- | Run as blocking subprocesses, printing stdout and throwing exception on non-zero exit runCmd_ :: (MonadIO io) => Text -> [Text] -> io () runCmd_ cmd args = R.procs cmd args R.empty --- | Run commands as blocking subprocesses +-- | Run as blocking subprocesses, returning stdout and throwing exception on non-zero exit runCmdOut :: (MonadIO io) => Text -> [Text] -> io Text runCmdOut cmd args = snd <$> R.procStrict cmd args R.empty diff --git a/nstack/nstack.cabal b/nstack/nstack.cabal index cb7a0b9..7fcd11c 100644 --- a/nstack/nstack.cabal +++ b/nstack/nstack.cabal @@ -1,5 +1,5 @@ name: nstack -version: 0.0.7.1 +version: 0.0.8 cabal-version: >=1.22 build-type: Simple license: BSD3 @@ -20,10 +20,13 @@ library exposed-modules: NStack.Auth NStack.Common.Environment + NStack.Comms.TypeRepresentation NStack.Comms.Types NStack.UUIDOrphans NStack.Module.Parser + NStack.Module.QMap NStack.Module.Types + NStack.Module.Types.Aeson NStack.SafeCopyOrphans NStack.Settings NStack.Utils.Archive diff --git a/nstack/src/NStack/Common/Environment.hs b/nstack/src/NStack/Common/Environment.hs index da91c74..1e2747c 100644 --- a/nstack/src/NStack/Common/Environment.hs +++ b/nstack/src/NStack/Common/Environment.hs @@ -2,3 +2,9 @@ module NStack.Common.Environment where httpApiPort :: Int httpApiPort = 8443 + +httpSourcesPort :: Int +httpSourcesPort = 8080 + +httpsSourcesPort :: Int +httpsSourcesPort = 8083 diff --git a/nstack/src/NStack/Comms/TypeRepresentation.hs b/nstack/src/NStack/Comms/TypeRepresentation.hs new file mode 100644 index 0000000..314602f --- /dev/null +++ b/nstack/src/NStack/Comms/TypeRepresentation.hs @@ -0,0 +1,40 @@ +module NStack.Comms.TypeRepresentation where + +import qualified Data.Map as Map +import qualified Data.Text as T +import GHC.Generics +import Data.Serialize (Serialize(..)) +import Data.Serialize.Text () + +-- | Simplified version of `ClosedTypeExpr` for sending to the clients +data TypeRepresentation + = TextType + | IntegerType + | DoubleType + | BoolType + | JsonType + | ByteArrayType + | VoidType + | MapType (Map.Map T.Text TypeRepresentation) + | TupleType [TypeRepresentation] + | ListType TypeRepresentation + | OptionalType TypeRepresentation + | SumType (Map.Map T.Text TypeRepresentation) + deriving (Show, Eq, Generic) + +-- | Type representation of a monomorphic nstack method +data MTypeRepresentation = MTypeRepresentation { + _inType :: TypeRepresentation, + _outType :: TypeRepresentation + } deriving (Show, Eq, Generic) + +instance Serialize TypeRepresentation +instance Serialize MTypeRepresentation + +isSink :: MTypeRepresentation -> Bool +isSink (MTypeRepresentation _ VoidType) = True +isSink _ = False + +isSource :: MTypeRepresentation -> Bool +isSource (MTypeRepresentation VoidType _) = True +isSource _ = False diff --git a/nstack/src/NStack/Comms/Types.hs b/nstack/src/NStack/Comms/Types.hs index 766437d..2cdb2b2 100644 --- a/nstack/src/NStack/Comms/Types.hs +++ b/nstack/src/NStack/Comms/Types.hs @@ -3,18 +3,18 @@ module NStack.Comms.Types (module NStack.Comms.Types) where +import Control.Lens (makeLenses, Lens', Iso') import Data.ByteString (ByteString) -- from: bytestring import Data.Coerce (coerce) import qualified Data.Map as Map import Data.Monoid ((<>)) -import Data.SafeCopy (deriveSafeCopy, base, contain, SafeCopy(..), safePut, safeGet) -import Data.Serialize (Serialize(..), putTwoOf, getTwoOf) +import Data.SafeCopy (deriveSafeCopy, base, SafeCopy(..)) +import Data.Serialize (Serialize(..)) import Data.Serialize.Text () -- Serialize Text instances import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import Data.Thyme (UTCTime) -import Data.Thyme.Time (fromThyme, toThyme) import Data.Typeable (Typeable) import qualified Data.Loc as Loc import Data.UUID (UUID) @@ -23,48 +23,88 @@ import Text.PrettyPrint.Mainland (Pretty(..), text, spaces, align, stack) import Language.Haskell.TH (Name) import Control.Exception(Exception(..)) +import NStack.Comms.TypeRepresentation import NStack.Module.Types (DebugOpt, ModuleName, QFnName, Stack, Image(..), Qualified) import NStack.Prelude.Text (putText, getText) import NStack.Prelude.Time (timeToUnix, timeFromUnix) -- general newtypes used from client/server comms -newtype StartTime = StartTime UTCTime +newtype BookendTime = BookendTime { _bookendTime :: UTCTime } deriving (Eq, Ord) +newtype StartTime = StartTime { _startBookend :: BookendTime } + deriving (Eq, Ord, Serialize, Pretty) + +newtype StopTime = StopTime { _stopBookend :: BookendTime } + deriving (Eq, Ord, Serialize, Pretty) + +instance Show BookendTime where + show (BookendTime t) = show t + +instance Show StopTime where + show (StopTime t) = show t + instance Show StartTime where show (StartTime t) = show t -instance Pretty StartTime where +instance Pretty BookendTime where ppr = text . show -instance Serialize StartTime where - put (StartTime t) = put $ timeToUnix t +instance Serialize BookendTime where + put (BookendTime t) = put $ timeToUnix t get = do s <- get maybe (fail "Could not parse date string") return $ timeM s - where timeM = fmap StartTime . timeFromUnix + where timeM = fmap BookendTime . timeFromUnix + +instance Serialize UTCTime where + put t = put $ timeToUnix t + get = do + s <- get + maybe (fail "Could not parse date string") return $ timeFromUnix s + +instance SafeCopy StartTime + +instance SafeCopy BookendTime + +instance SafeCopy StopTime + +instance Pretty UTCTime where + ppr = text . show + -instance SafeCopy StartTime where - putCopy (StartTime t) = contain . safePut $ fromThyme t - getCopy = contain $ StartTime . toThyme <$> safeGet newtype ProcessId = ProcessId Text deriving (Eq, Pretty, Ord, Generic) +newtype StoppedFrom = StoppedFrom Int + deriving (Serialize, Num, Eq, Show, Ord) + +newtype StoppedAmount = StoppedAmount Int + deriving (Serialize, Num) + +processIdText :: Lens' ProcessId Text +processIdText f (ProcessId t) = ProcessId <$> f t + newtype GitRepo = GitRepo { _gitRepo :: Bool } deriving (Eq) -data ProcessInfo = ProcessInfo +data ProcessInfo a = ProcessInfo { _processId :: ProcessId , _timestamp :: StartTime - , _command :: Text - } deriving (Eq, Ord, Show, Generic) + , _dslCommand :: Text + , _stopTime :: a + } deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable) + +instance Pretty (ProcessInfo ()) where + ppr (ProcessInfo (ProcessId p) t c _) = ppr p <> spaces 5 <> ppr t <> spaces 2 <> align (stack $ ppr <$> T.lines c) -instance Pretty ProcessInfo where - ppr (ProcessInfo (ProcessId p) t c) = ppr p <> spaces 5 <> ppr t <> spaces 2 <> align (stack $ ppr <$> T.lines c) +instance Pretty (ProcessInfo StopTime) where + ppr (ProcessInfo (ProcessId p) t c stop) = ppr p <> spaces 5 <> ppr t <> spaces 2 <> ppr stop <> spaces 2 <> align (stack $ ppr <$> T.lines c) newtype ContainerId = ContainerId { _containerId :: Text } -- systemd dbus object path + deriving (Serialize) newtype BuildTarball = BuildTarball { _buildTarball :: ByteString } newtype WorkflowSrc = WorkflowSrc { _workflowSrc :: Text } newtype LogsLine = LogsLine { _logLine :: Text } @@ -76,14 +116,21 @@ data TypeSignature | TypeDefinition Text -- ^ the 'QFnName' is a type with this definition deriving (Show, Generic, Eq) + +-- Maybe acknowledges that not all nstack methods have a proper +-- 'MTypeRepresentation'. Only monomorphic methods do. +data MethodInfo = MethodInfo TypeSignature (Maybe MTypeRepresentation) + deriving (Show, Eq, Generic) + newtype DSLSource = DSLSource { _src :: Text } deriving (Eq, Ord, Typeable, IsString) -- | Simplified nstack-server info for sending to the CLI data ServerInfo = ServerInfo { - _processes :: [ProcessInfo], - _methods :: Map.Map QFnName TypeSignature, - _modules :: Map.Map ModuleName ModuleInfo } + _siProcesses :: [ProcessInfo ()], + _siStopped :: [ProcessInfo StopTime], + _siMethods :: Map.Map QFnName MethodInfo, + _siModules :: Map.Map ModuleName ModuleInfo } deriving (Eq, Show, Generic) -- | Simplified module info for sending to the CLI @@ -131,9 +178,7 @@ instance Serialize ProcessId where put = coerce putText get = coerce getText -instance Serialize ProcessInfo where - put (ProcessInfo pId t c) = putTwoOf put (putTwoOf put putText) (pId, (t, c)) - get = (\(p, (t, c)) -> ProcessInfo p t c) <$> getTwoOf get (getTwoOf get getText) +instance Serialize a => Serialize (ProcessInfo a) instance Serialize WorkflowSrc where put = coerce putText @@ -144,6 +189,7 @@ instance Serialize LogsLine where get = coerce getText instance Serialize TypeSignature +instance Serialize MethodInfo instance Serialize DSLSource where put = coerce putText @@ -221,10 +267,10 @@ instance Serialize Loc.Pos data ApiCall a b where ApiCall :: (Serialize a, Serialize b) => Text -> ApiCall a b -startCommand :: ApiCall (DSLSource, DebugOpt) ProcessInfo +startCommand :: ApiCall (DSLSource, DebugOpt) (ProcessInfo ()) startCommand = ApiCall "StartCommand" -stopCommand :: ApiCall ProcessId ProcessId +stopCommand :: ApiCall ProcessId (ProcessInfo StopTime) stopCommand = ApiCall "StopCommand" logsCommand :: ApiCall ProcessId [LogsLine] @@ -240,15 +286,21 @@ infoCommand = ApiCall "InfoCommand" listCommand :: ApiCall (Maybe EntityType, Bool) [(Qualified Text, TypeSignature)] listCommand = ApiCall "ListCommand" +listScheduledCommand :: ApiCall () [(ProcessInfo (), [UTCTime])] +listScheduledCommand = ApiCall "ListScheduledCommand" + listModulesCommand :: ApiCall Bool [ModuleName] listModulesCommand = ApiCall "ListModulesCommand" deleteModuleCommand :: ApiCall ModuleName () deleteModuleCommand = ApiCall "DeleteModuleCommand" -listProcessesCommand :: ApiCall () [ProcessInfo] +listProcessesCommand :: ApiCall () [ProcessInfo ()] listProcessesCommand = ApiCall "ListProcessesCommand" +listStoppedCommand :: ApiCall (Maybe StoppedFrom, Maybe StoppedAmount) [ProcessInfo StopTime] +listStoppedCommand = ApiCall "ListStoppedCommand" + gcCommand :: ApiCall () [UUID] gcCommand = ApiCall "GarbageCollectCommand" @@ -258,9 +310,21 @@ buildCommand = ApiCall "BuildCommand" buildFrontendCommand :: ApiCall (ContainerData, DropBadModules) ModuleName buildFrontendCommand = ApiCall "BuildFrontendCommand" -testCommand :: ApiCall (QFnName, HttpPath) ProcessInfo +testCommand :: ApiCall (QFnName, HttpPath) (ProcessInfo ()) testCommand = ApiCall "TestCommand" +$(makeLenses ''ServerInfo) +$(makeLenses ''ProcessInfo) +$(makeLenses ''BookendTime) +$(makeLenses ''StartTime) +$(makeLenses ''StopTime) + +stopToTime :: Iso' StopTime UTCTime +stopToTime = stopBookend.bookendTime + +startTime :: Iso' StartTime UTCTime +startTime = startBookend.bookendTime + -- | List all supported API calls. -- -- This list needs to be kept up to date for correct versioning. See "NStack.Comms.ApiHash". @@ -275,6 +339,8 @@ allApiCalls = , 'listCommand , 'listModulesCommand , 'listProcessesCommand + , 'listStoppedCommand + , 'listScheduledCommand , 'logsCommand , 'serverLogsCommand , 'startCommand diff --git a/nstack/src/NStack/Module/ConfigFile.hs b/nstack/src/NStack/Module/ConfigFile.hs index 7cb44e0..995ca22 100644 --- a/nstack/src/NStack/Module/ConfigFile.hs +++ b/nstack/src/NStack/Module/ConfigFile.hs @@ -2,60 +2,87 @@ module NStack.Module.ConfigFile where +import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Except(MonadError) -- mtl import Control.Monad.Trans(MonadIO, liftIO) -- mtl import Data.Aeson.Types (typeMismatch) -import Data.Text(Text, unpack, pack) +import Data.Text(Text, unpack, pack, toLower) import qualified Data.Yaml as Y -import Data.Yaml((.:), (.:?), (.!=)) +import Data.Yaml((.:), (.:?), (.!=), (.=)) import Data.String (IsString) import Turtle (()) import qualified Turtle as R -import NStack.Module.Types (ModuleName(..), Stack(..)) -import NStack.Module.Parser (parseModuleName, pStack, inlineParser) +import NStack.Module.Types (APIVersion, ModuleName(..), Language(..), FedoraVersion, FedoraSnapshot) +import NStack.Module.Parser (parseModuleName, pLanguage, inlineParser) import NStack.Prelude.FilePath (fromFP, toFP) import NStack.Prelude.Exception (throwPermanentError) +import NStack.Prelude.Text (showT, pprT) type API = Text type Package = Text type Command = Text type File = Text --- TODO - rename as Project? --- | ConfigFile module configuration file --- used to describe the module project dir +instance Y.FromJSON Language where + parseJSON obj@(Y.String t) = either (`typeMismatch` obj) return (inlineParser pLanguage t) + parseJSON _ = mzero + +instance Y.ToJSON Language where + toJSON = Y.String . pack . show + +data ConfigStack = ConfigStack { + _cfgLang :: Language, + _cfgApiVersion :: APIVersion, + _cfgSnapVersion :: (FedoraVersion, FedoraSnapshot) +} deriving (Show) + +instance Y.FromJSON ConfigStack where + parseJSON (Y.Object v) = + ConfigStack <$> + v .: "language" <*> + v .: "api-version" <*> + v .: "snapshot" + parseJSON _ = mzero + +instance Y.ToJSON ConfigStack where + toJSON (ConfigStack l v s) = Y.object ["language" .= toLower (showT l), "api-version" .= v, "snapshot" .= s] + +instance Y.FromJSON ModuleName where + parseJSON (Y.String t) = either fail return $ parseModuleName t + parseJSON _ = mzero + +instance Y.ToJSON ModuleName where + toJSON = Y.String . pprT + +mkStackParent :: Either ConfigStack ModuleName -> Y.Value +mkStackParent (Left cfgStack) = Y.object ["stack" .= cfgStack] +mkStackParent (Right modName) = Y.object ["parent" .= modName] + +-- | ConfigFile module configuration file used to describe the module project dir data ConfigFile = ConfigFile { _cfgName :: Maybe ModuleName, - _cfgStack :: Stack, - _cfgParent :: ModuleName, + -- ^ the name of the module - I think we can remove this as is also specified within the module.nml + _cfgStackParent :: Either ConfigStack ModuleName, + -- ^ We can define the parent either in terms of the stack, which then resolves to a known-parent, or reference a parent (i.e. Framework) directly - in either case the stack is taken from the parent _cfgPackages :: [Package], + -- ^ system packages needed by the module _cfgCommands :: [Command], + -- ^ script commands to run during the build process _cfgFiles :: [File] + -- ^ files to copy into the container from the directory root } deriving (Show) instance Y.FromJSON ConfigFile where parseJSON (Y.Object v) = ConfigFile <$> v .:? "name" <*> - v .: "stack" <*> - v .: "parent" <*> + (Right <$> v .: "parent" <|> Left <$> v .: "stack") <*> v .:? "packages" .!= mempty <*> v .:? "commands" .!= mempty <*> v .:? "files" .!= mempty parseJSON _ = mzero -instance Y.FromJSON ModuleName where - parseJSON (Y.String t) = either fail return $ parseModuleName t - parseJSON _ = mzero - -instance Y.FromJSON Stack where - parseJSON obj@(Y.String t) = either (`typeMismatch` obj) return (inlineParser pStack t) - parseJSON _ = mzero - -instance Y.ToJSON Stack where - toJSON = Y.String . pack . show - configFile :: IsString s => s configFile = "nstack.yaml" diff --git a/nstack/src/NStack/Module/Parser.hs b/nstack/src/NStack/Module/Parser.hs index e9345ab..3740ee1 100644 --- a/nstack/src/NStack/Module/Parser.hs +++ b/nstack/src/NStack/Module/Parser.hs @@ -28,8 +28,8 @@ spaceConsumer = L.space (void spaceChar) (L.skipLineComment "/") (L.skipBlockCom symbol :: String -> Parser String symbol = L.symbol spaceConsumer -pStack :: Parser Stack -pStack = ((string "python" <|> string "Python") *> ((Python2 <$ (string "27" <|> string "2")) +pLanguage :: Parser Language +pLanguage = ((string "python" <|> string "Python") *> ((Python2 <$ (string "27" <|> string "2")) <|> pure Python)) <|> (NodeJS <$ (string "nodejs" <|> string "NodeJS")) diff --git a/nstack/src/NStack/Module/QMap.hs b/nstack/src/NStack/Module/QMap.hs new file mode 100644 index 0000000..ebb91ed --- /dev/null +++ b/nstack/src/NStack/Module/QMap.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module NStack.Module.QMap where + +import Data.Aeson +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) + +import GHC.Generics (Generic) + +import NStack.Module.Types (Qualified(..), ModuleName(..)) +import NStack.Module.Types.Aeson () + +{- + Qualified Map datatype - store values under Qualified Keys, with a simplified interface + for querying and working with them. +-} + +newtype QMap k v = QMap { + inner :: Map ModuleName (Map k v) +} deriving (Show, Functor, Generic, ToJSON, FromJSON) + +-- QMap monoid is left-biased like Map +-- This could probably be more performant if we took into account +-- the actual internal structure of the map +instance Ord k => Monoid (QMap k v) where + (QMap inner) `mappend` b = + foldl (flip $ uncurry insert) b elements + where elements = do (mod', map') <- Map.toList inner + (k, v) <- Map.toList map' + return (Qualified mod' k, v) + mempty = QMap mempty + +lookup :: Ord k => Qualified k -> QMap k v -> Maybe v +lookup (Qualified mod' k) (QMap inner) = Map.lookup mod' inner >>= Map.lookup k + +insert :: Ord k => Qualified k -> v -> QMap k v -> QMap k v +insert (Qualified mod' k) v (QMap inner) = QMap $ Map.insertWith f mod' (Map.singleton k v) inner + where f new old = new <> old + +-- Overrides previous members +overrideModule :: Ord k => ModuleName -> Map k v -> QMap k v -> QMap k v +overrideModule mod' members (QMap inner) = QMap $ Map.insert mod' members inner + +flatten :: Ord k => QMap k v -> Map (Qualified k) v +flatten (QMap inner) = Map.foldMapWithKey (\mod' m -> Map.mapKeys (Qualified mod') m) inner + +mapKeys :: Ord k2 => (k1 -> k2) -> QMap k1 v -> QMap k2 v +mapKeys f (QMap inner) = QMap $ Map.mapKeys f <$> inner + +filter :: (v -> Bool) -> QMap k v -> QMap k v +filter p (QMap inner) = QMap $ Map.filter p <$> inner diff --git a/nstack/src/NStack/Module/Types.hs b/nstack/src/NStack/Module/Types.hs index aca3bd1..6e8dae5 100644 --- a/nstack/src/NStack/Module/Types.hs +++ b/nstack/src/NStack/Module/Types.hs @@ -7,20 +7,20 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as Base16 import Data.Coerce (coerce) import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..), SafeCopy(..), safePut, safeGet, contain) -import Data.Semigroup +import Data.Monoid ((<>)) import Data.Serialize (Serialize(..)) import Data.Serialize.Get (getListOf) import Data.Serialize.Put (putListOf) import Data.String (IsString) import Data.Text (Text) -- from: text import qualified Data.Text as T -- from: text -import Data.Aeson (ToJSON(..)) +import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey, FromJSONKey) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable (Typeable) import Data.Data (Data(..)) import Data.UUID (UUID) import GHC.Generics (Generic) -import Text.PrettyPrint.Mainland (Pretty, ppr, text, commasep) -- from: mainland-pretty +import Text.PrettyPrint.Mainland (Pretty, ppr, text, commasep, char, integer) -- from: mainland-pretty import Text.Printf (printf) import NStack.Auth (UserName(..), nstackUserName) @@ -28,24 +28,32 @@ import NStack.SafeCopyOrphans () import NStack.UUIDOrphans () import NStack.Prelude.Text (showT, putText, getText, pprS) +type APIVersion = Integer -data Stack = Python | Python2 | NodeJS - -- Custom Text -- TODO - add a Custom Stack that reads config from a YAML file at build-time - deriving (Show, Eq, Generic) +data Language = Python | Python2 | NodeJS | Haskell | R + deriving (Show, Eq, Ord, Generic) + +data Stack = Stack Language APIVersion + deriving (Show, Eq, Ord, Generic) + +instance Serialize Language +$(deriveSafeCopy 0 'base ''Language) instance Serialize Stack $(deriveSafeCopy 0 'base ''Stack) -instance Pretty Stack where +instance Pretty Language where ppr = text . show --- System stacks -stacks :: [Stack] -stacks = [Python, Python2, NodeJS] +instance Pretty Stack where + ppr (Stack l v) = ppr l <> char '-' <> integer v newtype NSUri = NSUri { _nsUri :: [Text] } deriving (Eq, Ord, Typeable, Data, Generic) +instance ToJSON NSUri +instance FromJSON NSUri + instance Show NSUri where show = T.unpack . T.intercalate "." . _nsUri @@ -68,6 +76,9 @@ data Version_v1 = Version_v1 Integer Integer Integer Bool data Release = Snapshot | Release deriving (Eq, Ord, Show, Generic, Typeable, Data) +instance ToJSON Release +instance FromJSON Release + -- TODO add version helper funcs that support semver? data Version = Version { _majorVer :: Integer, @@ -76,6 +87,9 @@ data Version = Version { _release :: Release } deriving (Eq, Ord, Generic, Typeable, Data) +instance ToJSON Version +instance FromJSON Version + instance Migrate Version_v1 where type MigrateFrom Version_v1 = Version_v0 migrate (Version_v0 a b c) = Version_v1 a b c True @@ -105,25 +119,23 @@ data ModuleName = ModuleName { _mVersion :: Version } deriving (Show, Eq, Ord, Generic, Typeable, Data) --- | Used by IDLJSONWriter -instance ToJSON ModuleName where - toJSON = toJSON . pprS - instance Pretty ModuleName where ppr = text . showShortModuleName -sameNSName :: ModuleName -> ModuleName -> Bool -sameNSName (ModuleName r a n _) (ModuleName r' a' n' _) = r == r' && a == a' && n == n' - -ordByVersion :: ModuleName -> ModuleName -> Ordering -ordByVersion m@(ModuleName _ _ _ v) m'@(ModuleName _ _ _ v') = if sameNSName m m' then compare v v' else EQ - nStackRegistry :: NSUri nStackRegistry = NSUri ["registry", "nstack", "com"] +-- | Helper function to create a ModuleName using the default registry/author mkNStackModuleName :: NSUri -> Version -> ModuleName mkNStackModuleName = ModuleName nStackRegistry nstackUserName +type FedoraVersion = Integer +type FedoraSnapshot = Integer + +-- | Make an NStack module name used internally for base images by the system +mkBaseModuleName :: Text -> APIVersion -> FedoraVersion -> FedoraSnapshot -> ModuleName +mkBaseModuleName s v majS minS = mkNStackModuleName (NSUri ["NStack", s]) (Version majS minS v Release) + -- | display the module name, hiding registry and author if they are the default showShortModuleName :: ModuleName -> String showShortModuleName ModuleName{..} = T.unpack $ reg <> aut <> showT _mName <> ":" <> showT _mVersion @@ -152,7 +164,7 @@ instance Migrate ModuleName where -- | The name of an NStack function newtype FnName = FnName Text - deriving (Eq, Ord, Typeable, IsString, Pretty, Generic, ToJSON, Data) + deriving (Eq, Ord, Typeable, IsString, Pretty, Generic, ToJSON, FromJSON, ToJSONKey, FromJSONKey, Data) instance Show FnName where show = coerce T.unpack @@ -165,7 +177,7 @@ $(deriveSafeCopy 0 'base ''FnName) -- | The name of an NStack type newtype TyName = TyName Text - deriving (Eq, Ord, Typeable, Data, IsString, Pretty, Generic, ToJSON) + deriving (Eq, Ord, Typeable, Data, IsString, Pretty, Generic, ToJSON, FromJSON, ToJSONKey, FromJSONKey) instance Show TyName where show = coerce T.unpack @@ -181,10 +193,6 @@ data Qualified a = Qualified } deriving (Eq, Ord, Typeable, Generic, Data) --- | Used by IDLJSONWriter -instance ToJSON a => ToJSON (Qualified a) where - toJSON (Qualified m n) = toJSON (m, n) - type QFnName = Qualified FnName type QTyName = Qualified TyName @@ -252,6 +260,11 @@ instance Monoid DebugOpt where instance Serialize DebugOpt +instance ToJSON DebugOpt where + toJSON Debug = toJSON True + toJSON NoDebug = toJSON False + + class HasDebugOpt a where debugOpt :: Lens' a DebugOpt diff --git a/nstack/src/NStack/Module/Types/Aeson.hs b/nstack/src/NStack/Module/Types/Aeson.hs new file mode 100644 index 0000000..febf35c --- /dev/null +++ b/nstack/src/NStack/Module/Types/Aeson.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module exists to export Aeson instances for NStack.Module.Types definitions +-- where they would normally cause a cycle between that module and NStack.Module.Parser +module NStack.Module.Types.Aeson where +import Data.Aeson + +import NStack.Module.Parser +import NStack.Module.Types +import NStack.Prelude.Text (pprS) + +instance ToJSON ModuleName where + toJSON = toJSON . pprS + +instance FromJSON ModuleName where + parseJSON = withText "ModuleName" $ either error return . parseModuleName + +instance ToJSONKey ModuleName +instance FromJSONKey ModuleName + +instance ToJSON a => ToJSON (Qualified a) where + toJSON (Qualified m n) = toJSON (m, n) + +instance FromJSON a => FromJSON (Qualified a) where + parseJSON a = uncurry Qualified <$> parseJSON a + +instance ToJSON a => ToJSONKey (Qualified a) +instance FromJSON a => FromJSONKey (Qualified a) diff --git a/nstack/src/NStack/Settings.hs b/nstack/src/NStack/Settings.hs index 52ec7b4..1ffead8 100644 --- a/nstack/src/NStack/Settings.hs +++ b/nstack/src/NStack/Settings.hs @@ -17,8 +17,10 @@ module NStack.Settings (SettingsT, defaultAuthServer, frontendHost, serviceLimits, + getServiceLimits, cliTimeout, debug, + getCliTimeout, defaultFrontendHost, runSettingsParser, serverConn, diff --git a/nstack/src/NStack/Settings/Types.hs b/nstack/src/NStack/Settings/Types.hs index 4651110..d901a9d 100644 --- a/nstack/src/NStack/Settings/Types.hs +++ b/nstack/src/NStack/Settings/Types.hs @@ -94,11 +94,20 @@ authServer f s = (\r -> s { _authServer = r }) <$> f (_authServer s) frontendHost :: Lens' Settings (Maybe HostName) frontendHost f s = (\r -> s { _frontendHost = r }) <$> f (_frontendHost s) -serviceLimits :: Lens' Settings Bool -- containers are limited by default -serviceLimits f s = (\r -> s { _serviceLimits = Just r }) <$> f (fromMaybe True $ _serviceLimits s) +serviceLimits :: Lens' Settings (Maybe Bool) +serviceLimits f s = (\r -> s { _serviceLimits = r }) <$> f (_serviceLimits s) -cliTimeout :: Lens' Settings Int -cliTimeout f s = (\r -> s { _cliTimeout = Just r }) <$> f (fromMaybe 15 $ _cliTimeout s) +getOrDefault :: Lens' Settings (Maybe a) -> a -> Settings -> a +getOrDefault someLens someDefault s = fromMaybe someDefault (s ^. someLens) + +getServiceLimits :: Settings -> Bool +getServiceLimits = getOrDefault serviceLimits True + +cliTimeout :: Lens' Settings (Maybe Int) +cliTimeout f s = (\r -> s { _cliTimeout = r }) <$> f(_cliTimeout s) + +getCliTimeout :: Settings -> Int +getCliTimeout = getOrDefault cliTimeout 15 debug :: Lens' Settings DebugOpt debug f s = (\r -> s { _debug = Just r }) <$> f (fromMaybe NoDebug $ _debug s) @@ -137,7 +146,11 @@ instance ToJSON Settings where "authentication" .= (a ^. authSettings), "server" .= (a ^. serverConn), "auth-server" .= (a ^. authServer), - "frontend-host" .= (a ^. frontendHost)] + "frontend-host" .= (a ^. frontendHost), + "debug" .= (a ^. debug), + "cli-timeout" .= (a ^. cliTimeout), + "service-limits" .= (a ^. serviceLimits) ] + class MonadSettings m where settings :: m Settings diff --git a/nstack/test/TestSuite.hs b/nstack/test/TestSuite.hs index f46f681..24b7377 100644 --- a/nstack/test/TestSuite.hs +++ b/nstack/test/TestSuite.hs @@ -1,16 +1,19 @@ import Control.Monad (unless) import qualified Data.ByteString as BS +import Data.ByteString.Lazy (toStrict) import Data.List (isInfixOf) - +import Data.Aeson import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Runners (defaultMainWithIngredients) import Test.Tasty.Runners.AntXML +import NStack.Module.Types import NStack.Settings import NStack.Auth (readKey, readUserId) + main :: IO () main = defaultMainWithIngredients (antXMLRunner:defaultIngredients) $ testGroup "Tests" [ settingsParserTests @@ -40,7 +43,10 @@ settingsParserTests = testGroup "Unit Tests" checkErrorMessages "test/res/invalid-frontend-host.conf" "Expected frontend-host url not to contain a trailing slash", testCase "Parse a settings file" - parseSettingsFileTest + parseSettingsFileTest, + + testCase "Serializing and then deserializing is the identity" $ + serializeDeserialize completeSettingsSample ] checkErrorMessages :: FilePath -> String -> IO () @@ -77,3 +83,23 @@ parseSettingsFileTest = do Nothing Nothing Nothing + +completeSettingsSample :: Settings +completeSettingsSample = Settings + (Nothing :: Maybe InstallID) + (Just AnalyticsEnabled) + (NStackHMAC <$> readUserId "1a2b3c" <*> readKey "abc123") + (Just (HostName "https://demo-register.nstack.com:8443")) + (Just (ServerDetails (Just $ HostName "adfadfa") (Just 3000))) + (Just $ HostName "http://localhost:8000") + (Just True) + (Just 23) + (Just Debug) + +serializeDeserialize :: Settings -> IO () +serializeDeserialize s = do + let bs = toStrict (encode s) + either + (const $ assertFailure "Parsing should not have failed") + (assertEqual "Original and serialize-deserialized should be equal" s) + (runSettingsParser bs) diff --git a/nstack/test_output.xml b/nstack/test_output.xml index acb5cfb..4d49a98 100644 --- a/nstack/test_output.xml +++ b/nstack/test_output.xml @@ -1 +1 @@ - \ No newline at end of file + \ No newline at end of file