File.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Files, directories, and encoding / decoding file functions.
--
module Network.AWS.Wolf.File
  ( findRegularFiles
  , dataDirectory
  , storeDirectory
  , inputDirectory
  , outputDirectory
  , writeText
  , readText
  , writeJson
  , readYaml
  , withCurrentWorkDirectory
  ) where

import           Data.Aeson
import qualified Data.ByteString          as BS
import qualified Data.ByteString.Lazy     as LBS
import           Data.Time
import           Data.Yaml                hiding (encode)
import           Network.AWS.Wolf.Prelude hiding (find)
import           System.Directory
import           System.FilePath.Find
import           System.IO                hiding (readFile, writeFile)

-- | Recursively find all files under a directory.
--
findRegularFiles :: MonadIO m => FilePath -> m [FilePath]
findRegularFiles =
  liftIO . find always (fileType ==? RegularFile)

-- | Determine path to data directory and create it.
--
dataDirectory :: MonadIO m => FilePath -> m FilePath
dataDirectory dir = do
  let dir' = dir </> "data"
  liftIO $ createDirectoryIfMissing True dir'
  return dir'

-- | Determine path to store directory and create it.
--
storeDirectory :: MonadIO m => FilePath -> m FilePath
storeDirectory dir = do
  let dir' = dir </> "store"
  liftIO $ createDirectoryIfMissing True dir'
  return dir'

-- | Determine path to store input directory and create it.
--
inputDirectory :: MonadIO m => FilePath -> m FilePath
inputDirectory dir = do
  let dir' = dir </> "input"
  liftIO $ createDirectoryIfMissing True dir'
  return dir'

-- | Determine path to store output directory and create it.
--
outputDirectory :: MonadIO m => FilePath -> m FilePath
outputDirectory dir = do
  let dir' = dir </> "output"
  liftIO $ createDirectoryIfMissing True dir'
  return dir'

-- | Maybe write text to a file.
--
writeText :: MonadIO m => FilePath -> Maybe Text -> m ()
writeText file contents =
  liftIO $ void $ traverse (writeFile file) contents

-- | Maybe read text from a file.
--
readText :: MonadIO m => FilePath -> m (Maybe Text)
readText file =
 liftIO $ do
   b <- doesFileExist file
   if not b then return mempty else
     return <$> readFile file

-- | Encode from JSON and write file.
--
writeJson :: (MonadIO m, ToJSON a) => FilePath -> a -> m ()
writeJson file item =
  liftIO $ withFile file WriteMode $ \h ->
    BS.hPut h $ LBS.toStrict $ encode item

-- | Read file and decode it from YAML.
--
readYaml :: (MonadIO m, FromJSON a) => FilePath -> m a
readYaml file =
  liftIO $ withFile file ReadMode $ \h -> do
    body <- BS.hGetContents h
    eitherThrowIO $ decodeEither body

-- | Get a temporary timestamped work directory.
--
getWorkDirectory :: MonadIO m => Text -> m FilePath
getWorkDirectory uid =
  liftIO $ do
    td   <- getTemporaryDirectory
    time <- getCurrentTime
    let dir = td </> formatTime defaultTimeLocale "%FT%T%z" time </> textToString uid
    createDirectoryIfMissing True dir
    return dir

-- | Copy directory contents recursively.
--
copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> m ()
copyDirectoryRecursive fd td =
  liftIO $ do
    createDirectoryIfMissing True td
    cs <- filter (`notElem` [".", ".."]) <$> getDirectoryContents fd
    forM_ cs $ \c -> do
      let fc = fd </> c
          tc = td </> c
      e <- doesDirectoryExist fc
      bool (copyFile fc tc) (copyDirectoryRecursive fc tc) e

-- | Setup a temporary work directory.
--
withWorkDirectory :: MonadControl m => Text -> (FilePath -> m a) -> m a
withWorkDirectory uid =
  bracket (getWorkDirectory uid) (liftIO . removeDirectoryRecursive)

-- | Change to directory and then return to current directory.
--
withCurrentDirectory :: MonadControl m => FilePath -> (FilePath -> m a) -> m a
withCurrentDirectory wd action =
  bracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ \cd -> do
    liftIO $ setCurrentDirectory wd
    action cd

-- | Setup a temporary work directory and copy current directory files to it.
--
withCurrentWorkDirectory :: MonadControl m => Text -> (FilePath -> m a) -> m a
withCurrentWorkDirectory uid action =
  withWorkDirectory uid $ \wd ->
    withCurrentDirectory wd $ \cd -> do
      copyDirectoryRecursive cd wd
      action wd