{- |
Module      :  ./Common/FileType.hs
Description :  checking the file type
Copyright   :  (c) C. Maeder, DFKI 2014
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

check the file content by using the unix tool file
-}

module Common.FileType (getMagicFileType, getChecksum) where

import System.Exit

import Common.Utils
import Common.Result
import Common.ResultT
import qualified Control.Monad.Fail as Fail

import Data.List
import Data.Maybe

getChecksum :: FilePath -> ResultT IO String
getChecksum :: FilePath -> ResultT IO FilePath
getChecksum fn :: FilePath
fn = IO (Result FilePath) -> ResultT IO FilePath
forall (m :: * -> *) a. m (Result a) -> ResultT m a
ResultT (IO (Result FilePath) -> ResultT IO FilePath)
-> IO (Result FilePath) -> ResultT IO FilePath
forall a b. (a -> b) -> a -> b
$ do
  FilePath
ckprg <- FilePath -> FilePath -> IO FilePath
getEnvDef "HETS_CHECKSUM" "shasum -a 256"
  case FilePath -> [FilePath]
words FilePath
ckprg of  -- no support for options with spaces
    [] -> Result FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result FilePath -> IO (Result FilePath))
-> Result FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail "set HETS_CHECKSUM to a proper command"
    cmd :: FilePath
cmd : args :: [FilePath]
args -> do
      (ex :: ExitCode
ex, out :: FilePath
out, err :: FilePath
err) <- FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
executeProcess FilePath
cmd ([FilePath]
args [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
fn]) ""
      Result FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result FilePath -> IO (Result FilePath))
-> Result FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ case (ExitCode
ex, (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> [FilePath]
words ([FilePath] -> [[FilePath]]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
out) of
        (ExitSuccess, (h :: FilePath
h : _) : _) | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
err ->
          FilePath -> FilePath -> Result FilePath
forall a. a -> FilePath -> Result a
justHint FilePath
h (FilePath -> Result FilePath) -> FilePath -> Result FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
h FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fn
        _ -> FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail (FilePath -> Result FilePath) -> FilePath -> Result FilePath
forall a b. (a -> b) -> a -> b
$ "could not determine checksum: "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows ExitCode
ex "\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
out
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
err then "" else "\nerror\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err

getMagicFileType :: Maybe String -> FilePath -> ResultT IO String
getMagicFileType :: Maybe FilePath -> FilePath -> ResultT IO FilePath
getMagicFileType mp :: Maybe FilePath
mp fn :: FilePath
fn = IO (Result FilePath) -> ResultT IO FilePath
forall (m :: * -> *) a. m (Result a) -> ResultT m a
ResultT (IO (Result FilePath) -> ResultT IO FilePath)
-> IO (Result FilePath) -> ResultT IO FilePath
forall a b. (a -> b) -> a -> b
$ do
  Result FilePath
res <- ResultT IO FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO FilePath -> IO (Result FilePath))
-> ResultT IO FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType Maybe FilePath
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "--mime-encoding") FilePath
fn
  ResultT IO FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO FilePath -> IO (Result FilePath))
-> ResultT IO FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ case Result FilePath -> Maybe FilePath
forall a. Result a -> Maybe a
maybeResult Result FilePath
res of
    Just s :: FilePath
s -> do
      Result () -> ResultT IO ()
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result () -> ResultT IO ()) -> Result () -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ () -> FilePath -> Result ()
forall a. a -> FilePath -> Result a
justHint () (FilePath -> Result ()) -> FilePath -> Result ()
forall a b. (a -> b) -> a -> b
$ "mime-encoding: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s
      if (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
s) ["binary", "unknown"]
        then do
          Result () -> ResultT IO ()
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result () -> ResultT IO ()) -> Result () -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ () -> FilePath -> Result ()
forall a. a -> FilePath -> Result a
justWarn () (FilePath -> Result ()) -> FilePath -> Result ()
forall a b. (a -> b) -> a -> b
$ "no support for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fn
          Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
mp FilePath
fn
        else Maybe FilePath -> FilePath -> ResultT IO FilePath
