diff --git a/.hlint.yaml b/.hlint.yaml --- a/.hlint.yaml +++ b/.hlint.yaml @@ -741,6 +741,22 @@ name: Control.Monad.Identity within: [] - functions: + - message: "Partial: throws on base <= 1 or negative input. Ensure base > 1 and non-negative input." + name: showIntAtBase + within: [] + - message: "Partial: throws on negative numbers. Ensure non-negative input." + name: showInt + within: [] + - message: "Partial: throws on negative numbers. Ensure non-negative input." + name: showHex + within: [] + - message: "Partial: throws on negative numbers. Ensure non-negative input." + name: showOct + within: [] + - message: "Partial: throws on negative numbers. Ensure non-negative input." + name: showBin + within: [] +- functions: - message: "O(n^2) complexity. Use ordNub or nubOrd instead." name: nub within: [] diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,15 @@ ## [Unreleased] +## [1.1.1.0] - 2026-05-24 + +### Added + +- `Numeric` re-export in `Himari.Prelude` for extra numeric functions +- HLint rules to warn against partial functions re-exported from `Numeric`: + `showIntAtBase`, `showInt`, `showHex`, `showOct`, and `showBin`, + which throw on negative (or invalid base) input + ## [1.1.0.0] - 2026-04-11 ### Added @@ -15,11 +24,13 @@ ### Changed -- Relax `sydtest` dependency upper bound from `<0.19` to `<0.24` to support nixpkgs sydtest 0.20.0.1+ +- Relax `sydtest` dependency upper bound from `<0.19` to `<0.24` + to support nixpkgs sydtest 0.20.0.1+ ### Removed -- Drop Intel Mac (x86_64-darwin) from Nix build targets due to Nix ending support for this platform +- Drop Intel Mac (x86_64-darwin) from Nix build targets due + to Nix ending support for this platform ## [1.0.5.0] - 2026-01-12 @@ -29,21 +40,51 @@ - `Data.Default` re-export in `Himari.Prelude` for `Default` type class and `def` function - `retry` package (^>=0.9.3.1) as a dependency for retry combinators - `UnliftIO.Retry` re-export in `Himari.Prelude` for retry operations with exponential backoff -- HLint rules to warn against dangerous language extensions: `AllowAmbiguousTypes`, `DeferTypeErrors`, - `ExtendedDefaultRules`, `ImpredicativeTypes`, `IncoherentInstances`, `LiberalTypeSynonyms`, - `OverlappingInstances`, `RebindableSyntax`, `UndecidableSuperClasses` -- HLint rules to warn against discouraged language extensions: `ImplicitParams`, `UndecidableInstances` +- HLint rules to warn against dangerous language extensions: + `AllowAmbiguousTypes`, + `DeferTypeErrors`, + `ExtendedDefaultRules`, + `ImpredicativeTypes`, + `IncoherentInstances`, + `LiberalTypeSynonyms`, + `OverlappingInstances`, + `RebindableSyntax`, + `UndecidableSuperClasses` +- HLint rules to warn against discouraged language extensions: + `ImplicitParams`, + `UndecidableInstances` ### Changed -- Document recommended language extensions beyond GHC2024 (e.g., `BlockArguments`, `StrictData`, - `OverloadedStrings`, `NoFieldSelectors`, etc.) with rationale for each -- Document extensions intentionally not enabled (e.g., `Arrows`, `DeriveAnyClass`, `OverloadedLists`, - `OverloadedRecordUpdate`, `Strict`, `UnicodeSyntax`) with reasons -- Document dangerous language extensions that should be avoided: `AllowAmbiguousTypes`, `DeferTypeErrors`, - `ExtendedDefaultRules`, `ImpredicativeTypes`, `IncoherentInstances`, `LiberalTypeSynonyms`, - `OverlappingInstances`, `RebindableSyntax`, `UndecidableSuperClasses` -- Document discouraged language extensions that require caution: `ImplicitParams`, `UndecidableInstances` +- Document recommended language extensions beyond GHC2024 + (e.g., + `BlockArguments`, + `NoFieldSelectors`, + `OverloadedStrings`, + `StrictData`, + etc.) with rationale for each +- Document extensions intentionally not enabled + (e.g., + `Arrows`, + `DeriveAnyClass`, + `OverloadedLists`, + `OverloadedRecordUpdate`, + `Strict`, + `UnicodeSyntax` + ) with reasons +- Document dangerous language extensions that should be avoided: + `AllowAmbiguousTypes`, + `DeferTypeErrors`, + `ExtendedDefaultRules`, + `ImpredicativeTypes`, + `IncoherentInstances`, + `LiberalTypeSynonyms`, + `OverlappingInstances`, + `RebindableSyntax`, + `UndecidableSuperClasses` +- Document discouraged language extensions that require caution: + `ImplicitParams`, + `UndecidableInstances` ## [1.0.4.0] - 2026-01-09 @@ -55,9 +96,9 @@ - `UnliftIO.Exception.Lens` re-export in `Himari.Prelude` for lens-based exception handling - `UnliftIO.Foreign` is not re-exported to avoid `withArray` conflict with `Data.Aeson` - `UnliftIO.IO.File` re-export in `Himari.Prelude` for atomic/durable file operations -- HLint rules: prefer `UnliftIO.Concurrent` over `Control.Concurrent` for MonadIO support -- HLint rules: prefer `UnliftIO.Environment` over `System.Environment` for MonadIO support -- HLint rules: prefer `UnliftIO.Exception.Lens` over `Control.Exception.Lens` for MonadUnliftIO support +- HLint rules: prefer `UnliftIO.Concurrent` over `Control.Concurrent` +- HLint rules: prefer `UnliftIO.Environment` over `System.Environment` +- HLint rules: prefer `UnliftIO.Exception.Lens` over `Control.Exception.Lens` - HLint rule: restrict `forkOnWithUnmask` (exceptions don't propagate to parent thread) ### Changed @@ -79,9 +120,16 @@ ### Added - HLint language extension support in Dhall configuration -- Default language extensions for parsing: `QuasiQuotes`, `CPP`, `RecursiveDo`, `OverloadedRecordDot`, - `OverloadedRecordUpdate`, `TemplateHaskell`, `BlockArguments` -- `ExtensionItem` type and helper functions (`extensionNames`, `extensionNamesWithin`, `extensions`) +- Default language extensions for parsing: + `QuasiQuotes`, + `CPP`, + `RecursiveDo`, + `OverloadedRecordDot`, + `OverloadedRecordUpdate`, + `TemplateHaskell`, + `BlockArguments` +- `ExtensionItem` type and helper functions + (`extensionNames`, `extensionNamesWithin`, `extensions`) in `hlint/Builder.dhall` - `hlint/rules/extensions.dhall` for managing default enabled extensions @@ -89,7 +137,7 @@ ### Added -- `GHC.Stack` re-export in `Himari.Prelude` for call stack support (`HasCallStack`, `CallStack`, etc.) +- `GHC.Stack` re-export in `Himari.Prelude` for call stack support (`HasCallStack`, etc.) - HLint rule for `errorWithStackTrace` (deprecated function warning) ## [1.0.2.0] - 2026-01-07 @@ -126,7 +174,7 @@ - Added `Magnify` instance for `Himari` monad - Bundle `fourmolu.yaml` in Cabal `data-files` so downstream users can reuse the formatter config -- Add `fourmolu.yaml` reexports and fixity settings to resolve operator precedence for Himari’s Prelude +- Add `fourmolu.yaml` reexports and fixity settings to resolve operator precedence - Document setup steps in README for copying/merging `.hlint.yaml` and `fourmolu.yaml` - Add fourmolu customization notes to README @@ -141,7 +189,7 @@ - `Himari.Prelude.Category` module for `Control.Category` re-exports (hiding `id` and `.`) - `Himari.Prelude.Generics` module for `GHC.Generics` re-exports (hiding `from` and `to`) - `Himari.Prelude.FilePath` module for `System.FilePath` re-exports (hiding `<.>`) -- `Himari.Prelude.Type` module for type-only re-exports (`ByteString`, `Text`, `Map`, `Vector`, etc.) +- `Himari.Prelude.Type` module for type-only re-exports (`ByteString`, `Text`, `Map`, etc.) ### Changed @@ -151,7 +199,8 @@ ### Changed -- Move `-j` option from `himari.cabal` ghc-options to `cabal.project` to fix Hackage upload compatibility +- Move `-j` option from `himari.cabal` ghc-options to `cabal.project` + to fix Hackage upload compatibility ## [1.0.0.0] - 2026-01-01 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # himari -[![CI](https://github.com/ncaq/himari/actions/workflows/push.yml/badge.svg)](https://github.com/ncaq/himari/actions/workflows/push.yml) +[![CI](https://github.com/ncaq/himari/actions/workflows/check.yml/badge.svg)](https://github.com/ncaq/himari/actions/workflows/check.yml) [![License](https://img.shields.io/badge/license-Apache--2.0-blue.svg)](https://github.com/ncaq/himari/blob/master/LICENSE) [![Haskell](https://img.shields.io/badge/language-Haskell-5D4F85.svg)](https://www.haskell.org/) @@ -13,37 +13,85 @@ A standard library for Haskell to replace rio -## 注意 +このプロジェクトは、 +[commercialhaskell/rio: A standard library for Haskell](https://github.com/commercialhaskell/rio) +の思想を踏襲しつつ、 +よりスムーズな開発が出来ることを目指した改良ライブラリです。 -> [!IMPORTANT] -> himariはrioとは完全に同じように使えるわけではありません。 -> ここで主な注意点を挙げます。 +## 背景 -### 重大なランタイムの非互換性 +私はrioの思想が好みで長く使っています。 -#### ログの出力先の変更 +しかしrioの好みではない点もいくつかあります。 +単純に質の問題であれば私がコントリビュートすれば良いのですが、 +非互換な選択である部分が多いため、 +それは受け入れられないだろうと考えて、 +rioに似たライブラリであるhimariを作成することにしました。 -rioは基本的に標準出力にログを出力しますが、 -himariはデフォルトのガイドラインに従うと標準エラー出力にログを出力します。 +## 目標 -ログは標準エラー出力に出すべきだと考えているためです。 +### 依存関係が大きくなることを恐れない -変更したい時は出力先を`stderr`から`stdout`などに変更することで簡単に変更可能です。 +例えばrioは依存関係を小さくしようと考えているのか、 +[lens](https://hackage.haskell.org/package/lens)ではなく、 +[microlens](https://hackage.haskell.org/package/microlens)を採用しています。 -### 部分関数への対処方法の違い +しかし実際のライブラリでは本家のlensに依存していることも多いです。 +開発でも実際のlensを使いたいです。 +その結果コンフリクトすることが多発します。 -rioは部分関数を独自のモジュールでexportして提供していますが、 -himariはそのままオリジナルのモジュールを使ってもらいます。 +Haskellは静的にビルドする言語なので、 +依存関係が多いことはあまり怖くありません。 -よってhimariは部分関数を除去していません。 +ビルドした時に使わないデッドコードはコンパイラが勝手に消してくれます。 -なのでhimariはhlintのルールで警告を出すことで対処しています。 -詳細は[セットアップ](#セットアップ)を参照してください。 +他にも使うとは限らない依存関係もドシドシimportしてしまいます。 +バージョンごとの依存関係の解決が大変なのは、 +Nixなどのパッケージマネージャのレイヤーで解決することにします。 + +### なるべくimportを一行で済ませることを目指します + +himariは基本的には以下の一行で代替Preludeを提供することを目指します。 + +```haskell +import Himari +``` + +色々と書くのは面倒なので。 +衝突しない範囲で大量にimportしてしまいます。 + +同じシンボル名をexportしていて衝突してしまうものは仕方がないので、 +qualified importを使ってもらいます。 + +### なるべく独自のシンボルを定義しない + +himariはrioで言う`RIO.Text`のような独自のシンボルを定義することをなるべく避けます。 +開発メンバーやコーディングエージェントに独自のシンボルを使うことを守ってもらうのが難しいからです。 +しばしばオリジナルのシンボルをimportしてしまい、 +コードレビューなどで手戻りが発生します。 + +ただし`Himari.Prelude`のサブモジュールは存在します。 +`Himari.Prelude.Aeson`などのシンボルです。 +これはHaddockの制限により、 +`hiding`を使ったre-exportはシンボルが全て展開されてしまうからです。 +シンボルの展開が発生するとドキュメントが肥大化してしまいます。 +サブモジュールでhidingを隠蔽することで、 +`Himari.Prelude`のドキュメントをコンパクトに保っています。 + +これらのサブモジュールは`Himari.Prelude`から自動的にre-exportされるため、 +rioの`RIO.Text`のように個別にimportする必要はありません。 +ユーザから見ると直接扱う必要は基本的にないということです。 + +万が一誤ってサブモジュールを直接importした場合でも、 +`Himari.Prelude`と重複importすることになり、 +GHCが警告を出してくれるので、 +気が付きやすいです。 + ## セットアップ himariを使うプロジェクトでは、 -以下の設定ファイルをコピーすることを強く推奨します。 +以下の設定ファイルをセットアップすることを強く推奨します。 ### hlint @@ -62,7 +110,9 @@ fourmoluは演算子の優先順位(fixity)を正しく解決するために、 カスタムPreludeがどのモジュールをre-exportしているかを知る必要があります。 -プロジェクトルートにある[fourmolu.yaml](./fourmolu.yaml)ファイルの`reexports`セクションをコピーしてください。 +プロジェクトルートにある、 +[fourmolu.yaml](./fourmolu.yaml)ファイルの、 +`reexports`セクションをコピーしてください。 既存の`fourmolu.yaml`がある場合は`reexports`セクションをマージしてください。 ```console @@ -73,69 +123,59 @@ > fourmolu.yamlにはhimari固有のフォーマット設定(indentation, column-limitなど)も含まれています。 > 素朴な設定ですが、プロジェクトに合わせて適宜変更してください。 -## 背景 - -私は、 -[commercialhaskell/rio: A standard library for Haskell](https://github.com/commercialhaskell/rio) -の思想が好みで長く使っています。 - -しかしrioの好みではない点もいくつかあります。 -単純に質の問題であれば私がコントリビュートすれば良いのですが、 -非互換な選択である部分が多いため、 -それは受け入れられないだろうと考えて、 -rioに似たライブラリであるhimariを作成することにしました。 +### AIエージェント向けのプラグイン -## 目標 +himariとAIエージェントを組み合わせて開発する時には、 +[ncaq/konoka: AI prompts, agents, and skills as loadable plugins.](https://github.com/ncaq/konoka) +というマーケットプレイスで開発している、 +[haskell-tasukeプラグイン](https://github.com/ncaq/konoka/tree/master/plugins/haskell-tasuke) +を利用することを強く推奨します。 -### 依存関係が大きくなることを恐れない +セットアップ方法はリポジトリにあるREADMEを参照してください。 -rioは依存関係を小さくしようと考えているのか、 -[lens: Lenses, Folds and Traversals](https://hackage.haskell.org/package/lens) -ではなく、 -[microlens: A tiny lens library with no dependencies](https://hackage.haskell.org/package/microlens) -を採用しています。 +konokaリポジトリのREADMEに従ってマーケットプレイスを追加し、 +その後haskell-tasukeプラグインのREADMEに従ってインストールしてください。 -しかし実際のライブラリでは本家のlensに依存していることも多く、 -結局使おうとしてコンフリクトすることが多いです。 +一般的なHaskellの開発にも役立つプラグインにしていますが、 +特にhimariを利用するのにフィットするようになっています。 -Haskellは静的にビルドする言語なので、 -依存関係が多いことはあまり怖くありません。 +現在はClaude Codeでのみ動作確認をしています。 -使うとは限らない依存関係もドシドシimportしてしまいます。 +## 注意 -バージョンごとの依存関係の解決が大変なのはNixなどのパッケージマネージャのレイヤーで解決することにします。 +> [!IMPORTANT] +> himariはrioとは完全に同じように使えるわけではありません。 +> ここで主な注意点を挙げます。 -### なるべく一行で済ませたい +### 重大なランタイムの非互換性 -himariは基本的には以下の一行で代替Preludeを提供することを目指します。 +#### ログの出力先の変更 -```haskell -import Himari -``` +rioは基本的に標準出力にログを出力しますが、 +himariはデフォルトのセットアップ手順に従うと標準エラー出力にログを出力します。 -色々と書くのは面倒ですからね。 -これで衝突しない範囲はたくさんimportしてしまいます。 +ログは標準エラー出力に出すべきだと考えているためです。 -同じシンボル名をexportしていて衝突してしまうものは仕方がないのでqualified importを使ってもらいます。 +変更したい時は出力先を`stderr`から`stdout`などに変更することで簡単に変更可能です。 -### なるべく独自のシンボルを定義しない +### 部分関数への対処方法の違い -himariはrioで言う`RIO.Text`のような独自のシンボルを定義することをなるべく避けます。 -LLMのコーディングエージェントに独自のシンボルを使うことを守ってもらうのが難しいからです。 -しばしばオリジナルのシンボルをimportしてしまいます。 +rioは部分関数を独自のモジュールでexportして提供していますが、 +himariはそのままオリジナルのモジュールを使う方針です。 -ただし`Himari.Prelude`のサブモジュール(`Himari.Prelude.Aeson`など)は例外的に存在します。 -これはHaddockの制限により、`hiding`を使ったre-exportはシンボルが全て展開されてドキュメントが肥大化してしまうためです。 -サブモジュールでhidingを隠蔽することで、`Himari.Prelude`のドキュメントをコンパクトに保っています。 +よってhimariは部分関数を除去していません。 -これらのサブモジュールは`Himari.Prelude`から自動的にre-exportされるため、 -rioの`RIO.Text`のように個別にimportする必要はありません。 -万が一誤ってサブモジュールを直接importした場合でも、 -`Himari.Prelude`と重複importすることになり、GHCが警告を出してくれます。 +なのでhimariはhlintのルールで警告を出すことで対処しています。 +詳細は[セットアップ](#セットアップ)を参照してください。 ## Nix -このプロジェクトは[haskell.nix](https://input-output-hk.github.io/haskell.nix/)を使用しています。 +このプロジェクトは開発環境として、 +[haskell.nix](https://input-output-hk.github.io/haskell.nix/) +を使用しています。 + +あくまで開発環境として利用しているだけなので、 +himariを使うのにnixを利用する必要はありません。 ### `nix flake show`が失敗する場合 diff --git a/example/anomaly-monitor/Anomaly.hs b/example/anomaly-monitor/Anomaly.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Anomaly.hs @@ -0,0 +1,49 @@ +module Anomaly + ( AnomalySeverity (..) + , AnomalyReport (..) + , determineSeverity + , formatReport + ) where + +import Himari + +-- | Severity level of detected anomaly. +data AnomalySeverity + = Normal + | Warning + | Critical + | Catastrophic + deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) + +-- | Anomaly detection result. +data AnomalyReport = AnomalyReport + { cpuUsage :: Double + , threshold :: Double + , severity :: AnomalySeverity + , timestamp :: UTCTime + } + deriving (Eq, Generic, Ord, Read, Show) + +-- | Determine severity based on how much the threshold is exceeded. +-- returns `Normal` when not exceeded +determineSeverity :: Double -> Double -> AnomalySeverity +determineSeverity threshold' usage + | usage < threshold' = Normal + | usage < threshold' + 5 = Warning + | usage < threshold' + 15 = Critical + | otherwise = Catastrophic + +-- | Format anomaly report for logging. +formatReport :: AnomalyReport -> Text +formatReport report = + mconcat + [ "[ANOMALY DETECTED] " + , "Severity: " + , convert $ show report.severity + , " | CPU: " + , convert $ showFFloat (Just 1) report.cpuUsage "%" + , " (threshold: " + , convert $ showFFloat (Just 1) report.threshold "%" + , ") | Time: " + , convert $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" report.timestamp + ] diff --git a/example/anomaly-monitor/Banner.hs b/example/anomaly-monitor/Banner.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Banner.hs @@ -0,0 +1,23 @@ +module Banner + ( printBanner + ) where + +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Himari + +-- | Print banner. +printBanner :: (MonadIO m) => m () +printBanner = liftIO $ T.putStrLn banner + +banner :: Text +banner = + T.unlines + [ "╔═════════════════════════════════════════════════════════════════════╗" + , "║ Millennium Science School - Paranormal Affairs Dept. ║" + , "║ Anomaly Monitoring System ║" + , "║ ║" + , "║ I am the all-knowing Himari! Leave system monitoring to me, Sensei! ║" + , "║ ║" + , "╚═════════════════════════════════════════════════════════════════════╝" + ] diff --git a/example/anomaly-monitor/Config.hs b/example/anomaly-monitor/Config.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Config.hs @@ -0,0 +1,46 @@ +module Config + ( MonitorConfig (..) + , HasCpuThreshold (..) + , HasCheckInterval (..) + , HasMaxChecks (..) + , loadConfig + ) where + +import Exception +import Himari + +-- | Monitoring configuration loaded from JSON file. +data MonitorConfig = MonitorConfig + { cpuThreshold :: Double + -- ^ CPU usage threshold percentage (0-100). Anomaly detected if reached or exceeded. + , checkInterval :: Int + -- ^ Interval between checks in seconds. + , maxChecks :: Int + -- ^ Maximum number of checks to perform (0 = unlimited). + } + deriving (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier '[CamelToSnake]] MonitorConfig + +makeFieldsId ''MonitorConfig + +-- | Default configuration when no config file is provided. +instance Default MonitorConfig where + def = + MonitorConfig + { cpuThreshold = 80.0 + , checkInterval = 1 + , maxChecks = 5 + } + +-- | Load configuration from file or use defaults. +loadConfig :: (MonadIO m, MonadLogger m, MonadThrow m) => Maybe FilePath -> m MonitorConfig +loadConfig maybePath = case maybePath of + Nothing -> do + logInfoN "No config file specified, using defaults" + pure def + Just path -> do + logInfoN $ "Loading config from: " <> convert path + contentEither <- liftIO $ eitherDecodeFileStrict path + case contentEither of + Left exception -> throwM . ConfigDecodeException $ convert exception + Right config' -> pure config' diff --git a/example/anomaly-monitor/Cpu.hs b/example/anomaly-monitor/Cpu.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Cpu.hs @@ -0,0 +1,99 @@ +module Cpu + ( CpuStats (..) + , totalTime + , idleTime + , calculateCpuUsage + , readCpuStats + , showIOCpuThreshold + ) where + +import Config +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Text.Read qualified as T +import Env +import Himari + +-- | CPU time statistics from `/proc/stat`. +data CpuStats = CpuStats + { user :: Int + , nice :: Int + , system :: Int + , idle :: Int + , iowait :: Int + , irq :: Int + , softirq :: Int + } + deriving (Eq, Generic, Show) + +-- | Parse CPU stats from /proc/stat content. +parseCpuStats :: Text -> Maybe CpuStats +parseCpuStats content = do + -- Find the "cpu " line (aggregate of all CPUs) + cpuLine <- find ("cpu " `T.isPrefixOf`) $ T.lines content + let readDecimal x = case T.decimal x of + Left _ -> Nothing + Right (n, _) -> Just n + values = mapMaybe readDecimal . drop 1 $ T.words cpuLine + case values of + (user' : nice' : system' : idle' : iowait' : irq' : softirq' : _) -> + Just + CpuStats + { user = user' + , nice = nice' + , system = system' + , idle = idle' + , iowait = iowait' + , irq = irq' + , softirq = softirq' + } + _ -> Nothing + +-- | Calculate total CPU time. +totalTime :: CpuStats -> Int +totalTime stats = + sum + [ stats.user + , stats.nice + , stats.system + , stats.idle + , stats.iowait + , stats.irq + , stats.softirq + ] + +-- | Calculate idle CPU time. +idleTime :: CpuStats -> Int +idleTime stats = stats.idle + stats.iowait + +-- | Calculate CPU usage percentage between two measurements. +calculateCpuUsage :: CpuStats -> CpuStats -> Double +calculateCpuUsage prev curr = + let totalDiff = totalTime curr - totalTime prev + idleDiff = idleTime curr - idleTime prev + in if totalDiff == 0 + then 0.0 + else 100.0 * fromIntegral (totalDiff - idleDiff) / fromIntegral totalDiff + +-- | Read current CPU stats from /proc/stat. +readCpuStats :: (MonadLogger m, MonadUnliftIO m) => m (Maybe CpuStats) +readCpuStats = do + contentEither <- tryAny . liftIO $ T.readFile "/proc/stat" + case contentEither of + Left exception -> do + logWarnN $ "Failed to read /proc/stat: " <> convert (displayException exception) + pure Nothing + Right content -> pure $ parseCpuStats content + +-- | Format CPU threshold and other config values as text. +showIOCpuThreshold :: (MonadIO m, MonadReader MonitorEnv m) => m Text +showIOCpuThreshold = do + config' <- view config + return $ + "Configuration: CPU threshold = " + <> convert (showFFloat (Just 1) (config' ^. cpuThreshold) "%") + <> ", interval = " + <> convert (show $ config' ^. checkInterval) + <> "s" + <> ", max checks = " + <> convert (show $ config' ^. maxChecks) diff --git a/example/anomaly-monitor/Env.hs b/example/anomaly-monitor/Env.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Env.hs @@ -0,0 +1,37 @@ +module Env + ( MonitorEnv (..) + , HasLogAction (..) + , HasConfig (..) + , mkEnv + ) where + +import Config +import Himari + +-- | Custom environment for the monitoring application. +-- This demonstrates how to create your own Env instead of using SimpleEnv. +data MonitorEnv = MonitorEnv + { logAction :: LogAction + -- ^ Log output function. + , config :: MonitorConfig + -- ^ Monitoring configuration. + } + deriving (Generic) + +makeFieldsId ''MonitorEnv + +-- | Enable MonadLogger for our custom environment. +-- This is the key instance that allows us to use logging functions. +instance MonadLogger (Himari MonitorEnv) where + monadLoggerLog loc src level msg = do + logAction' <- view logAction + liftIO . logAction' loc src level $ toLogStr msg + +-- | Create the monitoring environment by loading configuration from command line arguments. +mkEnv :: (MonadIO m) => m MonitorEnv +mkEnv = do + -- Get config file path from command line args (optional) + args <- getArgs + let logAction' = defaultOutput stderr -- use stderr for logging + config' <- runSimpleEnv . loadConfig $ listToMaybe args + return $ MonitorEnv{logAction = logAction', config = config'} diff --git a/example/anomaly-monitor/Exception.hs b/example/anomaly-monitor/Exception.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Exception.hs @@ -0,0 +1,11 @@ +module Exception + ( AnomalyMonitorException (..) + ) where + +import Himari + +newtype AnomalyMonitorException + = ConfigDecodeException Text + deriving (Eq, Generic, Show) + +instance Exception AnomalyMonitorException diff --git a/example/anomaly-monitor/Loop.hs b/example/anomaly-monitor/Loop.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Loop.hs @@ -0,0 +1,56 @@ +module Loop + ( monitorLoop + ) where + +import Anomaly +import Config +import Cpu +import Env +import Himari + +-- | Run monitoring loop. +monitorLoop + :: (MonadLogger m, MonadReader MonitorEnv m, MonadUnliftIO m) + => CpuStats + -> Int + -> m () +monitorLoop prevStats checkCount = do + MonitorConfig + { cpuThreshold = cpuThreshold' + , checkInterval = checkInterval' + , maxChecks = maxChecks' + } <- + view config + -- Check if we should continue + when (maxChecks' == 0 || checkCount < maxChecks') do + -- Wait for checkInterval' + threadDelay $ checkInterval' * 1_000_000 + -- Read new stats + maybeStats <- readCpuStats + case maybeStats of + Nothing -> do + logErrorN "Cannot read CPU stats, retrying..." + monitorLoop prevStats checkCount + Just currStats -> do + let usage = calculateCpuUsage prevStats currStats + severity' = determineSeverity cpuThreshold' usage + formattedReport <- mkFormattedReport usage cpuThreshold' severity' + -- Log based on severity + case severity' of + Normal -> logDebugN $ "System normal. CPU: " <> convert (showFFloat (Just 1) usage "%") + Warning -> logWarnN formattedReport + Critical -> logErrorN formattedReport + Catastrophic -> logErrorN $ "!!! " <> formattedReport <> " !!!" + -- Continue monitoring + monitorLoop currStats (checkCount + 1) + where + mkFormattedReport usage threshold' severity' = do + now <- liftIO getCurrentTime + return $ + formatReport + AnomalyReport + { cpuUsage = usage + , threshold = threshold' + , severity = severity' + , timestamp = now + } diff --git a/example/anomaly-monitor/Main.hs b/example/anomaly-monitor/Main.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Main.hs @@ -0,0 +1,19 @@ +-- | Anomaly Monitoring System +-- +-- An example application demonstrating himari usage. +-- Inspired by Akeboshi Himari from Blue Archive, +-- who leads the Paranormal Affairs Department at Millennium Science School. +-- +-- This program monitors system metrics (CPU usage) and detects anomalies +-- when thresholds are exceeded. +module Main (main) where + +import Env +import Himari +import Run + +-- | Main entry point. +main :: IO () +main = do + initialEnv <- mkEnv + runHimari initialEnv runAnomalyMonitor diff --git a/example/anomaly-monitor/Run.hs b/example/anomaly-monitor/Run.hs new file mode 100644 --- /dev/null +++ b/example/anomaly-monitor/Run.hs @@ -0,0 +1,25 @@ +module Run + ( runAnomalyMonitor + ) where + +import Banner +import Cpu +import Env +import Himari +import Loop + +-- | Run application. +runAnomalyMonitor :: (MonadLogger m, MonadReader MonitorEnv m, MonadUnliftIO m) => m () +runAnomalyMonitor = do + logInfoN "Initializing Anomaly Monitoring System..." + printBanner + cpuThresholdText <- showIOCpuThreshold + logInfoN cpuThresholdText + -- Read initial CPU stats + maybeInitialStats <- readCpuStats + case maybeInitialStats of + Nothing -> logErrorN "Failed to read initial CPU stats. Is /proc/stat available?" + Just initialStats -> do + logInfoN "Starting monitoring loop..." + monitorLoop initialStats 0 + logInfoN "Monitoring complete." diff --git a/fourmolu.yaml b/fourmolu.yaml --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,5 +1,5 @@ indentation: 2 -column-limit: 120 +column-limit: 100 function-arrows: leading import-export-style: leading haddock-style: single-line @@ -43,6 +43,7 @@ - module Himari.Prelude exports "base" Data.Void - module Himari.Prelude exports "base" Data.Word - module Himari.Prelude exports "base" GHC.Stack + - module Himari.Prelude exports "base" Numeric - module Himari.Prelude exports "base" Numeric.Natural - module Himari.Prelude exports "base" Prelude - module Himari.Prelude exports "base" Text.Show diff --git a/himari.cabal b/himari.cabal --- a/himari.cabal +++ b/himari.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: himari -version: 1.1.0.0 +version: 1.1.1.0 synopsis: A standard library for Haskell as an alternative to rio description: A standard library for Haskell inspired by rio. @@ -135,6 +135,20 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + -- cabal-gild: discover ./test --exclude=**/Main.hs + other-modules: + Himari.CharSpec + Himari.Env.SimpleSpec + Himari.Prelude.FunctorSpec + Himari.Title + HlintBaseSpec + HlintExtensionSpec + HlintSamples.BasePartial + HlintSamples.ExtensionDangerous + HlintSamples.UnliftioPreference + HlintUnliftioSpec + TitleSpec + ghc-options: -threaded -rtsopts @@ -148,16 +162,25 @@ build-tool-depends: hlint:hlint ^>=3.10 - -- cabal-gild: discover ./test --exclude=**/Main.hs +executable anomaly-monitor + import: basic + hs-source-dirs: example/anomaly-monitor + main-is: Main.hs + -- cabal-gild: discover ./example/anomaly-monitor --exclude=**/Main.hs other-modules: - Himari.CharSpec - Himari.Env.SimpleSpec - Himari.Prelude.FunctorSpec - Himari.Title - HlintBaseSpec - HlintExtensionSpec - HlintSamples.BasePartial - HlintSamples.ExtensionDangerous - HlintSamples.UnliftioPreference - HlintUnliftioSpec - TitleSpec + Anomaly + Banner + Config + Cpu + Env + Exception + Loop + Run + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + + build-depends: + himari diff --git a/src/Himari/Env.hs b/src/Himari/Env.hs --- a/src/Himari/Env.hs +++ b/src/Himari/Env.hs @@ -6,7 +6,7 @@ , mapHimari ) where -import Control.Lens.Internal.Zoom (Effect) -- 直接の`UndecidableInstances`を避けるためにInternalを受け入れる。 +import Control.Lens.Internal.Zoom (Effect) -- 直接の`UndecidableInstances`の回避のためInternal許容。 import Himari.Prelude -- | The Reader + IO monad. @@ -14,7 +14,15 @@ newtype Himari env a = Himari { unHimari :: ReaderT env IO a } - deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader env, MonadThrow, MonadUnliftIO) + deriving newtype + ( Applicative + , Functor + , Monad + , MonadIO + , MonadReader env + , MonadThrow + , MonadUnliftIO + ) instance (Semigroup a) => Semigroup (Himari env a) where (<>) = liftA2 (<>) diff --git a/src/Himari/Prelude.hs b/src/Himari/Prelude.hs --- a/src/Himari/Prelude.hs +++ b/src/Himari/Prelude.hs @@ -54,6 +54,7 @@ import Himari.Prelude.Safe as Export import Himari.Prelude.Type as Export import Himari.Prelude.TypeLevel as Export +import Numeric as Export import Numeric.Natural as Export import Text.Pretty.Simple as Export import Text.Show as Export diff --git a/src/Himari/Prelude/Safe.hs b/src/Himari/Prelude/Safe.hs --- a/src/Himari/Prelude/Safe.hs +++ b/src/Himari/Prelude/Safe.hs @@ -1,6 +1,7 @@ -- | "Safe", "Safe.Exact", and "Safe.Foldable" re-exports. -- Only total functions are exported; partial functions are hidden. --- "Safe.Foldable" is preferred for more generic versions, so conflicting functions are hidden from "Safe". +-- "Safe.Foldable" is preferred for more generic versions, +-- so conflicting functions are hidden from "Safe". module Himari.Prelude.Safe ( module Export ) where diff --git a/test/Himari/CharSpec.hs b/test/Himari/CharSpec.hs --- a/test/Himari/CharSpec.hs +++ b/test/Himari/CharSpec.hs @@ -1,3 +1,6 @@ +-- このテストモジュール自体が避けるべき関数のラッパーを作れているか検査するため、 +-- 避けるべき関数を呼び出して振る舞いの互換性の検査などを行う必要があります。 +{- HLINT ignore "Avoid restricted function" -} module Himari.CharSpec (spec) where import Data.Char (chr, digitToInt, intToDigit, isHexDigit, ord, toUpper) @@ -52,7 +55,7 @@ it "matches digitToInt for all valid characters" $ do let validChars = ['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F'] forM_ validChars $ \c -> - digitToIntMay c `shouldBe` Just (digitToInt c {- HLINT ignore "Avoid restricted function" -}) + digitToIntMay c `shouldBe` Just (digitToInt c) describe "QuickCheck properties" $ do it "returns Just for hex digit characters" $ do @@ -65,7 +68,7 @@ it "matches digitToInt for all valid hex digit inputs" $ do property . forAll (elements (['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F'])) $ \c -> - digitToIntMay c == Just (digitToInt c {- HLINT ignore "Avoid restricted function" -}) + digitToIntMay c == Just (digitToInt c) it "agrees with isHexDigit on validity" $ do property $ \c -> @@ -104,7 +107,7 @@ it "matches intToDigit for all valid values" $ do let validRange = [0 .. 15] forM_ validRange $ \n -> - intToDigitMay n `shouldBe` Just (intToDigit n {- HLINT ignore "Avoid restricted function" -}) + intToDigitMay n `shouldBe` Just (intToDigit n) describe "QuickCheck properties" $ do it "returns Just for values in range 0-15" $ do @@ -121,7 +124,7 @@ it "matches intToDigit for all valid inputs" $ do property . forAll (choose (0, 15)) $ \n -> - intToDigitMay n == Just (intToDigit n {- HLINT ignore "Avoid restricted function" -}) + intToDigitMay n == Just (intToDigit n) it "produces lowercase hex digits for 10-15" $ do property . forAll (choose (10, 15)) $ \n -> @@ -195,7 +198,7 @@ it "matches chr for all valid inputs" $ do property . forAll (choose (0, 0xD7FF)) $ \n -> - chrMay n == Just (chr n {- HLINT ignore "Avoid restricted function" -}) + chrMay n == Just (chr n) it "is inverse of ord for valid characters" $ do property $ \c -> diff --git a/test/HlintBaseSpec.hs b/test/HlintBaseSpec.hs --- a/test/HlintBaseSpec.hs +++ b/test/HlintBaseSpec.hs @@ -25,6 +25,22 @@ itWithOuter "Debug.Trace.traceM should suggest pTraceM" $ \output -> do output `shouldSatisfy` containsWarningAt "traceM" "pTraceM" + describe "Numeric integer-showing functions are partial" $ do + itWithOuter "showHex should warn (partial function)" $ \output -> do + output `shouldSatisfy` containsWarningAt "showHex" "non-negative" + + itWithOuter "showInt should warn (partial function)" $ \output -> do + output `shouldSatisfy` containsWarningAt "showInt" "non-negative" + + itWithOuter "showOct should warn (partial function)" $ \output -> do + output `shouldSatisfy` containsWarningAt "showOct" "non-negative" + + itWithOuter "showBin should warn (partial function)" $ \output -> do + output `shouldSatisfy` containsWarningAt "showBin" "non-negative" + + itWithOuter "showIntAtBase should warn (partial function)" $ \output -> do + output `shouldSatisfy` containsWarningAt "showIntAtBase" "base > 1" + runHlintOnSample :: IO Text runHlintOnSample = do (exitCode, stdoutOutput, stderrOutput) <- diff --git a/test/HlintSamples/BasePartial.hs b/test/HlintSamples/BasePartial.hs --- a/test/HlintSamples/BasePartial.hs +++ b/test/HlintSamples/BasePartial.hs @@ -4,6 +4,7 @@ -- This file intentionally uses partial functions to test hlint rules module HlintSamples.BasePartial where +import Data.Char (intToDigit) -- test only partial functions import Data.List qualified as L import Data.List.NonEmpty qualified as NE import Debug.Trace (trace, traceM, traceShow) @@ -29,3 +30,20 @@ useTraceM :: IO () useTraceM = traceM "debug" + +-- Numeric integer-showing functions are partial (throw on negative input) +useShowHex :: Int -> String +useShowHex n = showHex n "" + +useShowInt :: Int -> String +useShowInt n = showInt n "" + +useShowOct :: Int -> String +useShowOct n = showOct n "" + +useShowBin :: Int -> String +useShowBin n = showBin n "" + +-- A base of 12 avoids hlint suggesting showHex/showOct/showBin +useShowIntAtBase :: Int -> String +useShowIntAtBase n = showIntAtBase 12 intToDigit n "" diff --git a/test/HlintUnliftioSpec.hs b/test/HlintUnliftioSpec.hs --- a/test/HlintUnliftioSpec.hs +++ b/test/HlintUnliftioSpec.hs @@ -7,26 +7,30 @@ spec :: Spec spec = do describe "hlint unliftio preference rules" . beforeAll runHlintOnSample $ do - itWithOuter "Control.Exception.catch should warn to use UnliftIO.Exception" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.Exception.catch" + describe "Control" $ do + describe "Exception" $ do + itWithOuter "catch should warn to use UnliftIO.Exception" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.Exception.catch" - itWithOuter "Control.Exception.bracket should warn to use UnliftIO.Exception" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.Exception.bracket" + itWithOuter "bracket should warn to use UnliftIO.Exception" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.Exception.bracket" - itWithOuter "Control.Exception.finally should warn to use UnliftIO.Exception" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.Exception.finally" + itWithOuter "finally should warn to use UnliftIO.Exception" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.Exception.finally" - itWithOuter "Control.Exception.try should warn to use UnliftIO.Exception" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.Exception.try" + itWithOuter "try should warn to use UnliftIO.Exception" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.Exception.try" - itWithOuter "Control.Concurrent.MVar.withMVar should warn to use UnliftIO.MVar" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.MVar.withMVar" + describe "Concurrent.MVar" $ do + itWithOuter "withMVar should warn to use UnliftIO.MVar" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.MVar.withMVar" - itWithOuter "Control.Concurrent.MVar.modifyMVar_ should warn to use UnliftIO.MVar" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.MVar.modifyMVar_" + itWithOuter "modifyMVar_ should warn to use UnliftIO.MVar" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.MVar.modifyMVar_" - itWithOuter "System.Timeout.timeout should warn to use UnliftIO.Timeout" $ \output -> do - output `shouldSatisfy` containsWarning "UnliftIO.Timeout.timeout" + describe "System.Timeout" $ do + itWithOuter "timeout should warn to use UnliftIO.Timeout" $ \output -> do + output `shouldSatisfy` containsWarning "UnliftIO.Timeout.timeout" runHlintOnSample :: IO Text runHlintOnSample = do