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

-- File recursive list

data UnixFile = RegularFile FilePath | Directory FilePath
    deriving (Int -> UnixFile -> ShowS
[UnixFile] -> ShowS
UnixFile -> String
(Int -> UnixFile -> ShowS)
-> (UnixFile -> String) -> ([UnixFile] -> ShowS) -> Show UnixFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnixFile] -> ShowS
$cshowList :: [UnixFile] -> ShowS
show :: UnixFile -> String
$cshow :: UnixFile -> String
showsPrec :: Int -> UnixFile -> ShowS
$cshowsPrec :: Int -> UnixFile -> ShowS
Show, UnixFile -> UnixFile -> Bool
(UnixFile -> UnixFile -> Bool)
-> (UnixFile -> UnixFile -> Bool) -> Eq UnixFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnixFile -> UnixFile -> Bool
$c/= :: UnixFile -> UnixFile -> Bool
== :: UnixFile -> UnixFile -> Bool
$c== :: UnixFile -> UnixFile -> Bool
Eq)

toUnixFile :: String -> IO (Maybe UnixFile)
toUnixFile filepath :: String
filepath = do
    Bool
exist <- String -> IO Bool
fileExist String
filepath
    if Bool
exist
        then do
            FileStatus
status <- String -> IO FileStatus
getFileStatus String
filepath
            Maybe UnixFile -> IO (Maybe UnixFile)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnixFile -> IO (Maybe UnixFile))
-> Maybe UnixFile -> IO (Maybe UnixFile)
forall a b. (a -> b) -> a -> b
$ FileStatus -> String -> Maybe UnixFile
toUnixFile' FileStatus
status String
filepath
        else Maybe UnixFile -> IO (Maybe UnixFile)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnixFile
forall a. Maybe a
Nothing
    where
        toUnixFile' :: FileStatus -> String -> Maybe UnixFile
toUnixFile' status :: FileStatus
status 
            | FileStatus -> Bool
isRegularFile FileStatus
status = UnixFile -> Maybe UnixFile
forall a. a -> Maybe a
Just (UnixFile -> Maybe UnixFile)
-> (String -> UnixFile) -> String -> Maybe UnixFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnixFile
RegularFile
            | FileStatus -> Bool
isDirectory FileStatus
status   = UnixFile -> Maybe UnixFile
forall a. a -> Maybe a
Just (UnixFile -> Maybe UnixFile)
-> (String -> UnixFile) -> String -> Maybe UnixFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnixFile
Directory
            | Bool
otherwise            = Maybe UnixFile -> String -> Maybe UnixFile
forall a b. a -> b -> a
const Maybe UnixFile
forall a. Maybe a
Nothing

toFilepath :: UnixFile -> String
toFilepath (RegularFile filepath :: String
filepath) = String
filepath
toFilepath (Directory filepath :: String
filepath)   = String
filepath

findDir :: UnixFile -> IO [UnixFile]
findDir (Directory filepath :: String
filepath) = do
    let readPaths :: DirStream -> IO [UnixFile]
readPaths stream :: DirStream
stream = do
            String
path <- DirStream -> IO String
readDirStream DirStream
stream
            if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                then [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                else do
                    [UnixFile]
paths <- DirStream -> IO [UnixFile]
readPaths DirStream
stream
                    if String -> Char
forall a. [a] -> a
head String
path Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.'
                        then [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return [UnixFile]
paths
                        else do
                            Maybe UnixFile
unix <- String -> IO (Maybe UnixFile)
toUnixFile (String -> IO (Maybe UnixFile)) -> String -> IO (Maybe UnixFile)
forall a b. (a -> b) -> a -> b
$ String
filepath String -> ShowS
forall a. [a] -> [a] -> [a]
++ "/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
                            case Maybe UnixFile
unix of
                                Nothing    -> [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return [UnixFile]
paths
                                Just unix' :: UnixFile
unix' -> [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnixFile] -> IO [UnixFile]) -> [UnixFile] -> IO [UnixFile]
forall a b. (a -> b) -> a -> b
$ UnixFile
unix' UnixFile -> [UnixFile] -> [UnixFile]
forall a. a -> [a] -> [a]
: [UnixFile]
paths
    IO DirStream
-> (DirStream -> IO ())
-> (DirStream -> IO [UnixFile])
-> IO [UnixFile]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO DirStream
openDirStream String
filepath) DirStream -> IO ()
closeDirStream DirStream -> IO [UnixFile]
readPaths
findDir _                    = [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    
findDirRecursive :: UnixFile -> IO [UnixFile]
findDirRecursive unixPath :: UnixFile
unixPath@(Directory filepath :: String
filepath) = do
    [UnixFile]
paths <- UnixFile -> IO [UnixFile]
findDir UnixFile
unixPath
    [UnixFile]
subPaths <- [[UnixFile]] -> [UnixFile]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnixFile]] -> [UnixFile]) -> IO [[UnixFile]] -> IO [UnixFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnixFile -> IO [UnixFile]) -> [UnixFile] -> IO [[UnixFile]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UnixFile -> IO [UnixFile]
findDirRecursive [UnixFile]
paths
    [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnixFile] -> IO [UnixFile]) -> [UnixFile] -> IO [UnixFile]
