diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,53 @@ +# Changelog for `magic` + +All notable changes to this project are documented here. + +## 2.0.0 (2026-06-09) + +A modernizing redesign, and the first release in which `magic` is genuinely safe and correct under real-world use. The reasons to upgrade: + +- **Thread-safe handles.** `Magic` is now an opaque handle whose operations are serialised by an internal per-handle lock, so sharing one handle across threads is safe (it was previously a silent data race). Use distinct handles for parallelism. (`Magic` was the transparent synonym `type Magic = ForeignPtr CMagic`, so the `CMagic` phantom type is no longer exported.) +- **Correct on any filename.** Paths are now `OsPath`, which stores the OS-native path bytes verbatim and avoids the lossy locale round-trip that `String` paths suffer on unusual filenames. `magicFile` takes an `OsPath`; `magicLoad`, `magicCompile`, and `magicCheck` take `[OsPath]` (the empty list means the default database); `magicGetPath` returns `[OsPath]`. The new `Magic.FilePath` module offers the whole API with ordinary `String` paths for convenience. +- **Correct on any in-memory data.** Removed `magicString`, which round-tripped data through the locale encoding and corrupted non-text bytes. Identify in-memory data with `magicByteString` (raw bytes) or `magicCString` (a raw pointer). +- **Memory-safe loading from memory.** Restored `magicLoadBuffers :: Magic -> [ByteString] -> IO ()` (removed in 1.1.2): the handle now retains the supplied buffers for its lifetime, so embedding and loading a compiled database from memory is memory-safe. +- **Typed, catchable errors.** Failures raise a dedicated `MagicException` carrying the failing operation and `libmagic`'s message, with a readable `displayException`, instead of a generic `IOError`. (`magicOpen` still raises an `errno` `IOError`, as there is no handle yet to query.) +- **Correct, ergonomic flags.** A `MagicFlags` bit-mask newtype replaces the old `MagicFlag` enumeration, whose `Enum`-as-bit-mask design mishandled aliased and composite constants. Combine flags with `(<>)`, start from `mempty`, test with `hasFlag`, narrow with `removeFlags`; each flag is a pattern synonym, and `show` prints the set flags by name. +- **`Text` results.** `magicFile`, `magicStdin`, `magicCString`, `magicByteString`, and `magicDescriptor` return `Text`. +- **Good-citizen instances.** Added `Generic` and `NFData` for `MagicFlags`, `MagicParam`, and `MagicException`. + +### Migrating from 1.x + +- Results are `Text`: add `Data.Text.unpack` where you still need `String`. +- In-memory data: `magicString` becomes `magicByteString` (pass a `ByteString`). +- Flags: `magicOpen [MagicMimeType, MagicError]` becomes `magicOpen (MagicMimeType <> MagicError)`, and `[]` becomes `mempty`. +- Paths: adopt `OsPath`, or `import Magic.FilePath` to keep `String` paths. +- Catch `MagicException` instead of `IOException`. + +## 1.1.2 (2026-06-09) + +Backwards-compatible additions: existing code continues to work unchanged. This release rounds out the binding to cover (almost) all of `libmagic`'s public API. + +- Added the remaining `MagicFlag` constructors from ``: `MagicApple`, `MagicExtension`, `MagicCompressTransp`, `MagicNoCompressFork`, `MagicNodesc`, and the whole no-check family (`MagicNoCheckCompress`, `…Tar`, `…Soft`, `…Apptype`, `…Elf`, `…Text`, `…Cdf`, `…Csv`, `…Tokens`, `…Encoding`, `…Json`, `…Simh`) plus `MagicNoCheckBuiltin`. +- Added new operations in `Magic.Operations`: `magicDescriptor` (identify an open file descriptor), `magicByteString` (binary-safe identification of a strict `ByteString`), `magicGetFlags`, `magicGetParam`/`magicSetParam` with the new `MagicParam` type, `magicCheck`, `magicGetPath`, `magicVersion`, and `magicErrno`. +- `magicGetParam`/`magicSetParam` require `libmagic` >= 5.21; `magicGetFlags` requires >= 5.05. All current systems are well past this. +- New dependency: `bytestring` (a GHC boot library) for the `ByteString` entry points. +- Moved the `CMagic` phantom type (the tag behind the `Magic` handle) into `Magic.Types` and removed the internal `Magic.TypesLL` module. `CMagic` is now documented and linkable from the exposed `Magic.Types`. Documentation polish throughout: full Haddock coverage with no warnings, `@since` annotations on the new API, and default values listed for each `MagicParam`. +- `magic_load` is now imported as a `safe` foreign call (it was `unsafe`). It reads and parses the magic database from disk (blocking I/O), so under the threaded runtime loading a database no longer stalls other Haskell threads or blocks garbage collection. No API change. +- Documented the thread-safety contract of the `Magic` handle: a single handle is not safe for concurrent use (serialise access or use one per thread); distinct handles are independent. + +## 1.1.1 (2026-06-09) + +No API changes: this release is a drop-in replacement for 1.1. + +- New maintainer: Philippe (); package handed over from John Goerzen. +- Modernised the Cabal package description (`cabal-version: 2.4`, proper `library`/`test-suite` stanzas, `source-repository`, `tested-with`). +- Added an automatic `pkgconfig` flag: libmagic is now located via pkg-config when available, falling back transparently to plain `extra-libraries` linking otherwise. +- Moved library sources under `src/` and tests under `test/` (no code or module-name changes). +- Revived the original HUnit test suite in place: completed the unfinished `Inittest` module with real tests exercising the bindings against the system magic database, and fixed the runner to exit non-zero on failure. +- Added a GitHub Actions CI workflow building and testing across GHC 9.6 / 9.8 / 9.10 / 9.12. +- Removed dead imports so the library builds `-Wall`-clean. +- Ships the `unsafe`-FFI fix (use safe FFI calls for blocking I/O) that was merged upstream after the 1.1 Hackage release but never published. + +## 1.1 (2014-10) and earlier + +Releases by John Goerzen. See the git history for details. diff --git a/Magic.hs b/Magic.hs deleted file mode 100644 --- a/Magic.hs +++ /dev/null @@ -1,35 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell Magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Top-level Magic module. - -Written by John Goerzen, jgoerzen\@complete.org - -Foo bar --} - -module Magic (-- * Basic Types - module Magic.Types, - -- * Initialization - module Magic.Init, - -- * Operation - module Magic.Operations - ) -where -import Magic.Types -import Magic.Init -import Magic.Operations diff --git a/Magic/Data.hsc b/Magic/Data.hsc deleted file mode 100644 --- a/Magic/Data.hsc +++ /dev/null @@ -1,77 +0,0 @@ --- AUTO-GENERATED FILE, DO NOT EDIT. GENERATED BY utils/genconsts.hs -{- | - Module : Magic.Data - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Haskell types for libmagic constants - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.Data (module Magic.Data) where - -#include "magic.h" - - -data MagicFlag = - MagicNone - | MagicDebug - | MagicSymlink - | MagicCompress - | MagicDevices - | MagicMimeType - | MagicMimeEncoding - | MagicMime - | MagicContinue - | MagicCheck - | MagicPreserveAtime - | MagicRaw - | MagicError - | UnknownMagicFlag Int - - deriving (Show) - -instance Enum MagicFlag where - toEnum (#{const MAGIC_NONE}) = MagicNone - toEnum (#{const MAGIC_DEBUG}) = MagicDebug - toEnum (#{const MAGIC_SYMLINK}) = MagicSymlink - toEnum (#{const MAGIC_COMPRESS}) = MagicCompress - toEnum (#{const MAGIC_DEVICES}) = MagicDevices - toEnum (#{const MAGIC_MIME_TYPE}) = MagicMimeType - toEnum (#{const MAGIC_MIME_ENCODING}) = MagicMimeEncoding - toEnum (#{const MAGIC_MIME}) = MagicMime - toEnum (#{const MAGIC_CONTINUE}) = MagicContinue - toEnum (#{const MAGIC_CHECK}) = MagicCheck - toEnum (#{const MAGIC_PRESERVE_ATIME}) = MagicPreserveAtime - toEnum (#{const MAGIC_RAW}) = MagicRaw - toEnum (#{const MAGIC_ERROR}) = MagicError - toEnum x = UnknownMagicFlag x - - fromEnum MagicNone = (#{const MAGIC_NONE}) - fromEnum MagicDebug = (#{const MAGIC_DEBUG}) - fromEnum MagicSymlink = (#{const MAGIC_SYMLINK}) - fromEnum MagicCompress = (#{const MAGIC_COMPRESS}) - fromEnum MagicDevices = (#{const MAGIC_DEVICES}) - fromEnum MagicMimeType = (#{const MAGIC_MIME_TYPE}) - fromEnum MagicMimeEncoding = (#{const MAGIC_MIME_ENCODING}) - fromEnum MagicMime = (#{const MAGIC_MIME}) - fromEnum MagicContinue = (#{const MAGIC_CONTINUE}) - fromEnum MagicCheck = (#{const MAGIC_CHECK}) - fromEnum MagicPreserveAtime = (#{const MAGIC_PRESERVE_ATIME}) - fromEnum MagicRaw = (#{const MAGIC_RAW}) - fromEnum MagicError = (#{const MAGIC_ERROR}) - fromEnum (UnknownMagicFlag x) = x - -instance Ord MagicFlag where - compare x y = compare (fromEnum x) (fromEnum y) - -instance Eq MagicFlag where - x == y = (fromEnum x) == (fromEnum y) - - diff --git a/Magic/Init.hsc b/Magic/Init.hsc deleted file mode 100644 --- a/Magic/Init.hsc +++ /dev/null @@ -1,58 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic.Init - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Initialization and shutdown for magic programs - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.Init(magicOpen, magicLoad, magicLoadDefault) -where - -import Foreign.Ptr -import Foreign.C.String -import Magic.Types -import Foreign.C.Types -import Magic.Utils -import Magic.TypesLL -import Foreign.Marshal.Utils - -{- | Create a Magic object. You must call either 'magicLoadDefault' -or 'magicLoad' after this. --} -magicOpen :: [MagicFlag] -> IO Magic -magicOpen mfl = - fromMagicPtr "magicOpen" (magic_open flags) - where flags = flaglist2int mfl - -{- | Load the system's default magic database. -} -magicLoadDefault :: Magic -> IO () -magicLoadDefault m = withMagicPtr m (\cmagic -> - checkIntError "magicLoadDefault" m $ magic_load cmagic nullPtr) - -{- | Load the specified magic database(s). The given string may contain -multiple colon-separated pathnames. -} -magicLoad :: Magic -> String -> IO () -magicLoad m s = withMagicPtr m (\cmagic -> - withCString s (\cs -> - checkIntError "magicLoad" m $ magic_load cmagic cs)) - -foreign import ccall unsafe "magic.h magic_open" - magic_open :: CInt -> IO (Ptr CMagic) - -foreign import ccall unsafe "magic.h magic_load" - magic_load :: Ptr CMagic -> CString -> IO CInt diff --git a/Magic/Operations.hsc b/Magic/Operations.hsc deleted file mode 100644 --- a/Magic/Operations.hsc +++ /dev/null @@ -1,102 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic.Init - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Initialization and shutdown for magic programs - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.Operations(-- * Guessing the type - magicFile, magicStdin, - magicString, magicCString, - -- * Other operations - magicSetFlags, magicCompile) -where - -import Foreign.Ptr -import Foreign.C.String -import Magic.Types -import Foreign.C.Types -import Data.Word -import Foreign.C.String -import Foreign.C.Error -import Magic.Utils -import Magic.TypesLL -import Foreign.Marshal.Utils - -{- | Calls the Magic system on the specified file. -} -magicFile :: Magic -> FilePath -> IO String -magicFile magic fp = - withMagicPtr magic (\cmagic -> - withCString fp (\cfp -> - do res <- throwErrorIfNull "magicFile" magic (magic_file cmagic cfp) - peekCString res - ) - ) - -{- | Calls the Magic system on stdin. -} -magicStdin :: Magic -> IO String -magicStdin magic = - withMagicPtr magic (\cmagic -> - do res <- throwErrorIfNull "magicStdin" magic (magic_file cmagic nullPtr) - peekCString res - ) - -{- | Calls the Magic system to process the given String. Please note: -it is not evaluated lazily. -} -magicString :: Magic -> String -> IO String -magicString m s = withCStringLen s (magicCString m) - -{- | Lower-level function used to call the Magic system to process a C -string. -} -magicCString :: Magic -> CStringLen -> IO String -magicCString magic (cstr, len) = - withMagicPtr magic (\cmagic -> - do res <- throwErrorIfNull "magicCString" magic (magic_buffer cmagic cstr (fromIntegral len)) - peekCString res - ) - -{- | Change the flags on an already-created object. -} -magicSetFlags :: Magic -> [MagicFlag] -> IO () -magicSetFlags m mfl = withMagicPtr m (\cmagic -> - checkIntError "magicSetFlags" m $ magic_setflags cmagic flags) - where flags = flaglist2int mfl - -{- | Compile the colon-separated list of database file(s). The compiled files -created have .mgc added to the names of the argument. --} -magicCompile :: Magic -- ^ Object to use - -> Maybe String -- ^ Colon separated list of databases, or Nothing for default - -> IO () -magicCompile m mstr = withMagicPtr m (\cm -> - case mstr of - Nothing -> worker cm nullPtr - Just x -> withCString x (worker cm) - ) - where worker cm cs = checkIntError "magicCompile" m $ magic_compile cm cs - -foreign import ccall unsafe "magic.h magic_file" - magic_file :: Ptr CMagic -> CString -> IO CString - -foreign import ccall unsafe "magic.h magic_buffer" - magic_buffer :: Ptr CMagic -> CString -> #{type size_t} -> IO CString - -foreign import ccall unsafe "magic.h magic_setflags" - magic_setflags :: Ptr CMagic -> CInt -> IO CInt - -foreign import ccall unsafe "magic.h magic_compile" - magic_compile :: Ptr CMagic -> CString -> IO CInt diff --git a/Magic/Types.hsc b/Magic/Types.hsc deleted file mode 100644 --- a/Magic/Types.hsc +++ /dev/null @@ -1,42 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic.Types - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Types for magic programs. - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.Types(Magic, - MagicFlag(..)) -where -import Foreign.Ptr -import Data.Word -import Data.Int -import Foreign.C.Types -import Foreign.ForeignPtr -import Magic.Data -import Magic.TypesLL - -#include - -{- | Main Magic object type. - -Magic objects are automatically closed (and memory freed) when they are -garbage-collected by Haskell. There is no need to explicitly close them. --} -type Magic = ForeignPtr CMagic - diff --git a/Magic/TypesLL.hs b/Magic/TypesLL.hs deleted file mode 100644 --- a/Magic/TypesLL.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic.TypesLL - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Low-Types for magic programs. - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.TypesLL(CMagic) -where - -data CMagic diff --git a/Magic/Utils.hsc b/Magic/Utils.hsc deleted file mode 100644 --- a/Magic/Utils.hsc +++ /dev/null @@ -1,77 +0,0 @@ -{- -*- Mode: haskell; -*- -Haskell magic Interface -Copyright (C) 2005 John Goerzen - -This code is under a 3-clause BSD license; see COPYING for details. --} - -{- | - Module : Magic.Utils - Copyright : Copyright (C) 2005 John Goerzen - License : BSD - - Maintainer : John Goerzen, - Maintainer : jgoerzen\@complete.org - Stability : provisional - Portability: portable - -Utils - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Magic.Utils (flaglist2int, fromMagicPtr, withMagicPtr, checkIntError, - throwErrorIfNull) -where - -import Foreign -import Foreign.C.Error -import Foreign.C.String -import Foreign.ForeignPtr -import Magic.TypesLL -import Magic.Types -import Data.Bits -import Foreign.C.Types -import Magic.Data - -flaglist2int :: [MagicFlag] -> CInt -flaglist2int mfl = - foldl (\c f -> c .|. (fromIntegral . fromEnum $ f)) 0 mfl - -fromMagicPtr :: String -> IO (Ptr CMagic) -> IO Magic -fromMagicPtr caller action = - do ptr <- throwErrnoIfNull caller action - newForeignPtr magic_close ptr - -throwErrorIfNull :: String -> Magic -> IO (Ptr a) -> IO (Ptr a) -throwErrorIfNull caller m action = - do res <- action - if res == nullPtr - then throwError caller m - else return res - -withMagicPtr :: Magic -> (Ptr CMagic -> IO a) -> IO a -withMagicPtr m = withForeignPtr m - -throwError :: String -> Magic -> IO a -throwError caller m = withMagicPtr m (\cmagic -> - do errormsg <- magic_error cmagic - if errormsg /= nullPtr - then do em <- peekCString errormsg - fail $ caller ++ ": " ++ em - else fail $ caller ++ ": got error code but no error message" - ) - -checkIntError :: String -> Magic -> IO CInt -> IO () -checkIntError caller m action = - do res <- action - if res == 0 - then return () - else throwError caller m - - -foreign import ccall unsafe "magic.h &magic_close" - magic_close :: FunPtr (Ptr CMagic -> IO ()) - -foreign import ccall unsafe "magic.h magic_error" - magic_error :: Ptr CMagic -> IO CString diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# magic + +It is a binding to the C [libmagic](https://www.darwinsys.com/file/) library. It allows you to determine the type of a file not by looking at its name or extension, but rather by examining the contents itself. + +libmagic can provide either a textual description or a MIME content type (and, occasionally, also a character set). The Haskell binding can examine files, open file descriptors, and in-memory data (as a strict `ByteString`). Results come back as `Text`. + +## Requirements + +You need the C `libmagic` library and its development headers installed before building. It is part of the [`file`](https://www.darwinsys.com/file/) package. + +| Platform | Install | +|----------|---------| +| Debian / Ubuntu | `apt-get install libmagic-dev` | +| Fedora | `dnf install file-devel` | +| Arch | `pacman -S file` | +| macOS (Homebrew) | `brew install libmagic` | +| Nix | `file` / `file.dev` | + +## Building + +With `cabal`: + +```sh +cabal build +cabal test +``` + +With `stack`: + +```sh +stack build +stack test +``` + +libmagic is located automatically via pkg-config. If pkg-config cannot find it (for example, an unusual install location), point Cabal at the library directly: + +```sh +cabal build \ + --extra-lib-dirs=/path/to/lib \ + --extra-include-dirs=/path/to/include +``` + +## Usage + +Add `magic` to your `build-depends`. The easiest way in is `Magic.FilePath`, which takes ordinary `String` paths: + +```haskell +import Magic.FilePath -- convenience facade: ordinary String paths +import qualified Data.Text.IO as T + +main :: IO () +main = do + magic <- magicOpen MagicMimeType + magicLoadDefault magic + mime <- magicFile magic "some-file.png" + T.putStrLn mime -- e.g. "image/png" +``` + +### `Magic` vs `Magic.FilePath` + +`import Magic` is the primary API. It is the same in every way except that paths are `OsPath` instead of `String`. Prefer it when filename correctness matters. + +`Magic.FilePath` is a drop-in facade that converts paths through the locale's filesystem encoding (`encodeFS` / `decodeFS`). For ordinary ASCII/UTF-8 filenames under a UTF-8 locale that is perfectly fine. What you give up: a `String` path cannot faithfully represent every path the operating system can. Filenames containing bytes that are not valid in the current locale (raw non-UTF-8 bytes on Unix, names created under a different `LANG`/`LC_*`, and so on) may be corrupted or fail to round-trip, so you can fail to open a file that exists, or open the wrong one, and the outcome depends on the environment. `OsPath` stores the OS-native path bytes verbatim, so it represents any path losslessly and independently of the locale. + +## Author & history + +magic-haskell was written by John Goerzen , who created it in 2005 and maintained it for nearly two decades. It is now maintained by Philippe, with development at . + +## License + +3-clause BSD. See the `COPYING` file included with the package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runhugs -arch-tag: Main setup script - -> import Distribution.Simple - -> main = defaultMain - diff --git a/magic.cabal b/magic.cabal --- a/magic.cabal +++ b/magic.cabal @@ -1,31 +1,133 @@ -Extra-Libraries: magic --- End detected settings section. Everything below here should not --- need editing. -Name: magic -Version: 1.1 -license: BSD3 -Maintainer: John Goerzen -Author: John Goerzen -Stability: Alpha -Copyright: Copyright (c) 2005-2009 John Goerzen -build-type: Simple -license-file: COPYING -Category: Text -Synopsis: Interface to C file/magic library -Description: This package provides a Haskell interface to the C libmagic library. - With it, you can determine the type of a file by examining its contents - rather than its name. The Haskell interface provides a full-featured - binding. --- C-Sources: glue/glue.c -Exposed-Modules: Magic, - Magic.Data, - Magic.Types, - Magic.Init, - Magic.Operations -Other-Modules: Magic.Utils, - Magic.TypesLL -Build-Depends: base >= 3 && < 5 -GHC-Options: -O2 --- CC-Options: -Iglue -Extensions: ForeignFunctionInterface, TypeSynonymInstances, - EmptyDataDecls +cabal-version: 2.4 +name: magic +version: 2.0.0 +synopsis: Interface to C file/magic library +description: + This package provides a Haskell interface to the C libmagic library. + With it, you can determine the type of a file by examining its contents + rather than its name. The Haskell interface provides a full-featured + binding. + . + Note: this package requires the C libmagic library (part of the @file@ + package) and its development headers to be installed at build time. + +category: Text +license: BSD-3-Clause +license-file: COPYING +author: John Goerzen +maintainer: Philippe +copyright: Copyright (c) 2005-2009 John Goerzen +homepage: https://github.com/philippedev101/magic-haskell +bug-reports: https://github.com/philippedev101/magic-haskell/issues +build-type: Simple +extra-doc-files: + README.md + CHANGELOG.md + +tested-with: + GHC ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + +source-repository head + type: git + location: https://github.com/philippedev101/magic-haskell.git + +flag pkgconfig + description: + Use pkg-config to locate the C libmagic library. Enabled by default; + because this flag is automatic, Cabal's solver transparently falls back + to plain @extra-libraries@ linking when pkg-config or libmagic.pc is + unavailable. + default: True + manual: False + +flag dev + description: Turn on developer settings, notably -Werror. + default: False + manual: True + +-- Strict warning set shared by all components. Based on -Weverything with the +-- pedantic / Safe-Haskell / style categories that the existing bindings cannot +-- satisfy without source changes disabled. The genuine bug-catching warnings +-- (unused bindings, incomplete patterns, name shadowing, missing local/export +-- signatures, type defaults, ...) remain ON. -Werror is opt-in via the `dev` +-- flag so a normal build, Hackage, or Stackage is never broken by a future +-- GHC introducing new warnings. +common warnings + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-missed-specialisations + -Wno-implicit-prelude + -Wno-missing-deriving-strategies + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + -Wno-safe + -Wno-unsafe + + if flag(dev) + ghc-options: -Werror + +library + import: warnings + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Magic + Magic.Data + Magic.Types + Magic.Init + Magic.Operations + Magic.FilePath + + other-modules: + Magic.Internal + + default-extensions: + EmptyDataDecls + ForeignFunctionInterface + TypeSynonymInstances + + build-depends: + , base >=4.9 && <5 + , bytestring >=0.10 && <0.13 + , deepseq >=1.4 && <1.6 + , filepath >=1.4.100 && <1.6 + , text >=1.2.3 && <2.2 + + -- The OsString internal types (used to marshal OsPath to a C string without a + -- lossy locale round-trip) live in os-string on GHC >= 9.10; on 9.6/9.8 they + -- are provided by filepath itself. + if impl(ghc >= 9.10) + build-depends: os-string >=2.0 && <2.1 + + if flag(pkgconfig) + pkgconfig-depends: libmagic + else + extra-libraries: magic + +test-suite magic-test + import: warnings + type: exitcode-stdio-1.0 + main-is: runtests.hs + hs-source-dirs: test + ghc-options: -threaded -with-rtsopts=-N + other-modules: + Inittest + Tests + + default-language: Haskell2010 + build-depends: + , base >=4.9 && <5 + , bytestring >=0.10 && <0.13 + , deepseq >=1.4 && <1.6 + , directory >=1.2 && <1.4 + , filepath >=1.4.100 && <1.6 + , HUnit >=1.6 && <1.7 + , magic + , text >=1.2.3 && <2.2 + , unix >=2.8 && <2.9 diff --git a/src/Magic.hs b/src/Magic.hs new file mode 100644 --- /dev/null +++ b/src/Magic.hs @@ -0,0 +1,74 @@ +{- -*- Mode: haskell; -*- +Haskell Magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{- | + Module : Magic + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +Haskell bindings to the C @libmagic@ library, which identifies the type of a +file by inspecting its contents rather than its name. It can report a textual +description, a MIME type, or a character-set encoding. + +This top-level module re-exports the whole interface: the types in +"Magic.Types", the initialization functions in "Magic.Init", and the querying +functions in "Magic.Operations". + +If you just want to pass ordinary @String@ paths, start with "Magic.FilePath", +a drop-in facade over this module. The functions here take +'System.OsPath.OsPath' instead, which represents any filename losslessly and +independently of the locale (see the note below). + +A typical session creates a handle, loads the system magic database, then +queries files or in-memory data. The flags passed to 'magicOpen' choose what +kind of answer comes back (see t'MagicFlags'); combine them with @('<>')@ and +use 'mempty' (i.e. 'MagicNone') for the defaults: + +> {-# LANGUAGE QuasiQuotes #-} +> import Magic +> import System.OsPath (osp) +> import qualified Data.Text.IO as T +> +> main :: IO () +> main = do +> magic <- magicOpen MagicMimeType -- ask for MIME types +> magicLoadDefault magic -- load the system database +> mime <- magicFile magic [osp|/etc/passwd|] +> T.putStrLn mime -- e.g. "text/plain" + +Paths here are 'System.OsPath.OsPath', which stores the OS-native path bytes +verbatim and so represents any path the system can, without a lossy locale +round-trip. The "Magic.FilePath" facade offers the same API with @String@ +paths for convenience; it is fine for ordinary filenames, but cannot faithfully +represent names whose bytes are invalid in the current locale. + +Handles are closed and their memory freed automatically when they are +garbage-collected (see t'Magic'); there is no explicit close. On failure, most +operations raise a t'MagicException'; 'magicOpen' raises an 'IOError' (from +@errno@) if the handle cannot be allocated. + +Originally written by John Goerzen. +-} + +module Magic (-- * Basic Types + module Magic.Types, + -- * Flags + module Magic.Data, + -- * Initialization + module Magic.Init, + -- * Operation + module Magic.Operations + ) +where +import Magic.Types +import Magic.Data +import Magic.Init +import Magic.Operations diff --git a/src/Magic/Data.hsc b/src/Magic/Data.hsc new file mode 100644 --- /dev/null +++ b/src/Magic/Data.hsc @@ -0,0 +1,273 @@ +-- AUTO-GENERATED FILE, DO NOT EDIT. GENERATED BY utils/genconsts.hs +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} +{- | + Module : Magic.Data + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +The t'MagicFlags' bit-mask, mapping the C @libmagic@ @MAGIC_*@ constants to +Haskell. Flags are combined with @('<>')@, tested with 'hasFlag', and narrowed +with 'removeFlags'; the empty set ('mempty') is 'MagicNone'. +-} + +module Magic.Data + ( MagicFlags(..) + , hasFlag + , removeFlags + , pattern MagicNone + , pattern MagicDebug + , pattern MagicSymlink + , pattern MagicCompress + , pattern MagicDevices + , pattern MagicMimeType + , pattern MagicMimeEncoding + , pattern MagicMime + , pattern MagicContinue + , pattern MagicCheck + , pattern MagicPreserveAtime + , pattern MagicRaw + , pattern MagicError + , pattern MagicApple + , pattern MagicExtension + , pattern MagicCompressTransp + , pattern MagicNoCompressFork + , pattern MagicNodesc + , pattern MagicNoCheckCompress + , pattern MagicNoCheckTar + , pattern MagicNoCheckSoft + , pattern MagicNoCheckApptype + , pattern MagicNoCheckElf + , pattern MagicNoCheckText + , pattern MagicNoCheckCdf + , pattern MagicNoCheckCsv + , pattern MagicNoCheckTokens + , pattern MagicNoCheckEncoding + , pattern MagicNoCheckJson + , pattern MagicNoCheckSimh + , pattern MagicNoCheckBuiltin + ) where + +#include "magic.h" + +import Control.DeepSeq (NFData(rnf)) +import Data.Bits ((.&.), (.|.), complement, popCount) +import Data.List (intercalate) +import Foreign.C.Types (CInt) +import GHC.Generics (Generic) + +-- | A set of @libmagic@ flags, represented as the underlying C bit-mask. +-- Combine flags with @('<>')@, start from 'mempty' (no flags), test +-- membership with 'hasFlag', and narrow with 'removeFlags'. The +-- v'MagicFlags' constructor is an escape hatch for passing a raw mask; +-- prefer the pattern synonyms below. +-- +-- @since 2.0.0 +newtype MagicFlags = MagicFlags CInt + deriving (Eq, Ord, Generic) + +instance NFData MagicFlags where rnf (MagicFlags x) = x `seq` () + +-- | Flags combine by bitwise-or. +instance Semigroup MagicFlags where + MagicFlags a <> MagicFlags b = MagicFlags (a .|. b) + +-- | 'mempty' is the empty flag set ('MagicNone'). +instance Monoid MagicFlags where + mempty = MagicFlags 0 + +-- | Prints the set flags by name (e.g. @MagicMimeType <> MagicError@), or +-- @MagicNone@ when empty. Any bits not corresponding to a known flag are +-- shown as a raw @MagicFlags n@ term. +instance Show MagicFlags where + showsPrec p fs = + case names of + [] -> showString "MagicNone" + [n] -> showString n + _ -> showParen (p > 6) (showString (intercalate " <> " names)) + where + MagicFlags raw = fs + set = [ (n, v) | (n, MagicFlags v) <- allNamedFlags, popCount v == 1, raw .&. v == v ] + covered = foldr (\(_, v) acc -> v .|. acc) (0 :: CInt) set + leftover = raw .&. complement covered + names = map fst set ++ [ "MagicFlags " ++ show leftover | leftover /= (0 :: CInt) ] + +-- | @'hasFlag' fs flag@ is 'True' when every bit of @flag@ is set in @fs@. +-- Works for composite flags too (e.g. @fs \`hasFlag\` 'MagicMime'@). Note +-- that @fs \`hasFlag\` 'MagicNone'@ is always 'True' (the empty set is a +-- subset of everything). +-- +-- @since 2.0.0 +hasFlag :: MagicFlags -> MagicFlags -> Bool +hasFlag (MagicFlags x) (MagicFlags m) = x .&. m == m + +-- | @'removeFlags' fs drop@ clears every bit of @drop@ from @fs@ (set +-- difference), e.g. @flags \`removeFlags\` 'MagicError'@. +-- +-- @since 2.0.0 +removeFlags :: MagicFlags -> MagicFlags -> MagicFlags +removeFlags (MagicFlags a) (MagicFlags b) = MagicFlags (a .&. complement b) + +-- | No special handling; return a textual description (the default). This is 'mempty'. +pattern MagicNone :: MagicFlags +pattern MagicNone = MagicFlags (#{const MAGIC_NONE}) + +-- | Print debugging messages to stderr. +pattern MagicDebug :: MagicFlags +pattern MagicDebug = MagicFlags (#{const MAGIC_DEBUG}) + +-- | Follow symbolic links. +pattern MagicSymlink :: MagicFlags +pattern MagicSymlink = MagicFlags (#{const MAGIC_SYMLINK}) + +-- | Look inside compressed files. +pattern MagicCompress :: MagicFlags +pattern MagicCompress = MagicFlags (#{const MAGIC_COMPRESS}) + +-- | Look at the contents of block or character special devices. +pattern MagicDevices :: MagicFlags +pattern MagicDevices = MagicFlags (#{const MAGIC_DEVICES}) + +-- | Return a MIME type string instead of a textual description. +pattern MagicMimeType :: MagicFlags +pattern MagicMimeType = MagicFlags (#{const MAGIC_MIME_TYPE}) + +-- | Return the MIME encoding (character set) instead of a textual description. +pattern MagicMimeEncoding :: MagicFlags +pattern MagicMimeEncoding = MagicFlags (#{const MAGIC_MIME_ENCODING}) + +-- | Return both the MIME type and the encoding (@'MagicMimeType' '<>' 'MagicMimeEncoding'@). +pattern MagicMime :: MagicFlags +pattern MagicMime = MagicFlags (#{const MAGIC_MIME}) + +-- | Return all matches, not just the first. +pattern MagicContinue :: MagicFlags +pattern MagicContinue = MagicFlags (#{const MAGIC_CONTINUE}) + +-- | Check the magic database for consistency and report problems. +pattern MagicCheck :: MagicFlags +pattern MagicCheck = MagicFlags (#{const MAGIC_CHECK}) + +-- | Preserve the access time of examined files. +pattern MagicPreserveAtime :: MagicFlags +pattern MagicPreserveAtime = MagicFlags (#{const MAGIC_PRESERVE_ATIME}) + +-- | Do not translate unprintable characters to octal escapes. +pattern MagicRaw :: MagicFlags +pattern MagicRaw = MagicFlags (#{const MAGIC_RAW}) + +-- | Treat errors while examining a file as real errors instead of embedding them in the result. +pattern MagicError :: MagicFlags +pattern MagicError = MagicFlags (#{const MAGIC_ERROR}) + +-- | Return the Apple creator and type. +pattern MagicApple :: MagicFlags +pattern MagicApple = MagicFlags (#{const MAGIC_APPLE}) + +-- | Return a slash-separated list of valid file extensions for the detected type. +pattern MagicExtension :: MagicFlags +pattern MagicExtension = MagicFlags (#{const MAGIC_EXTENSION}) + +-- | Report on the compressed contents only, without mentioning the compression itself (transparent decompression). +pattern MagicCompressTransp :: MagicFlags +pattern MagicCompressTransp = MagicFlags (#{const MAGIC_COMPRESS_TRANSP}) + +-- | Do not allow decompression that requires forking a helper process. +pattern MagicNoCompressFork :: MagicFlags +pattern MagicNoCompressFork = MagicFlags (#{const MAGIC_NO_COMPRESS_FORK}) + +-- | Composite of 'MagicExtension', 'MagicMime' and 'MagicApple': return identifiers rather than a textual description. +pattern MagicNodesc :: MagicFlags +pattern MagicNodesc = MagicFlags (#{const MAGIC_NODESC}) + +-- | Do not look inside compressed files. +pattern MagicNoCheckCompress :: MagicFlags +pattern MagicNoCheckCompress = MagicFlags (#{const MAGIC_NO_CHECK_COMPRESS}) + +-- | Do not examine tar archives. +pattern MagicNoCheckTar :: MagicFlags +pattern MagicNoCheckTar = MagicFlags (#{const MAGIC_NO_CHECK_TAR}) + +-- | Do not consult the magic database entries (soft magic). +pattern MagicNoCheckSoft :: MagicFlags +pattern MagicNoCheckSoft = MagicFlags (#{const MAGIC_NO_CHECK_SOFT}) + +-- | Do not check for an application type (e.g. EMX). +pattern MagicNoCheckApptype :: MagicFlags +pattern MagicNoCheckApptype = MagicFlags (#{const MAGIC_NO_CHECK_APPTYPE}) + +-- | Do not examine ELF details. +pattern MagicNoCheckElf :: MagicFlags +pattern MagicNoCheckElf = MagicFlags (#{const MAGIC_NO_CHECK_ELF}) + +-- | Do not examine text files. +pattern MagicNoCheckText :: MagicFlags +pattern MagicNoCheckText = MagicFlags (#{const MAGIC_NO_CHECK_TEXT}) + +-- | Do not examine CDF (Microsoft Compound Document) files. +pattern MagicNoCheckCdf :: MagicFlags +pattern MagicNoCheckCdf = MagicFlags (#{const MAGIC_NO_CHECK_CDF}) + +-- | Do not examine CSV files. +pattern MagicNoCheckCsv :: MagicFlags +pattern MagicNoCheckCsv = MagicFlags (#{const MAGIC_NO_CHECK_CSV}) + +-- | Do not look for known text tokens. +pattern MagicNoCheckTokens :: MagicFlags +pattern MagicNoCheckTokens = MagicFlags (#{const MAGIC_NO_CHECK_TOKENS}) + +-- | Do not check text encodings. +pattern MagicNoCheckEncoding :: MagicFlags +pattern MagicNoCheckEncoding = MagicFlags (#{const MAGIC_NO_CHECK_ENCODING}) + +-- | Do not examine JSON files. +pattern MagicNoCheckJson :: MagicFlags +pattern MagicNoCheckJson = MagicFlags (#{const MAGIC_NO_CHECK_JSON}) + +-- | Do not examine SIMH tape files. +pattern MagicNoCheckSimh :: MagicFlags +pattern MagicNoCheckSimh = MagicFlags (#{const MAGIC_NO_CHECK_SIMH}) + +-- | Disable all built-in tests; consult only the magic database. +pattern MagicNoCheckBuiltin :: MagicFlags +pattern MagicNoCheckBuiltin = MagicFlags (#{const MAGIC_NO_CHECK_BUILTIN}) + +-- Every named flag, used by the 'Show' instance to print flags by name. +allNamedFlags :: [(String, MagicFlags)] +allNamedFlags = + [ ("MagicNone", MagicNone) + , ("MagicDebug", MagicDebug) + , ("MagicSymlink", MagicSymlink) + , ("MagicCompress", MagicCompress) + , ("MagicDevices", MagicDevices) + , ("MagicMimeType", MagicMimeType) + , ("MagicMimeEncoding", MagicMimeEncoding) + , ("MagicMime", MagicMime) + , ("MagicContinue", MagicContinue) + , ("MagicCheck", MagicCheck) + , ("MagicPreserveAtime", MagicPreserveAtime) + , ("MagicRaw", MagicRaw) + , ("MagicError", MagicError) + , ("MagicApple", MagicApple) + , ("MagicExtension", MagicExtension) + , ("MagicCompressTransp", MagicCompressTransp) + , ("MagicNoCompressFork", MagicNoCompressFork) + , ("MagicNodesc", MagicNodesc) + , ("MagicNoCheckCompress", MagicNoCheckCompress) + , ("MagicNoCheckTar", MagicNoCheckTar) + , ("MagicNoCheckSoft", MagicNoCheckSoft) + , ("MagicNoCheckApptype", MagicNoCheckApptype) + , ("MagicNoCheckElf", MagicNoCheckElf) + , ("MagicNoCheckText", MagicNoCheckText) + , ("MagicNoCheckCdf", MagicNoCheckCdf) + , ("MagicNoCheckCsv", MagicNoCheckCsv) + , ("MagicNoCheckTokens", MagicNoCheckTokens) + , ("MagicNoCheckEncoding", MagicNoCheckEncoding) + , ("MagicNoCheckJson", MagicNoCheckJson) + , ("MagicNoCheckSimh", MagicNoCheckSimh) + , ("MagicNoCheckBuiltin", MagicNoCheckBuiltin) + ] diff --git a/src/Magic/FilePath.hs b/src/Magic/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/Magic/FilePath.hs @@ -0,0 +1,71 @@ +{- -*- Mode: haskell; -*- +Haskell magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{- | + Module : Magic.FilePath + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +A convenience facade over "Magic" that takes ordinary 'FilePath's instead of +'System.OsPath.OsPath's. Import this module /instead of/ "Magic" if you prefer +@String@ paths: + +> import Magic.FilePath + +Everything else (the handle, flags, in-memory and descriptor queries, and so on) +is re-exported unchanged from "Magic". + +The 'FilePath' wrappers convert with 'System.OsPath.encodeFS' / +'System.OsPath.decodeFS', which go through the locale's filesystem encoding. For +ordinary ASCII/UTF-8 filenames under a UTF-8 locale this is fine. But a +'FilePath' cannot faithfully represent every path the operating system can: +names whose bytes are not valid in the current locale (raw non-UTF-8 bytes on +Unix, or names created under a different locale) may be corrupted or fail to +round-trip, so a call can fail to open a file that exists, or open the wrong +one. The @OsPath@ functions in "Magic" store the path bytes verbatim and avoid +this entirely; prefer them when correctness on arbitrary filenames matters. + +@since 2.0.0 +-} + +module Magic.FilePath + ( module Magic + , magicFile + , magicLoad + , magicCompile + , magicCheck + , magicGetPath + ) where + +import Magic hiding (magicFile, magicLoad, magicCompile, magicCheck, magicGetPath) +import qualified Magic as O +import Data.Text (Text) +import System.OsPath (decodeFS, encodeFS) + +-- | 'Magic.magicFile' taking a 'FilePath'. +magicFile :: Magic -> FilePath -> IO Text +magicFile m p = O.magicFile m =<< encodeFS p + +-- | 'Magic.magicLoad' taking 'FilePath's (empty list = the default database). +magicLoad :: Magic -> [FilePath] -> IO () +magicLoad m ps = O.magicLoad m =<< mapM encodeFS ps + +-- | 'Magic.magicCompile' taking 'FilePath's (empty list = the default database). +magicCompile :: Magic -> [FilePath] -> IO () +magicCompile m ps = O.magicCompile m =<< mapM encodeFS ps + +-- | 'Magic.magicCheck' taking 'FilePath's (empty list = the default database). +magicCheck :: Magic -> [FilePath] -> IO Bool +magicCheck m ps = O.magicCheck m =<< mapM encodeFS ps + +-- | 'Magic.magicGetPath' returning 'FilePath's. +magicGetPath :: IO [FilePath] +magicGetPath = O.magicGetPath >>= mapM decodeFS diff --git a/src/Magic/Init.hsc b/src/Magic/Init.hsc new file mode 100644 --- /dev/null +++ b/src/Magic/Init.hsc @@ -0,0 +1,74 @@ +{- -*- Mode: haskell; -*- +Haskell magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{- | + Module : Magic.Init + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +Creating a magic handle and loading magic databases into it. A handle returned +by 'magicOpen' must be given a database with 'magicLoadDefault' or 'magicLoad' +before it can be queried with the functions in "Magic.Operations". + +Written by John Goerzen. +-} + +module Magic.Init(magicOpen, magicLoad, magicLoadDefault) +where + +import Foreign.Ptr +import Foreign.C.String +import Magic.Internal (Magic, CMagic, fromMagicPtr, withMagicPtr, checkIntError, withSearchPathCString) +import Magic.Data (MagicFlags(..)) +import Foreign.C.Types +import System.OsPath (OsPath) + +{- | Create a new magic handle configured with the given flags. Combine flags +with @('<>')@ (see t'MagicFlags'), or pass 'mempty' for the defaults. Before +querying anything you must load a database with 'magicLoadDefault' or +'magicLoad'. + +The handle is freed automatically when it is garbage-collected. Raises an +'IOError' if the handle cannot be created. +-} +magicOpen :: MagicFlags -> IO Magic +magicOpen (MagicFlags flags) = + fromMagicPtr "magicOpen" (magic_open flags) + +{- | Load the system's default magic database into the handle. Raises a +@MagicException@ if the database cannot be loaded. -} +magicLoadDefault :: Magic -> IO () +magicLoadDefault m = withMagicPtr m (\cmagic -> + checkIntError "magicLoadDefault" m $ magic_load cmagic nullPtr) + +{- | Load the given magic database(s) into the handle. Pass the empty list to +load the system default (equivalent to 'magicLoadDefault'). Raises a +@MagicException@ if a database cannot be loaded. + +(libmagic joins the list with the platform search-path separator, so a path +that itself contains that separator cannot be represented.) -} +magicLoad :: Magic -> [OsPath] -> IO () +magicLoad m ps = withMagicPtr m (\cmagic -> + case ps of + [] -> checkIntError "magicLoad" m $ magic_load cmagic nullPtr + _ -> withSearchPathCString ps (\cs -> + checkIntError "magicLoad" m $ magic_load cmagic cs)) + +-- Allocates the cookie, no file I/O -> unsafe +foreign import ccall unsafe "magic.h magic_open" + magic_open :: CInt -> IO (Ptr CMagic) + +-- Reads and parses the (potentially multi-megabyte) magic database from disk: +-- blocking I/O, so this must be a safe call. A safe call lets other Haskell +-- threads run during the load and does not stall garbage collection, whereas +-- an unsafe call would block the capability for the whole load. +foreign import ccall safe "magic.h magic_load" + magic_load :: Ptr CMagic -> CString -> IO CInt diff --git a/src/Magic/Internal.hs b/src/Magic/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Magic/Internal.hs @@ -0,0 +1,203 @@ +{- -*- Mode: haskell; -*- +Haskell magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +{- | + Module : Magic.Internal + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +Internal representation of the t'Magic' handle, the t'MagicException' error type, +and the helpers shared by the other modules. Not part of the public API: it is +exposed only so the rest of the package can build, and may change without a +major-version bump. +-} + +module Magic.Internal + ( CMagic + , Magic(..) + , MagicException(..) + , fromMagicPtr + , withMagicPtr + , checkIntError + , throwErrorIfNull + , peekCStringText + , withOsPathCString + , withSearchPathCString + , peekSearchPath + ) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (Exception, displayException, throwIO) +import GHC.Generics (Generic) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Foreign +import Foreign.C.Error (throwErrnoIfNull) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt) +import System.OsPath (OsPath) + +#if defined(mingw32_HOST_OS) +import Data.List (intercalate) +import Foreign.C.String (peekCString, withCString) +import System.OsPath (decodeFS, encodeFS) +#else +import qualified Data.ByteString.Short as SBS +import System.OsString.Internal.Types (OsString(OsString, getOsString), PosixString(PosixString, getPosixString)) +#endif + +-- | Phantom type standing in for the C @magic_t@ cookie. It appears only as the +-- argument of a 'ForeignPtr' inside the t'Magic' handle and has no values of its +-- own. +data CMagic + +{- | The magic handle: an opaque cookie obtained from @magicOpen@ and passed to +the loading and querying functions. + +Handles are closed (and their memory freed) automatically when they are +garbage-collected; there is no need to close them explicitly. + +__Thread safety.__ Operations on a single handle are serialised by an internal +lock, so it is safe to share one handle across threads (concurrent calls simply +take turns). For genuine parallelism, use one handle per thread; distinct +handles are independent. Programs doing blocking work (loading databases, +examining files) should use the threaded runtime (@-threaded@). +-} +data Magic = Magic !(ForeignPtr CMagic) !(MVar [BS.ByteString]) +-- The MVar is both the per-handle lock and the store that keeps any buffers +-- passed to magicLoadBuffers alive for the lifetime of the handle (libmagic +-- retains, rather than copies, those buffers). + +-- | The handle is opaque; it shows as a fixed placeholder. +instance Show Magic where + show _ = "" + +-- | The exception raised when a @libmagic@ operation fails. Carries the name of +-- the operation that failed and the message reported by @libmagic@. +-- +-- @since 2.0.0 +data MagicException = MagicException + { magicErrorContext :: !Text -- ^ the operation that failed, e.g. @\"magicFile\"@ + , magicErrorMessage :: !Text -- ^ @libmagic@'s error message + } deriving (Show, Eq, Generic) + +instance NFData MagicException where + rnf (MagicException c m) = rnf c `seq` rnf m + +instance Exception MagicException where + displayException (MagicException ctx msg) = T.unpack ctx ++ ": " ++ T.unpack msg + +-- | Read a NUL-terminated C string into 'Text', decoding UTF-8 leniently +-- (replacing invalid bytes). Avoids the locale round-trip through 'String'. +peekCStringText :: CString -> IO Text +peekCStringText cs = decodeUtf8With lenientDecode <$> BS.packCString cs + +-- | Build a handle from a C cookie-returning action, attaching the +-- @magic_close@ finalizer. Raises an 'IOError' (from @errno@) if the action +-- returns @NULL@. +fromMagicPtr :: String -> IO (Ptr CMagic) -> IO Magic +fromMagicPtr caller action = + do ptr <- throwErrnoIfNull caller action + fp <- newForeignPtr magic_close ptr + mv <- newMVar [] + return (Magic fp mv) + +-- | Run an action on the raw handle pointer, holding the per-handle lock and +-- keeping the handle alive for the whole action. +withMagicPtr :: Magic -> (Ptr CMagic -> IO a) -> IO a +withMagicPtr (Magic fp mv) act = withMVar mv (\_ -> withForeignPtr fp act) + +-- Turn libmagic's last error into a 'MagicException'. Accesses the handle +-- lock-free because it is only ever called from inside an operation that +-- already holds the lock (so re-taking it would deadlock). +throwError :: String -> Magic -> IO a +throwError caller (Magic fp _) = + withForeignPtr fp (\cmagic -> + do errormsg <- magic_error cmagic + msg <- if errormsg /= nullPtr + then peekCStringText errormsg + else return (T.pack "got error code but no error message") + throwIO (MagicException (T.pack caller) msg)) + +-- | Raise a t'MagicException' if the C action returns a non-zero (failure) code. +checkIntError :: String -> Magic -> IO CInt -> IO () +checkIntError caller m action = + do res <- action + if res == 0 then return () else throwError caller m + +-- | Raise a t'MagicException' if the C action returns a @NULL@ pointer. +throwErrorIfNull :: String -> Magic -> IO (Ptr a) -> IO (Ptr a) +throwErrorIfNull caller m action = + do res <- action + if res == nullPtr then throwError caller m else return res + +foreign import ccall unsafe "magic.h &magic_close" + magic_close :: FunPtr (Ptr CMagic -> IO ()) + +foreign import ccall unsafe "magic.h magic_error" + magic_error :: Ptr CMagic -> IO CString + +-- Marshalling between 'OsPath' and the C @const char*@ that libmagic expects. +-- On POSIX an 'OsPath' is exactly the path bytes the OS uses, which is exactly +-- what libmagic wants, so they pass through untouched (no lossy locale round +-- trip). On Windows we fall back to the locale encoding (a libmagic build for +-- Windows is a rarity). + +#if defined(mingw32_HOST_OS) + +withOsPathCString :: OsPath -> (CString -> IO a) -> IO a +withOsPathCString p k = decodeFS p >>= \s -> withCString s k + +withSearchPathCString :: [OsPath] -> (CString -> IO a) -> IO a +withSearchPathCString ps k = + do ss <- mapM decodeFS ps + withCString (intercalate ";" ss) k + +peekSearchPath :: CString -> IO [OsPath] +peekSearchPath cs = + do s <- peekCString cs + mapM encodeFS (filter (not . null) (splitOn ';' s)) + where + splitOn :: Char -> String -> [String] + splitOn c s = case break (== c) s of + (a, []) -> [a] + (a, _:rest) -> a : splitOn c rest + +#else + +osPathBytes :: OsPath -> BS.ByteString +osPathBytes = SBS.fromShort . getPosixString . getOsString + +bytesOsPath :: BS.ByteString -> OsPath +bytesOsPath = OsString . PosixString . SBS.toShort + +-- | Run an action with the path marshalled to a NUL-terminated C string. +withOsPathCString :: OsPath -> (CString -> IO a) -> IO a +withOsPathCString = BS.useAsCString . osPathBytes + +-- | Marshal a search path: the paths joined by the @:@ separator. +withSearchPathCString :: [OsPath] -> (CString -> IO a) -> IO a +withSearchPathCString ps = + BS.useAsCString (BS.intercalate (BS.singleton 0x3a) (map osPathBytes ps)) + +-- | Read a @:@-separated C search-path string back into a list of paths. +peekSearchPath :: CString -> IO [OsPath] +peekSearchPath cs = + (map bytesOsPath . filter (not . BS.null) . BS.split 0x3a) <$> BS.packCString cs + +#endif diff --git a/src/Magic/Operations.hsc b/src/Magic/Operations.hsc new file mode 100644 --- /dev/null +++ b/src/Magic/Operations.hsc @@ -0,0 +1,314 @@ +{- -*- Mode: haskell; -*- +Haskell magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{- | + Module : Magic.Operations + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +Querying the type of files and in-memory data, and other operations on a magic +handle. The handle must first be created with @magicOpen@ and populated with +@magicLoadDefault@ or @magicLoad@ (see "Magic.Init"). + +Written by John Goerzen. +-} + +module Magic.Operations(-- * Guessing the type + magicFile, magicStdin, magicDescriptor, + magicCString, magicByteString, + -- * Flags + magicSetFlags, magicGetFlags, + -- * Tunable parameters + magicGetParam, magicSetParam, + -- * Magic databases + magicCompile, magicCheck, magicLoadBuffers, + magicGetPath, + -- * Library information + magicVersion, magicErrno) +where + +import Control.Concurrent.MVar (modifyMVar_) +import Control.Exception (throwIO) +import qualified Data.Text as T +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (withArray) +import Foreign.Marshal.Utils (with) +import Foreign.Storable (peek) +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BSU +import Data.Text (Text) +import System.OsPath (OsPath) +import System.Posix.Types (Fd) +import Magic.Types (MagicParam(..)) +import Magic.Data (MagicFlags(..)) +import Magic.Internal (Magic(..), CMagic, MagicException(..), withMagicPtr, throwErrorIfNull, checkIntError, peekCStringText, withOsPathCString, withSearchPathCString, peekSearchPath) + +#include + +{- | Identify the file at the given path. The result is in the form selected by +the handle's flags (a textual description, a MIME type, an encoding, and so on; +see t'MagicFlags'). Raises a @MagicException@ if the file cannot be +examined. -} +magicFile :: Magic -> OsPath -> IO Text +magicFile magic fp = + withMagicPtr magic (\cmagic -> + withOsPathCString fp (\cfp -> + do res <- throwErrorIfNull "magicFile" magic (magic_file cmagic cfp) + peekCStringText res + ) + ) + +{- | Identify the data available on standard input, as 'magicFile' does for a +named file. Raises a @MagicException@ if the data cannot be +examined. -} +magicStdin :: Magic -> IO Text +magicStdin magic = + withMagicPtr magic (\cmagic -> + do res <- throwErrorIfNull "magicStdin" magic (magic_file cmagic nullPtr) + peekCStringText res + ) + +{- | Identify the contents of a C string buffer (a pointer and a length). The +lowest-level in-memory primitive; for ordinary use prefer 'magicByteString'. +Raises a @MagicException@ if the data cannot be examined. -} +magicCString :: Magic -> CStringLen -> IO Text +magicCString magic (cstr, len) = + withMagicPtr magic (\cmagic -> + do res <- throwErrorIfNull "magicCString" magic (magic_buffer cmagic cstr (fromIntegral len)) + peekCStringText res + ) + +{- | Change the flags (see t'MagicFlags') on an existing handle, for example to +switch between textual descriptions and MIME types. Raises a @MagicException@ on +failure. -} +magicSetFlags :: Magic -> MagicFlags -> IO () +magicSetFlags m (MagicFlags flags) = withMagicPtr m (\cmagic -> + checkIntError "magicSetFlags" m $ magic_setflags cmagic flags) + +{- | Compile the given magic database file(s) into the binary @.mgc@ form. Each +compiled file is named after its source with @.mgc@ appended. Pass the empty +list to compile the default database. Raises a @MagicException@ on failure. + +(libmagic joins the list with the platform search-path separator, so a path +that itself contains that separator cannot be represented.) +-} +magicCompile :: Magic -> [OsPath] -> IO () +magicCompile m ps = withMagicPtr m (\cm -> + case ps of + [] -> worker cm nullPtr + _ -> withSearchPathCString ps (worker cm)) + where worker cm cs = checkIntError "magicCompile" m $ magic_compile cm cs + +{- | Identify the data behind an open file descriptor, as 'magicFile' does for a +named file. Useful for sockets, pipes, or files you have already opened. Raises +a @MagicException@ if the descriptor cannot be examined. + +@since 1.1.2 +-} +magicDescriptor :: Magic -> Fd -> IO Text +magicDescriptor magic fd = + withMagicPtr magic (\cmagic -> + do res <- throwErrorIfNull "magicDescriptor" magic + (magic_descriptor cmagic (fromIntegral fd)) + peekCStringText res) + +{- | Identify the contents of a strict 'ByteString'. Does no encoding +conversion, so it is the right way to examine in-memory data. Raises a +@MagicException@ if the data cannot be examined. + +@since 1.1.2 +-} +magicByteString :: Magic -> ByteString -> IO Text +magicByteString magic bs = + withMagicPtr magic (\cmagic -> + BSU.unsafeUseAsCStringLen bs (\(cstr, len) -> + do res <- throwErrorIfNull "magicByteString" magic + (magic_buffer cmagic cstr (fromIntegral len)) + peekCStringText res)) + +{- | Read the flags currently set on the handle (see 'magicSetFlags'). Test the +result with @hasFlag@. Raises a @MagicException@ if the running @libmagic@ does not +support querying flags. + +@since 1.1.2 +-} +magicGetFlags :: Magic -> IO MagicFlags +magicGetFlags m = + withMagicPtr m (\cmagic -> + do fl <- magic_getflags cmagic + if fl < 0 + then throwIO (MagicException (T.pack "magicGetFlags") + (T.pack "magic_getflags is unsupported by this libmagic")) + else return (MagicFlags fl)) + +{- | Read a tunable parameter (see 'MagicParam'). + +@since 1.1.2 +-} +magicGetParam :: Magic -> MagicParam -> IO Int +magicGetParam m p = + withMagicPtr m (\cmagic -> + alloca (\ptr -> + do checkIntError "magicGetParam" m + (magic_getparam cmagic (paramToCInt p) (castPtr ptr)) + v <- peek ptr + return (fromIntegral (v :: CSize)))) + +{- | Set a tunable parameter (see 'MagicParam'), for example to cap the number +of bytes scanned in untrusted input. Raises a @MagicException@ on failure. + +@since 1.1.2 +-} +magicSetParam :: Magic -> MagicParam -> Int -> IO () +magicSetParam m p val = + withMagicPtr m (\cmagic -> + with (fromIntegral val :: CSize) (\ptr -> + checkIntError "magicSetParam" m + (magic_setparam cmagic (paramToCInt p) (castPtr ptr)))) + +paramToCInt :: MagicParam -> CInt +paramToCInt p = case p of + MagicParamIndirMax -> #{const MAGIC_PARAM_INDIR_MAX} + MagicParamNameMax -> #{const MAGIC_PARAM_NAME_MAX} + MagicParamElfPhnumMax -> #{const MAGIC_PARAM_ELF_PHNUM_MAX} + MagicParamElfShnumMax -> #{const MAGIC_PARAM_ELF_SHNUM_MAX} + MagicParamElfNotesMax -> #{const MAGIC_PARAM_ELF_NOTES_MAX} + MagicParamRegexMax -> #{const MAGIC_PARAM_REGEX_MAX} + MagicParamBytesMax -> #{const MAGIC_PARAM_BYTES_MAX} + MagicParamEncodingMax -> #{const MAGIC_PARAM_ENCODING_MAX} + MagicParamElfShsizeMax -> #{const MAGIC_PARAM_ELF_SHSIZE_MAX} + +{- | Check the validity of the given magic database file(s) without compiling +them, as @file -c@ does. Pass the empty list for the default database. Returns +'True' if the database is valid. (libmagic joins the list with the platform +search-path separator, so a path that itself contains that separator cannot be +represented.) + +@since 1.1.2 +-} +magicCheck :: Magic -> [OsPath] -> IO Bool +magicCheck m ps = + withMagicPtr m (\cmagic -> + case ps of + [] -> fmap (== 0) (magic_check cmagic nullPtr) + _ -> withSearchPathCString ps (fmap (== 0) . magic_check cmagic)) + +{- | Load magic from one or more in-memory compiled databases (the @.mgc@ binary +form produced by 'magicCompile'), rather than from files. This lets a program +embed its magic database. + +@libmagic@ keeps (does not copy) the supplied buffers for the lifetime of the +handle, so the handle retains references to the given 'ByteString's to keep +their memory alive until it is closed. Raises a @MagicException@ on failure. + +@since 2.0.0 +-} +magicLoadBuffers :: Magic -> [ByteString] -> IO () +magicLoadBuffers (Magic fp mv) bufs = + modifyMVar_ mv $ \retained -> + do withForeignPtr fp $ \cmagic -> + withBuffers bufs $ \pls -> + withArray (map fst pls) $ \pptr -> + withArray (map snd pls) $ \sptr -> + checkIntError "magicLoadBuffers" (Magic fp mv) + (magic_load_buffers cmagic pptr sptr (fromIntegral (length bufs))) + -- Keep the buffers reachable (and so, being pinned, validly addressable) + -- for as long as the handle lives. + return (bufs ++ retained) + where + withBuffers :: [ByteString] -> ([(Ptr Word8, CSize)] -> IO a) -> IO a + withBuffers [] k = k [] + withBuffers (b:bs) k = + BSU.unsafeUseAsCStringLen b (\(p, l) -> + withBuffers bs (\rest -> k ((castPtr p, fromIntegral l) : rest))) + +{- | The default magic database search path, honouring the @MAGIC@ environment +variable, as a list of paths. + +@since 1.1.2 +-} +magicGetPath :: IO [OsPath] +magicGetPath = + do res <- magic_getpath nullPtr 0 + if res == nullPtr then return [] else peekSearchPath res + +{- | The version of the @libmagic@ library in use, encoded as a single integer +(for example @545@ for version 5.45). + +@since 1.1.2 +-} +magicVersion :: IO Int +magicVersion = fmap fromIntegral magic_version + +{- | The @errno@ recorded by the last failing operation on the handle, or @0@ if +the last failure was not caused by a system error. + +@since 1.1.2 +-} +magicErrno :: Magic -> IO Int +magicErrno m = withMagicPtr m (fmap fromIntegral . magic_errno) + +-- Does file I/O -> safe +foreign import ccall safe "magic.h magic_file" + magic_file :: Ptr CMagic -> CString -> IO CString + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_buffer" + magic_buffer :: Ptr CMagic -> CString -> #{type size_t} -> IO CString + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_setflags" + magic_setflags :: Ptr CMagic -> CInt -> IO CInt + +-- Does file I/O -> safe +foreign import ccall safe "magic.h magic_compile" + magic_compile :: Ptr CMagic -> CString -> IO CInt + +-- Reads the descriptor -> safe +foreign import ccall safe "magic.h magic_descriptor" + magic_descriptor :: Ptr CMagic -> CInt -> IO CString + +-- Validates a database file -> safe +foreign import ccall safe "magic.h magic_check" + magic_check :: Ptr CMagic -> CString -> IO CInt + +-- Parses (potentially large) in-memory databases -> safe +foreign import ccall safe "magic.h magic_load_buffers" + magic_load_buffers :: Ptr CMagic -> Ptr (Ptr Word8) -> Ptr CSize -> CSize -> IO CInt + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_getflags" + magic_getflags :: Ptr CMagic -> IO CInt + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_getparam" + magic_getparam :: Ptr CMagic -> CInt -> Ptr () -> IO CInt + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_setparam" + magic_setparam :: Ptr CMagic -> CInt -> Ptr () -> IO CInt + +-- Reads an environment variable -> unsafe +foreign import ccall unsafe "magic.h magic_getpath" + magic_getpath :: CString -> CInt -> IO CString + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_version" + magic_version :: IO CInt + +-- Does not do I/O -> unsafe +foreign import ccall unsafe "magic.h magic_errno" + magic_errno :: Ptr CMagic -> IO CInt diff --git a/src/Magic/Types.hsc b/src/Magic/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Magic/Types.hsc @@ -0,0 +1,62 @@ +{- -*- Mode: haskell; -*- +Haskell magic Interface +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +{-# LANGUAGE DeriveGeneric #-} + +{- | + Module : Magic.Types + Copyright : Copyright (C) 2005 John Goerzen + License : BSD-3-Clause + + Maintainer : Philippe + Stability : provisional + Portability: portable + +The core types of the binding: the opaque t'Magic' handle, the t'MagicException' +error type (both defined in "Magic.Internal"), and the 'MagicParam' tunables. +The flag bit-mask lives in "Magic.Data". +-} + +module Magic.Types(Magic, + MagicException(..), + MagicParam(..)) +where +import Control.DeepSeq (NFData(rnf)) +import GHC.Generics (Generic) +import Magic.Internal (Magic, MagicException(..)) + +{- | Tunable limits that bound how hard @libmagic@ works when examining data, +read and written with @magicGetParam@ and @magicSetParam@ (see +"Magic.Operations"). Lowering these (especially 'MagicParamBytesMax') is a way +to cap the effort spent on untrusted input. Defaults below are those documented +for @libmagic@ 5.45. + +@since 1.1.2 +-} +data MagicParam + = -- | Maximum number of levels of recursion when following indirect magic. (Default: 15.) + MagicParamIndirMax + | -- | Maximum length of a name used by name\/use magic. (Default: 30.) + MagicParamNameMax + | -- | Maximum number of ELF program header sections processed. (Default: 128.) + MagicParamElfPhnumMax + | -- | Maximum number of ELF section header sections processed. (Default: 32768.) + MagicParamElfShnumMax + | -- | Maximum number of ELF notes processed. (Default: 256.) + MagicParamElfNotesMax + | -- | Maximum length of a regex search. (Default: 8192.) + MagicParamRegexMax + | -- | Maximum number of bytes read from a file before giving up. (Default: 1048576, i.e. 1 MiB.) + MagicParamBytesMax + | -- | Maximum number of bytes scanned when guessing a text encoding. + MagicParamEncodingMax + | -- | Maximum size of an ELF section processed. + MagicParamElfShsizeMax + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance NFData MagicParam where rnf x = x `seq` () + diff --git a/test/Inittest.hs b/test/Inittest.hs new file mode 100644 --- /dev/null +++ b/test/Inittest.hs @@ -0,0 +1,304 @@ +{- +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +module Inittest(tests) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.DeepSeq (rnf) +import Control.Exception (SomeException, bracket, displayException, try) +import Control.Monad (forM, forM_) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.List (isInfixOf, isPrefixOf, isSuffixOf) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (doesFileExist, getTemporaryDirectory, removeFile) +import System.FilePath (()) +import System.Mem (performMajorGC) +import System.OsPath (encodeFS) +import System.Posix.IO (OpenMode(ReadOnly), closeFd, defaultFileFlags, openFd) +import Test.HUnit + +import Magic.FilePath +import qualified Magic as M + +-- | Open a handle with the given flags and load the default database. +withDefault :: MagicFlags -> (Magic -> IO a) -> IO a +withDefault flags act = do + m <- magicOpen flags + magicLoadDefault m + act m + +-- 8-byte PNG signature followed by the start of an IHDR chunk. +pngBytes :: BS.ByteString +pngBytes = BS.pack + [0x89,0x50,0x4E,0x47,0x0D,0x0A,0x1A,0x0A + ,0x00,0x00,0x00,0x0D,0x49,0x48,0x44,0x52] + +-- | Run an action with a temporary file holding the PNG bytes. +withPngFile :: (FilePath -> IO b) -> IO b +withPngFile act = do + dir <- getTemporaryDirectory + let pngPath = dir "magic-test-sample.png" + bracket (BS.writeFile pngPath pngBytes >> return pngPath) + removeFile + act + +-- | A small in-memory byte string is detected as plain text. +test_textMime :: Test +test_textMime = TestCase $ do + result <- withDefault MagicMimeType $ \m -> + magicByteString m (BS8.pack "Hello, world!\nThis is just some plain ASCII text.\n") + assertBool ("expected a text/* MIME type, got: " ++ show result) + ("text/" `isPrefixOf` T.unpack result) + +-- | The textual description of plain text mentions \"text\". +test_textDescription :: Test +test_textDescription = TestCase $ do + result <- withDefault MagicNone $ \m -> + magicByteString m (BS8.pack "The quick brown fox jumps over the lazy dog.\n") + assertBool ("expected a description mentioning 'text', got: " ++ show result) + ("text" `isInfixOf` T.unpack result) + +-- | A file whose contents start with the PNG signature is recognised as a PNG. +test_pngMime :: Test +test_pngMime = TestCase $ + withPngFile $ \pngPath -> do + result <- withDefault MagicMimeType $ \m -> magicFile m pngPath + assertEqual "PNG MIME type" "image/png" (T.unpack result) + +-- | The primary "Magic" API identifies a file given as an 'OsPath'. +test_osPathFile :: Test +test_osPathFile = TestCase $ + withPngFile $ \pngPath -> do + p <- encodeFS pngPath + result <- do + m <- M.magicOpen M.MagicMimeType + M.magicLoadDefault m + M.magicFile m p + assertEqual "PNG MIME via OsPath" "image/png" (T.unpack result) + +-- | 'magicByteString' identifies binary data directly, without an intermediate +-- file and without locale-encoding corruption. +test_byteStringMime :: Test +test_byteStringMime = TestCase $ do + result <- withDefault MagicMimeType $ \m -> magicByteString m pngBytes + assertEqual "PNG MIME via ByteString" "image/png" (T.unpack result) + +-- | 'magicDescriptor' identifies the data behind an open file descriptor. +test_descriptorMime :: Test +test_descriptorMime = TestCase $ + withPngFile $ \pngPath -> do + result <- withDefault MagicMimeType $ \m -> + bracket (openFd pngPath ReadOnly defaultFileFlags) closeFd + (magicDescriptor m) + assertEqual "PNG MIME via descriptor" "image/png" (T.unpack result) + +-- | 'magicVersion' reports a sane (positive) library version. +test_version :: Test +test_version = TestCase $ do + v <- magicVersion + assertBool ("expected a positive libmagic version, got " ++ show v) (v > 0) + +-- | Flags set with 'magicSetFlags' are read back by 'magicGetFlags'. +test_getFlags :: Test +test_getFlags = TestCase $ + withDefault MagicNone $ \m -> do + magicSetFlags m (MagicMimeType <> MagicError) + fl <- magicGetFlags m + assertBool ("expected MimeType and Error set in " ++ show fl) + (hasFlag fl MagicMimeType && hasFlag fl MagicError) + +-- | Pure laws and helpers of the 'MagicFlags' algebra: monoid identity, +-- 'hasFlag' (including its edge cases), 'removeFlags', and the name-printing +-- 'Show' (composites decompose into their atomic flags). +test_flagAlgebra :: Test +test_flagAlgebra = TestCase $ do + assertEqual "mempty is MagicNone" MagicNone (mempty :: MagicFlags) + assertEqual "right identity" MagicMimeType (MagicMimeType <> mempty) + let both = MagicMimeType <> MagicError + assertBool "contains a set flag" (hasFlag both MagicError) + assertBool "lacks an unset flag" (not (hasFlag MagicMimeType MagicError)) + assertBool "empty is a subset" (hasFlag MagicMimeType MagicNone) + let dropped = removeFlags both MagicError + assertBool "removed flag is gone" (not (hasFlag dropped MagicError)) + assertBool "other flag remains" (hasFlag dropped MagicMimeType) + assertEqual "removing an absent flag is a no-op" + MagicMimeType (removeFlags MagicMimeType MagicError) + assertEqual "show of the empty set" "MagicNone" (show MagicNone) + assertEqual "show of one flag" "MagicMimeType" (show MagicMimeType) + assertEqual "show decomposes composites" + "MagicMimeType <> MagicMimeEncoding" (show MagicMime) + +-- | The opaque 'Magic' handle shows as a fixed placeholder. +test_showHandle :: Test +test_showHandle = TestCase $ do + m <- magicOpen MagicNone + assertEqual "handle shows as placeholder" "" (show m) + +-- | The 'NFData' instances force values fully without bottoming. +test_nfdata :: Test +test_nfdata = TestCase $ + rnf (MagicMimeType <> MagicError) `seq` + rnf MagicParamBytesMax `seq` + rnf (MagicException (T.pack "ctx") (T.pack "msg")) `seq` + assertBool "NFData forces flags, params, and exceptions without error" True + +-- | A parameter set with 'magicSetParam' is read back by 'magicGetParam'. +test_params :: Test +test_params = TestCase $ + withDefault MagicNone $ \m -> do + magicSetParam m MagicParamBytesMax 4096 + v <- magicGetParam m MagicParamBytesMax + assertEqual "bytes-max round-trip" 4096 v + +-- | The system's default magic database validates with 'magicCheck'. +test_check :: Test +test_check = TestCase $ do + ok <- withDefault MagicNone $ \m -> magicCheck m [] + assertBool "default magic database should be valid" ok + +-- | 'magicGetPath' returns a non-empty default database path. +test_getPath :: Test +test_getPath = TestCase $ do + p <- magicGetPath + assertBool "expected a non-empty default magic path" (not (null p)) + +-- | A newly added flag ('MagicExtension') maps to the right value end-to-end: +-- it makes libmagic report candidate file extensions. +test_extension :: Test +test_extension = TestCase $ + withPngFile $ \pngPath -> do + result <- withDefault MagicExtension $ \m -> magicFile m pngPath + assertBool ("expected 'png' among extensions, got: " ++ show result) + ("png" `isInfixOf` T.unpack result) + +-- | The composite 'MagicMime' mask is read back decomposed into its component +-- flags by 'magicGetFlags'. +test_getFlagsComposite :: Test +test_getFlagsComposite = TestCase $ + withDefault MagicNone $ \m -> do + magicSetFlags m MagicMime + fl <- magicGetFlags m + assertBool ("expected MimeType and MimeEncoding set in " ++ show fl) + (hasFlag fl MagicMimeType && hasFlag fl MagicMimeEncoding) + +-- | With 'MagicError' set, examining a missing file raises an 'IOError' rather +-- than embedding the message in the result. +test_errorRaised :: Test +test_errorRaised = TestCase $ do + r <- withDefault MagicError $ \m -> + try (magicFile m "/no/such/magic/file") :: IO (Either MagicException Text) + case r of + Left e -> do + assertEqual "exception carries the operation as its context" + "magicFile" (T.unpack (magicErrorContext e)) + assertBool "exception carries a non-empty libmagic message" + (not (T.null (magicErrorMessage e))) + assertBool ("displayException is prefixed with the context, got: " + ++ displayException e) + ("magicFile: " `isPrefixOf` displayException e) + Right s -> assertFailure ("expected a MagicException, got: " ++ show s) + +-- | After a failed operation, 'magicErrno' reports the underlying system error. +test_errno :: Test +test_errno = TestCase $ + withDefault MagicError $ \m -> do + _ <- try (magicFile m "/no/such/magic/file") + :: IO (Either MagicException Text) + e <- magicErrno m + assertBool ("expected a non-zero errno after a failed open, got " ++ show e) + (e /= 0) + +-- | 'magicLoadBuffers' loads a compiled database from memory, and the handle +-- keeps the buffer alive: after dropping the local reference and forcing a GC, +-- the handle still works. Skipped (passes trivially) when no compiled @.mgc@ +-- database can be located, to avoid depending on the host layout. +test_loadBuffers :: Test +test_loadBuffers = TestCase $ do + mfile <- findCompiledMagic + case mfile of + Nothing -> return () -- no compiled database available here + Just f -> do + m <- magicOpen MagicMimeType + -- Load from a buffer that goes out of scope immediately afterwards. + do buf <- BS.readFile f + magicLoadBuffers m [buf] + performMajorGC -- try to reclaim the now-unreferenced buffer + result <- magicByteString m pngBytes + assertEqual "PNG MIME after magicLoadBuffers (buffer survived GC)" + "image/png" (T.unpack result) + +-- | 'magicLoad' with a non-empty path list (exercises the search-path +-- marshalling, joining the paths for libmagic). Loads a located compiled +-- database explicitly, then identifies data. Skipped when none is found. +test_loadFromPath :: Test +test_loadFromPath = TestCase $ do + mfile <- findCompiledMagic + case mfile of + Nothing -> return () + Just f -> do + result <- do + m <- magicOpen MagicMimeType + magicLoad m [f] -- non-empty list -> withSearchPathCString + magicByteString m pngBytes + assertEqual "PNG MIME after magicLoad from an explicit path" + "image/png" (T.unpack result) + +-- | Many concurrent calls on a single shared handle all succeed (exercises the +-- per-handle lock; run under the threaded RTS with @-N@). +test_concurrent :: Test +test_concurrent = TestCase $ + withDefault MagicMimeType $ \m -> do + let n = 32 :: Int + done <- newEmptyMVar + forM_ [1 .. n] $ \_ -> forkIO $ do + r <- try (magicByteString m pngBytes) :: IO (Either SomeException Text) + putMVar done r + results <- forM [1 .. n] $ \_ -> takeMVar done + let ok :: Either SomeException Text -> Bool + ok (Right s) = T.unpack s == "image/png" + ok (Left _) = False + assertBool "every concurrent call returned image/png" (all ok results) + +-- | Locate a compiled magic database from the default search path. +findCompiledMagic :: IO (Maybe FilePath) +findCompiledMagic = do + paths <- magicGetPath + firstExisting (filter (".mgc" `isSuffixOf`) + (concatMap (\p -> [p, p ++ ".mgc"]) paths)) + where + firstExisting :: [FilePath] -> IO (Maybe FilePath) + firstExisting [] = return Nothing + firstExisting (f:fs) = do + e <- doesFileExist f + if e then return (Just f) else firstExisting fs + +tests :: Test +tests = TestList + [ TestLabel "text MIME type" test_textMime + , TestLabel "text description" test_textDescription + , TestLabel "PNG MIME type" test_pngMime + , TestLabel "PNG MIME (OsPath)" test_osPathFile + , TestLabel "PNG MIME (ByteString)" test_byteStringMime + , TestLabel "PNG MIME (descriptor)" test_descriptorMime + , TestLabel "library version" test_version + , TestLabel "get/set flags" test_getFlags + , TestLabel "composite flags" test_getFlagsComposite + , TestLabel "flag algebra" test_flagAlgebra + , TestLabel "show handle" test_showHandle + , TestLabel "NFData instances" test_nfdata + , TestLabel "extension flag" test_extension + , TestLabel "get/set params" test_params + , TestLabel "check database" test_check + , TestLabel "default path" test_getPath + , TestLabel "error raised" test_errorRaised + , TestLabel "errno after failure" test_errno + , TestLabel "load buffers" test_loadBuffers + , TestLabel "load from path" test_loadFromPath + , TestLabel "concurrent handle use" test_concurrent + ] diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,13 @@ +{- Tests main file +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +module Tests(tests) where + +import Test.HUnit +import qualified Inittest + +tests :: Test +tests = TestList [TestLabel "init" Inittest.tests] diff --git a/test/runtests.hs b/test/runtests.hs new file mode 100644 --- /dev/null +++ b/test/runtests.hs @@ -0,0 +1,18 @@ +{- Test runner +Copyright (C) 2005 John Goerzen + +This code is under a 3-clause BSD license; see COPYING for details. +-} + +module Main (main) where + +import Control.Monad (when) +import System.Exit (exitFailure) +import Test.HUnit + +import Tests + +main :: IO () +main = do + cs <- runTestTT tests + when (errors cs > 0 || failures cs > 0) exitFailure