BkrConfig.hs

module System.Bkr.BkrConfig ( FileUpdateCheckType(..)
                     , getConfPairsFromFile
                     , getConfPairsFromFile'
                     , getConfPairsFromFile_
                     , getConfPairsFromFile_'
                     , getConfPairsFromFileS
                     , getConfPairsFromFileS'
                     , getConfPairsFromByteString
                     , getConfPairsFromByteString'
                     , getConfFile
                     , writeBkrMetaFile
                     , getValue
                     , getValueS
                     , getBackupFolders
                     , getFilesToIgnore
                     , getFileExtensionsToIgnore
                     , getFoldersToIgnore
                     , getUseS3ReducedRedundancy
                     , getLogLevel
                     , getFileUpdateCheckType
                     , getLogFileLocation
                     , getLogFileMaximumSize
                     ) where

--import Bkr.BkrLogging
import System.Bkr.Hasher

import System.IO
import System.Directory (getTemporaryDirectory, getModificationTime, doesFileExist, getHomeDirectory, copyFile, getTemporaryDirectory, getAppUserDataDirectory, createDirectoryIfMissing)
import System.FilePath.Posix (takeDirectory)
import Control.Monad (liftM)
import Data.String.Utils (split, strip, replace)
import Aws.S3.Model (StorageClass(..))
import System.Log.Logger (Priority(..))
import System.Environment (getArgs)
--import Data.Maybe (isNothing, fromJust)

import qualified System.IO.Strict as S
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T

--import System.IO
--import Data.List (lines)
--import Control.Monad (mapM)
--import List (find)
--import Data.Maybe (fromJust)
--import System.IO.Error (ioError, userError)

data FileUpdateCheckType = FUCChecksum
                         | FUCDate
                         | FUCSmart
                         deriving Eq

