copy directory recursively

gistfile1.hs

import Prelude hiding (catch)
import System.Environment
import System.IO
import System.Directory
import System.FilePath
import Control.Exception
import Control.Applicative
import Control.Monad
import Data.List

partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM p xs = do
    bools <- mapM p xs
    let (l1, l2) = partition fst (zip bools xs)
    return (map snd l1, map snd l2)

-- | prompt user and get feedback.
prompt :: String -> IO String
prompt s = putStr s >> hFlush stdout >> getLine

-- | check boolean user input.
yesOrNo :: String -> IO Bool
yesOrNo s = case s of
    "yes" -> return True
    "no"  -> return False
    _     -> yesOrNo =<< prompt "Please input \"yes\" or \"no\"? "

-- | walk directory recursively
walkDirectory :: FilePath -> (FilePath -> IO ()) -> IO ()
walkDirectory root process = walk "."
  where
    walk dir = do
        let dir' = root </> dir
        paths <- filter (`notElem` [".", ".."]) <$> getDirectoryContents dir'
        (files, dirs) <- partitionM (doesFileExist . (dir' </>)) paths
        mapM_ process $ map (dir </>) files
        mapM_ (walk . (dir </>)) dirs

-- | mkdir -p path/to/dir
createRecursive :: FilePath -> IO ()
createRecursive dir = do
    let base = dropFileName . dropTrailingPathSeparator $ dir
    exists <- doesDirectoryExist base
    if exists then
        createDirectory dir
    else
        createRecursive base >> createDirectory dir

-- | copy directory recursively, prompt user when necessary.
copyPrompt :: FilePath -> FilePath -> IO ()
copyPrompt f1 f2 = do
    exists <- doesFileExist f2
    if exists then do
        overwrite <- yesOrNo =<< prompt ("File \""++f2++"\" exists, overwrite? ")
        when overwrite doCopy
    else do
        let dstDir = dropFileName f2
        exists' <- doesDirectoryExist dstDir
        if exists' then doCopy
        else do
            create <- yesOrNo =<< prompt ("Directory \""++dstDir++"\" not exists, create? ")
            when create $ createRecursive dstDir >> doCopy
  where
    doCopy = do
        putStrLn $ "Copy "++f1++" to "++f2
        withBinaryFile f1 ReadMode $ \h1 ->
            withBinaryFile f2 WriteMode $ \h2 ->
                hGetContents h1 >>= hPutStr h2

main :: IO ()
main = do
    [src, dst] <- getArgs
    putStrLn "Copying"
    walkDirectory src $ \path ->
        copyPrompt (normalise $ src </> path) (normalise $ dst </> path)
    putStrLn "done"
    `catch` (\e -> putStrLn $ "ERROR!!!" ++ show (e::SomeException))