From 5552a7714d4e77fffef7ee4b8fabc5946fd68b01 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Mon, 26 May 2025 23:33:52 -0300 Subject: [PATCH 1/7] Witch casts --- src/Lineman.hs | 46 ++++++++++++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/src/Lineman.hs b/src/Lineman.hs index dd7b917..23752d1 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -14,6 +14,7 @@ import qualified Control.Monad.Extra as E import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) import Cook (prepareConditions) +import Data.Text (Text) import qualified Data.Text as T import Log (logDebug, logError, logInfo) import Path.IO (doesDirExist, doesFileExist, listDir, listDirRecur) @@ -29,29 +30,34 @@ launchAction = do target <- asks envTarget conditions <- asks envConditions list <- prepareConditions target conditions - logDebug $ T.pack $ show list + logDebug $ into @Text $ show list forM_ list $ \(mTarget, mFiles, dirs, exts, command, args) -> do dirsForLaunch <- case (mTarget, mFiles) of (Just t, Just fs) -> getDirsForCommand t fs dirs exts _ -> pure [] - logDebug $ "Directories for running action: " <> T.pack (show dirsForLaunch) + logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) forAction <- asks envActionMode codes <- seq dirsForLaunch $ forAction dirsForLaunch $ \d -> do let act = showCommandForUser command args - let dir = T.pack (show d) - logInfo $ "Action \'" <> T.pack act <> "\' is running in " <> dir + let dir = into @Text (show d) + logInfo $ "Action \'" <> into @Text act <> "\' is running in " <> dir action command args d if all (== ExitSuccess) codes then logInfo "All actions successfuly finished!" else logError "Some action(s) failed" -getDirsForCommand :: Path Abs Dir -> [Path Rel File] -> [Path Rel Dir] -> [String] -> App [Path Abs Dir] +getDirsForCommand + :: Path Abs Dir + -> [Path Rel File] + -> [Path Rel Dir] + -> [String] + -> App [Path Abs Dir] getDirsForCommand target files dirs exts = do (targets, _) <- listDirRecur target seq targets $ do res <- findDirsDyFiles (target : targets) files dirs exts - logDebug $ "Found directories: " <> T.pack (show res) + logDebug $ "Found directories: " <> into @Text (show res) pure res action :: FilePath -> [String] -> Path Abs Dir -> App ExitCode @@ -64,17 +70,21 @@ action commandName args path = do readProcess dateConfig case stderr of "" -> pure () - err -> logError $ "In " - <> T.pack (show path) - <> " occurred stderr: \n" - <> T.strip (unsafeInto @T.Text $ into @Utf8L err) + err -> + logError $ + "In " + <> into @Text (show path) + <> " occurred stderr: \n" + <> T.strip (unsafeInto @Text $ into @Utf8L err) case stdout of "" -> pure () - out -> logDebug $ "In " - <> T.pack (show path) - <> " occurred stdout: \n" - <> unsafeInto @T.Text (into @Utf8L out) - logDebug $ T.pack (show exitCode) + out -> + logDebug $ + "In " + <> into @Text (show path) + <> " occurred stdout: \n" + <> unsafeInto @Text (into @Utf8L out) + logDebug $ into @Text (show exitCode) pure exitCode findDirsDyFiles @@ -93,9 +103,9 @@ findDirsDyFiles d [] [] [] = pure d findDirsDyFiles (d : ds) files dirs exts = do dFiles <- snd <$> listDir d existFiles <- E.allM (\f -> doesFileExist $ d f) files - logDebug $ "In directory: " <> T.pack (show d) - logDebug $ "file(s) " <> T.pack (show files) - logDebug $ "exist? " <> T.pack (show existFiles) + logDebug $ "In directory: " <> into @Text (show d) + logDebug $ "file(s) " <> into @Text (show files) + logDebug $ "exist? " <> into @Text (show existFiles) existDirs <- E.allM (\f -> doesDirExist $ d f) dirs existExts <- isExtsInFiles exts dFiles if existFiles && existDirs && existExts From 2a44cd3b724b729925bd20e231d871ce092ce35a Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Tue, 27 May 2025 23:51:44 -0300 Subject: [PATCH 2/7] Reorganize stuff --- CHANGELOG.md | 6 +++ justfile | 3 ++ lineman.cabal | 7 +-- lineman.dhall | 52 ++++++++++++--------- src/App.hs | 21 ++++----- src/Concurrent.hs | 10 ++++ src/Cook.hs | 78 -------------------------------- src/Lineman.hs | 35 +++++++------- src/Parser.hs | 76 +++++++++++++++++++++++++++++++ src/{Types.hs => Type/Domain.hs} | 59 ++++++++---------------- src/Type/Raw.hs | 43 ++++++++++++++++++ 11 files changed, 218 insertions(+), 172 deletions(-) delete mode 100644 src/Cook.hs create mode 100644 src/Parser.hs rename src/{Types.hs => Type/Domain.hs} (63%) create mode 100644 src/Type/Raw.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 51b76db..12ef0ec 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,12 @@ `lineman` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 1.0.5 + +* Restructure modules +* Differ raw and domain types +* Add option for swarm concurrency + ## 1.0.4 * Land on `typed-base` diff --git a/justfile b/justfile index c82b57e..e0c7c40 100644 --- a/justfile +++ b/justfile @@ -12,6 +12,9 @@ install: build: cabal build +run: + cabal run lineman -- ./lineman.dhall + # update the bounds of dependencies update: cabal-bounds update diff --git a/lineman.cabal b/lineman.cabal index d951b4d..3f165a2 100644 --- a/lineman.cabal +++ b/lineman.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: lineman -version: 1.0.4 +version: 1.0.5 synopsis: traverse directory and run command description: Lineman traverses directory recursively and run command by condition @@ -54,11 +54,12 @@ library hs-source-dirs: src exposed-modules: App - Cook + Type.Raw + Type.Domain + Parser Concurrent Lineman Log - Types build-depends: , containers diff --git a/lineman.dhall b/lineman.dhall index d2d4cfc..f7cd5c4 100644 --- a/lineman.dhall +++ b/lineman.dhall @@ -1,23 +1,36 @@ -let Condition : Type = - { hasFiles : List Text - , hasDirectories : List Text - , hasExtensions : List Text - , command : Text - , args : List Text +let RawCondition : Type = + { rcIndex : Natural + , rcTarget : Text + , rcHasFiles : List Text + , rcHasDirectories : List Text + , rcHasExtensions : List Text + , rcCommand : Text + , rcArgs : List Text + , rcActConcurrent : Bool + , rcWithBreak : Natural } -let condition1 : Condition = - { hasFiles = ["stack.yaml"] : List Text +let condition_1 : RawCondition = + { rcIndex = 1 + -- Arbitrary index + , rcTarget = "~/source/test/" + -- ^ target where you plan that the lineman recursively starts from. + -- target consume 'rel', 'abs' and '~'' paths + , rcHasFiles = ["log"] : List Text -- ^ Target directory has files - , hasDirectories = [".exercism"] : List Text + , rcHasDirectories = [] : List Text -- ^ Target directory has directories - , hasExtensions = [] : List Text + , rcHasExtensions = [] : List Text -- ^ Target directory has extensions. -- It consume exts with and without '.' - , command = "ls" + , rcCommand = "kate" -- ^ Command to run in searched directories - , args = [] : List Text + , rcArgs = ["log"] : List Text -- ^ Command's arguments + , rcActConcurrent = True + -- ^ run actions concurrently within the particular condition + , rcWithBreak = 0 + -- ^ Interval between actions in microseconds } let Verbosity : Type = < V0 | V1 | V2 | V3 > @@ -25,13 +38,10 @@ let Verbosity : Type = < V0 | V1 | V2 | V3 > let Severity : Type = < DebugS | InfoS | NoticeS | WarningS | ErrorS | CriticalS | AlertS | EmergencyS > -in { cTarget = "your/path" - -- ^ target where you plan that the lineman recursively starts from. - -- target consume 'rel', 'abs' and '~'' paths - , cConditions = [ condition1 ] : List Condition - -- ^ within the target one can run several commands with its own conditions - , cAsync = False - -- ^ make lineman to work concurrently - , cSeverity = Severity.DebugS - , cVerbosity = Verbosity.V0 +in { confRawConditions = [ condition_1 ] : List RawCondition + -- ^ within the target it is possible to run several commands with own conditions + , confSeverity = Severity.DebugS + , confVerbosity = Verbosity.V0 + , confSwarmConcurrent = False + -- ^ run the swarm of actions concurrently } \ No newline at end of file diff --git a/src/App.hs b/src/App.hs index 35342f6..6225d67 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,15 +2,14 @@ module App ( appLineman, ) where -import Cook (safeHead) import Lineman (launchAction) import Log (mkLogEnv) -import Types (App (unApp), Config (..), Env (..)) -import Concurrent (forConcurrentlyKi) +import Parser (prepareConditions, safeHead) +import Type.Domain (App (unApp), Env (..)) +import Type.Raw (Config (..)) --- import Control.Concurrent.Async.Lifted (forConcurrently) import Control.Exception.Safe (throwIO, tryAny) -import Control.Monad (forM, when) +import Control.Monad (when) import Control.Monad.Reader (ReaderT (..)) import Dhall (auto, inputFile) import System.Environment (getArgs) @@ -27,18 +26,15 @@ appLineman = do pPrintString "Launch command with that Config? (yes/no)" str <- getLine when (str == "yes") $ do - logEnv <- mkLogEnv (cVerbosity config) (cSeverity config) + conditions <- prepareConditions $ confRawConditions config + logEnv <- mkLogEnv (confVerbosity config) (confSeverity config) let env = Env { envLogEnv = logEnv - , envActionMode = - if cAsync config - then forConcurrentlyKi - else forM , envLogContext = mempty , envLogNamespace = mempty - , envTarget = cTarget config - , envConditions = cConditions config + , envConditions = conditions + , envSwarmConcurrent = confSwarmConcurrent config } runApp env launchAction @@ -53,4 +49,3 @@ getConfig path = do pPrintString "Config parsing failed" throwIO err Right decoded -> pure decoded - diff --git a/src/Concurrent.hs b/src/Concurrent.hs index 4f15845..41276f4 100644 --- a/src/Concurrent.hs +++ b/src/Concurrent.hs @@ -4,6 +4,7 @@ module Concurrent ( forConcurrentlyKi, + forConcurrentlyKi_, ) where import Control.Concurrent.STM (atomically) @@ -21,6 +22,15 @@ forConcurrentlyKi ns f = control $ \unlift -> scopedM \scope -> unlift $ do threads <- mapM (forkM scope . f) ns mapM (liftBase . atomically . Ki.await) threads +forConcurrentlyKi_ + :: (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) + => [a] + -> (a -> m b) + -> m () +forConcurrentlyKi_ ns f = control $ \unlift -> scopedM \scope -> unlift $ do + threads <- mapM (forkM scope . f) ns + mapM_ (liftBase . atomically . Ki.await) threads + forkM :: (MonadBaseControl IO m, StM m (Ki.Thread a) ~ Ki.Thread a, StM m a ~ a) => Ki.Scope diff --git a/src/Cook.hs b/src/Cook.hs deleted file mode 100644 index 43a4b1d..0000000 --- a/src/Cook.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Cook ( - safeHead, - prepareConditions, -) where - -import Control.Monad (forM) -import qualified Control.Monad.Extra as E -import qualified Data.List.Extra as E -import Data.Maybe (fromMaybe) -import Data.Set (toList) -import Path.IO (AnyPath (makeAbsolute)) -import Path.Posix ( - Abs, - Dir, - File, - Path, - Rel, - SomeBase (Abs, Rel), - parseRelDir, - parseSomeDir, - parseSomeFile, - ) -import qualified System.Directory as D -import qualified System.FilePath.Posix as FP - -import Control.Monad.IO.Class (liftIO) -import Types (App, Conditions (..)) - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (a : _) = Just a - --- Normilize functions - -normilizeDirAbs :: FilePath -> App (Maybe (Path Abs Dir)) -normilizeDirAbs path = do - let (homeMarker, relPath) = splitAt 1 path - path' <- E.whenMaybe (homeMarker == "~") $ do - home <- liftIO D.getHomeDirectory - pure $ home <> "/" <> relPath - someDir <- liftIO $ parseSomeDir $ fromMaybe path path' - case someDir of - Abs a -> pure $ Just a - Rel r -> Just <$> makeAbsolute r - -normilizeDirRel :: FilePath -> App (Path Rel Dir) -normilizeDirRel = liftIO . parseRelDir - -normilizeFile :: FilePath -> App (Maybe (Path Rel File)) -normilizeFile path = - if FP.isRelative path && FP.isValid path && not (FP.hasTrailingPathSeparator path) - then do - someFile <- liftIO $ parseSomeFile path - case someFile of - Abs _ -> pure Nothing - Rel r -> pure $ Just r - else pure Nothing - -prepareConditions - :: FilePath - -> [Conditions] - -> App - [ ( Maybe (Path Abs Dir) - , Maybe [Path Rel File] - , [Path Rel Dir] - , [String] - , String - , [String] - ) - ] -prepareConditions target conditions = do - mTarget <- normilizeDirAbs $ E.trim target - forM conditions $ \Conditions{..} -> do - mFiles <- sequence <$> traverse normilizeFile (toList hasFiles) - dirs <- traverse normilizeDirRel $ toList hasDirectories - let normalizedExt e = if "." == take 1 e then e else '.' : e - let exts = map normalizedExt $ toList hasExtensions - pure (mTarget, mFiles, dirs, exts, command, args) diff --git a/src/Lineman.hs b/src/Lineman.hs index 23752d1..e3c8bd5 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -7,13 +7,15 @@ module Lineman ( ) where +import Concurrent (forConcurrentlyKi, forConcurrentlyKi_) +import Type.Domain (App, Condition (..), Env (..)) + -- import Control.Concurrent (threadDelay) import Control.Exception.Safe (try) -import Control.Monad (forM_) +import Control.Monad (forM, forM_) import qualified Control.Monad.Extra as E import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) -import Cook (prepareConditions) +import Control.Monad.Reader (ask) import Data.Text (Text) import qualified Data.Text as T import Log (logDebug, logError, logInfo) @@ -21,28 +23,27 @@ import Path.IO (doesDirExist, doesFileExist, listDir, listDirRecur) import Path.Posix (Abs, Dir, File, Path, PathException, Rel, fileExtension, toFilePath, ()) import System.Process.Extra (showCommandForUser) import System.Process.Typed -import Types (App, Env (..)) import Witch import Prelude hiding (log) launchAction :: App () launchAction = do - target <- asks envTarget - conditions <- asks envConditions - list <- prepareConditions target conditions - logDebug $ into @Text $ show list - forM_ list $ \(mTarget, mFiles, dirs, exts, command, args) -> do - dirsForLaunch <- case (mTarget, mFiles) of - (Just t, Just fs) -> getDirsForCommand t fs dirs exts + env <- ask + let conditions = envConditions env + logDebug $ "Conditions: " <> into @Text (show conditions) + let forSwarm = if envSwarmConcurrent env then forConcurrentlyKi_ else forM_ + forSwarm conditions $ \Condition{..} -> do + dirsForLaunch <- case (cTarget, cFiles) of + (Just target, Just files) -> getDirsForCommand target files cDirectories cExtensions _ -> pure [] logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) - forAction <- asks envActionMode + let forAction = if cActConcurrent then forConcurrentlyKi else forM codes <- seq dirsForLaunch $ forAction dirsForLaunch $ \d -> do - let act = showCommandForUser command args + let act = showCommandForUser cCommand cArguments let dir = into @Text (show d) logInfo $ "Action \'" <> into @Text act <> "\' is running in " <> dir - action command args d + action cCommand cArguments d if all (== ExitSuccess) codes then logInfo "All actions successfuly finished!" else logError "Some action(s) failed" @@ -73,7 +74,7 @@ action commandName args path = do err -> logError $ "In " - <> into @Text (show path) + <> into @Text (toFilePath path) <> " occurred stderr: \n" <> T.strip (unsafeInto @Text $ into @Utf8L err) case stdout of @@ -81,7 +82,7 @@ action commandName args path = do out -> logDebug $ "In " - <> into @Text (show path) + <> into @Text (toFilePath path) <> " occurred stdout: \n" <> unsafeInto @Text (into @Utf8L out) logDebug $ into @Text (show exitCode) @@ -103,7 +104,7 @@ findDirsDyFiles d [] [] [] = pure d findDirsDyFiles (d : ds) files dirs exts = do dFiles <- snd <$> listDir d existFiles <- E.allM (\f -> doesFileExist $ d f) files - logDebug $ "In directory: " <> into @Text (show d) + logDebug $ "In directory: " <> into @Text (toFilePath d) logDebug $ "file(s) " <> into @Text (show files) logDebug $ "exist? " <> into @Text (show existFiles) existDirs <- E.allM (\f -> doesDirExist $ d f) dirs diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 index 0000000..879e573 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,76 @@ +module Parser ( + safeHead, + prepareConditions, +) where + +import Type.Domain (Condition (..)) +import Type.Raw (RawCondition (..)) + +import Control.Monad (forM) +import qualified Control.Monad.Extra as E +import qualified Data.List.Extra as E +import Data.Maybe (fromMaybe) +import Data.Set (toList) +import Path.IO (AnyPath (makeAbsolute)) +import Path.Posix ( + Abs, + Dir, + File, + Path, + Rel, + SomeBase (Abs, Rel), + parseRelDir, + parseSomeDir, + parseSomeFile, + ) +import qualified System.Directory as D +import qualified System.FilePath.Posix as FP + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (a : _) = Just a + +-- Normalize functions + +normalizeDirAbs :: FilePath -> IO (Maybe (Path Abs Dir)) +normalizeDirAbs path = do + let (homeMarker, relPath) = splitAt 1 path + path' <- E.whenMaybe (homeMarker == "~") $ do + home <- D.getHomeDirectory + pure $ home <> "/" <> relPath + someDir <- parseSomeDir $ fromMaybe path path' + case someDir of + Abs a -> pure $ Just a + Rel r -> Just <$> makeAbsolute r + +normalizeFile :: FilePath -> IO (Maybe (Path Rel File)) +normalizeFile path = + if FP.isRelative path && FP.isValid path && not (FP.hasTrailingPathSeparator path) + then do + someFile <- parseSomeFile path + case someFile of + Abs _ -> pure Nothing + Rel r -> pure $ Just r + else pure Nothing + +prepareConditions + :: [RawCondition] + -> IO [Condition] +prepareConditions raw = do + forM raw $ \RawCondition{..} -> do + mTarget <- normalizeDirAbs $ E.trim rcTarget + mFiles <- sequence <$> traverse normalizeFile (toList rcHasFiles) + dirs <- traverse parseRelDir $ toList rcHasDirectories + let normalizedExt e = if "." == take 1 e then e else '.' : e + let exts = map normalizedExt $ toList rcHasExtensions + pure $ Condition { + cIndex = rcIndex, + cTarget = mTarget, + cFiles = mFiles, + cDirectories = dirs, + cExtensions = exts, + cCommand = rcCommand, + cArguments = rcArgs, + cActConcurrent = rcActConcurrent, + cWithBreak = rcWithBreak + } diff --git a/src/Types.hs b/src/Type/Domain.hs similarity index 63% rename from src/Types.hs rename to src/Type/Domain.hs index 8f73ee8..72fef92 100644 --- a/src/Types.hs +++ b/src/Type/Domain.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,18 +6,13 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Types ( +module Type.Domain ( App (..), Env (..), - Conditions (..), - Config (..), - ActionMode, + Condition (..), ) where import Control.Exception.Safe (MonadCatch, MonadMask, MonadThrow) @@ -31,14 +25,10 @@ import Control.Monad.Reader ( local, ) import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Set (Set) -import Dhall (FromDhall (..)) -import GHC.Generics (Generic) -import GHC.IO.Exception (ExitCode (..)) -import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace, Severity, Verbosity) +import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace) +import Path (File, Rel) import Path.Posix (Abs, Dir, Path) - newtype App a = MkApp { unApp :: ReaderT Env IO a } @@ -75,36 +65,25 @@ instance KatipContext App where localKatipNamespace f (MkApp m) = MkApp (local (\s -> s{envLogNamespace = f (envLogNamespace s)}) m) -type ActionMode = [Path Abs Dir] -> (Path Abs Dir -> App ExitCode) -> App [ExitCode] +-- type ActionMode = [Path Abs Dir] -> (Path Abs Dir -> App ExitCode) -> App [ExitCode] data Env = Env { envLogEnv :: LogEnv - , envActionMode :: ActionMode , envLogContext :: LogContexts , envLogNamespace :: Namespace - , envTarget :: FilePath - , envConditions :: [Conditions] + , envConditions :: [Condition] + , envSwarmConcurrent :: Bool } -data Config = Config - { cTarget :: FilePath - , cConditions :: [Conditions] - , cAsync :: Bool - , cSeverity :: Severity - , cVerbosity :: Verbosity - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromDhall) - -deriving anyclass instance FromDhall Verbosity -deriving anyclass instance FromDhall Severity - -data Conditions = Conditions - { hasFiles :: Set FilePath - , hasDirectories :: Set FilePath - , hasExtensions :: Set String - , command :: String - , args :: [String] +data Condition = Condition + { cIndex :: Word + , cTarget :: Maybe (Path Abs Dir) + , cFiles :: Maybe [Path Rel File] + , cDirectories :: [Path Rel Dir] + , cExtensions :: [String] + , cCommand :: String + , cArguments :: [String] + , cActConcurrent :: Bool + , cWithBreak :: Word } - deriving stock (Eq, Show, Generic, Ord) - deriving anyclass (FromDhall) + deriving stock (Show, Eq) diff --git a/src/Type/Raw.hs b/src/Type/Raw.hs new file mode 100644 index 0000000..3a4f428 --- /dev/null +++ b/src/Type/Raw.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Type.Raw ( + RawCondition (..), + Config (..), +) +where + +import Data.Set (Set) +import Dhall (FromDhall (..)) +import GHC.Generics (Generic) +import Katip (Severity, Verbosity) + +data RawCondition = RawCondition + { rcIndex :: Word + , rcTarget :: FilePath + , rcHasFiles :: Set FilePath + , rcHasDirectories :: Set FilePath + , rcHasExtensions :: Set String + , rcCommand :: String + , rcArgs :: [String] + , rcActConcurrent :: Bool + , rcWithBreak :: Word + } + deriving stock (Eq, Show, Generic, Ord) + deriving anyclass (FromDhall) + +data Config = Config + { confRawConditions :: [RawCondition] + , confSeverity :: Severity + , confVerbosity :: Verbosity + , confSwarmConcurrent :: Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromDhall) + +deriving anyclass instance FromDhall Verbosity + +deriving anyclass instance FromDhall Severity From a1a9f781f80632b4cc42c9ae9dfeb510ee0f9b0b Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Wed, 28 May 2025 00:59:31 -0300 Subject: [PATCH 3/7] Add breaks to conditions and general config --- lineman.dhall | 39 ++++++++++++++++++++++++++++++++------- src/App.hs | 28 ++++++++++++++++------------ src/Concurrent.hs | 10 +++++----- src/Lineman.hs | 21 ++++++++++++++------- src/Parser.hs | 6 ++++-- src/Type/Domain.hs | 6 ++++-- src/Type/Raw.hs | 3 ++- 7 files changed, 77 insertions(+), 36 deletions(-) diff --git a/lineman.dhall b/lineman.dhall index f7cd5c4..297d174 100644 --- a/lineman.dhall +++ b/lineman.dhall @@ -7,7 +7,7 @@ let RawCondition : Type = , rcCommand : Text , rcArgs : List Text , rcActConcurrent : Bool - , rcWithBreak : Natural + , rcWithBreak : Double } let condition_1 : RawCondition = @@ -23,14 +23,37 @@ let condition_1 : RawCondition = , rcHasExtensions = [] : List Text -- ^ Target directory has extensions. -- It consume exts with and without '.' - , rcCommand = "kate" + , rcCommand = "touch" -- ^ Command to run in searched directories - , rcArgs = ["log"] : List Text + , rcArgs = ["readme.txt"] : List Text -- ^ Command's arguments - , rcActConcurrent = True + , rcActConcurrent = False -- ^ run actions concurrently within the particular condition - , rcWithBreak = 0 - -- ^ Interval between actions in microseconds + , rcWithBreak = 1.0 + -- ^ Interval between actions in seconds + } + +let condition_2 : RawCondition = + { rcIndex = 2 + -- Arbitrary index + , rcTarget = "~/source/test/" + -- ^ target where you plan that the lineman recursively starts from. + -- target consume 'rel', 'abs' and '~'' paths + , rcHasFiles = ["log"] : List Text + -- ^ Target directory has files + , rcHasDirectories = [] : List Text + -- ^ Target directory has directories + , rcHasExtensions = [] : List Text + -- ^ Target directory has extensions. + -- It consume exts with and without '.' + , rcCommand = "rm" + -- ^ Command to run in searched directories + , rcArgs = ["readme.txt"] : List Text + -- ^ Command's arguments + , rcActConcurrent = False + -- ^ run actions concurrently within the particular condition + , rcWithBreak = 1.0 + -- ^ Interval between actions in seconds } let Verbosity : Type = < V0 | V1 | V2 | V3 > @@ -38,10 +61,12 @@ let Verbosity : Type = < V0 | V1 | V2 | V3 > let Severity : Type = < DebugS | InfoS | NoticeS | WarningS | ErrorS | CriticalS | AlertS | EmergencyS > -in { confRawConditions = [ condition_1 ] : List RawCondition +in { confRawConditions = [ condition_1, condition_2 ] : List RawCondition -- ^ within the target it is possible to run several commands with own conditions , confSeverity = Severity.DebugS , confVerbosity = Verbosity.V0 , confSwarmConcurrent = False -- ^ run the swarm of actions concurrently + , confSwarmBreak = 5.0 + -- ^ add delay of running next batch of actions (in seconds) } \ No newline at end of file diff --git a/src/App.hs b/src/App.hs index 6225d67..49415f5 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,7 +2,7 @@ module App ( appLineman, ) where -import Lineman (launchAction) +import Lineman (launchSwarm) import Log (mkLogEnv) import Parser (prepareConditions, safeHead) import Type.Domain (App (unApp), Env (..)) @@ -26,17 +26,21 @@ appLineman = do pPrintString "Launch command with that Config? (yes/no)" str <- getLine when (str == "yes") $ do - conditions <- prepareConditions $ confRawConditions config - logEnv <- mkLogEnv (confVerbosity config) (confSeverity config) - let env = - Env - { envLogEnv = logEnv - , envLogContext = mempty - , envLogNamespace = mempty - , envConditions = conditions - , envSwarmConcurrent = confSwarmConcurrent config - } - runApp env launchAction + mConditions <- prepareConditions $ confRawConditions config + case mConditions of + Nothing -> pPrintString "No conditions found in config file for running lineman" + Just conditions -> do + logEnv <- mkLogEnv (confVerbosity config) (confSeverity config) + let env = + Env + { envLogEnv = logEnv + , envLogContext = mempty + , envLogNamespace = mempty + , envConditions = conditions + , envSwarmConcurrent = confSwarmConcurrent config + , envSwarmBreak = confSwarmBreak config + } + runApp env launchSwarm runApp :: Env -> App a -> IO a runApp env app = runReaderT (unApp app) env diff --git a/src/Concurrent.hs b/src/Concurrent.hs index 41276f4..a22b666 100644 --- a/src/Concurrent.hs +++ b/src/Concurrent.hs @@ -14,17 +14,17 @@ import Control.Monad.Trans.Control (MonadBaseControl, StM, control) import Ki forConcurrentlyKi - :: (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) - => [a] + :: (Traversable t, MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) + => t a -> (a -> m b) - -> m [b] + -> m (t b) forConcurrentlyKi ns f = control $ \unlift -> scopedM \scope -> unlift $ do threads <- mapM (forkM scope . f) ns mapM (liftBase . atomically . Ki.await) threads forConcurrentlyKi_ - :: (MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) - => [a] + :: (Traversable t, MonadBaseControl IO m, StM m (Ki.Thread b) ~ Ki.Thread b, StM m b ~ b, MonadIO m) + => t a -> (a -> m b) -> m () forConcurrentlyKi_ ns f = control $ \unlift -> scopedM \scope -> unlift $ do diff --git a/src/Lineman.hs b/src/Lineman.hs index e3c8bd5..ceda980 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -1,22 +1,23 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} module Lineman ( - launchAction, + launchSwarm, ) where import Concurrent (forConcurrentlyKi, forConcurrentlyKi_) import Type.Domain (App, Condition (..), Env (..)) --- import Control.Concurrent (threadDelay) import Control.Exception.Safe (try) -import Control.Monad (forM, forM_) +import Control.Monad (forM, forM_, when) import qualified Control.Monad.Extra as E import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask) import Data.Text (Text) +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as T import Log (logDebug, logError, logInfo) import Path.IO (doesDirExist, doesFileExist, listDir, listDirRecur) @@ -25,21 +26,26 @@ import System.Process.Extra (showCommandForUser) import System.Process.Typed import Witch import Prelude hiding (log) +import System.Time.Extra (sleep) +-- import Data.List (uncons) -launchAction :: App () -launchAction = do +launchSwarm :: App () +launchSwarm = do env <- ask let conditions = envConditions env logDebug $ "Conditions: " <> into @Text (show conditions) let forSwarm = if envSwarmConcurrent env then forConcurrentlyKi_ else forM_ + let firstIndex = cIndex $ NonEmpty.head conditions forSwarm conditions $ \Condition{..} -> do + when (cIndex /= firstIndex) $ liftIO $ sleep $ envSwarmBreak env dirsForLaunch <- case (cTarget, cFiles) of (Just target, Just files) -> getDirsForCommand target files cDirectories cExtensions _ -> pure [] logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) let forAction = if cActConcurrent then forConcurrentlyKi else forM - codes <- seq dirsForLaunch $ - forAction dirsForLaunch $ \d -> do + let firstDirectory = seq dirsForLaunch $ head dirsForLaunch + codes <- forAction dirsForLaunch $ \d -> do + when (d /= firstDirectory) $ liftIO $ sleep cWithBreak let act = showCommandForUser cCommand cArguments let dir = into @Text (show d) logInfo $ "Action \'" <> into @Text act <> "\' is running in " <> dir @@ -47,6 +53,7 @@ launchAction = do if all (== ExitSuccess) codes then logInfo "All actions successfuly finished!" else logError "Some action(s) failed" + getDirsForCommand :: Path Abs Dir diff --git a/src/Parser.hs b/src/Parser.hs index 879e573..4a8b6bd 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -25,6 +25,7 @@ import Path.Posix ( ) import qualified System.Directory as D import qualified System.FilePath.Posix as FP +import Data.List.NonEmpty (NonEmpty, nonEmpty) safeHead :: [a] -> Maybe a safeHead [] = Nothing @@ -55,9 +56,9 @@ normalizeFile path = prepareConditions :: [RawCondition] - -> IO [Condition] + -> IO (Maybe (NonEmpty Condition)) prepareConditions raw = do - forM raw $ \RawCondition{..} -> do + conditions <- forM raw $ \RawCondition{..} -> do mTarget <- normalizeDirAbs $ E.trim rcTarget mFiles <- sequence <$> traverse normalizeFile (toList rcHasFiles) dirs <- traverse parseRelDir $ toList rcHasDirectories @@ -74,3 +75,4 @@ prepareConditions raw = do cActConcurrent = rcActConcurrent, cWithBreak = rcWithBreak } + pure $ nonEmpty conditions diff --git a/src/Type/Domain.hs b/src/Type/Domain.hs index 72fef92..629e0c0 100644 --- a/src/Type/Domain.hs +++ b/src/Type/Domain.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace) import Path (File, Rel) import Path.Posix (Abs, Dir, Path) +import Data.List.NonEmpty (NonEmpty) newtype App a = MkApp { unApp :: ReaderT Env IO a @@ -71,8 +72,9 @@ data Env = Env { envLogEnv :: LogEnv , envLogContext :: LogContexts , envLogNamespace :: Namespace - , envConditions :: [Condition] + , envConditions :: NonEmpty Condition , envSwarmConcurrent :: Bool + , envSwarmBreak :: Double } data Condition = Condition @@ -84,6 +86,6 @@ data Condition = Condition , cCommand :: String , cArguments :: [String] , cActConcurrent :: Bool - , cWithBreak :: Word + , cWithBreak :: Double } deriving stock (Show, Eq) diff --git a/src/Type/Raw.hs b/src/Type/Raw.hs index 3a4f428..917fb9a 100644 --- a/src/Type/Raw.hs +++ b/src/Type/Raw.hs @@ -24,7 +24,7 @@ data RawCondition = RawCondition , rcCommand :: String , rcArgs :: [String] , rcActConcurrent :: Bool - , rcWithBreak :: Word + , rcWithBreak :: Double } deriving stock (Eq, Show, Generic, Ord) deriving anyclass (FromDhall) @@ -34,6 +34,7 @@ data Config = Config , confSeverity :: Severity , confVerbosity :: Verbosity , confSwarmConcurrent :: Bool + , confSwarmBreak :: Double } deriving stock (Eq, Show, Generic) deriving anyclass (FromDhall) From cc1a46986ed52b0349da3917a549e0d615f8c4b9 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Wed, 28 May 2025 08:54:09 -0300 Subject: [PATCH 4/7] Throw readable exception when target path is invalid --- lineman.dhall | 2 +- src/Lineman.hs | 5 ++--- src/Parser.hs | 41 +++++++++++++++++++++++++---------------- src/Type/Domain.hs | 4 ++-- 4 files changed, 30 insertions(+), 22 deletions(-) diff --git a/lineman.dhall b/lineman.dhall index 297d174..4f3acef 100644 --- a/lineman.dhall +++ b/lineman.dhall @@ -14,7 +14,7 @@ let condition_1 : RawCondition = { rcIndex = 1 -- Arbitrary index , rcTarget = "~/source/test/" - -- ^ target where you plan that the lineman recursively starts from. + -- ^ first target where lineman starts recursively from. -- target consume 'rel', 'abs' and '~'' paths , rcHasFiles = ["log"] : List Text -- ^ Target directory has files diff --git a/src/Lineman.hs b/src/Lineman.hs index ceda980..bf2385b 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -27,7 +27,6 @@ import System.Process.Typed import Witch import Prelude hiding (log) import System.Time.Extra (sleep) --- import Data.List (uncons) launchSwarm :: App () launchSwarm = do @@ -38,8 +37,8 @@ launchSwarm = do let firstIndex = cIndex $ NonEmpty.head conditions forSwarm conditions $ \Condition{..} -> do when (cIndex /= firstIndex) $ liftIO $ sleep $ envSwarmBreak env - dirsForLaunch <- case (cTarget, cFiles) of - (Just target, Just files) -> getDirsForCommand target files cDirectories cExtensions + dirsForLaunch <- case cFiles of + Just files -> getDirsForCommand cTarget files cDirectories cExtensions _ -> pure [] logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) let forAction = if cActConcurrent then forConcurrentlyKi else forM diff --git a/src/Parser.hs b/src/Parser.hs index 4a8b6bd..5a9c53a 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeApplications #-} + module Parser ( safeHead, prepareConditions, @@ -17,15 +19,19 @@ import Path.Posix ( Dir, File, Path, + PathException, Rel, SomeBase (Abs, Rel), parseRelDir, parseSomeDir, parseSomeFile, ) + +import Control.Exception (catch, throwIO) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified System.Directory as D import qualified System.FilePath.Posix as FP -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Text.Pretty.Simple (pPrintString) safeHead :: [a] -> Maybe a safeHead [] = Nothing @@ -33,7 +39,7 @@ safeHead (a : _) = Just a -- Normalize functions -normalizeDirAbs :: FilePath -> IO (Maybe (Path Abs Dir)) +normalizeDirAbs :: FilePath -> IO (Path Abs Dir) normalizeDirAbs path = do let (homeMarker, relPath) = splitAt 1 path path' <- E.whenMaybe (homeMarker == "~") $ do @@ -41,8 +47,8 @@ normalizeDirAbs path = do pure $ home <> "/" <> relPath someDir <- parseSomeDir $ fromMaybe path path' case someDir of - Abs a -> pure $ Just a - Rel r -> Just <$> makeAbsolute r + Abs a -> pure a + Rel r -> makeAbsolute r normalizeFile :: FilePath -> IO (Maybe (Path Rel File)) normalizeFile path = @@ -59,20 +65,23 @@ prepareConditions -> IO (Maybe (NonEmpty Condition)) prepareConditions raw = do conditions <- forM raw $ \RawCondition{..} -> do - mTarget <- normalizeDirAbs $ E.trim rcTarget + target <- catch @PathException (normalizeDirAbs $ E.trim rcTarget) $ \e -> do + pPrintString $ "Target path in condition " <> show rcIndex <> " is invalid" + throwIO e mFiles <- sequence <$> traverse normalizeFile (toList rcHasFiles) dirs <- traverse parseRelDir $ toList rcHasDirectories let normalizedExt e = if "." == take 1 e then e else '.' : e let exts = map normalizedExt $ toList rcHasExtensions - pure $ Condition { - cIndex = rcIndex, - cTarget = mTarget, - cFiles = mFiles, - cDirectories = dirs, - cExtensions = exts, - cCommand = rcCommand, - cArguments = rcArgs, - cActConcurrent = rcActConcurrent, - cWithBreak = rcWithBreak - } + pure $ + Condition + { cIndex = rcIndex + , cTarget = target + , cFiles = mFiles + , cDirectories = dirs + , cExtensions = exts + , cCommand = rcCommand + , cArguments = rcArgs + , cActConcurrent = rcActConcurrent + , cWithBreak = rcWithBreak + } pure $ nonEmpty conditions diff --git a/src/Type/Domain.hs b/src/Type/Domain.hs index 629e0c0..595636a 100644 --- a/src/Type/Domain.hs +++ b/src/Type/Domain.hs @@ -25,10 +25,10 @@ import Control.Monad.Reader ( local, ) import Control.Monad.Trans.Control (MonadBaseControl) +import Data.List.NonEmpty (NonEmpty) import Katip (Katip (..), KatipContext (..), LogContexts, LogEnv (..), Namespace) import Path (File, Rel) import Path.Posix (Abs, Dir, Path) -import Data.List.NonEmpty (NonEmpty) newtype App a = MkApp { unApp :: ReaderT Env IO a @@ -79,7 +79,7 @@ data Env = Env data Condition = Condition { cIndex :: Word - , cTarget :: Maybe (Path Abs Dir) + , cTarget :: Path Abs Dir , cFiles :: Maybe [Path Rel File] , cDirectories :: [Path Rel Dir] , cExtensions :: [String] From 352d14cff9a2b246b487f593fbc73b343a0449c1 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Wed, 28 May 2025 14:17:04 -0300 Subject: [PATCH 5/7] Handle absence of the target path --- lineman.cabal | 1 - lineman.dhall | 58 +++++++++++++++++++++++----------------------- src/Lineman.hs | 6 ++--- src/Parser.hs | 53 ++++++++++++++++++++++++------------------ src/Type/Domain.hs | 2 +- 5 files changed, 63 insertions(+), 57 deletions(-) diff --git a/lineman.cabal b/lineman.cabal index 3f165a2..41dfe04 100644 --- a/lineman.cabal +++ b/lineman.cabal @@ -66,7 +66,6 @@ library , dhall , directory , extra - , filepath , katip , ki , monad-control diff --git a/lineman.dhall b/lineman.dhall index 4f3acef..234be95 100644 --- a/lineman.dhall +++ b/lineman.dhall @@ -1,72 +1,72 @@ let RawCondition : Type = { rcIndex : Natural + -- Arbitrary index , rcTarget : Text + -- ^ first target where lineman starts recursively from. + -- target consume 'rel', 'abs' and '~'' paths , rcHasFiles : List Text + -- ^ Target directory has files that have to be relative to target path. , rcHasDirectories : List Text + -- ^ Target directory has directories that have to be relative to target path , rcHasExtensions : List Text + -- ^ Target directory has files with these extensions. + -- It consume exts with and without '.' , rcCommand : Text + -- ^ Command to run in searched directories , rcArgs : List Text + -- ^ Command's arguments , rcActConcurrent : Bool + -- ^ run actions concurrently within the particular condition , rcWithBreak : Double + -- ^ Interval between actions in seconds } let condition_1 : RawCondition = { rcIndex = 1 - -- Arbitrary index , rcTarget = "~/source/test/" - -- ^ first target where lineman starts recursively from. - -- target consume 'rel', 'abs' and '~'' paths - , rcHasFiles = ["log"] : List Text - -- ^ Target directory has files + , rcHasFiles = ["a/log"] : List Text , rcHasDirectories = [] : List Text - -- ^ Target directory has directories , rcHasExtensions = [] : List Text - -- ^ Target directory has extensions. - -- It consume exts with and without '.' , rcCommand = "touch" - -- ^ Command to run in searched directories , rcArgs = ["readme.txt"] : List Text - -- ^ Command's arguments , rcActConcurrent = False - -- ^ run actions concurrently within the particular condition , rcWithBreak = 1.0 - -- ^ Interval between actions in seconds } let condition_2 : RawCondition = { rcIndex = 2 - -- Arbitrary index , rcTarget = "~/source/test/" - -- ^ target where you plan that the lineman recursively starts from. - -- target consume 'rel', 'abs' and '~'' paths - , rcHasFiles = ["log"] : List Text - -- ^ Target directory has files + , rcHasFiles = ["a/log"] : List Text , rcHasDirectories = [] : List Text - -- ^ Target directory has directories , rcHasExtensions = [] : List Text - -- ^ Target directory has extensions. - -- It consume exts with and without '.' , rcCommand = "rm" - -- ^ Command to run in searched directories , rcArgs = ["readme.txt"] : List Text - -- ^ Command's arguments , rcActConcurrent = False - -- ^ run actions concurrently within the particular condition , rcWithBreak = 1.0 - -- ^ Interval between actions in seconds } let Verbosity : Type = < V0 | V1 | V2 | V3 > --- ^ levels of verbosity let Severity : Type = < DebugS | InfoS | NoticeS | WarningS | ErrorS | CriticalS | AlertS | EmergencyS > -in { confRawConditions = [ condition_1, condition_2 ] : List RawCondition +let Config : Type = + { confRawConditions : List RawCondition -- ^ within the target it is possible to run several commands with own conditions + , confSeverity : Severity + , confVerbosity : Verbosity +-- ^ level of verbosity + , confSwarmConcurrent : Bool + -- ^ run the swarm of actions concurrently + , confSwarmBreak : Double + -- ^ add delay of running next batch of actions (in seconds) + } + +let config : Config = + { confRawConditions = [ condition_1, condition_2 ] : List RawCondition , confSeverity = Severity.DebugS , confVerbosity = Verbosity.V0 , confSwarmConcurrent = False - -- ^ run the swarm of actions concurrently , confSwarmBreak = 5.0 - -- ^ add delay of running next batch of actions (in seconds) - } \ No newline at end of file + } + +in config \ No newline at end of file diff --git a/src/Lineman.hs b/src/Lineman.hs index bf2385b..8e51e32 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -37,9 +37,7 @@ launchSwarm = do let firstIndex = cIndex $ NonEmpty.head conditions forSwarm conditions $ \Condition{..} -> do when (cIndex /= firstIndex) $ liftIO $ sleep $ envSwarmBreak env - dirsForLaunch <- case cFiles of - Just files -> getDirsForCommand cTarget files cDirectories cExtensions - _ -> pure [] + dirsForLaunch <- getDirsForCommand cTarget cFiles cDirectories cExtensions logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) let forAction = if cActConcurrent then forConcurrentlyKi else forM let firstDirectory = seq dirsForLaunch $ head dirsForLaunch @@ -50,7 +48,7 @@ launchSwarm = do logInfo $ "Action \'" <> into @Text act <> "\' is running in " <> dir action cCommand cArguments d if all (== ExitSuccess) codes - then logInfo "All actions successfuly finished!" + then logInfo "All actions successfully finished!" else logError "Some action(s) failed" diff --git a/src/Parser.hs b/src/Parser.hs index 5a9c53a..e7cfd61 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -23,15 +23,18 @@ import Path.Posix ( Rel, SomeBase (Abs, Rel), parseRelDir, + parseRelFile, parseSomeDir, - parseSomeFile, + toFilePath, ) import Control.Exception (catch, throwIO) +import Control.Monad.Extra (whenM) import Data.List.NonEmpty (NonEmpty, nonEmpty) +import System.Directory (doesDirectoryExist) import qualified System.Directory as D -import qualified System.FilePath.Posix as FP -import Text.Pretty.Simple (pPrintString) +import Text.Pretty.Simple (pPrintString, pString) +import Witch (into) safeHead :: [a] -> Maybe a safeHead [] = Nothing @@ -39,44 +42,50 @@ safeHead (a : _) = Just a -- Normalize functions -normalizeDirAbs :: FilePath -> IO (Path Abs Dir) -normalizeDirAbs path = do +normalizeDirAbs :: Word -> FilePath -> IO (Path Abs Dir) +normalizeDirAbs index path = do let (homeMarker, relPath) = splitAt 1 path path' <- E.whenMaybe (homeMarker == "~") $ do home <- D.getHomeDirectory pure $ home <> "/" <> relPath - someDir <- parseSomeDir $ fromMaybe path path' - case someDir of + someDir <- catch @PathException (parseSomeDir $ fromMaybe path path') $ \e -> do + pPrintString $ "Target path " <> path <> " from condition " <> show index <> " is invalid" + throwIO e + aPath <- case someDir of Abs a -> pure a Rel r -> makeAbsolute r + whenM (not <$> doesDirectoryExist (toFilePath aPath)) $ + throwIO $ + userError $ + into @String $ + pString "Target path not found" + pure aPath -normalizeFile :: FilePath -> IO (Maybe (Path Rel File)) -normalizeFile path = - if FP.isRelative path && FP.isValid path && not (FP.hasTrailingPathSeparator path) - then do - someFile <- parseSomeFile path - case someFile of - Abs _ -> pure Nothing - Rel r -> pure $ Just r - else pure Nothing +normalizeRelFile :: FilePath -> IO (Path Rel File) +normalizeRelFile path = catch @PathException (parseRelFile path) $ \e -> do + pPrintString $ "File path " <> path <> " is invalid" + throwIO e + +normalizeRelDir :: FilePath -> IO (Path Rel Dir) +normalizeRelDir path = catch @PathException (parseRelDir path) $ \e -> do + pPrintString $ "Directory path " <> path <> " is invalid" + throwIO e prepareConditions :: [RawCondition] -> IO (Maybe (NonEmpty Condition)) prepareConditions raw = do conditions <- forM raw $ \RawCondition{..} -> do - target <- catch @PathException (normalizeDirAbs $ E.trim rcTarget) $ \e -> do - pPrintString $ "Target path in condition " <> show rcIndex <> " is invalid" - throwIO e - mFiles <- sequence <$> traverse normalizeFile (toList rcHasFiles) - dirs <- traverse parseRelDir $ toList rcHasDirectories + target <- normalizeDirAbs rcIndex $ E.trim rcTarget + files <- mapM normalizeRelFile $ toList rcHasFiles + dirs <- traverse normalizeRelDir $ toList rcHasDirectories let normalizedExt e = if "." == take 1 e then e else '.' : e let exts = map normalizedExt $ toList rcHasExtensions pure $ Condition { cIndex = rcIndex , cTarget = target - , cFiles = mFiles + , cFiles = files , cDirectories = dirs , cExtensions = exts , cCommand = rcCommand diff --git a/src/Type/Domain.hs b/src/Type/Domain.hs index 595636a..2a774e6 100644 --- a/src/Type/Domain.hs +++ b/src/Type/Domain.hs @@ -80,7 +80,7 @@ data Env = Env data Condition = Condition { cIndex :: Word , cTarget :: Path Abs Dir - , cFiles :: Maybe [Path Rel File] + , cFiles :: [Path Rel File] , cDirectories :: [Path Rel Dir] , cExtensions :: [String] , cCommand :: String From 312814521a7bbc1e9bba9e1278f615fe0adc3791 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Wed, 28 May 2025 14:52:31 -0300 Subject: [PATCH 6/7] Better namings. Update Readme --- CHANGELOG.md | 4 ++++ README.md | 18 ++++++++++++++---- lineman.dhall | 26 +++++++++++++------------- src/App.hs | 4 ++-- src/Lineman.hs | 2 +- src/Parser.hs | 8 ++++---- src/Type/Domain.hs | 2 +- src/Type/Raw.hs | 10 +++++----- 8 files changed, 44 insertions(+), 30 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 12ef0ec..0c3349f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ The changelog is available [on GitHub][2]. * Restructure modules * Differ raw and domain types * Add option for swarm concurrency +* Prevent processing of invalid paths and absent targets +* Add delay option to config +* Use clear namings +* Update README ## 1.0.4 diff --git a/README.md b/README.md index 2a61ecb..4e90e35 100644 --- a/README.md +++ b/README.md @@ -26,8 +26,18 @@ And either Lineman uses [dhall](https://dhall-lang.org) configuration. See [Config](./lineman.dhall) example. -According to the config `lineman`: -- traverses target directory recursively. -- finds directories that have `lineman.cabal` file. -- apply `mkdir test_dir` in the found directories. +## Term policy + +- `Action` - a single command that run in a directory due to particular `Conditions` +- `Conditions` describe the directory has to have to run `Action` +- `EntryPoint` is a parent directory where `lineman` starts seeking for `Targets` +- `Target` is a directory that aligns to `Condition` +- `Swarm` is a bunch of `Actions` that match to `Condition` +- `Hive` is a collection of `Swarms` + +## Features + +- Both `Actions` in `Swarm` and `Swarms` in `Hive` can be run concurrently or successively +- Both `Actions` and `Swarms` can be interspersed with breaks + diff --git a/lineman.dhall b/lineman.dhall index 234be95..82f4e88 100644 --- a/lineman.dhall +++ b/lineman.dhall @@ -1,7 +1,7 @@ let RawCondition : Type = { rcIndex : Natural -- Arbitrary index - , rcTarget : Text + , rcEntryPoint : Text -- ^ first target where lineman starts recursively from. -- target consume 'rel', 'abs' and '~'' paths , rcHasFiles : List Text @@ -15,34 +15,34 @@ let RawCondition : Type = -- ^ Command to run in searched directories , rcArgs : List Text -- ^ Command's arguments - , rcActConcurrent : Bool + , rcConcurrentAgents : Bool -- ^ run actions concurrently within the particular condition - , rcWithBreak : Double + , rcBreakBetweenAgents : Double -- ^ Interval between actions in seconds } let condition_1 : RawCondition = { rcIndex = 1 - , rcTarget = "~/source/test/" + , rcEntryPoint = "~/source/test/" , rcHasFiles = ["a/log"] : List Text , rcHasDirectories = [] : List Text , rcHasExtensions = [] : List Text , rcCommand = "touch" , rcArgs = ["readme.txt"] : List Text - , rcActConcurrent = False - , rcWithBreak = 1.0 + , rcConcurrentAgents = False + , rcBreakBetweenAgents = 1.0 } let condition_2 : RawCondition = { rcIndex = 2 - , rcTarget = "~/source/test/" + , rcEntryPoint = "~/source/test/" , rcHasFiles = ["a/log"] : List Text , rcHasDirectories = [] : List Text , rcHasExtensions = [] : List Text , rcCommand = "rm" , rcArgs = ["readme.txt"] : List Text - , rcActConcurrent = False - , rcWithBreak = 1.0 + , rcConcurrentAgents = False + , rcBreakBetweenAgents = 1.0 } let Verbosity : Type = < V0 | V1 | V2 | V3 > @@ -55,9 +55,9 @@ let Config : Type = , confSeverity : Severity , confVerbosity : Verbosity -- ^ level of verbosity - , confSwarmConcurrent : Bool + , confConcurrentSwarms : Bool -- ^ run the swarm of actions concurrently - , confSwarmBreak : Double + , confBreakBetweenSwarms : Double -- ^ add delay of running next batch of actions (in seconds) } @@ -65,8 +65,8 @@ let config : Config = { confRawConditions = [ condition_1, condition_2 ] : List RawCondition , confSeverity = Severity.DebugS , confVerbosity = Verbosity.V0 - , confSwarmConcurrent = False - , confSwarmBreak = 5.0 + , confConcurrentSwarms = False + , confBreakBetweenSwarms = 5.0 } in config \ No newline at end of file diff --git a/src/App.hs b/src/App.hs index 49415f5..bacc878 100644 --- a/src/App.hs +++ b/src/App.hs @@ -37,8 +37,8 @@ appLineman = do , envLogContext = mempty , envLogNamespace = mempty , envConditions = conditions - , envSwarmConcurrent = confSwarmConcurrent config - , envSwarmBreak = confSwarmBreak config + , envSwarmConcurrent = confConcurrentSwarms config + , envSwarmBreak = confBreakBetweenSwarms config } runApp env launchSwarm diff --git a/src/Lineman.hs b/src/Lineman.hs index 8e51e32..6414170 100644 --- a/src/Lineman.hs +++ b/src/Lineman.hs @@ -37,7 +37,7 @@ launchSwarm = do let firstIndex = cIndex $ NonEmpty.head conditions forSwarm conditions $ \Condition{..} -> do when (cIndex /= firstIndex) $ liftIO $ sleep $ envSwarmBreak env - dirsForLaunch <- getDirsForCommand cTarget cFiles cDirectories cExtensions + dirsForLaunch <- getDirsForCommand cEntryPoint cFiles cDirectories cExtensions logDebug $ "Directories for running action: " <> into @Text (show dirsForLaunch) let forAction = if cActConcurrent then forConcurrentlyKi else forM let firstDirectory = seq dirsForLaunch $ head dirsForLaunch diff --git a/src/Parser.hs b/src/Parser.hs index e7cfd61..7af895a 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -76,7 +76,7 @@ prepareConditions -> IO (Maybe (NonEmpty Condition)) prepareConditions raw = do conditions <- forM raw $ \RawCondition{..} -> do - target <- normalizeDirAbs rcIndex $ E.trim rcTarget + target <- normalizeDirAbs rcIndex $ E.trim rcEntryPoint files <- mapM normalizeRelFile $ toList rcHasFiles dirs <- traverse normalizeRelDir $ toList rcHasDirectories let normalizedExt e = if "." == take 1 e then e else '.' : e @@ -84,13 +84,13 @@ prepareConditions raw = do pure $ Condition { cIndex = rcIndex - , cTarget = target + , cEntryPoint = target , cFiles = files , cDirectories = dirs , cExtensions = exts , cCommand = rcCommand , cArguments = rcArgs - , cActConcurrent = rcActConcurrent - , cWithBreak = rcWithBreak + , cActConcurrent = rcConcurrentAgents + , cWithBreak = rcBreakBetweenAgents } pure $ nonEmpty conditions diff --git a/src/Type/Domain.hs b/src/Type/Domain.hs index 2a774e6..ce473f8 100644 --- a/src/Type/Domain.hs +++ b/src/Type/Domain.hs @@ -79,7 +79,7 @@ data Env = Env data Condition = Condition { cIndex :: Word - , cTarget :: Path Abs Dir + , cEntryPoint :: Path Abs Dir , cFiles :: [Path Rel File] , cDirectories :: [Path Rel Dir] , cExtensions :: [String] diff --git a/src/Type/Raw.hs b/src/Type/Raw.hs index 917fb9a..bd84e59 100644 --- a/src/Type/Raw.hs +++ b/src/Type/Raw.hs @@ -17,14 +17,14 @@ import Katip (Severity, Verbosity) data RawCondition = RawCondition { rcIndex :: Word - , rcTarget :: FilePath + , rcEntryPoint :: FilePath , rcHasFiles :: Set FilePath , rcHasDirectories :: Set FilePath , rcHasExtensions :: Set String , rcCommand :: String , rcArgs :: [String] - , rcActConcurrent :: Bool - , rcWithBreak :: Double + , rcConcurrentAgents :: Bool + , rcBreakBetweenAgents :: Double } deriving stock (Eq, Show, Generic, Ord) deriving anyclass (FromDhall) @@ -33,8 +33,8 @@ data Config = Config { confRawConditions :: [RawCondition] , confSeverity :: Severity , confVerbosity :: Verbosity - , confSwarmConcurrent :: Bool - , confSwarmBreak :: Double + , confConcurrentSwarms :: Bool + , confBreakBetweenSwarms :: Double } deriving stock (Eq, Show, Generic) deriving anyclass (FromDhall) From 81f9a4f75365c73c73fd713783e00ee5eebf1e43 Mon Sep 17 00:00:00 2001 From: Vladislav Sabanov Date: Wed, 28 May 2025 15:18:50 -0300 Subject: [PATCH 7/7] Update readme --- README.md | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 4e90e35..aea9ad1 100644 --- a/README.md +++ b/README.md @@ -28,16 +28,20 @@ Lineman uses [dhall](https://dhall-lang.org) configuration. See [Config](./linem ## Term policy -- `Action` - a single command that run in a directory due to particular `Conditions` -- `Conditions` describe the directory has to have to run `Action` -- `EntryPoint` is a parent directory where `lineman` starts seeking for `Targets` -- `Target` is a directory that aligns to `Condition` -- `Swarm` is a bunch of `Actions` that match to `Condition` -- `Hive` is a collection of `Swarms` +- `Action` - a single command that run in a directory due to particular `conditions` +- `Conditions` describe the directory has to have to run `action` +- `EntryPoint` is a parent directory where `lineman` starts seeking for `targets` +- `Target` is a directory that aligns to `condition` +- `Swarm` is a bunch of `actions` that match to `condition` +- `Hive` is a collection of `swarms` ## Features -- Both `Actions` in `Swarm` and `Swarms` in `Hive` can be run concurrently or successively -- Both `Actions` and `Swarms` can be interspersed with breaks +- Both `actions` in a `swarm` and `swarms` in a `hive` can be run concurrently or successively +- Both `actions` and `swarms` can be interspersed with breaks +- `Lineman` starts seeking `targets` from `entryPoint` recursively and finds directories that have particular subdirectories, files or extensions. And then it run `Action` in found `targets`. +## Use cases + +- Clear build artefact in bunch of projects.