minirotate (empty) → 0.1.0.0
raw patch · 7 files changed
+415/−0 lines, 7 filesdep +basedep +data-accessordep +data-accessor-templatesetup-changed
Dependencies added: base, data-accessor, data-accessor-template, directory, filepath, mtl, old-locale, old-time, safe, split
Files
- LICENSE +10/−0
- README +1/−0
- Setup.lhs +3/−0
- minirotate.cabal +34/−0
- src/Main.hs +173/−0
- src/Options.hs +112/−0
- src/Pattern.hs +82/−0
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2010, Krzysztof Skrzętnicki+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+ * The names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,1 @@+See miniorotate.cabal for details.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ minirotate.cabal view
@@ -0,0 +1,34 @@+name: minirotate+version: 0.1.0.0+synopsis: Minimalistic file rotation utility+description:+ minirotate is minimalistic file rotation utility designed for calling from cron or similar tool.+category: Development+license: BSD3+license-file: LICENSE+author: Krzysztof Skrzetnicki <krzysztof.skrzetnicki+hackage@gmail.com>+maintainer: Krzysztof Skrzetnicki <krzysztof.skrzetnicki+hackage@gmail.com>+homepage: http://tener.github.com/haskell-minirotate+stability: Beta+build-type: Simple+cabal-version: >= 1.6+extra-source-files: README++source-repository head+ Type: Git+ Location: http://github.com/Tener/haskell-minirotate.git++executable minirotate+ hs-source-dirs: src+ other-modules: Pattern, Options+ main-is: Main.hs+ build-depends: filepath >= 1.1.0 && < 1.2.0,+ base >= 4 && < 5,+ directory >= 1,+ data-accessor-template == 0.2.1.3,+ data-accessor == 0.2.1.2,+ old-time >= 1,+ old-locale,+ safe == 0.2,+ split == 0.1.2,+ mtl >= 1.1.0
+ src/Main.hs view
@@ -0,0 +1,173 @@+module Main where++import System.Time+import System.FilePath+import System.Directory+import System.Environment+import System.IO ( hPutStrLn, stderr )+import System.Exit ( exitFailure )++import Data.Accessor+import Data.Accessor.Tuple+import Data.Accessor.Basic ( get )+import Data.Maybe+import Data.List ( sort, partition, intercalate )++import Control.Monad ( when )+import Control.Applicative ( (<$>) )++import Text.Printf++import Paths_minirotate ( version )++import Debug.Trace++-- local imports+import Options+import Pattern++data FileOrDir = File | Dir deriving (Show,Ord,Eq)++-- | auxilary function. to be replaced by proper logging.+logErr str = hPutStrLn stderr ("ERR: " ++ str)++main :: IO ()+main = do+ args <- getArgs+ case parseOptions args of+ Left errmsg -> logErr errmsg >> exitFailure+ Right (locs,(envO,runO)) -> do+ when (get showHelp $ envO) (logErr usage)+ when (get showVers $ envO) (logErr $ printf "minirotate version %s" (show version))+ when (get showDefs $ envO) (logErr $ printf "Defaults:\n\t%s\n\t%s\n"+ (show (def :: EnvOptions))+ (show (def :: RunOptions)))+ when (get continue $ envO) (runRotate runO locs)++++copyOp :: CopyMode -> (FilePath -> FilePath -> IO ())+-- copyOp Copy = \from to -> logErr (printf "COPY: %s -> %s" from to)+-- copyOp Move = \from to -> logErr (printf "MOVE: %s -> %s" from to)+copyOp Copy = copyFile+copyOp Move = renameFile++runRotate :: RunOptions -> [FilePath] -> IO ()+runRotate opts locs | length locs < 2 = logErr "Need at least one source location and destination\n" >> exitFailure+ | otherwise = do++ -- check pattern+ runPattern <- case compilePattern (get filePattern $ opts) of+ Left err -> logErr ("Pattern error: " ++ err) >> exitFailure+ Right pat -> return pat++ let -- if source location is empty string "" we skip it.+ locFrom = (filter (not . null)) $ init locs+ locTo = last locs++ -- | oneLocation firstLevel? (element type, element name)+ oneLocation _ (File,fp) = do+ modTime <- getModificationTime fp+ (copyOp (get copyMode $ opts)) fp (locTo </> (runPattern modTime fp))+ oneLocation True (Dir,fp) = do+ logErr (printf "Directory %s is a subdirectory at source site. Recursive operation is not supported. Skipping."+ (show fp))+ oneLocation False (Dir,fp) = do+ cont <- getDirectoryContentsRooted fp+ mapM fileOrDir cont >>= mapM_ (either logErr (oneLocation True))++ -- check for correct destination+ dest <- fileOrDir locTo+ case dest of+ Left err -> logErr ("Problem with destination:" ++ err) >> exitFailure+ Right (File,fp) -> logErr ("Destination should be directory, not file: " ++ (show fp)) >> exitFailure+ _ -> return () -- all ok.++ -- for each location decide if it's file or directory.+ -- then copy file to destination or report error.+ mapM fileOrDir locFrom >>= mapM_ (either logErr (oneLocation False))++ -- rotate files in final directory+ rotateFiles opts locTo++-- | rotate files in location directory+rotateFiles :: RunOptions -> FilePath -> IO ()+rotateFiles opts loc = do+ -- time stuff+ now <- getClockTime++ -- get files in directory, filter out directories+ let checkFileGetModTime (Left err) = logErr ("rotateFiles: bad file: " ++ err) >> return Nothing+ checkFileGetModTime (Right (Dir,fp)) = logErr ("rotateFiles: skipping directory: " ++ show fp) >> return Nothing+ checkFileGetModTime (Right (File,fp)) = do+ mt <- getModificationTime fp+ return (Just (fp,mt))++ -- important note: files are sorted by (modification time,name)+ cont <- sort <$> (mapM fileOrDir =<< getDirectoryContentsRooted loc)+ contM <- catMaybes <$> mapM checkFileGetModTime cont++ -- now apply the rules (in order):+ -- 1. Delete too old files (by mod time)+ -- 2. Delete exceeding files (by filename)+ -- 3. Undelete to keep minimum count of files (by filename)++ let -- here is the implementation of rules. note the nice symmetry.+ -- 1.+ maxAge = addToClockTime (noTimeDiff { tdSec = negate (get maximumAge $ opts) }) now+ tooOld (todel,tokeep) = let (newdel,keep) = partition (\(fp,mt) -> mt < maxAge) tokeep+ in {- tS 1 -} ((newdel ++ todel),keep)+ -- 2.+ tooMany (todel,tokeep) = let (newdel,keep) = splitAt (length contM - (get maximumFiles $ opts)) (sort tokeep)+ in {- tS 2 -} ((newdel ++ todel),keep)+ -- 3.+ keepMin (todel,tokeep) = let (del,newkeep) = splitAt (length contM - (get minimumFiles $ opts)) (sort todel)+ in {- tS 3 -} (del,newkeep ++ tokeep)++ getDeletedFiles = map fst . fst+ getKeptFiles = map fst . snd+ partitionedFiles = (keepMin . tooMany . tooOld) $ ([],contM)++{-+ print ("maxAge",maxAge)+ print ("now",now)++ putStrLn "DELETE:"+ print (getDeletedFiles partitionedFiles)+ putStrLn "KEEP:"+ print (getKeptFiles partitionedFiles)+-}++ mapM_ removeFile (getDeletedFiles partitionedFiles)++ return ()+++-- | * A few auxilary functions++getDirectoryContentsRooted loc = map (loc </>) . filterSpecial <$> getDirectoryContents loc+-- | remove special directory elements ('.','..')+filterSpecial = (filter (\fp -> not (fp `elem` [".",".."])))+fileOrDir fp = do+ f <- doesFileExist fp+ d <- doesDirectoryExist fp+ return $ case () of+ _ | f -> Right (File,fp)+ | d -> Right (Dir,fp)+ | otherwise -> Left (printf "Neither file nor directory: %s" (show fp))+++-- debug stuff+tS tag xs = let mapf' = showX . map fst+ mapf = showY+ in+ traceShow (printf "%d. DEL: %s KEEP: %s"+ (tag :: Int)+ (mapf . fst $ xs)+ (mapf . snd $ xs)+ :: String+ )+ xs++showY xs = "[" ++ intercalate ", " (map (\(n,t) -> "(" ++ n ++ "," ++ show t ++ ")" ) xs) ++ "]"+showX xs = "[" ++ intercalate ", " xs ++ "]"
+ src/Options.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TemplateHaskell #-}++module Options where++import System.Console.GetOpt+import Data.Accessor+import Data.Accessor.Tuple+import Data.Accessor.Template+import Text.Printf++import Safe ( readDef )++data CopyMode = Move | Copy+ deriving (Read,Show,Eq,Ord)++data RunOptions = RunOptions { + filePattern_ :: String -- ^ output file pattern+ , copyMode_ :: CopyMode -- ^ should we move or copy files?+ , minimumFiles_ :: Int -- ^ minimum # of files+ , maximumFiles_ :: Int -- ^ maximum # of files+ , maximumAge_ :: Int -- ^ oldest age allowed (in seconds)+ } deriving (Read,Show,Eq,Ord)++ +data EnvOptions = EnvOptions {+ showHelp_ :: Bool -- ^ show help+ , showVers_ :: Bool -- ^ show version on run+ , showDefs_ :: Bool -- ^ show program defaults+ , continue_ :: Bool -- ^ set to False if either showVers or showHelp is True. if True program will not be run.++-- NOT IMPLEMENTED YET:+ , logger_ :: String+ , verbose_ :: Bool+ } deriving (Read,Show,Eq,Ord)++class Default a where+ def :: a++instance Default RunOptions where+ def = RunOptions {+ filePattern_ = "{basename}-{modtime %d-%m-%Y-%H_%M_%S}{ext}" -- ext includes leading '.'+ , copyMode_ = Copy+ , minimumFiles_ = 3+ , maximumFiles_ = 20+ -- set maximum age to 3 months+ , maximumAge_ = 3600 {- hour -} * 24 {- day -} * 30 {- month -} * 3+ }++instance Default EnvOptions where+ def = EnvOptions {+ showHelp_ = False+ , showVers_ = False+ , showDefs_ = False+ , continue_ = True+ , logger_ = ""+ , verbose_ = False+ }++type Options = (EnvOptions,RunOptions)+type ErrorString = String++$( deriveAccessors ''RunOptions )+$( deriveAccessors ''EnvOptions )++-- | strict function composition+f .! g = \x -> f $! g x+readErr errmsg str = readDef (error (printf "%s (input: %s)" errmsg str)) str++options :: [OptDescr (Options -> Options)]+options = [ Option ['h','?'] ["help"] (NoArg ((first .> continue ^= False) . + (first .> showHelp ^= True)))+ "show help"+ , Option ['V'] ["version"] (NoArg ((first .> continue ^= False) .+ (first .> showVers ^= True)))+ "show version"+ , Option [] ["show-defaults"] (NoArg ((first .> continue ^= False) .+ (first .> showDefs ^= True)))+ "show program defaults"+ , Option ['p'] ["pattern"] (ReqArg (second .> filePattern ^=) "PATTERN")+ "pattern for final files"+ , Option ['m'] ["move"] (NoArg (second .> copyMode ^= Move))+ "set copy mode to 'move'"+ , Option ['c'] ["copy"] (NoArg (second .> copyMode ^= Copy))+ "set copy mode to 'copy'"+ , Option [] ["min-files"] (ReqArg ((second .> minimumFiles ^=) .! + (readErr "--min-files: bad format"))+ "NUM")+ "minimum number of files to keep"+ , Option [] ["max-files"] (ReqArg ((second .> maximumFiles ^=) .! + (readErr "--max-files: bad format"))+ "NUM")+ "maximum number of files to keep"+ , Option [] ["max-age"] (ReqArg ((second .> maximumAge ^=) .! + (readErr "--max-age: bad format"))+ "NUMSEC")+ "maximum age of files to keep"+-- TODO: logger, verbose+ ]++usage = usageInfo header options where+ header = "Usage: minirotate [OPTIONS] SOURCE [SOURCE..] DESTINATION"+ ++parseOptions :: [String] -> Either ErrorString ([FilePath],Options)+parseOptions args = case getOpt Permute options args of+ (o,places,[]) -> Right $ (places, foldl (flip id) (def,def) o)+ (_,_,err) -> + let errs = if not (null err) + then "Bad options: \n" ++ concat err ++ "\n" + else ""+ in+ Left $ errs ++ usage
+ src/Pattern.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}++module Pattern where++import System.Time+import System.FilePath+import System.Locale ( defaultTimeLocale )++import Data.Accessor+import Data.Accessor.Basic ( get )+import Data.Accessor.Template++import Data.List.Split ( split, dropBlanks, whenElt )+import Text.Printf++import Control.Monad.Error () -- brings instance for Monad (Either String b)+import Debug.Trace+import System.IO.Unsafe ( unsafePerformIO )++type ErrString = String++data PatternEnv = PatternEnv { file_ :: FilePath+ , basename_ :: FilePath+ , ext_ :: FilePath+ , modtime_ :: ClockTime+ }++++$( deriveAccessors ''PatternEnv )++makeEnv mt fp = PatternEnv { file_ = takeFileName fp+ , basename_ = takeBaseName fp+ , ext_ = takeExtension fp+ , modtime_ = mt+ }++-- | compile file pattern and produce function that maps clock time and file name into resulting file name+compilePattern :: String -> Either ErrString (ClockTime -> String -> String)+compilePattern pat = case compilePatternLow pat of+ Left err -> Left err+ Right fun -> Right (\mt fp -> fun (makeEnv mt fp))++-- | compile pattern into environment-taking function that returns final string+compilePatternLow pat = let f <> g = \e -> (f e) ++ (g e)+ aux acc [] = return acc+ aux acc ("{":funargs:"}":rest) = do+ let (fun,spaceargs) = break (==' ') funargs+ args = dropWhile (== ' ') spaceargs+ newFun <- getFunction fun args+ aux (acc <> newFun) rest+ aux acc ("{":_) = fail "Bad format: unterminated '{'"+ aux acc (sth:rest) = aux (acc <> const sth) rest+ in+ aux (const "") (split (whenElt (`elem` "{}")) pat)+ ++-- | return function that applied to environment will return string+getFunction "file" "" = Right (get file)+getFunction "ext" "" = Right (get ext)+getFunction "basename" "" = Right (get basename)+ +getFunction "file" _ = Left "Function 'file' takes no arguments."+getFunction "ext" _ = Left "Function 'ext' takes no arguments."+getFunction "basename" _ = Left "Function 'basename' takes no arguments."++getFunction "modtime" [] = Left "Function 'modtime' requires format string as an argument."+getFunction "modtime" format = Right (\ env -> let mt = (get modtime) $ env+ ct = unsafePerformIO (toCalendarTime mt)+ in+ formatCalendarTime defaultTimeLocale format ct)++getFunction xx yy = Left (printf "Unknown function: '%s', args: %s" xx (show yy))++++{-+functions = ["file"+ ,"basename"+ ,"ext"+ ,"modtime"]+-}