module Web.Marmalade.Magic
( MagicException
, guessMimeType)
where
import Control.Exception (Exception,throwIO,bracket)
import Data.Typeable (Typeable)
#ifdef WITH_LIBMAGIC
import qualified Web.Marmalade.Magic.Native as N
import Control.Monad (when)
import Data.Bits ((.|.))
import Foreign.C (CInt,peekCString)
import Foreign.ForeignPtr (ForeignPtr,newForeignPtr,withForeignPtr)
import Foreign.Ptr (nullPtr)
import System.IO.Error (catchIOError)
import System.Posix.IO (OpenMode(ReadOnly),openFd,closeFd,defaultFileFlags)
import System.Posix.Types (Fd(Fd))
#else
import Control.DeepSeq (rnf)
import Control.Exception (finally,evaluate)
import System.Exit(ExitCode(..))
import System.IO (IOMode(ReadMode),Handle,withBinaryFile,hGetContents,hClose)
import System.Process (CreateProcess(std_out,std_err,std_in),
StdStream(CreatePipe,UseHandle),
proc,createProcess,waitForProcess)
#endif
newtype MagicException = MagicException String
deriving Typeable
instance Show MagicException where
show (MagicException message) = message
instance Exception MagicException
#ifdef WITH_LIBMAGIC
type Magic = ForeignPtr ()
magicOpen :: CInt -> IO Magic
magicOpen flags = do
raw <- N.magic_open flags
when (raw == nullPtr) (throwIO (MagicException "Failed to allocate cookie"))
newForeignPtr N.magic_close raw
throwCurrentMagicError :: Magic -> IO a
throwCurrentMagicError magic = do
message <- withForeignPtr magic N.magic_error
if message == nullPtr
then throwIO (MagicException "Unknown error")
else peekCString message >>= throwIO.MagicException
magicDescription :: Magic -> Fd -> IO String
magicDescription magic (Fd fd) = do
buffer <- withForeignPtr magic $ \ptr -> N.magic_descriptor ptr fd
when (buffer == nullPtr) (throwCurrentMagicError magic)
peekCString buffer
withBinaryFileFd :: FilePath -> OpenMode -> (Fd -> IO a) -> IO a
withBinaryFileFd fileName mode =
bracket (openFd fileName mode Nothing defaultFileFlags) closeFdSafe
where
closeFdSafe fd = catchIOError (closeFd fd) (const $ return ())
guessMimeType :: FilePath -> IO String
guessMimeType fileName = do
cookie <- magicOpen (N.magicSymlink .|. N.magicMimeType .|. N.magicError)
withForeignPtr cookie ((flip N.magic_load) nullPtr)
withBinaryFileFd fileName ReadOnly (magicDescription cookie)
#else
hGuessMimeType :: Handle -> IO String
hGuessMimeType handle =
bracket (createProcess process) closeHandles $ \(_, Just oh, Just eh, proch) -> do
stdout <- hGetContents oh
stderr <- hGetContents eh
evaluate $ rnf stdout
evaluate $ rnf stderr
exitStatus <- waitForProcess proch
case exitStatus of
ExitSuccess -> return (head (lines stdout))
ExitFailure _ -> throwIO (MagicException (stdout ++ stderr))
where closeHandles (_, Just outh, Just errh, _) =
finally (hClose outh) (hClose errh)
closeHandles _ = return ()
process =
(proc "file" ["--brief", "--mime-type", "-"]) {
std_out = CreatePipe,
std_err = CreatePipe,
std_in = UseHandle handle }
guessMimeType :: FilePath -> IO String
guessMimeType fileName = withBinaryFile fileName ReadMode hGuessMimeType
#endif