diff options
Diffstat (limited to 'Logs')
-rw-r--r-- | Logs/Line.hs | 51 | ||||
-rw-r--r-- | Logs/MapLog.hs | 3 | ||||
-rw-r--r-- | Logs/Presence/Pure.hs | 3 | ||||
-rw-r--r-- | Logs/SingleValue.hs | 3 | ||||
-rw-r--r-- | Logs/Transitions.hs | 3 | ||||
-rw-r--r-- | Logs/UUIDBased.hs | 3 |
6 files changed, 61 insertions, 5 deletions
diff --git a/Logs/Line.hs b/Logs/Line.hs new file mode 100644 index 000000000..a7e17190e --- /dev/null +++ b/Logs/Line.hs @@ -0,0 +1,51 @@ +{- + +The Glasgow Haskell Compiler License + +Copyright 2001, The University Court of the University of Glasgow. +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. + +- Neither name of the University nor 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 UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + +-} + +module Logs.Line where + +-- This is the same as Data.List.lines, with \r added. +-- This works around some versions of git-annex which wrote \r +-- into git-annex branch files on Windows. Those \r's sometimes +-- accumulated over time, so a single line could end with multiple \r's +-- before the \n. +splitLines :: String -> [String] +splitLines "" = [] +splitLines s = cons (case break (\c -> c == '\n' || c == '\r') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> splitLines s'')) + where + cons ~(h, t) = h : t diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs index d5bb67f68..097439ac5 100644 --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -18,6 +18,7 @@ import Data.Time.Clock.POSIX import Common import Logs.TimeStamp +import Logs.Line data TimeStamp = Unknown | Date POSIXTime deriving (Eq, Ord, Show) @@ -38,7 +39,7 @@ showMapLog fieldshower valueshower = unlines . map showpair . M.toList unwords ["0", fieldshower f, valueshower v] parseMapLog :: Ord f => (String -> Maybe f) -> (String -> Maybe v) -> String -> MapLog f v -parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . lines +parseMapLog fieldparser valueparser = M.fromListWith best . mapMaybe parse . splitLines where parse line = do let (ts, rest) = splitword line diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs index e2ec3f13d..7955c8da3 100644 --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Annex.Common import Logs.TimeStamp +import Logs.Line import Utility.QuickCheck data LogLine = LogLine { @@ -25,7 +26,7 @@ data LogStatus = InfoPresent | InfoMissing | InfoDead {- Parses a log file. Unparseable lines are ignored. -} parseLog :: String -> [LogLine] -parseLog = mapMaybe parseline . lines +parseLog = mapMaybe parseline . splitLines where parseline l = LogLine <$> parsePOSIXTime d diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs index 9b1306c98..201e205eb 100644 --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -16,6 +16,7 @@ module Logs.SingleValue where import Annex.Common import qualified Annex.Branch import Logs.TimeStamp +import Logs.Line import qualified Data.Set as S import Data.Time.Clock.POSIX @@ -37,7 +38,7 @@ showLog = unlines . map showline . S.toList showline (LogEntry t v) = unwords [show t, serialize v] parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v -parseLog = S.fromList . mapMaybe parse . lines +parseLog = S.fromList . mapMaybe parse . splitLines where parse line = do let (ts, s) = splitword line diff --git a/Logs/Transitions.hs b/Logs/Transitions.hs index 544004768..07667c407 100644 --- a/Logs/Transitions.hs +++ b/Logs/Transitions.hs @@ -19,6 +19,7 @@ import qualified Data.Set as S import Annex.Common import Logs.TimeStamp +import Logs.Line transitionsLog :: FilePath transitionsLog = "transitions.log" @@ -50,7 +51,7 @@ showTransitions = unlines . map showTransitionLine . S.elems {- If the log contains new transitions we don't support, returns Nothing. -} parseTransitions :: String -> Maybe Transitions -parseTransitions = check . map parseTransitionLine . lines +parseTransitions = check . map parseTransitionLine . splitLines where check l | all isJust l = Just $ S.fromList $ catMaybes l diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs index 5613c6fb4..97ecd1011 100644 --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -35,6 +35,7 @@ import Common import Types.UUID import Logs.MapLog import Logs.TimeStamp +import Logs.Line type Log v = MapLog UUID v @@ -50,7 +51,7 @@ parseLog :: (String -> Maybe a) -> String -> Log a parseLog = parseLogWithUUID . const parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a -parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines +parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . splitLines where parse line -- This is a workaround for a bug that caused |