randfile-0.1.0.0: Main.hs

import Prelude hiding (catch)

import Stat

import Control.Applicative
import Control.Exception
import Control.Monad.CryptoRandom
import Control.Monad.Trans.Class
import Control.Monad.Trans.Error
import Crypto.Random
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO

-- | Handle an IOException by returning the given value instead.
onIOException :: a -> IO a -> IO a
onIOException fallback_result action =
        action `catch` handler fallback_result
    where
        handler :: a -> IOException -> IO a
        handler x _ = return x

notSpecial :: FilePath -> Bool
notSpecial name = name /= "." && name /= ".."

listFiles :: FilePath -> IO [FilePath]
listFiles dir = onIOException []
              $ map (dir </>) . filter notSpecial <$> getDirectoryContents dir

randFile :: (CryptoRandomGen g, Error e, ContainsGenError e)
         => FilePath
         -> CRandT g e IO (Maybe FilePath)
randFile dir = lift (listFiles dir) >>= pickFromList where
    pickFromList list =
        if null list
            then return Nothing
            else do
                let len = length list
                idx  <- getCRandomR (0, len-1)
                let path = list !! idx

                st <- lift (stat path)
                case st of
                    File      -> return (Just path)
                    Directory -> do
                        r <- randFile path
                        case r of
                            Just _  -> return r
                            Nothing -> pickFromList (list `without` idx)
                    Other     -> pickFromList (list `without` idx)
    without list idx = as ++ bs where
        (as, _:bs) = splitAt idx list

-- | Like 'runCRandT', but discard the generator and throw the error
-- (if necessary).
runCRandT_ :: CRandT g GenError IO a -> g -> IO a
runCRandT_ action gen = do
    res <- runCRandT action gen
    case res of
        Left e       -> throwIO $ userError $ show e
        Right (a, _) -> return a

main :: IO ()
main = do
    g <- newGenIO :: IO SystemRandom
    file <- runCRandT_ (randFile ".") g
    case file of
        Just f  -> putStrLn $ makeRelative "." $ f
        Nothing -> do
            progName <- getProgName
            hPutStrLn stderr $
                progName ++ ": Current directory does not contain any files"
            exitFailure