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
$cshowsPrec :: Int -> UnixFile -> ShowS
showsPrec :: Int -> UnixFile -> ShowS
$cshow :: UnixFile -> String
show :: UnixFile -> String
$cshowList :: [UnixFile] -> ShowS
showList :: [UnixFile] -> ShowS
Show, UnixFile -> UnixFile -> Bool
(UnixFile -> UnixFile -> Bool)
-> (UnixFile -> UnixFile -> Bool) -> Eq UnixFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnixFile -> UnixFile -> Bool
== :: UnixFile -> UnixFile -> Bool
$c/= :: UnixFile -> UnixFile -> Bool
/= :: UnixFile -> UnixFile -> Bool
Eq)

toUnixFile :: String -> IO (Maybe UnixFile)
toUnixFile String
filepath = do
    exist <- String -> IO Bool
fileExist String
filepath
    if exist
        then do
            status <- getFileStatus filepath
            return $ toUnixFile' status filepath
        else return Nothing
    where
        toUnixFile' :: FileStatus -> String -> Maybe UnixFile
toUnixFile' 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 String
filepath) = String
filepath
toFilepath (Directory String
filepath)   = String
filepath

findDir :: UnixFile -> IO [UnixFile]
findDir (Directory String
filepath) = do
    let readPaths :: DirStream -> IO [UnixFile]
readPaths DirStream
stream = do
            path <- DirStream -> IO String
readDirStream DirStream
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
                                Maybe UnixFile
Nothing    -> [UnixFile] -> IO [UnixFile]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [UnixFile]
paths
                                Just UnixFile
unix' -> [UnixFile] -> IO [UnixFile]
forall a. a -> IO a
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
_                    = [UnixFile] -> IO [UnixFile]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    
findDirRecursive :: UnixFile -> IO [UnixFile]
findDirRecursive unixPath :: UnixFile
unixPath@(Directory String
filepath) = do
    paths <- UnixFile -> IO [UnixFile]
findDir UnixFile
unixPath
    subPaths <- concat <$> mapM findDirRecursive paths
    return $ paths ++ subPaths
findDirRecursive UnixFile
_                             = [UnixFile] -> IO [UnixFile]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- mimetype detection

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

runMimetypeDetection :: StateT Magic IO b -> IO b
runMimetypeDetection StateT Magic IO b
action = do
    magic <- [MagicFlag] -> IO Magic
magicOpen [ MagicFlag
MagicMimeType ]
    magicLoadDefault magic
    evalStateT action magic

-- find image files

isImage :: UnixFile -> StateT Magic IO Bool
isImage (RegularFile String
filepath) = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"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 UnixFile
_ = Bool -> StateT Magic IO Bool
forall a. a -> StateT Magic IO a
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 [String]
filepaths = do
    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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe UnixFile)
toUnixFile [String]
filepaths
    files  <- concat <$> mapM findDirRecursive paths
    images <- runMimetypeDetection $ filterM isImage files
    return $ nub $ map toFilepath images