diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for ogma-extra +## [1.16.0] - 2026-09-21 + +* Version bump (1.16.0) (#606). +* Remove unnecessary line breaks (#520). +* Bump upper version constraint on `QuickCheck` (#545). +* Handle template expansion errors using specialized exception type (#390). +* Address HLint suggestions (#579). +* Remove unused import from `System.Directory.Extra` module (#588). + ## [1.15.0] - 2026-07-21 * Version bump (1.15.0) (#508). diff --git a/ogma-extra.cabal b/ogma-extra.cabal --- a/ogma-extra.cabal +++ b/ogma-extra.cabal @@ -19,7 +19,7 @@ build-type: Simple name: ogma-extra -version: 1.15.0 +version: 1.16.0 homepage: https://github.com/nasa/ogma bug-reports: https://github.com/nasa/ogma/issues license: Apache-2.0 @@ -68,6 +68,7 @@ , directory >= 1.3.1.5 && < 1.4 , filepath >= 1.4.2 && < 1.6 , microstache >= 1.0 && < 1.1 + , parsec >= 3.1.13.0 && < 3.2 , text >= 1.2.3.1 && < 2.2 hs-source-dirs: @@ -88,7 +89,7 @@ build-depends: base >= 4.11.0.0 && < 5 - , QuickCheck >= 2.8.2 && < 2.17 + , QuickCheck >= 2.8.2 && < 2.19 , test-framework >= 0.8.2 && < 0.9 , test-framework-quickcheck2 >= 0.3.0.4 && < 0.4 diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -39,5 +39,5 @@ -- | Remove a suffix from a string, if present. stripSuffix :: String -> String -> String stripSuffix suffix string - | isSuffixOf suffix string = take (length string - length suffix) string - | otherwise = string + | suffix `isSuffixOf` string = take (length string - length suffix) string + | otherwise = string diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs --- a/src/System/Directory/Extra.hs +++ b/src/System/Directory/Extra.hs @@ -19,24 +19,33 @@ -- | Auxiliary functions for working with directories. module System.Directory.Extra ( copyTemplate + , CopyTemplateException(..) ) where -- External imports +import Control.Exception ( Exception, IOException, catch, + throwIO ) import Control.Monad ( filterM, forM_ ) import Data.Aeson ( Value (..) ) import qualified Data.ByteString.Lazy as B +import Data.List ( isInfixOf ) import Data.Text.Lazy ( pack, unpack ) import Data.Text.Lazy.Encoding ( encodeUtf8 ) import Distribution.Simple.Utils ( getDirectoryContentsRecursive ) import System.Directory ( createDirectoryIfMissing, doesFileExist ) import System.FilePath ( makeRelative, splitFileName, - takeDirectory, () ) -import Text.Microstache ( compileMustacheFile, + () ) +import Text.Microstache ( MustacheException (..), Template, + compileMustacheFile, compileMustacheText, renderMustache ) +import Text.Parsec.Error ( Message (..), errorMessages, + errorPos ) +import Text.Parsec.Pos ( sourceColumn, sourceLine ) +{- HLINT ignore "Redundant <$>" -} -- | Copy a template directory into a target location, expanding variables -- provided in a map in a JSON value, both in the file contents and in the -- filepaths themselves. @@ -46,7 +55,8 @@ -- Get all files (not directories) in the template dir. To keep a directory, -- create an empty file in it (e.g., .keep). tmplContents <- map (templateDir ) . filter (`notElem` ["..", "."]) - <$> getDirectoryContentsRecursive templateDir + <$> getDirectoryContentsRecursiveE templateDir + tmplFiles <- filterM doesFileExist tmplContents -- Copy files to new locations, expanding their name and contents as @@ -71,11 +81,112 @@ -- File contents, treated as a mustache template. contents <- encodeUtf8 <$> (`renderMustache` subst) - <$> compileMustacheFile fp + <$> compileMustacheFileE fp -- Create target directory if necessary let dirName = fst $ splitFileName fullPath - createDirectoryIfMissing True dirName + createDirectoryIfMissingE True dirName -- Write expanded contents to expanded file path - B.writeFile fullPath contents + -- Capture exceptions here + writeFileE fullPath contents + +-- | Exception detected during the template expansion process. +newtype CopyTemplateException = CopyTemplateException String + +instance Show CopyTemplateException where + show (CopyTemplateException s) = s + +instance Exception CopyTemplateException + +-- | Wrap 'getDirectoryContentsRecursive' and throw any 'IOException' as a +-- 'CopyTemplateException'. +getDirectoryContentsRecursiveE :: FilePath -> IO [FilePath] +getDirectoryContentsRecursiveE s = + catch (getDirectoryContentsRecursive s) handler + where + handler :: IOException -> IO [FilePath] + handler e = throwIO (CopyTemplateException (show e)) + +-- | Wrap 'createDirectoryIfMissing' and throw any 'IOException' as a +-- 'CopyTemplateException', possibly making the error message more +-- user-friendly. +createDirectoryIfMissingE :: Bool -> FilePath -> IO () +createDirectoryIfMissingE parents fp = + catch (createDirectoryIfMissing parents fp) handler + where + handler :: IOException -> IO () + handler e + | "createDirectory: permission denied" `isInfixOf` show e + = throwIO $ CopyTemplateException $ + fp ++ ": " ++ "Error creating target directory (permission denied)" + + | otherwise + = throwIO $ CopyTemplateException $ fp ++ ": " ++ show e + +-- | Wrap 'writeFile' and throw any 'IOException' as a 'CopyTemplateException', +-- possibly making the error message more user-friendly. +writeFileE :: FilePath -> B.ByteString -> IO () +writeFileE fp contents = + catch (B.writeFile fp contents) handler + where + handler :: IOException -> IO () + handler e + | "permission denied" `isInfixOf` show e + = throwIO $ CopyTemplateException $ + fp ++ ": " ++ "Error creating target file (permission denied)" + + | "resource exhausted" `isInfixOf` show e + = throwIO $ CopyTemplateException $ + fp ++ ": " ++ "No space left on device" + + | otherwise + = throwIO $ CopyTemplateException $ fp ++ ": " ++ show e + +-- | Wrap 'compileMustacheFile' and throw any 'IOException' or +-- 'MustacheException' as a 'CopyTemplateException', possibly making the error +-- message more user-friendly. +compileMustacheFileE :: FilePath -> IO Template +compileMustacheFileE fp = do + catch (catch (compileMustacheFile fp) handler) handlerIO + where + handler :: MustacheException -> IO Template + handler (MustacheParserException p) = do + let pos = errorPos p + line = sourceLine pos + column = sourceColumn pos + messages = keepHead $ map showMessage $ errorMessages p + throwIO $ CopyTemplateException $ + fp ++ ":" ++ show line ++ ":" ++ show column ++ ": " ++ messages + + handler e = do + throwIO $ CopyTemplateException $ fp ++ ": " ++ show e + + handlerIO :: IOException -> IO Template + handlerIO e + | "hGetContents: invalid argument" `isInfixOf` show e + = throwIO $ CopyTemplateException $ + fp ++ ": " ++ "Invalid UTF-8 byte sequence" + + | "invalid byte sequence" `isInfixOf` show e + = throwIO $ CopyTemplateException $ + fp ++ ": " ++ "Invalid UTF-8 byte sequence" + + | "openFile: permission denied" `isInfixOf` show e + = throwIO $ CopyTemplateException $ fp ++ ": " ++ "Permission denied" + + | otherwise + = throwIO $ CopyTemplateException $ fp ++ ": " ++ show e + +-- | Show a parse message. +showMessage :: Message -> String +showMessage (SysUnExpect s) = "Unexpected " ++ s +showMessage (UnExpect s) = "Unexpected " ++ s +showMessage (Expect s) = "Expected " ++ s +showMessage (Message s) = s + +-- | Keep the first element of a list of strings, returning the empty string if +-- the list is empty. +keepHead :: [String] -> String +keepHead (a:_) = a +keepHead _ = "" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -29,8 +29,7 @@ -- | Run all unit tests on Ogma's core. main :: IO () -main = - defaultMainWithOpts tests mempty +main = defaultMainWithOpts tests mempty -- | All unit tests for Ogma's core. tests :: [Test.Framework.Test]