模块系统与项目组织¶

module MyApp.Config (Config (..), parseConfig) where

import Options.Applicative

data Config = Config
  { cfgLogFile :: FilePath
  , cfgLimit :: Int
  } deriving (Show)

parseConfig :: IO Config
parseConfig = execParser (info (helper <*> parser) (progDesc "示例应用"))
  where
    parser = Config
      <$> strOption (long "log" <> metavar "FILE" <> value "app.log" <> help "日志文件")
      <*> option auto (long "limit" <> metavar "N" <> value 100 <> help "单次上限")

module MyApp.Types (Env (..), App, runApp) where

import Control.Monad.Reader (ReaderT, runReaderT)
import Data.IORef (IORef)
import MyApp.Config (Config)
import System.IO (Handle)

data Env = Env
  { envConfig :: Config
  , envLog :: Handle        -- 由 main 用 bracket 打开和关闭
  , envTotal :: IORef Int   -- 可变状态放进 Env，见并发一章
  }

type App = ReaderT Env IO

runApp :: Env -> App a -> IO a
runApp env app = runReaderT app env

module MyApp.Logic (validate, process) where

import Control.Monad.Reader (asks, liftIO)
import Data.IORef (atomicModifyIORef')
import MyApp.Config (Config (..))
import MyApp.Types (App, Env (..))
import System.IO (hPutStrLn)

-- 业务规则是纯函数，失败用 Either 表达，可以直接测试
validate :: Int -> Int -> Either String Int
validate limit n
  | n < 0 = Left "数量不能为负"
  | n > limit = Left ("超过上限 " ++ show limit)
  | otherwise = Right n

process :: Int -> App ()
process n = do
  limit <- asks (cfgLimit . envConfig)
  logH <- asks envLog
  case validate limit n of
    Left err -> liftIO (hPutStrLn logH ("拒绝 " ++ show n ++ ": " ++ err))
    Right ok -> do
      total <- asks envTotal
      new <- liftIO (atomicModifyIORef' total (\t -> (t + ok, t + ok)))
      liftIO (hPutStrLn logH ("接受 " ++ show ok ++ "，累计 " ++ show new))

module Main (main) where

import Control.Exception (SomeException, bracket, catch)
import Data.IORef (newIORef, readIORef)
import MyApp.Config (Config (..), parseConfig)
import MyApp.Logic (process)
import MyApp.Types (Env (..), runApp)
import System.Exit (exitFailure)
import System.IO

main :: IO ()
main = do
  cfg <- parseConfig            -- 第 26 章：--help 与参数错误在这一步就已处理完
  run cfg `catch` \e -> do
    -- 最外层兜底：没人处理的异常在这里变成一条错误信息和非零退出码
    hPutStrLn stderr ("致命错误: " ++ show (e :: SomeException))
    exitFailure

run :: Config -> IO ()
run cfg = do
  total <- newIORef 0
  -- 第 22 章：资源用 bracket 打开和释放
  bracket (openFile (cfgLogFile cfg) AppendMode) hClose $ \logH -> do
    let env = Env { envConfig = cfg, envLog = logH, envTotal = total }
    runApp env (mapM_ process [30, -1, 500, 70])   -- 第 20 章
  readIORef total >>= \t -> putStrLn ("总计: " ++ show t)

module Main (main) where

import MyApp.Logic (validate)
import System.Exit (exitFailure)

main :: IO ()
main
  | validate 100 (-1) == Left "数量不能为负" && validate 100 42 == Right 42 = putStrLn "ok"
  | otherwise = exitFailure