{-| Read lines from s and filter on empty lines and lines beginning with # -}
getFilteredLines :: String -> [T.Text]
getFilteredLines s = [ x | x <- map T.pack (lines s), x /= T.empty, T.head (T.stripStart x) /= '#' ]

{-| Gets configuration pairs. This function takes a FilePath and reads the file lazy which might lead to unexpected consequences. If you want to have more control over the file handle use getConfPairsFromFile_ and if you want the file to be read strictly without the unwanted (or wanted) lazines side effects use getConfPairsFromFileS. -}
getConfPairsFromFile :: FilePath -> IO [(T.Text, T.Text)]
getConfPairsFromFile path = do
     --logDebug "getConfPairsFromFile called"
     -- Read the config file, split into lines and pack as Text
     hndl <- openBinaryFile path ReadMode
     readF <- hGetContents hndl
     
     -- Just testing some styles. I'm not sure which one looks better, the first one is prabably easier to read.
     --return $ map getConfPair (getFilteredLines readF)
     return $ getConfPair `map` getFilteredLines readF

{-| Like getConfPairsFromFile but gets a String pair instead of Text. -}
getConfPairsFromFile' :: FilePath -> IO [(String, String)]
getConfPairsFromFile' path = --do
     --logDebug "getConfPairsFromFile' called"
     
     --pairs <- getConfPairsFromFile path
     --return $ map textToString pairs
     getConfPairsFromFile path >>= return . map textToString

{-| Like getConfPairsFromFile but takes a file handle instead of FilePath. -}
getConfPairsFromFile_ :: Handle -> IO [(T.Text, T.Text)]
getConfPairsFromFile_ hndl = do
     --logDebug "getConfPairsFromFile_ called"
     -- Read the config file, split into lines and pack as Text
     readF <- hGetContents hndl

     return $ map getConfPair (getFilteredLines readF)

{-| Like getConfPairsFromFile' but takes a file handle instead of FilePath. -}
getConfPairsFromFile_' :: Handle -> IO [(String, String)]
getConfPairsFromFile_' hndl = --do
     --logDebug "getConfPairsFromFile_' called"
     
     --pairs <- getConfPairsFromFile_ hndl
     --return $ map textToString pairs
     getConfPairsFromFile_ hndl >>= return . map textToString

{-| Like getConfPairsFromFile but reads file contents strictly. -}
getConfPairsFromFileS :: FilePath -> IO [(T.Text, T.Text)]
getConfPairsFromFileS path = do
     --logDebug "getConfPairsFromFileS called"
     -- Read the config file, split into lines and pack as Text
     hndl <- openBinaryFile path ReadMode
     -- Read contents strictly
     readF <- S.hGetContents hndl
     hClose hndl
     
     return $ map getConfPair (getFilteredLines readF)

{-| Like getConfPairsFromFile' but reads file contents strictly. -}
getConfPairsFromFileS' :: FilePath -> IO [(String, String)]
getConfPairsFromFileS' path = --do
     --logDebug "getConfPairsFromFileS' called"

     --pairs <- getConfPairsFromFileS path
     --return $ map textToString pairs
     getConfPairsFromFileS path >>= return . map textToString

{-| Take a ByteString text, convert to lines and return Text pairs. -}
getConfPairsFromByteString :: BS.ByteString -> IO [(T.Text, T.Text)]
getConfPairsFromByteString bS = do
     --logDebug "getConfPairsFromByteString called"
     --let fileLines = map T.pack (lines $ BS.unpack bS)
     -- Get lines and filter lines beginning with #
     let fileLines = [ x | x <- map T.pack (lines $ BS.unpack bS), x /= T.empty, T.head (T.stripStart x) /= '#' ]
     return $ map getConfPair fileLines

{-| Like getConfPairsFromByteString but returns String. -}
getConfPairsFromByteString' :: BS.ByteString -> IO [(String, String)]
getConfPairsFromByteString' bS = --do
     --logDebug "getConfPairsFromByteString' called"

     --pairs <- getConfPairsFromByteString bS
     --return $ map textToString pairs
     getConfPairsFromByteString bS >>= return . map textToString

{-| Get a pair for Text line. |-}
getConfPair :: T.Text -> (T.Text, T.Text)
getConfPair line = (T.strip $ head s, T.strip $ last s)
                    where s = T.split (==':') line

{-| Convert a Text pair to a String pair. |-}
textToString :: (T.Text, T.Text) -> (String, String)
textToString x = (T.unpack $ fst x, T.unpack $ snd x)

{-| Gets the value for a list of value pairs. The function matches on the first key found and does not check for multiple keys with the same name. If the key is not found Nothing is returned. -}
getValue :: T.Text -> [(T.Text, T.Text)] -> Maybe T.Text
getValue _ [] = Nothing
getValue key (x:xs) = if fst x == key
                           then Just $ snd x
                           else getValue key xs

{-| Same as getValue but for String value pairs |-}
getValueS :: String -> [(String, String)] -> Maybe String
--getValueS value values = lookup value values
getValueS = lookup

-- Bkr specific fuctions

{-| Take a bkr conf pair and write a .bkrm file in a temporary directory. -}
writeBkrMetaFile :: (String, String) -> IO FilePath
writeBkrMetaFile confPair = do
     --logDebug "writeBkrMetaFile called"
     -- Get tmp dir
     tmpDir <- getTemporaryDirectory
     -- Get hash of the file name
     let fullPathHash = show $ getHashForString $ fst confPair
     -- Get the full file path to the .bkrm file (<full path hash:file hash.bkrm>)
     let fullPath = tmpDir ++ fullPathHash ++ "." ++ snd confPair
     -- Get file modification time
     modTime <- getModificationTime $ fst confPair 
     -- Open a file handle
     hndl <- openBinaryFile fullPath WriteMode
     -- Map over a list of the lines to write to the file
     let hPutStrLnHndl = hPutStrLn hndl
     _ <- mapM hPutStrLnHndl ["[BkrMetaInfo]", 
                              "fullpath: " ++ fst confPair, 
                              "checksum: " ++ snd confPair, 
                              "modificationtime: " ++ show modTime, 
                              "fullpathchecksum: " ++ show (getHashForString $ fst confPair), 
                              "modificationtimechecksum: " ++ show (getHashForString $ show modTime)]
     -- Close the handle and return the file path
     hClose hndl
     return fullPath

{-| Check if bkr.conf is passed as the first argument. We do not check if the bkr.conf file is valid, just that a file was passed as the first argument. -}
getArgIfValid :: IO (Maybe FilePath)
getArgIfValid = do
     args <- getArgs
     case args of
          [x] -> do
                  fileExists <- doesFileExist x
                  if fileExists
                     then return $ Just x
                     else return Nothing
          _   -> return Nothing

{-| Check if there is a bkr.conf file in the same directory as the bkr executable. We do not check that the bkr.conf file is valid, only if it exists. -}
getBkrConfFromDot :: IO (Maybe FilePath)
getBkrConfFromDot = do
     fileExists <- doesFileExist "./bkr.conf"
     if fileExists
        then return $ Just "./bkr.conf"
        else return Nothing

{-| Check if there is a $HOME/.bkr.conf file. We do not check if the .bkr.conf file is valid, only if it exists. If the file cannot be found the bkr.conf.example file is copied to $HOME/.bkr.conf and the user is instructed to edit it. -}
getBkrFromHomeDir :: IO (Maybe FilePath)
getBkrFromHomeDir = do
     homeDir <- getHomeDirectory
     let filePath = (++) homeDir "/.bkr.conf"
     fileExists <- doesFileExist filePath
     if fileExists
        then return $ Just filePath
        else do
              copyFile "./bkr.conf.example" filePath
              print $ "bkr configuration file could not be found. An example configuration file has been copied to your home directory, " ++ filePath ++ ". Please edit the configuration file and run bkr again."
              return Nothing

{-|
Gets file path to the Bkr configuration file. File locations checked (in order):
    1. The first command line argument
    2. ./bkr.conf
    3. $HOME/.bkr.conf
-}
getConfFile :: IO (Maybe FilePath)
getConfFile = do
     argIfValid <- getArgIfValid
     case argIfValid of
          Just x -> return $ Just x
          _      -> do
                     bkrFromDot <- getBkrConfFromDot
                     case bkrFromDot of
                          Just x -> return $ Just x
                          _      -> do
                                     bkrFromHome <- getBkrFromHomeDir
                                     case bkrFromHome of
                                          Just x -> return $ Just x
                                          _      -> return Nothing
{-getConfFile = do
     argIfValid <- getArgIfValid
     when ((isNothing argIfValid) == False) (return argIfValid)

     bkrFromDot <- getBkrConfFromDot
     when ((isNothing bkrFromDot) == False) (return bkrFromDot)

     bkrFromHome <- getBkrFromHomeDir
     when ((isNothing bkrFromHome) == False) (return bkrFromHome)
     
     return Nothing-}

getConfSetting :: String -> IO (Maybe String)
getConfSetting key = do
     confFile <- getConfFile
     case confFile of
          Just x   -> liftM (getValueS key) (getConfPairsFromFileS' x)
          Nothing  -> return Nothing

{-| Get a list of the folders to back up. If the setting cannot be found an IO Error is raised. -}
getBackupFolders :: IO [FilePath]
getBackupFolders = do
     --logDebug "getBackupFolders called"

     confSetting <- getConfSetting "folderstobackup"
     case confSetting of
          Just x  -> return $ map strip (split "," x)
          Nothing -> ioError $ userError "Failed to find the configuration setting folderstobackup. Please check the configuration."

{-| Get a list of files to ignore. If the settings cannot be found an empty list is returned. -}
getFilesToIgnore :: IO [FilePath]
getFilesToIgnore = do
     --logDebug "getFilesToIgnore called"

     confSetting <- getConfSetting "filestoignore"
     case confSetting of
          Just x  -> return $ map strip (split "," x)
          Nothing -> do
                  --logDebug $ "getFilesToIgnore: " ++ "the setting filestoignore was not found."
                  return []

{-| Get a list of files to ignore be extension. If the settings cannot be found an empty list is returned. -}
getFileExtensionsToIgnore :: IO [FilePath]
getFileExtensionsToIgnore = do
    --logDebug "getFileExtensionsToIgnore called"

    confSetting <- getConfSetting "fileextensionstoignore"
    case confSetting of
         Just x  -> return $ map strip (split "," x)
         Nothing -> do
                 --logDebug $ "getFileExtensionsToIgnore: " ++ "the setting fileextensionstoignore was not found."
                 return []

{-| Get a list of folders to ignore. If the settings cannot be found an empty list is returned. -}
getFoldersToIgnore :: IO [FilePath]
getFoldersToIgnore = do
    --logDebug "getFoldersToIgnore called"

    confSetting <- getConfSetting "folderstoignore"
    case confSetting of
         Just x  -> return $ map strip (split "," x)
         Nothing -> do
                 --logDebug $ "getFoldersToIgnore: " ++ "the setting folderstoignore was not found."
                 return []

{-| Get if we should use S3 reduced redundancy, if the setting cannot be found return reduced redundacy (there is not real reason not to use reduced redundancy for this kind of application. |-}
getUseS3ReducedRedundancy :: IO (Maybe StorageClass)
getUseS3ReducedRedundancy = do
     --logDebug "getUseS3ReducedRedundancy called"

     confSetting <- getConfSetting "uses3reducedredundancy"
     case confSetting of
          Just x -> if x == "yes"
                       then return $ Just ReducedRedundancy
                       else return $ Just Standard
          Nothing -> do
                  --logDebug $ "getUseS3ReducedRedundancy: " ++ "the setting uses3reducedredundancy was not found."
                  return $ Just ReducedRedundancy

{-| Get the log priority and default to debug if it could not be found or is misconfigured. -}
getLogLevel :: IO Priority
getLogLevel = do
     --print "getLogLevel called"

     confSetting <- getConfSetting "loglevel"
     case confSetting of
          Just x  -> case x of
                         "notify"   -> return NOTICE
                         "critical" -> return CRITICAL
                         _          -> return DEBUG
          Nothing -> return DEBUG

{-| Get the file update check type, default to smart if it could not be found or is misconfigured. -}
getFileUpdateCheckType :: IO FileUpdateCheckType
getFileUpdateCheckType = do
     --logDebug "getFileUpdateCheckType called"

     confSetting <- getConfSetting "fileupdatecheck"
     case confSetting of
          Just x -> case x of
                         "checksum" -> return FUCChecksum
                         "date"     -> return FUCDate
                         _          -> return FUCSmart
          _      -> return FUCSmart

{-| Get log file location. $HOME, $TMP and $APPDATA are replaced with user's home directory, system temp directory and user's application data directory respectively. If the directory is not present it's created. -}
getLogFileLocation :: IO (Maybe FilePath)
getLogFileLocation = do
     confSetting <- getConfSetting "logfilelocation"
     case confSetting of
          Just x -> do
                     homeDir <- getHomeDirectory
                     tmpDir <- getTemporaryDirectory
                     appDir <- getAppUserDataDirectory "bkr"
                     let logFilePath = strReplace ["$HOME", "$TMP", "$APPDATA"] [homeDir, tmpDir, appDir] x 

                     createDirectoryIfMissing True (takeDirectory logFilePath)

                     return $ Just $ logFilePath
          _      -> return Nothing

     where strReplace :: [String] -> [String] -> String -> String
           strReplace (x:xs) (xR:xRs) s = strReplace xs xRs (replace x xR s)
           strReplace _ _ s = s

{-| Get log file maximum size in bytes. If the size cannot be found default to 5MB. -}
getLogFileMaximumSize :: IO Int
getLogFileMaximumSize = do
     confSetting <- getConfSetting "logfilemaximumsize"
     case confSetting of
          Just x -> return $ rInt x
          _      -> return 5242880
     
     where rInt :: String -> Int
           rInt = read