getMagicFileTypeAux Maybe FilePath
mp FilePath
fn
    _ -> Result FilePath -> ResultT IO FilePath
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR Result FilePath
res

getMagicFileTypeAux :: Maybe String -> FilePath -> ResultT IO String
getMagicFileTypeAux :: Maybe FilePath -> FilePath -> ResultT IO FilePath
getMagicFileTypeAux pm :: Maybe FilePath
pm fn :: FilePath
fn = IO (Result FilePath) -> ResultT IO FilePath
forall (m :: * -> *) a. m (Result a) -> ResultT m a
ResultT (IO (Result FilePath) -> ResultT IO FilePath)
-> IO (Result FilePath) -> ResultT IO FilePath
forall a b. (a -> b) -> a -> b
$ do
  FilePath
magic <- FilePath -> FilePath -> IO FilePath
getEnvDef "HETS_MAGIC" ""
  Result FilePath
res <- if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
magic then Result FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result FilePath -> IO (Result FilePath))
-> Result FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail "null magic" else
      ResultT IO FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO FilePath -> IO (Result FilePath))
-> ResultT IO FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing FilePath
magic
  ResultT IO FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO FilePath -> IO (Result FilePath))
-> ResultT IO FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ case Result FilePath -> Maybe FilePath
forall a. Result a -> Maybe a
maybeResult Result FilePath
res of
    Just s :: FilePath
s | FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf "magic" FilePath
s -> Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
magic) Maybe FilePath
pm FilePath
fn
    _ -> do
      Result () -> ResultT IO ()
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result () -> ResultT IO ()) -> Result () -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ () -> FilePath -> Result ()
forall a. a -> FilePath -> Result a
justWarn () "set HETS_MAGIC to a proper magic file"
      Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
pm FilePath
fn

getFileType :: Maybe FilePath -> Maybe String -> FilePath -> ResultT IO String
getFileType :: Maybe FilePath -> Maybe FilePath -> FilePath -> ResultT IO FilePath
getFileType mmf :: Maybe FilePath
mmf mp :: Maybe FilePath
mp fn :: FilePath
fn = IO (Result FilePath) -> ResultT IO FilePath
forall (m :: * -> *) a. m (Result a) -> ResultT m a
ResultT (IO (Result FilePath) -> ResultT IO FilePath)
-> IO (Result FilePath) -> ResultT IO FilePath
forall a b. (a -> b) -> a -> b
$ do
  (ex :: ExitCode
ex, out :: FilePath
out, err :: FilePath
err) <- FilePath
-> [FilePath]
-> FilePath
-> [(FilePath, FilePath)]
-> IO (ExitCode, FilePath, FilePath)
executeProcessWithEnvironment "file"
    (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
mp [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["--brief", FilePath
fn]) ""
    ([(FilePath, FilePath)] -> IO (ExitCode, FilePath, FilePath))
-> [(FilePath, FilePath)] -> IO (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)]
-> (FilePath -> [(FilePath, FilePath)])
-> Maybe FilePath
-> [(FilePath, FilePath)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ mf :: FilePath
mf -> [("MAGIC", FilePath
mf)]) Maybe FilePath
mmf
  let unexp :: FilePath
unexp = "unexpected file type "
  Result FilePath -> IO (Result FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result FilePath -> IO (Result FilePath))
-> Result FilePath -> IO (Result FilePath)
forall a b. (a -> b) -> a -> b
$ case (ExitCode
ex, FilePath -> [FilePath]
lines FilePath
out) of
    (ExitSuccess, ls :: [FilePath]
ls) -> if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
err then case [FilePath]
ls of
        [l :: FilePath
l] -> FilePath -> Result FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
l
        _ -> FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail (FilePath -> Result FilePath) -> FilePath -> Result FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
unexp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "output:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
out
      else FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail (FilePath -> Result FilePath) -> FilePath -> Result FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
unexp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "error:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
    _ -> FilePath -> Result FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
Fail.fail (FilePath -> Result FilePath) -> FilePath -> Result FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
unexp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "exit code: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
ex