forall a b. (a -> b) -> a -> b
$ [UnixFile]
paths [UnixFile] -> [UnixFile] -> [UnixFile]
forall a. [a] -> [a] -> [a]
++ [UnixFile]
subPaths
findDirRecursive _                             = [UnixFile] -> IO [UnixFile]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- mimetype detection

mimetype :: FilePath -> StateT Magic IO String
mimetype :: String -> StateT Magic IO String
mimetype filepath :: String
filepath = do
    Magic
magic <- StateT Magic IO Magic
forall s (m :: * -> *). MonadState s m => m s
get
    IO String -> StateT Magic IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> StateT Magic IO String)
-> IO String -> StateT Magic IO String
forall a b. (a -> b) -> a -> b
$ Magic -> String -> IO String
magicFile Magic
magic String
filepath

runMimetypeDetection :: StateT Magic IO b -> IO b
runMimetypeDetection action :: StateT Magic IO b
action = do
    Magic
magic <- [MagicFlag] -> IO Magic
magicOpen [ MagicFlag
MagicMimeType ]
    Magic -> IO ()
magicLoadDefault Magic
magic
    StateT Magic IO b -> Magic -> IO b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT Magic IO b
action Magic
magic

-- find image files

isImage :: UnixFile -> StateT Magic IO Bool
isImage (RegularFile filepath :: String
filepath) = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "image" (String -> Bool) -> StateT Magic IO String -> StateT Magic IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> StateT Magic IO String
mimetype String
filepath
isImage _ = Bool -> StateT Magic IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

{- |
Recursively search supplied paths. Files are filtered by mimetypes, which is determined by magic bits. Duplicated paths will be removed.
-}
findImages :: [String] -> IO [String]
findImages filepaths :: [String]
filepaths = do
    [UnixFile]
paths  <- [Maybe UnixFile] -> [UnixFile]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnixFile] -> [UnixFile])
-> IO [Maybe UnixFile] -> IO [UnixFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe UnixFile)) -> [String] -> IO [Maybe UnixFile]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe UnixFile)
toUnixFile [String]
filepaths
    [UnixFile]
files  <- [[UnixFile]] -> [UnixFile]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnixFile]] -> [UnixFile]) -> IO [[UnixFile]] -> IO [UnixFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnixFile -> IO [UnixFile]) -> [UnixFile] -> IO [[UnixFile]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UnixFile -> IO [UnixFile]
findDirRecursive [UnixFile]
paths
    [UnixFile]
images <- StateT Magic IO [UnixFile] -> IO [UnixFile]
forall b. StateT Magic IO b -> IO b
runMimetypeDetection (StateT Magic IO [UnixFile] -> IO [UnixFile])
-> StateT Magic IO [UnixFile] -> IO [UnixFile]
forall a b. (a -> b) -> a -> b
$ (UnixFile -> StateT Magic IO Bool)
-> [UnixFile] -> StateT Magic IO [UnixFile]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM UnixFile -> StateT Magic IO Bool
isImage [UnixFile]
files
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (UnixFile -> String) -> [UnixFile] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnixFile -> String
toFilepath [UnixFile]
images