module XMonad.Wallpaper.Find (findImages) where
import System.Posix.Directory
import System.Posix.Files
import Control.Applicative
import Control.Monad
import Control.Exception
import Magic
import Control.Monad.State
import Data.Maybe
import Data.List
data UnixFile = RegularFile FilePath | Directory FilePath
deriving (Show, Eq)
toUnixFile filepath = do
exist <- fileExist filepath
if exist
then do
status <- getFileStatus filepath
return $ toUnixFile' status filepath
else return Nothing
where
toUnixFile' status
| isRegularFile status = Just . RegularFile
| isDirectory status = Just . Directory
| otherwise = const Nothing
toFilepath (RegularFile filepath) = filepath
toFilepath (Directory filepath) = filepath
findDir (Directory filepath) = do
let readPaths stream = do
path <- readDirStream stream
if length path == 0
then return []
else do
paths <- readPaths stream
if head path == '.'
then return paths
else do
unix <- toUnixFile $ filepath ++ "/" ++ path
case unix of
Nothing -> return paths
Just unix' -> return $ unix' : paths
bracket (openDirStream filepath) closeDirStream readPaths
findDir _ = return []
findDirRecursive unixPath@(Directory filepath) = do
paths <- findDir unixPath
subPaths <- concat <$> mapM findDirRecursive paths
return $ paths ++ subPaths
findDirRecursive _ = return []
mimetype :: FilePath -> StateT Magic IO String
mimetype filepath = do
magic <- get
liftIO $ magicFile magic filepath
runMimetypeDetection action = do
magic <- magicOpen [ MagicMimeType ]
magicLoadDefault magic
evalStateT action magic
isImage (RegularFile filepath) = isPrefixOf "image" <$> mimetype filepath
isImage _ = return False
findImages filepaths = do
paths <- catMaybes <$> mapM toUnixFile filepaths
files <- concat <$> mapM findDirRecursive paths
images <- runMimetypeDetection $ filterM isImage files
return $ nub $ map toFilepath images