-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-- THE SOFTWARE.

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}

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
    -- Force reading of the process handles
    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