diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,21 @@ +### 1.4.2.0 + +- Fix regression (introduced in 1.4.1.0 release) in `Data.Compression.Inflate` +- Drop redundant dependency on `HUnit` +- Add more explicit `SafeHaskell` annotations to modules; all modules + except for `System.Debian` are now explicitly either `Safe` or `Trustworthy` +- Add support for `network-3.0` and `network-3.1` + +## 1.4.1.0 + +- Support for GHC 8.6.1 / `base-4.12` ([#45](https://github.com/haskell-hvr/missingh/issues/45)) + +### 1.4.0.1 + +- Restore compatibility with GHC 7.4.2 + +# 1.4.0.0 + +- Removal of `Data.Hash.CRC32.Posix` and `System.Time.Utils.ParseDate` + +- Added explicit `SafeHaskell` annotations to modules diff --git a/Makefile b/Makefile deleted file mode 100644 --- a/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# Copyright (C) 2004 - 2009 John Goerzen -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2.1 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -all: setup - @echo "Please use Cabal to build this package; not make." - ./setup configure - ./setup build - -setup: Setup.hs - ghc --make -o setup Setup.hs - -install: setup - ./setup install - -clean: - runghc ./Setup.hs clean - -.PHONY: test -test: test-ghc test-hugs - @echo "" - @echo "All tests pass." - -test-hugs: setup - @echo " ****** Running hugs tests" - ./setup configure -f buildtests --hugs - ./setup build - runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \ - dist/scratch/programs/runtests/Main.hs - -test-ghc: setup - @echo " ****** Building GHC tests" - ./setup configure -f buildtests - ./setup build - @echo " ****** Running GHC tests" - ./dist/build/runtests/runtests diff --git a/MissingH.cabal b/MissingH.cabal --- a/MissingH.cabal +++ b/MissingH.cabal @@ -1,131 +1,194 @@ -Name: MissingH -Version: 1.4.1.0 -License: BSD3 -Maintainer: John Goerzen -Author: John Goerzen -Copyright: Copyright (c) 2004-2018 John Goerzen +cabal-version: 1.12 +name: MissingH +version: 1.4.2.0 + +build-type: Simple +license: BSD3 +author: John Goerzen +copyright: Copyright (c) 2004-2018 John Goerzen +maintainer: Herbert Valerio Riedel license-file: LICENSE -extra-source-files: LICENSE, - announcements/0.10.0.txt, - announcements/0.8.0.txt, - announcements/0.9.0.txt, - testsrc/gzfiles/empty.gz, - testsrc/gzfiles/t1.gz, - testsrc/gzfiles/t1bad.gz, - testsrc/gzfiles/t2.gz, - testsrc/gzfiles/zeros.gz, - testsrc/mime.types.test, - 3rd-party-licenses/BSD, - 3rd-party-licenses/LGPL-2.1, - Makefile, - TODO, - examples/simplegrep.hs, - examples/test2.hs, - examples/test3.hs, - pending/Gopher.hs, - pending/Maildir.disabled, - pending/Tar.newhs, - pending/Tar/HeaderParser.newhs, - tolgpl, - winbuild.bat, - wintest.bat -homepage: http://software.complete.org/missingh -Category: Unclassified +tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + synopsis: Large utility library -Description: MissingH is a library of all sorts of utility functions for - Haskell programmers. It is written in pure Haskell and thus should - be extremely portable and easy to use. -Stability: Beta -Build-Type: Simple -Cabal-Version: >=1.8 +description: + @MissingH@ is a library of all sorts of utility functions for Haskell + programmers. It is written in pure Haskell and thus should be + extremely portable and easy to use. +category: Unclassified +bug-reports: https://github.com/hvr/missingh/issues -Library - Hs-Source-Dirs: src - Exposed-Modules: - Data.String.Utils, System.IO.Utils, System.IO.Binary, Data.List.Utils, - System.Daemon, - Text.ParserCombinators.Parsec.Utils, - Network.Email.Mailbox, - Control.Concurrent.Thread.Utils, - Network.Email.Sendmail, - Data.CSV, - System.Cmd.Utils, - Data.BinPacking, - Data.Progress.Tracker, - Data.Progress.Meter, - Data.Quantity, - Data.Map.Utils, System.Path, System.Path.NameManip, - System.Path.WildMatch, System.Path.Glob, - System.Time.Utils, - Network.Utils, - Network.SocketServer, - Data.Either.Utils, - Data.Maybe.Utils, - Data.Tuple.Utils, - Data.Bits.Utils, - Data.Hash.CRC32.GZip, - Data.Hash.MD5, Data.Hash.MD5.Zord64_HARD, - Data.Compression.Inflate, - System.FileArchive.GZip, - System.IO.HVFS, - System.IO.HVFS.Combinators, - System.IO.HVFS.InstanceHelpers, - System.IO.HVFS.Utils, - System.IO.HVIO, System.IO.StatCompat, System.IO.WindowsCompat, - System.IO.PlafCompat, System.Posix.Consts, - System.Debian, System.Debian.ControlParser, - Data.MIME.Types, - System.Console.GetOpt.Utils +extra-source-files: + CHANGES.md + LICENSE + announcements/0.10.0.txt + announcements/0.8.0.txt + announcements/0.9.0.txt + testsrc/gzfiles/empty.gz + testsrc/gzfiles/t1.gz + testsrc/gzfiles/t1bad.gz + testsrc/gzfiles/t2.gz + testsrc/gzfiles/zeros.gz + testsrc/mime.types.test + 3rd-party-licenses/BSD + 3rd-party-licenses/LGPL-2.1 + examples/simplegrep.hs + examples/test2.hs + examples/test3.hs - Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, CPP, Rank2Types, - MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, - ScopedTypeVariables +flag network--GE-3_0_0 + description: [network](http://hackage.haskell.org/package/network) ≥ 3.0.0 + default: True + manual: False - Build-Depends: network, parsec, base, - mtl, HUnit, regex-compat, - filepath, - hslogger, - base >= 4.5, base < 5, directory, random, process, old-time, - containers, old-locale, array, time - If ! os(windows) - Build-Depends: unix +source-repository head + type: git + location: https://github.com/hvr/missingh.git +library + hs-source-dirs: src + exposed-modules: + Control.Concurrent.Thread.Utils + Data.BinPacking + Data.Bits.Utils + Data.CSV + Data.Compression.Inflate + Data.Either.Utils + Data.Hash.CRC32.GZip + Data.Hash.MD5 + Data.Hash.MD5.Zord64_HARD + Data.List.Utils + Data.MIME.Types + Data.Map.Utils + Data.Maybe.Utils + Data.Progress.Meter + Data.Progress.Tracker + Data.Quantity + Data.String.Utils + Data.Tuple.Utils + Network.Email.Mailbox + Network.Email.Sendmail + Network.SocketServer + Network.Utils + System.Cmd.Utils + System.Console.GetOpt.Utils + System.Daemon + System.Debian + System.Debian.ControlParser + System.FileArchive.GZip + System.IO.Binary + System.IO.HVFS + System.IO.HVFS.Combinators + System.IO.HVFS.InstanceHelpers + System.IO.HVFS.Utils + System.IO.HVIO + System.IO.PlafCompat + System.IO.StatCompat + System.IO.Utils + System.IO.WindowsCompat + System.Path + System.Path.Glob + System.Path.NameManip + System.Path.WildMatch + System.Posix.Consts + System.Time.Utils + Text.ParserCombinators.Parsec.Utils + + default-language: Haskell2010 + default-extensions: + ExistentialQuantification + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + OverlappingInstances + Rank2Types + ScopedTypeVariables + UndecidableInstances + other-extensions: + CPP + Safe + Trustworthy + TypeSynonymInstances + + build-depends: + array >= 0.4.0.0 && < 0.6 + , base >= 4.5.0.0 && < 4.13 + , containers >= 0.4.2.1 && < 0.7 + , directory >= 1.1.0.2 && < 1.4 + , filepath >= 1.3.0.0 && < 1.5 + , hslogger >= 1.3.0.0 && < 1.4 + , mtl >= 1.1.1.0 && < 2.3 + , old-locale == 1.0.* + , old-time == 1.1.* + , parsec == 3.1.* && (< 3.1.12 || >= 3.1.13) + , process >= 1.1.0.1 && < 1.7 + , random >= 1.0.1.1 && < 1.2 + , regex-compat >= 0.95.1 && < 0.96 + , time >= 1.4 && < 1.10 + + if flag(network--GE-3_0_0) + build-depends: network-bsd >= 2.8.1 && <2.9, + network >= 3.0 && <3.2 + else + build-depends: network >= 2.6.3.1 && <2.9 + + If !os(windows) + Build-Depends: unix >= 2.5.1.0 && < 2.8 + + ghc-options: -fno-warn-deprecations + +---------------------------------------------------------------------------- + test-suite runtests - type: exitcode-stdio-1.0 + type: exitcode-stdio-1.0 - Build-Depends: network, parsec, base, - mtl, HUnit, regex-compat, - errorcall-eq-instance, - filepath, - hslogger, - base >= 4.5, base < 5, directory, random, process, old-time, - containers, old-locale, array, time - If ! os(windows) - Build-Depends: unix - Build-Depends: testpack, QuickCheck, HUnit + hs-source-dirs: testsrc + main-is: runtests.hs + other-modules: + TestUtils - Main-Is: runtests.hs - HS-Source-Dirs: testsrc, ., src - Other-Modules: Bitstest, - CRC32GZIPtest, - Eithertest, - GZiptest, - Globtest, - HVFStest, - HVIOtest, - IOtest, - Listtest, - MIMETypestest, - Maptest, - Pathtest, - ProgressTrackertest, - Str.CSVtest, - Strtest, - Tests, - Timetest, + Bitstest + CRC32GZIPtest + Eithertest + GZiptest + Globtest + HVFStest + HVIOtest + IOtest + Listtest + MIMETypestest + Maptest + Pathtest + ProgressTrackertest + Str.CSVtest + Strtest + Tests + Timetest WildMatchtest - Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, CPP, Rank2Types, - MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, - ScopedTypeVariables + + default-language: Haskell2010 + + -- intra-package dependency + build-depends: MissingH + + -- deps with version bounds inherited via lib:MissingH component + build-depends: + base + , containers + , directory + , filepath + , old-time + , parsec + , regex-compat + , time + + if !os(windows) + build-depends: unix + + -- additional testsuite-specific dependencies + build-depends: + HUnit == 1.6.* +-- , QuickCheck == 2.7.* + , errorcall-eq-instance == 0.3.* + + ghc-options: -fno-warn-deprecations diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,2 @@ -#!/usr/bin/env runhugs - import Distribution.Simple - main = defaultMain diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,33 +0,0 @@ -Document MissingH/Quantity and see if it has tests yet - -Test forceEitherMsg - -Cmd: pOpenBoth -- read and write, use forkIO for one of them - -tests for new Parsec stuff - -HVFStest: - test all sorts of exceptions - test .. et al - -FTP server: - timeouts - Proper error checking lots of places, esp. runDataChan - -CSVtest: - Test CSV generation - -Add Quantity and ProgressTracker to README - --------------------------------------------------- -From: Jeremy Shaw -The patch to MissingH.HUnit includes a modified version of the 'tests' function -from Test.QuickCheck. That module has the license: - --- Module : Test.QuickCheck --- Copyright : (c) Koen Claessen, John Hughes 2001 --- License : BSD-style (see the file libraries/base/LICENSE) - -If this is problematic, let me know, and I can rewrite it. - -j. diff --git a/pending/Gopher.hs b/pending/Gopher.hs deleted file mode 100644 --- a/pending/Gopher.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- arch-tag: Gopher support -Copyright (C) 2004 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : MissingH.Network.Gopher - Copyright : Copyright (C) 2004 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen, - Maintainer : jgoerzen@complete.org - Stability : experimental - Portability: systems with networking - -This module provides types and generic support for Gopher clients or serves. - -Related standards: RFC1436 , -Gopher+ spec - -Written by John Goerzen, jgoerzen\@complete.org --} - -module MissingH.Network.Gopher (-- * Types - GopherEntry(..) - ) - where - -import MissingH.Printf -import MissingH.Str -import Data.FiniteMap - -{- | Type representing an entry in a Gopher directory. - -May add more Gopher+ stuff in here down the road. - -You can show a 'GopherEntry'. This will produce a one-line string suitable -for use on a Gopher server. - -You can 'read' to a 'GopherEntry'. This will parse a string as a one-line -piece of text suitable for use generating a 'GopherEntry'. - -Neither show nor read will consider the 'ea' member. -} -data GopherEntry = GopherEntry - { - selector :: String, -- ^ Path to file on server - gophertype :: Char, -- ^ Gopher0 type character - name :: String, -- ^ Gopher menu name - host :: String, -- ^ Content host name - port :: Integer, -- ^ Remote port - gopherpsupport :: Bool, -- ^ Whether Gopher+ is supported - ea :: FiniteMap String String -- ^ Gopher+ extended attributes - } - -instance Show GopherEntry where - show x = let basic = vsprintf "%c%s\t%s\t%s\t%d" - (gophertype x) (name x) (selector x) (host x) - (port x) - in if gopherpsupport x then - basic ++ "\t+" - else basic - -instance Read GopherEntry where - read s = let parts = split "\t" s - in - GopherEntry {selector = parts !! 2, - gophertype = head (parts !! 0), - name = parts !! 1, - host = parts !! 3, - port = read (parts !! 4), - gopherpsupport = length parts > 5 && (parts !! 5 == "+"), - ea = emptyFM - } diff --git a/pending/Maildir.disabled b/pending/Maildir.disabled deleted file mode 100644 --- a/pending/Maildir.disabled +++ /dev/null @@ -1,76 +0,0 @@ -{- -Copyright (C) 2005 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : MissingH.Email.Mailbox.Maildir - Copyright : Copyright (C) 2005 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Support for Maildir-style mailboxes. - -Information about the Maildir format can be found at: - - * - - * - -Written by John Goerzen, jgoerzen\@complete.org --} - -module MissingH.Email.Mailbox.Maildir(Maildir(..), readMaildir) -where - -import MissingH.Email.Mailbox -import System.Posix.IO(OpenMode(..)) -import System.Directory -import MissingH.Path -import MissingH.Maybe -import Control.Monad -import Text.Regex - -data Maildir = Maildir - {loc :: FilePath} -instance Show Maildir - where show x = loc x - -{- -splitFN :: String -> (String, Flags) - -splitFN fn = - - where (base, fstr) = - case span (/= ':') of - (h, []) = (h, []) - (h, f) = (h, tail f) - --} -{- | Open a Maildir mailbox. -} --- For reading only, for now. - -openMaildir :: FilePath -> IO Maildir -openMaildir fp = - do cwd <- getCurrentDirectory - let abspath = forceMaybeMsg "abspath readMaildir" $ absNormPath cwd fp - c <- getDirectoryContents fp - unless ("cur" `elem` c && "new" `elem` c && "tmp" `elem` c) - $ error (fp ++ " is not a valid Maildir.") - return (Maildir fp) diff --git a/pending/Tar.newhs b/pending/Tar.newhs deleted file mode 100644 --- a/pending/Tar.newhs +++ /dev/null @@ -1,61 +0,0 @@ -{- -Copyright (C) 2005 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : MissingH.FileArchive.Tar - Copyright : Copyright (C) 2005 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Tar file format handler - -Copyright (c) 2005 John Goerzen, jgoerzen\@complete.org - --} -module MissingH.FileArchive.Tar ( - - ) -where - -import MissingH.Checksum.CRC32.GZip -import MissingH.List -import Data.List -import Data.Bits -import Control.Monad.Error -import Control.Monad.State -import Data.Char -import Data.Word -import MissingH.Bits -import System.IO -import Numeric - -type Section = (Header, [Word8]) - -data GZipError = CRCError -- ^ CRC-32 check failed - | NotGZIPFile -- ^ Couldn't find a GZip header - | UnknownMethod -- ^ Compressed with something other than method 8 (deflate) - | UnknownError String -- ^ Other problem arose - deriving (Eq, Show) - -instance Error GZipError where - noMsg = UnknownError "" - strMsg = UnknownError - diff --git a/pending/Tar/HeaderParser.newhs b/pending/Tar/HeaderParser.newhs deleted file mode 100644 --- a/pending/Tar/HeaderParser.newhs +++ /dev/null @@ -1,98 +0,0 @@ -{- -Copyright (C) 2005 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : MissingH.FileArchive.Tar.HeaderParser - Copyright : Copyright (C) 2005 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Parser for tar-format headers. - -Copyright (c) 2005 John Goerzen, jgoerzen\@complete.org - --} -module MissingH.FileArchive.Tar.HeaderParser - ( - - ) - -where - -import Text.ParserCombinators.Parsec -import Data.Word -import Numeric - -{- | The data structure representing the Tar header. This occurs -at the beginning of each 'Section'. -} -data Header = - UStar { - name :: String, - mode :: Int, - uid :: Int, - gid :: Int, - size :: Integer, - mtime :: Integer, - chksum :: Word32, - typeflag :: Char, - linkname :: String, - magic :: String, - version :: String, - uname :: String, - gname :: String, - devmajor :: Integer, - devminor :: Integer, - prefix :: String} - deriving (Eq, Show) - -parseUStarHeader :: CharParser st Header -parseUStarHeader = - do name <- (grab 100 >>= rchopstr) - mode <- (grab 8 >>= rreadoct) - uid <- (grab 8 >>= rreadoct) - gid <- (grab 8 >>= rreadoct) - size <- (grab 8 >>= rreadoct) - mtime <- (grab 12 >>= rreadoct) - chksum <- (grab 8 >>= rreadoct) - typeflag <- anyChar - linkname <- (grab 100 >>= rchopstr) - string "ustar\0" -- Magic - string "00" -- Version - uname <- (grab 32 >>= rchopstr) - gname <- (grab 32 >>= rchopstr) - devmajor <- (grab 8 >>= rreadoct) - devminor <- (grab 8 >>= rreadoct) - prefix <- (grab 155 >>= rchopstr) - - return $ UStar {name = name, mode = mode, uid = uid, gid = gid, - size = size, mtime = mtime, chksum = chksum, - typeflag = typeflag, linkname = linkname, - magic = "", version = "", - uname = uname, gname = gname, devmajor = devmajor, - devminor = devminor, prefix = prefix} - where grab n = count n anyChar - chopstr = takeWhile (\c -> c /= '\0') - rchopstr = return . chopstr - chopsstr = takeWhile (\c -> c /= ' ') . chopstr - readoct :: (Num a) => String -> a - readoct = fst . head . readOct . chopsstr - rreadoct :: (Num a, Monad m) => String -> m a - rreadoct = return . readoct diff --git a/src/Control/Concurrent/Thread/Utils.hs b/src/Control/Concurrent/Thread/Utils.hs --- a/src/Control/Concurrent/Thread/Utils.hs +++ b/src/Control/Concurrent/Thread/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Control.Concurrent.Thread.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -26,9 +25,9 @@ ) where -import Control.Concurrent +import Control.Concurrent -{- | Takes a IO action and a function. The IO action will be called in a +{- | Takes a IO action and a function. The IO action will be called in a separate thread. When it is completed, the specified function is called with its result. This is a simple way of doing callbacks. -} diff --git a/src/Data/BinPacking.hs b/src/Data/BinPacking.hs --- a/src/Data/BinPacking.hs +++ b/src/Data/BinPacking.hs @@ -10,9 +10,8 @@ {- | Module : Data.BinPacking Copyright : Copyright (C) 2008-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Data/Bits/Utils.hs b/src/Data/Bits/Utils.hs --- a/src/Data/Bits/Utils.hs +++ b/src/Data/Bits/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Data.Bits.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with rawSystem @@ -24,8 +23,8 @@ module Data.Bits.Utils(getBytes, fromBytes, c2w8, s2w8, w82c, w82s) where -import Data.Bits -import Data.Word +import Data.Bits +import Data.Word {- | Returns a list representing the bytes that comprise a data type. @@ -34,7 +33,7 @@ > getBytes (0x12345678::Int) -> [0x12, 0x34, 0x56, 0x78] -} getBytes :: (Integral a, Bounded a, Bits a) => a -> [a] -getBytes input = +getBytes input = let getByte _ 0 = [] getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1) in @@ -51,7 +50,7 @@ fromBytes :: (Bits a, Num a) => [a] -> a fromBytes input = - let dofb accum [] = accum + let dofb accum [] = accum dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs in dofb 0 input diff --git a/src/Data/CSV.hs b/src/Data/CSV.hs --- a/src/Data/CSV.hs +++ b/src/Data/CSV.hs @@ -10,9 +10,8 @@ {- | Module : Data.CSV Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -50,7 +49,7 @@ lines; each line is a list of cells; and each cell is a String. Please note that CSV files may have a different number of cells on each line. -Also, it is impossible to distinguish a CSV line that has a call with no data +Also, it is impossible to distinguish a CSV line that has a cell with no data from a CSV line that has no cells. Here are some examples: diff --git a/src/Data/Compression/Inflate.hs b/src/Data/Compression/Inflate.hs --- a/src/Data/Compression/Inflate.hs +++ b/src/Data/Compression/Inflate.hs @@ -16,11 +16,9 @@ {- | Module : Data.Compression.Inflate - Copyright : Copyright (C) 2004 Ian Lynagh - License : 3-clause BSD + Copyright : Copyright (C) 2004 Ian Lynagh + SPDX-License-Identifier: BSD-3-Clause - Maintainer : Ian Lynagh, - Maintainer : Stability : provisional Portability: portable @@ -34,15 +32,15 @@ inflate, Output, Bit, bits_to_word32) where -import Data.Array -import Data.List -import Data.Maybe +import Control.Applicative +import Control.Monad +import Data.Array import qualified Data.Char -import Control.Applicative -import Control.Monad +import Data.List +import Data.Maybe -import Data.Bits -import Data.Word +import Data.Bits +import Data.Word inflate_string :: String -> String inflate_string = fst . inflate_string_remainder @@ -92,7 +90,7 @@ showList bs = showString $ "'" ++ map show_b bs ++ "'" show_b :: Bit -> Char -show_b (Bit True) = '1' +show_b (Bit True) = '1' show_b (Bit False) = '0' int_to_bits :: Int -> [Bit] @@ -111,10 +109,10 @@ offset is rarely used, so make it strict to avoid building huge closures. -} -data State = State { bits :: [Bit], -- remaining input bits - offset :: !Word32, -- num bits consumed mod 8 +data State = State { bits :: [Bit], -- remaining input bits + offset :: !Word32, -- num bits consumed mod 8 history :: Array Word32 Word32, -- last 32768 output words - loc :: Word32 -- where in history we are + loc :: Word32 -- where in history we are } data InfM a = InfM (State -> (a, State)) @@ -152,8 +150,8 @@ (ys, zs) -> (ys, s { bits = zs, offset = (n + offset s) `mod` 8 } ) - where need 0 xs = ([], xs) - need _ [] = error "get_bits: Don't have enough!" + where need 0 xs = ([], xs) + need _ [] = error "get_bits: Don't have enough!" need i (x:xs) = let (ys, zs) = need (i-1) xs in (x:ys, zs) extract_InfM :: InfM a -> (a, [Bit]) @@ -188,8 +186,8 @@ get_bit :: InfM Bit get_bit = do res <- get_bits 1 case res of - _ -> error $ "get_bit: expected exactly one bit" [x] -> return x + _ -> error $ "get_bit: expected exactly one bit" {- \section{Inflate itself} @@ -249,8 +247,8 @@ triple :: [a] -> [[a]] triple (a:b:c:xs) = [a,b,c]:triple xs -triple [] = [] -triple _ = error "triple: can't happen" +triple [] = [] +triple _ = error "triple: can't happen" make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32] make_lit_dist_lengths _ i _ | i < 0 = error "make_lit_dist_lengths i < 0" @@ -348,7 +346,7 @@ make_table :: [(Length, Code)] -> Table make_table lcs = case make_tree 0 $ sort $ filter ((/= 0) . fst) lcs of (tree, []) -> get_code tree - _ -> error $ "make_table: Left-over lcs from" + _ -> error $ "make_table: Left-over lcs from" get_code :: Tree -> InfM Code get_code (Branch zero_tree one_tree) diff --git a/src/Data/Either/Utils.hs b/src/Data/Either/Utils.hs --- a/src/Data/Either/Utils.hs +++ b/src/Data/Either/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Data.Either.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -27,7 +26,7 @@ eitherToMonadError, fromLeft, fromRight, fromEither ) where -import Control.Monad.Error +import Control.Monad.Error {- | Converts a Maybe value to an Either value, using the supplied parameter as the Left value if the Maybe is Nothing. @@ -43,39 +42,39 @@ e -- ^ (Left e) will be returned if the Maybe value is Nothing -> Maybe a -- ^ (Right a) will be returned if this is (Just a) -> m a -maybeToEither errorval Nothing = throwError errorval +maybeToEither errorval Nothing = throwError errorval maybeToEither _ (Just normalval) = return normalval {- | Pulls a "Right" value out of an Either value. If the Either value is Left, raises an exception with "error". -} forceEither :: Show e => Either e a -> a -forceEither (Left x) = error (show x) +forceEither (Left x) = error (show x) forceEither (Right x) = x {- | Like 'forceEither', but can raise a specific message with the error. -} forceEitherMsg :: Show e => String -> Either e a -> a forceEitherMsg msg (Left x) = error $ msg ++ ": " ++ show x -forceEitherMsg _ (Right x) = x +forceEitherMsg _ (Right x) = x {- | Takes an either and transforms it into something of the more generic MonadError class. -} eitherToMonadError :: MonadError e m => Either e a -> m a -eitherToMonadError (Left x) = throwError x +eitherToMonadError (Left x) = throwError x eitherToMonadError (Right x) = return x -- | Take a Left to a value, crashes on a Right fromLeft :: Either a b -> a fromLeft (Left a) = a -fromLeft _ = error "Data.Either.Utils.fromLeft: Right" +fromLeft _ = error "Data.Either.Utils.fromLeft: Right" -- | Take a Right to a value, crashes on a Left fromRight :: Either a b -> b fromRight (Right a) = a -fromRight _ = error "Data.Either.Utils.fromRight: Left" +fromRight _ = error "Data.Either.Utils.fromRight: Left" -- | Take an Either, and return the value inside it fromEither :: Either a a -> a -fromEither (Left a) = a +fromEither (Left a) = a fromEither (Right a) = a diff --git a/src/Data/Hash/CRC32/GZip.hs b/src/Data/Hash/CRC32/GZip.hs --- a/src/Data/Hash/CRC32/GZip.hs +++ b/src/Data/Hash/CRC32/GZip.hs @@ -10,25 +10,24 @@ {- | Module : Data.Hash.CRC32.GZip Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable CRC32 checksumming using the GZIP\/PKZIP algorithm as used in both -ISO 3309 and section 8.1.1.6.2 of ITU-T V.42 and referenced in +ISO 3309 and section 8.1.1.6.2 of ITU-T V.42 and referenced in RFC1952. -} module Data.Hash.CRC32.GZip where -import Data.Array -import Data.Bits -import Data.Word -import Data.List -import Data.Char +import Data.Array +import Data.Bits +import Data.Char +import Data.List +import Data.Word update_crc :: Word32 -> Char -> Word32 update_crc crc ch = @@ -43,7 +42,7 @@ calc_crc32 :: [Char] -> Word32 calc_crc32 s = update_crc_list 0 s - + gzipcrctab :: Array Int Word32 gzipcrctab = array (0,255) (zip [0..255] [ diff --git a/src/Data/Hash/MD5.hs b/src/Data/Hash/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/MD5.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +{- | + Module : Data.Hash.MD5 + Copyright : Copyright (C) 2001 Ian Lynagh + SPDX-License-Identifier: BSD-3-Clause OR GPL-2.0-or-later + + Maintainer : Ian Lynagh + Stability : provisional + Portability: portable + +Generation of MD5sums + +Written by Ian Lynagh, igloo\@earth.li +-} + +module Data.Hash.MD5 + ( md5 + , md5s + , md5i + , MD5(..) + , ABCD(..) + , Zord64 + , Str(..) + , BoolList(..) + , WordList(..) + ) where + +import Data.Bits +import Data.Char (chr, ord) +import Data.Word + +-- | Synonym for 'Word64' due to historic reasons +type Zord64 = Word64 + +-- ======================== TYPES AND CLASS DEFINTIONS ======================== + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Zord64) + +-- | Anything we want to work out the MD5 of must be an instance of class MD5 +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Zord64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + +-- | __WARNING__: This instance only defines the '+' operation +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + +-- ======================== EXPORTED FUNCTIONS ======================== + + +{- | The simplest function, gives you the MD5 of a string as 4-tuple of +32bit words. -} +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +{- | Returns a hex number ala the md5sum program. -} +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +{- | Returns an integer equivalent to hex number from 'md5s'. -} +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ======================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Zord64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotateL mid_a s + a' = b + rot_a + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ======================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Zord64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 diff --git a/src/Data/Hash/MD5.lhs b/src/Data/Hash/MD5.lhs deleted file mode 100644 --- a/src/Data/Hash/MD5.lhs +++ /dev/null @@ -1,359 +0,0 @@ ->{- | -> Module : Data.Hash.MD5 -> Copyright : Copyright (C) 2001 Ian Lynagh -> License : Either BSD or GPL -> -> Maintainer : Ian Lynagh -> Stability : provisional -> Portability: portable -> ->Generation of MD5sums -> ->Written by Ian Lynagh, igloo\@earth.li ->-} - -> module Data.Hash.MD5 (md5, md5s, md5i, -> MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where - -> import Data.Char -> import Data.Bits -> import Data.Word - - -Nasty kludge to create a type Zord64 which is really a Word64 but works -how we want in hugs ands nhc98 too... -Also need a rotate left function that actually works. - -#ifdef __GLASGOW_HASKELL__ -#define rotL rotateL -> type Zord64 = Word64 -#else - -> import Data.Hash.MD5.Zord64_HARD - -> rotL :: Word32 -> Rotation -> Word32 -> rotL a s = shiftL a s .|. shiftL a (s-32) - -#endif - -======================== TYPES AND CLASS DEFINTIONS ======================== - - -> type XYZ = (Word32, Word32, Word32) -> type Rotation = Int -> newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) -> newtype Str = Str String -> newtype BoolList = BoolList [Bool] -> newtype WordList = WordList ([Word32], Zord64) - -> -- | Anything we want to work out the MD5 of must be an instance of class MD5 -> class MD5 a where -> get_next :: a -> ([Word32], Int, a) -- get the next blocks worth -> -- \ \ \------ the rest of the input -> -- \ \--------- the number of bits returned -> -- \--------------- the bits returned in 32bit words -> len_pad :: Zord64 -> a -> a -- append the padding and length -> finished :: a -> Bool -- Have we run out of input yet? - - -Mainly exists because it's fairly easy to do MD5s on input where the -length is not a multiple of 8 - -> instance MD5 BoolList where -> get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) -> where (ys, zs) = splitAt 512 s -> len_pad l (BoolList bs) -> = BoolList (bs ++ [True] -> ++ replicate (fromIntegral $ (447 - l) .&. 511) False -> ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] -> ) -> where mangle [] = [] -> mangle xs = reverse ys ++ mangle zs -> where (ys, zs) = splitAt 8 xs -> finished (BoolList s) = s == [] - - -The string instance is fairly straightforward - -> instance MD5 Str where -> get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) -> where (ys, zs) = splitAt 64 s -> len_pad c64 (Str s) = Str (s ++ padding ++ l) -> where padding = '\128':replicate (fromIntegral zeros) '\000' -> zeros = shiftR ((440 - c64) .&. 511) 3 -> l = length_to_chars 8 c64 -> finished (Str s) = s == "" - - -YA instance that is believed will be useful - -> instance MD5 WordList where -> get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) -> where (xs, ys) = splitAt 16 ws -> taken = if l > 511 then 512 else l .&. 511 -> len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) -> where beginning = if length ws > 0 then start ++ lastone' else [] -> start = init ws -> lastone = last ws -> offset = c64 .&. 31 -> lastone' = [if offset > 0 then lastone + theone else lastone] -> theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) -> (fromIntegral $ offset .&. (31 - 7)) -> nextish = if offset == 0 then [128] else [] -> c64' = c64 + (32 - offset) -> num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) -> blanks = replicate num_blanks 0 -> lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) -> topsize = fromIntegral $ shiftR c64 32 -> size = [lowsize, topsize] -> newlen = l .&. (complement 511) -> + if c64 .&. 511 >= 448 then 1024 else 512 -> finished (WordList (_, z)) = z == 0 - - -> instance Num ABCD where -> ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) - - -======================== EXPORTED FUNCTIONS ======================== - - -> {- | The simplest function, gives you the MD5 of a string as 4-tuple of -> 32bit words. -} -> md5 :: (MD5 a) => a -> ABCD -> md5 m = md5_main False 0 magic_numbers m - - -> {- | Returns a hex number ala the md5sum program. -} -> md5s :: (MD5 a) => a -> String -> md5s = abcd_to_string . md5 - - -> {- | Returns an integer equivalent to hex number from 'md5s'. -} -> md5i :: (MD5 a) => a -> Integer -> md5i = abcd_to_integer . md5 - - -======================== THE CORE ALGORITHM ======================== - - -Decides what to do. The first argument indicates if padding has been -added. The second is the length mod 2^64 so far. Then we have the -starting state, the rest of the string and the final state. - -> md5_main :: (MD5 a) => -> Bool -- Have we added padding yet? -> -> Zord64 -- The length so far mod 2^64 -> -> ABCD -- The initial state -> -> a -- The non-processed portion of the message -> -> ABCD -- The resulting state -> md5_main padded ilen abcd m -> = if finished m && padded -> then abcd -> else md5_main padded' (ilen + 512) (abcd + abcd') m'' -> where (m16, l, m') = get_next m -> len' = ilen + fromIntegral l -> ((m16', _, m''), padded') = if not padded && l < 512 -> then (get_next $ len_pad len' m, True) -> else ((m16, l, m'), padded) -> abcd' = md5_do_block abcd m16' - - -md5_do_block processes a 512 bit block by calling md5_round 4 times to -apply each round with the correct constants and permutations of the -block - -> md5_do_block :: ABCD -- Initial state -> -> [Word32] -- The block to be processed - 16 32bit words -> -> ABCD -- Resulting state -> md5_do_block abcd0 w = abcd4 -> where (r1, r2, r3, r4) = rounds -> {- -> map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] -> -- [(5 * x + 1) `mod` 16 | x <- [0..15]] -> map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] -> -- [(3 * x + 5) `mod` 16 | x <- [0..15]] -> map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] -> -- [(7 * x) `mod` 16 | x <- [0..15]] -> -} -> perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] -> = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] -> perm5 _ = error "broke at perm5" -> perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] -> = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] -> perm3 _ = error "broke at perm3" -> perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] -> = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] -> perm7 _ = error "broke at perm7" -> abcd1 = md5_round md5_f abcd0 w r1 -> abcd2 = md5_round md5_g abcd1 (perm5 w) r2 -> abcd3 = md5_round md5_h abcd2 (perm3 w) r3 -> abcd4 = md5_round md5_i abcd3 (perm7 w) r4 - - -md5_round does one of the rounds. It takes an auxiliary function and foldls -(md5_inner_function f) to repeatedly apply it to the initial state with the -correct constants - -> md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I -> -- for those of you with a copy of -> -- the prayer book^W^WRFC) -> -> ABCD -- Initial state -> -> [Word32] -- The 16 32bit words of input -> -> [(Rotation, Word32)] -- The list of 16 rotations and -> -- additive constants -> -> ABCD -- Resulting state -> md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' -> where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns - - -Apply one of the functions md5_[fghi] and put the new ABCD together - -> md5_inner_function :: (XYZ -> Word32) -- Auxiliary function -> -> ABCD -- Initial state -> -> (Rotation, Word32) -- The rotation and additive -> -- constant (X[i] + T[j]) -> -> ABCD -- Resulting state -> md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) -> where mid_a = a + f(b,c,d) + ki -> rot_a = rotL mid_a s -> a' = b + rot_a - - -The 4 auxiliary functions - -> md5_f :: XYZ -> Word32 -> md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) -> {- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} - -> md5_g :: XYZ -> Word32 -> md5_g (x, y, z) = md5_f (z, x, y) -> {- was: (x .&. z) .|. (y .&. (complement z)) -} - -> md5_h :: XYZ -> Word32 -> md5_h (x, y, z) = x `xor` y `xor` z - -> md5_i :: XYZ -> Word32 -> md5_i (x, y, z) = y `xor` (x .|. (complement z)) - - -The magic numbers from the RFC. - -> magic_numbers :: ABCD -> magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) - - -The 4 lists of (rotation, additive constant) tuples, one for each round - -> rounds :: ([(Rotation, Word32)], -> [(Rotation, Word32)], -> [(Rotation, Word32)], -> [(Rotation, Word32)]) -> rounds = (r1, r2, r3, r4) -> where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), -> (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), -> (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), -> (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), -> (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), -> (s14, 0x49b40821)] -> r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), -> (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), -> (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), -> (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), -> (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), -> (s24, 0x8d2a4c8a)] -> r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), -> (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), -> (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), -> (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), -> (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), -> (s34, 0xc4ac5665)] -> r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), -> (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), -> (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), -> (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), -> (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), -> (s44, 0xeb86d391)] -> s11 = 7 -> s12 = 12 -> s13 = 17 -> s14 = 22 -> s21 = 5 -> s22 = 9 -> s23 = 14 -> s24 = 20 -> s31 = 4 -> s32 = 11 -> s33 = 16 -> s34 = 23 -> s41 = 6 -> s42 = 10 -> s43 = 15 -> s44 = 21 - - -======================== CONVERSION FUNCTIONS ======================== - - -Turn the 4 32 bit words into a string representing the hex number they -represent. - -> abcd_to_string :: ABCD -> String -> abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] - - -Split the 32 bit word up, swap the chunks over and convert the numbers -to their hex equivalents. - -> display_32bits_as_hex :: Word32 -> String -> display_32bits_as_hex w = swap_pairs cs -> where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] -> getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) -> swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs -> swap_pairs _ = [] - -Convert to an integer, performing endianness magic as we go - -> abcd_to_integer :: ABCD -> Integer -> abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) -> + rev_num b * 2^(64 :: Int) -> + rev_num c * 2^(32 :: Int) -> + rev_num d - -> rev_num :: Word32 -> Integer -> rev_num i = toInteger j `mod` (2^(32 :: Int)) -> -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ -> where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) -> 0 [0,8,16,24] - -Used to convert a 64 byte string to 16 32bit words - -> string_to_word32s :: String -> [Word32] -> string_to_word32s "" = [] -> string_to_word32s ss = this:string_to_word32s ss' -> where (s, ss') = splitAt 4 ss -> this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s - - -Used to convert a list of 512 bools to 16 32bit words - -> bools_to_word32s :: [Bool] -> [Word32] -> bools_to_word32s [] = [] -> bools_to_word32s bs = this:bools_to_word32s rest -> where (bs1, bs1') = splitAt 8 bs -> (bs2, bs2') = splitAt 8 bs1' -> (bs3, bs3') = splitAt 8 bs2' -> (bs4, rest) = splitAt 8 bs3' -> this = boolss_to_word32 [bs1, bs2, bs3, bs4] -> bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 -> boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 - - -Convert the size into a list of characters used by the len_pad function -for strings - -> length_to_chars :: Int -> Zord64 -> String -> length_to_chars 0 _ = [] -> length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) -> where this = chr $ fromIntegral $ n .&. 255 - diff --git a/src/Data/Hash/MD5/Zord64_HARD.hs b/src/Data/Hash/MD5/Zord64_HARD.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/MD5/Zord64_HARD.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | Obsolete legacy module +module Data.Hash.MD5.Zord64_HARD (Zord64) where + +import Data.Bits +import Data.Word + +data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) + +w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi +integerToW64 x = case x `quotRem` 0x100000000 of + (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} + +instance Show Zord64 + +instance Read Zord64 + +instance Num Zord64 where + W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} + where lo' = lo_a + lo_b + hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 + W64{lo=lo_a,hi=hi_a} - W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} + where lo' = lo_a - lo_b + hi' = hi_a - hi_b + if lo' > lo_a then 1 else 0 + fromInteger = integerToW64 + +instance Bits Zord64 where + W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} + where lo' = lo_a .&. lo_b + hi' = hi_a .&. hi_b + W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} + where lo' = lo_a .|. lo_b + hi' = hi_a .|. hi_b + shift w 0 = w + shift W64{lo=lo,hi=hi} x + | x > 63 = W64{lo=0,hi=0} + | x > 31 = W64{lo = 0, hi = shift lo (x-32)} + | x > 0 = W64{lo = shift lo x, hi = shift hi x .|. shift lo (x-32)} + | x < -63 = W64{lo=0,hi=0} + | x < -31 = W64{lo = shift hi (x+32), hi = 0} + | x < 0 = W64{lo = shift lo x .|. shift hi (x+32), hi = shift hi x} + complement W64{lo=lo,hi=hi} = W64{lo=complement lo,hi=complement hi} + +instance Integral Zord64 where + toInteger = w64ToInteger + +instance Real Zord64 +instance Enum Zord64 + diff --git a/src/Data/Hash/MD5/Zord64_HARD.lhs b/src/Data/Hash/MD5/Zord64_HARD.lhs deleted file mode 100644 --- a/src/Data/Hash/MD5/Zord64_HARD.lhs +++ /dev/null @@ -1,48 +0,0 @@ ->-- #hide -> module Data.Hash.MD5.Zord64_HARD (Zord64) where - -> import Data.Word -> import Data.Bits - -> data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) - -> w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi -> integerToW64 x = case x `quotRem` 0x100000000 of -> (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} - -> instance Show Zord64 - -> instance Read Zord64 - -> instance Num Zord64 where -> W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a + lo_b -> hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 -> W64{lo=lo_a,hi=hi_a} - W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a - lo_b -> hi' = hi_a - hi_b + if lo' > lo_a then 1 else 0 -> fromInteger = integerToW64 - -> instance Bits Zord64 where -> W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a .&. lo_b -> hi' = hi_a .&. hi_b -> W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} -> where lo' = lo_a .|. lo_b -> hi' = hi_a .|. hi_b -> shift w 0 = w -> shift W64{lo=lo,hi=hi} x -> | x > 63 = W64{lo=0,hi=0} -> | x > 31 = W64{lo = 0, hi = shift lo (x-32)} -> | x > 0 = W64{lo = shift lo x, hi = shift hi x .|. shift lo (x-32)} -> | x < -63 = W64{lo=0,hi=0} -> | x < -31 = W64{lo = shift hi (x+32), hi = 0} -> | x < 0 = W64{lo = shift lo x .|. shift hi (x+32), hi = shift hi x} -> complement W64{lo=lo,hi=hi} = W64{lo=complement lo,hi=complement hi} - -> instance Integral Zord64 where -> toInteger = w64ToInteger - -> instance Real Zord64 -> instance Enum Zord64 - diff --git a/src/Data/List/Utils.hs b/src/Data/List/Utils.hs --- a/src/Data/List/Utils.hs +++ b/src/Data/List/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Data.List.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -49,10 +48,12 @@ -- -- * Sub-List Selection -- sub, ) where -import Data.List(intersperse, concat, isPrefixOf, isSuffixOf, elemIndices, - elemIndex, elemIndices, tails, find, findIndex, isInfixOf, nub) -import Control.Monad.State(State, get, put) -import Data.Maybe(isJust) +import Control.Monad.State (State, get, put) +import Data.List (concat, elemIndex, elemIndices, + elemIndices, find, findIndex, intersperse, + isInfixOf, isPrefixOf, isSuffixOf, nub, + tails) +import Data.Maybe (isJust) {- | Merge two sorted lists into a single, sorted whole. @@ -83,7 +84,7 @@ mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] mergeBy cmp [] ys = ys mergeBy cmp xs [] = xs -mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) +mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) -- Ordering derives Eq, Ord, so the comparison below is valid. -- Explanation left as an exercise for the reader. -- Someone please put this code out of its misery. @@ -118,8 +119,8 @@ hasAny :: Eq a => [a] -- ^ List of elements to look for -> [a] -- ^ List to search -> Bool -- ^ Result -hasAny [] _ = False -- An empty search list: always false -hasAny _ [] = False -- An empty list to scan: always false +hasAny [] _ = False -- An empty search list: always false +hasAny _ [] = False -- An empty list to scan: always false hasAny search (x:xs) = if x `elem` search then True else hasAny search xs {- | Similar to Data.List.takeWhile, takes elements while the func is true. @@ -127,7 +128,7 @@ takeWhileList :: ([a] -> Bool) -> [a] -> [a] takeWhileList _ [] = [] takeWhileList func list@(x:xs) = - if func list + if func list then x : takeWhileList func xs else [] @@ -141,9 +142,9 @@ else list {- | Similar to Data.List.span, but performs the test on the entire remaining -list instead of just one element. +list instead of just one element. -@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ +@spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ -} spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) @@ -172,12 +173,12 @@ split _ [] = [] split delim str = let (firstline, remainder) = breakList (startswith delim) str - in + in firstline : case remainder of [] -> [] x -> if x == delim then [] : [] - else split delim + else split delim (drop (length delim) x) @@ -280,7 +281,7 @@ worker ((k, v):xs) accum = case lookup v accum of Nothing -> worker xs ((v, [k]) : accum) - Just y -> worker xs (addToAL accum v (k:y)) + Just y -> worker xs (addToAL accum v (k:y)) in worker oldl [] @@ -296,13 +297,13 @@ in unlines . map worker $ inp {- | The inverse of 'strFromAL', this function reads a string and outputs the -appropriate association list. +appropriate association list. Like 'strFromAL', this is designed to work with [(String, String)] association lists but may also work with other objects with simple representations. -} strToAL :: (Read a, Read b) => String -> [(a, b)] -strToAL inp = +strToAL inp = let worker line = case reads line of [(key, remainder)] -> case remainder of @@ -324,7 +325,7 @@ elemRIndex :: Eq a => a -> [a] -> Maybe Int elemRIndex item l = case reverse $ elemIndices item l of - [] -> Nothing + [] -> Nothing (x:_) -> Just x {- | Like elemRIndex, but returns -1 if there is nothing found. -} @@ -332,11 +333,11 @@ alwaysElemRIndex item list = case elemRIndex item list of Nothing -> -1 - Just x -> x + Just x -> x {- | Forces the evaluation of the entire list. -} seqList :: [a] -> [a] -seqList [] = [] +seqList [] = [] seqList list@(x:xs) = seq (seqList xs) list -------------------------------------------------- @@ -347,7 +348,7 @@ -} newtype WholeFunc a b = WholeFunc ([a] -> (WholeFunc a b, [a], [b])) -{- | This is an enhanced version of the concatMap or map functions in +{- | This is an enhanced version of the concatMap or map functions in Data.List. Unlike those functions, this one: @@ -401,7 +402,7 @@ > --> ["Hello",", T","his is"," ","a test."] -} fixedWidth :: [Int] -> WholeFunc a [a] -fixedWidth len = +fixedWidth len = WholeFunc (fixedWidthFunc len) where -- Empty input: Empty output, stop fixedWidthFunc _ [] = ((fixedWidth []), [], []) diff --git a/src/Data/MIME/Types.hs b/src/Data/MIME/Types.hs --- a/src/Data/MIME/Types.hs +++ b/src/Data/MIME/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- arch-tag: MIME Types main file Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : Data.MIME.Types Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Data/Map/Utils.hs b/src/Data/Map/Utils.hs --- a/src/Data/Map/Utils.hs +++ b/src/Data/Map/Utils.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{- +{- Copyright (c) 2004-2011 John Goerzen All rights reserved. @@ -10,9 +10,8 @@ {- | Module : Data.Map.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -29,8 +28,8 @@ ) where +import Data.List.Utils (flipAL, strFromAL, strToAL) import qualified Data.Map -import Data.List.Utils(flipAL, strToAL, strFromAL) {- | Converts a String, String Map into a string representation. See 'Data.List.Utils.strFromAL' for more on the similar function for @@ -71,7 +70,7 @@ flippedLookupM v fm = case Data.Map.lookup v (flipM fm) of Nothing -> [] - Just x -> x + Just x -> x {- | Performs a lookup, and raises an exception (with an error message prepended with the given string) if the key could not be found. @@ -80,5 +79,5 @@ Data.Map.Map key elt -> elt forceLookupM msg k fm = case Data.Map.lookup k fm of - Just x -> x + Just x -> x Nothing -> error $ msg ++ ": could not find key " ++ (show k) diff --git a/src/Data/Maybe/Utils.hs b/src/Data/Maybe/Utils.hs --- a/src/Data/Maybe/Utils.hs +++ b/src/Data/Maybe/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Data.Maybe.Utils Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -33,4 +32,4 @@ Nothing is supplied. -} forceMaybeMsg :: String -> Maybe a -> a forceMaybeMsg msg Nothing = error msg -forceMaybeMsg _ (Just x) = x +forceMaybeMsg _ (Just x) = x diff --git a/src/Data/Progress/Meter.hs b/src/Data/Progress/Meter.hs --- a/src/Data/Progress/Meter.hs +++ b/src/Data/Progress/Meter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- Copyright (c) 2006-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : Data.Progress.Meter Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Data/Progress/Tracker.hs b/src/Data/Progress/Tracker.hs --- a/src/Data/Progress/Tracker.hs +++ b/src/Data/Progress/Tracker.hs @@ -10,9 +10,8 @@ {- | Module : Data.Progress.Tracker Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Data/Quantity.hs b/src/Data/Quantity.hs --- a/src/Data/Quantity.hs +++ b/src/Data/Quantity.hs @@ -10,9 +10,8 @@ {- | Module : Data.Quantity Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -33,17 +32,17 @@ ) where -import Data.List -import Text.Printf -import Data.Char +import Data.Char +import Data.List +import Text.Printf {- | The options for 'quantifyNum' and 'renderNum' -} -data SizeOpts = SizeOpts { base :: Int, -- ^ The base from which calculations are made - powerIncr :: Int, -- ^ The increment to the power for each new suffix +data SizeOpts = SizeOpts { base :: Int, -- ^ The base from which calculations are made + powerIncr :: Int, -- ^ The increment to the power for each new suffix firstPower :: Int, -- ^ The first power for which suffixes are given - suffixes :: String -- ^ The suffixes themselves + suffixes :: String -- ^ The suffixes themselves } - + {- | Predefined definitions for byte measurement in groups of 1024, from 0 to 2**80 -} binaryOpts :: SizeOpts @@ -80,7 +79,7 @@ incrList = map idx2pwr [0..length (suffixes opts) - 1] incrIdxList = zip incrList [0..] idx2pwr i = i * powerIncr opts + firstPower opts - finderfunc (x, _) = (fromIntegral $ base opts) ** (fromIntegral x) + finderfunc (x, _) = (fromIntegral $ base opts) ** (fromIntegral x) <= (abs number) -- Find the largest item that does not exceed the number given. -- If the number is larger than the larger item in the list, @@ -88,7 +87,7 @@ (usedexp, expidx) = case find finderfunc (reverse incrIdxList) of - Just x -> x + Just x -> x Nothing -> head incrIdxList -- If not found, it's smaller than the first suffix = (suffixes opts !! (fromIntegral expidx)) procnum n = (fromRational . toRational $ n) / @@ -123,7 +122,7 @@ > "100.00u" If you want more control over the output, see 'quantifyNum'. -} -renderNum :: (Ord a, Real a) => +renderNum :: (Ord a, Real a) => SizeOpts -> Int -- ^ Precision of the result -> a -- ^ The number to examine @@ -157,7 +156,7 @@ map printit convnums where printit num = (printf ("%." ++ show prec ++ "f") num) ++ [suffix] - (convnums, suffix) = + (convnums, suffix) = (quantifyNums opts numbers)::([Double], Char) {- | Parses a String, possibly generated by 'renderNum'. Parses the suffix @@ -168,7 +167,7 @@ If you want an Integral result, the convenience function 'parseNumInt' is for you. -} -parseNum :: (Read a, Fractional a) => +parseNum :: (Read a, Fractional a) => SizeOpts -- ^ Information on how to parse this data -> Bool -- ^ Whether to perform a case-insensitive match -> String -- ^ The string to parse @@ -179,18 +178,18 @@ [(num, "")] -> Right num -- No suffix; pass number unhindered [(num, [suffix])] -> case lookup (caseTransformer suffix) suffixMap of - Nothing -> Left $ "Unrecognized suffix " ++ show suffix + Nothing -> Left $ "Unrecognized suffix " ++ show suffix Just power -> Right $ num * multiplier power [(_, suffix)] -> Left $ "Multi-character suffix " ++ show suffix _ -> Left "Multiple parses for input" - where suffixMap = zip (map caseTransformer . suffixes $ opts) + where suffixMap = zip (map caseTransformer . suffixes $ opts) (iterate (+ (powerIncr opts)) (firstPower opts)) caseTransformer x | insensitive = toLower x | otherwise = x multiplier :: (Read a, Fractional a) => Int -> a multiplier power = - fromRational . toRational $ + fromRational . toRational $ fromIntegral (base opts) ** fromIntegral power {- | Parse a number as with 'parseNum', but return the result as an 'Integral'. Any type such as Integer, Int, etc. can be used for the @@ -201,12 +200,12 @@ By using this function, a user can still say something like 1.5M and get an integral result. -} -parseNumInt :: (Read a, Integral a) => +parseNumInt :: (Read a, Integral a) => SizeOpts -- ^ Information on how to parse this data -> Bool -- ^ Whether to perform a case-insensitive match -> String -- ^ The string to parse -> Either String a parseNumInt opts insensitive inp = case (parseNum opts insensitive inp)::Either String Double of - Left x -> Left x + Left x -> Left x Right n -> Right (round n) diff --git a/src/Data/String/Utils.hs b/src/Data/String/Utils.hs --- a/src/Data/String/Utils.hs +++ b/src/Data/String/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} + {- arch-tag: String utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : Data.String.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -35,10 +36,10 @@ maybeRead ) where -import Data.List.Utils (startswith, endswith, join, split, replace) -import Data.Char (isAlpha, isAscii, isDigit) -import Data.Maybe (listToMaybe) -import Text.Regex (mkRegex, splitRegex) +import Data.Char (isAlpha, isAscii, isDigit) +import Data.List.Utils (endswith, join, replace, split, startswith) +import Data.Maybe (listToMaybe) +import Text.Regex (mkRegex, splitRegex) wschars :: String wschars = " \t\r\n" diff --git a/src/Data/Tuple/Utils.hs b/src/Data/Tuple/Utils.hs --- a/src/Data/Tuple/Utils.hs +++ b/src/Data/Tuple/Utils.hs @@ -10,13 +10,12 @@ {- | Module : Data.Tuple.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable -This module provides various helpful utilities for dealing with lists. +This module provides various helpful utilities for dealing with tuples. Written by Neil Mitchell, -} diff --git a/src/Network/Email/Mailbox.hs b/src/Network/Email/Mailbox.hs --- a/src/Network/Email/Mailbox.hs +++ b/src/Network/Email/Mailbox.hs @@ -10,9 +10,8 @@ {- | Module : Network.Email.Mailbox Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Network/Email/Sendmail.hs b/src/Network/Email/Sendmail.hs --- a/src/Network/Email/Sendmail.hs +++ b/src/Network/Email/Sendmail.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + {- arch-tag: Sendmail utility Copyright (c) 2004-2011 John Goerzen @@ -10,9 +12,8 @@ {- | Module : Network.Email.Sendmail Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/Network/SocketServer.hs b/src/Network/SocketServer.hs --- a/src/Network/SocketServer.hs +++ b/src/Network/SocketServer.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} + {- arch-tag: Generic Server Support Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : Network.SocketServer Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : experimental Portability: systems with networking @@ -44,21 +45,21 @@ handleHandler ) where -import Network.Socket -import Network.BSD -import Network.Utils -import Control.Concurrent -import System.IO +import Control.Concurrent +import Network.BSD +import Network.Socket +import Network.Utils +import System.IO import qualified System.Log.Logger {- | Options for your server. -} data InetServerOptions = InetServerOptions {listenQueueSize :: Int, - portNumber :: PortNumber, - interface :: HostAddress, - reuse :: Bool, - family :: Family, - sockType :: SocketType, - protoStr :: String + portNumber :: PortNumber, + interface :: HostAddress, + reuse :: Bool, + family :: Family, + sockType :: SocketType, + protoStr :: String } deriving (Eq, Show) @@ -71,13 +72,13 @@ The third is the address of the local endpoint. -} type HandlerT = Socket -> SockAddr -> SockAddr -> IO () - + {- | Get Default options. You can always modify it later. -} simpleTCPOptions :: Int -- ^ Port Number -> InetServerOptions simpleTCPOptions p = InetServerOptions {listenQueueSize = 5, portNumber = (fromIntegral p), - interface = iNADDR_ANY, + interface = 0, reuse = False, family = AF_INET, sockType = Stream, @@ -85,7 +86,7 @@ } data SocketServer = SocketServer {optionsSS :: InetServerOptions, - sockSS :: Socket} + sockSS :: Socket} deriving (Eq, Show) {- | Takes some options and sets up the 'SocketServer'. I will bind @@ -95,9 +96,9 @@ do proto <- getProtocolNumber (protoStr opts) s <- socket (family opts) (sockType opts) proto setSocketOption s ReuseAddr (case (reuse opts) of - True -> 1 + True -> 1 False -> 0) - bindSocket s (SockAddrInet (portNumber opts) + bind s (SockAddrInet (portNumber opts) (interface opts)) listen s (listenQueueSize opts) return $ SocketServer {optionsSS = opts, sockSS = s} @@ -106,8 +107,8 @@ handlers, if any. -} closeSocketServer :: SocketServer -> IO () closeSocketServer ss = - sClose (sockSS ss) - + close (sockSS ss) + {- | Handle one incoming request from the given 'SocketServer'. -} handleOne :: SocketServer -> HandlerT -> IO () handleOne ss func = @@ -115,7 +116,7 @@ in do a <- accept (sockSS ss) localaddr <- getSocketName (fst a) func (fst a) (snd a) localaddr - + {- | Handle all incoming requests from the given 'SocketServer'. -} serveForever :: SocketServer -> HandlerT -> IO () serveForever ss func = @@ -132,7 +133,7 @@ -} serveTCPforever :: InetServerOptions -- ^ Server options -> HandlerT -- ^ Handler function - -> IO () + -> IO () serveTCPforever options func = do sockserv <- setupSocketServer options serveForever sockserv func @@ -152,17 +153,17 @@ -> System.Log.Logger.Priority -- ^ Priority of logged messages -> HandlerT -- ^ Handler to call after logging -> HandlerT -- ^ Resulting handler -loggingHandler hname prio nexth socket r_sockaddr l_sockaddr = +loggingHandler hname prio nexth socket r_sockaddr l_sockaddr = do sockStr <- showSockAddr r_sockaddr - System.Log.Logger.logM hname prio + System.Log.Logger.logM hname prio ("Received connection from " ++ sockStr) - System.Log.Logger.traplogging hname - System.Log.Logger.WARNING "" (nexth socket r_sockaddr + System.Log.Logger.traplogging hname + System.Log.Logger.WARNING "" (nexth socket r_sockaddr l_sockaddr) System.Log.Logger.logM hname prio ("Connection " ++ sockStr ++ " disconnected") - + -- | Handle each incoming connection in its own thread to -- make the server multi-tasking. threadedHandler :: HandlerT -- ^ Handler to call in the new thread @@ -182,7 +183,7 @@ -} handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -- ^ Handler to call -> HandlerT -handleHandler func socket r_sockaddr l_sockaddr = +handleHandler func socket r_sockaddr l_sockaddr = do h <- socketToHandle socket ReadWriteMode hSetBuffering h LineBuffering func h r_sockaddr l_sockaddr diff --git a/src/Network/Utils.hs b/src/Network/Utils.hs --- a/src/Network/Utils.hs +++ b/src/Network/Utils.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + {- arch-tag: Network utilities main file Copyright (c) 2004-2011 John Goerzen @@ -8,9 +11,8 @@ {- | Module : Network.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: systems with networking @@ -24,10 +26,9 @@ listenTCPAddr, showSockAddr) where -import Network -import Network.Socket -import Network.BSD -import System.IO +import Network.BSD +import Network.Socket +import System.IO #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import qualified System.Posix.Signals #endif @@ -70,7 +71,7 @@ listenTCPAddr addr queuelen = do proto <- getProtocolNumber "tcp" s <- socket AF_INET Stream proto - bindSocket s addr + bind s addr listen s queuelen return s @@ -78,6 +79,6 @@ #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) showSockAddr (SockAddrUnix x) = return $ "UNIX socket at " ++ x #endif -showSockAddr (SockAddrInet port host) = - do h <- inet_ntoa host +showSockAddr sa@(SockAddrInet port host) = + do (Just h,_) <- getNameInfo [NI_NUMERICHOST] True False sa return $ "IPv4 host " ++ h ++ ", port " ++ (show port) diff --git a/src/System/Cmd/Utils.hs b/src/System/Cmd/Utils.hs --- a/src/System/Cmd/Utils.hs +++ b/src/System/Cmd/Utils.hs @@ -1,5 +1,7 @@ -- arch-tag: Command utilities main file {-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + {- Copyright (c) 2004-2011 John Goerzen @@ -11,9 +13,8 @@ {- | Module : System.Cmd.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with POSIX process\/signal tools diff --git a/src/System/Console/GetOpt/Utils.hs b/src/System/Console/GetOpt/Utils.hs --- a/src/System/Console/GetOpt/Utils.hs +++ b/src/System/Console/GetOpt/Utils.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Safe #-} -{- +{- Copyright (c) 2005-2011 John Goerzen All rights reserved. @@ -10,9 +10,8 @@ {- | Module : MissingH.getOpt Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -28,8 +27,8 @@ stdOptional ) where -import System.Console.GetOpt -import System.Environment +import System.Console.GetOpt +import System.Environment {- | Simple command line parser -- a basic wrapper around the system's default getOpt. See the System.Console.GetOpt manual for a description of the @@ -40,11 +39,11 @@ The return value consists of the list of parsed flags and a list of non-option arguments. -} parseCmdLine :: ArgOrder a -> [OptDescr a] -> String -> IO ([a], [String]) -parseCmdLine order options header = +parseCmdLine order options header = do argv <- getArgs case getOpt order options argv of (o, n, []) -> return (o, n) - (_, _, errors) -> ioError (userError (concat errors ++ + (_, _, errors) -> ioError (userError (concat errors ++ usageInfo header options)) {- | Similar to 'parseCmdLine', but takes an additional function that validates @@ -80,5 +79,5 @@ {- | Handle an optional argument. -} stdOptional :: String -- ^ Name of arg -> Maybe String -> StdOption -stdOptional name Nothing = (name, "") +stdOptional name Nothing = (name, "") stdOptional name (Just x) = (name, x) diff --git a/src/System/Daemon.hs b/src/System/Daemon.hs --- a/src/System/Daemon.hs +++ b/src/System/Daemon.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + {- Copyright (c) 2005-2011 John Goerzen @@ -10,9 +12,8 @@ {- | Module : System.Daemon Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with POSIX process\/signal tools @@ -41,11 +42,11 @@ where #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Process -import System.Posix.IO -import System.Directory -import System.Log.Logger -import System.Exit +import System.Directory +import System.Exit +import System.Log.Logger +import System.Posix.IO +import System.Posix.Process trap :: IO a -> IO a diff --git a/src/System/Debian.hs b/src/System/Debian.hs --- a/src/System/Debian.hs +++ b/src/System/Debian.hs @@ -9,9 +9,8 @@ {- | Module : System.Debian Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -28,9 +27,9 @@ ) where -import System.Process -import System.IO.Unsafe -import System.Exit +import System.Exit +import System.IO.Unsafe (unsafePerformIO) +import System.Process {- | The type representing the contents of a Debian control file, or any control-like file (such as the output from apt-cache show, etc.) -} @@ -41,7 +40,10 @@ ---------------------------------------------------------------------- {- | The type representing a Debian version number. This type is an instance -of 'Prelude.Ord', but you can also use 'compareDebVersion' if you prefer. -} +of 'Prelude.Ord', but you can also use 'compareDebVersion' if you prefer. + +__WARNING__: calls out to @dpkg@ and will throw exceptions if @dpkg@ is missing +-} data DebVersion = DebVersion String deriving (Eq) instance Ord DebVersion where @@ -68,5 +70,5 @@ checkDebVersion v1 op v2 = do ec <- rawSystem "dpkg" ["--compare-versions", v1, op, v2] case ec of - ExitSuccess -> return True + ExitSuccess -> return True ExitFailure _ -> return False diff --git a/src/System/Debian/ControlParser.hs b/src/System/Debian/ControlParser.hs --- a/src/System/Debian/ControlParser.hs +++ b/src/System/Debian/ControlParser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- arch-tag: Parser for Debian control file Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : System.Debian.ControlParser Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -24,8 +25,8 @@ module System.Debian.ControlParser(control, depPart) where -import Text.ParserCombinators.Parsec -import Data.String.Utils (split) +import Data.String.Utils (split) +import Text.ParserCombinators.Parsec eol, extline :: GenParser Char st String eol = (try (string "\r\n")) diff --git a/src/System/FileArchive/GZip.hs b/src/System/FileArchive/GZip.hs --- a/src/System/FileArchive/GZip.hs +++ b/src/System/FileArchive/GZip.hs @@ -10,9 +10,8 @@ {- | Module : System.FileArchive.GZip Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -39,14 +38,14 @@ ) where -import Data.Compression.Inflate (inflate_string_remainder) -import Data.Hash.CRC32.GZip (update_crc) -import Data.Bits ((.&.)) -import Control.Monad.Error -- (Error(), strMsg, throwError) -import Data.Char (ord) -import Data.Word (Word32()) -import Data.Bits.Utils (fromBytes) -import System.IO (hGetContents, hPutStr, Handle()) +import Control.Monad.Error +import Data.Bits ((.&.)) +import Data.Bits.Utils (fromBytes) +import Data.Char (ord) +import Data.Compression.Inflate (inflate_string_remainder) +import Data.Hash.CRC32.GZip (update_crc) +import Data.Word (Word32) +import System.IO (Handle, hGetContents, hPutStr) data GZipError = CRCError -- ^ CRC-32 check failed | NotGZIPFile -- ^ Couldn't find a GZip header @@ -73,20 +72,20 @@ {- | The data structure representing the GZip header. This occurs at the beginning of each 'Section' on disk. -} data Header = Header { - method :: Int, -- ^ Compression method. Only 8 is defined at present. - flags :: Int, - extra :: Maybe String, + method :: Int, -- ^ Compression method. Only 8 is defined at present. + flags :: Int, + extra :: Maybe String, filename :: Maybe String, - comment :: Maybe String, - mtime :: Word32, -- ^ Modification time of the original file - xfl :: Int, -- ^ Extra flags - os :: Int -- ^ Creating operating system + comment :: Maybe String, + mtime :: Word32, -- ^ Modification time of the original file + xfl :: Int, -- ^ Extra flags + os :: Int -- ^ Creating operating system } deriving (Eq, Show) {- | Stored on-disk at the end of each section. -} data Footer = Footer { - size :: Word32, -- ^ The size of the original, decompressed data - crc32 :: Word32, -- ^ The stored GZip CRC-32 of the original, decompressed data + size :: Word32, -- ^ The size of the original, decompressed data + crc32 :: Word32, -- ^ The stored GZip CRC-32 of the original, decompressed data crc32valid :: Bool -- ^ Whether or not the stored CRC-32 matches the calculated CRC-32 of the data } diff --git a/src/System/IO/Binary.hs b/src/System/IO/Binary.hs --- a/src/System/IO/Binary.hs +++ b/src/System/IO/Binary.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} + {- arch-tag: I/O utilities, binary tools Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : System.IO.Binary Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable to platforms supporting binary I\/O diff --git a/src/System/IO/HVFS.hs b/src/System/IO/HVFS.hs --- a/src/System/IO/HVFS.hs +++ b/src/System/IO/HVFS.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE CPP, TypeSynonymInstances #-} +{-# LANGUAGE Trustworthy #-} {- arch-tag: HVFS main file Copyright (c) 2004-2011 John Goerzen @@ -10,9 +11,8 @@ {- | Module : System.IO.HVFS Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/System/IO/HVFS/Combinators.hs b/src/System/IO/HVFS/Combinators.hs --- a/src/System/IO/HVFS/Combinators.hs +++ b/src/System/IO/HVFS/Combinators.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} {- arch-tag: HVFS Combinators Copyright (c) 2004-2011 John Goerzen @@ -9,9 +10,8 @@ {- | Module : System.IO.HVFS.Combinators Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -26,17 +26,18 @@ HVFSChroot, newHVFSChroot) where -import System.IO -import System.IO.Error -import System.IO.HVFS -import System.IO.HVFS.InstanceHelpers (getFullPath) +import System.IO +import System.IO.Error +import System.IO.HVFS +import System.IO.HVFS.InstanceHelpers (getFullPath) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Files -- This actually needed? -Wall doesn't seem to think +import System.Posix.Files -- so, but I'm not sure... #endif -import System.Path (secureAbsNormPath) -import System.Path.NameManip (normalise_path) -import System.FilePath ((), pathSeparator, isPathSeparator) +import System.FilePath (isPathSeparator, pathSeparator, + ()) +import System.Path (secureAbsNormPath) +import System.Path.NameManip (normalise_path) ---------------------------------------------------------------------- -- Providing read-only access @@ -79,7 +80,7 @@ instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where vOpen fh fp mode = case mode of ReadMode -> withro (\h -> vOpen h fp mode) fh - _ -> roerror fh + _ -> roerror fh ---------------------------------------------------------------------- -- Restricting to a subdirectory diff --git a/src/System/IO/HVFS/InstanceHelpers.hs b/src/System/IO/HVFS/InstanceHelpers.hs --- a/src/System/IO/HVFS/InstanceHelpers.hs +++ b/src/System/IO/HVFS/InstanceHelpers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: HVFS instance helpers Copyright (c) 2004-2011 John Goerzen @@ -9,9 +10,8 @@ {- | Module : System.IO.HVFS.InstanceHelpers Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -33,21 +33,23 @@ getFullSlice) where -import Data.IORef (newIORef, readIORef, writeIORef, IORef()) -import Data.List (genericLength) -import System.IO -- (ReadMode) -import System.IO.Error (doesNotExistErrorType, illegalOperationErrorType, permissionErrorType) -import System.IO.HVFS -import System.IO.HVIO (newStreamReader) -import System.Path (absNormPath) -import System.Path.NameManip (slice_path) -import System.FilePath ((), pathSeparator, isPathSeparator) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (genericLength) +import System.FilePath (isPathSeparator, pathSeparator, ()) +import System.IO +import System.IO.Error (doesNotExistErrorType, + illegalOperationErrorType, + permissionErrorType) +import System.IO.HVFS +import System.IO.HVIO (newStreamReader) +import System.Path (absNormPath) +import System.Path.NameManip (slice_path) {- | A simple "System.IO.HVFS.HVFSStat" class that assumes that everything is either a file or a directory. -} data SimpleStat = SimpleStat { - isFile :: Bool, -- ^ True if file, False if directory + isFile :: Bool, -- ^ True if file, False if directory fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory } deriving (Show, Eq) instance HVFSStat SimpleStat where @@ -71,7 +73,7 @@ resizable ramdisk written in Haskell. -} data MemoryVFS = MemoryVFS { content :: IORef [MemoryNode], - cwd :: IORef FilePath + cwd :: IORef FilePath } instance Show MemoryVFS where @@ -99,7 +101,7 @@ nice_slice :: String -> [String] nice_slice path | path == [pathSeparator] = [] - | otherwise = + | otherwise = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 @@ -152,7 +154,7 @@ in do c <- readIORef $ content x case walk (MemoryDirectory c) (sliced2) of - Left err -> vRaiseError x doesNotExistErrorType err Nothing + Left err -> vRaiseError x doesNotExistErrorType err Nothing Right result -> return result -- | Find an element on the tree, normalizing the path first diff --git a/src/System/IO/HVFS/Utils.hs b/src/System/IO/HVFS/Utils.hs --- a/src/System/IO/HVFS/Utils.hs +++ b/src/System/IO/HVFS/Utils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + {- arch-tag: HVFS utilities main file Copyright (c) 2004-2011 John Goerzen @@ -10,13 +11,12 @@ {- | Module : System.IO.HVFS.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable -This module provides various helpful utilities for dealing +This module provides various helpful utilities for dealing filesystems. Written by John Goerzen, jgoerzen\@complete.org @@ -33,16 +33,16 @@ ) where -import System.IO.HVFS -import System.Time.Utils -import System.IO.PlafCompat -import Text.Printf -import System.Time -import System.Locale -import System.IO.Unsafe -import System.FilePath ((), pathSeparator) +import System.FilePath (pathSeparator, ()) +import System.IO.HVFS +import System.IO.PlafCompat +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Locale +import System.Time +import System.Time.Utils +import Text.Printf -{- | Obtain a recursive listing of all files\/directories beneath +{- | Obtain a recursive listing of all files\/directories beneath the specified directory. The traversal is depth-first and the original item is always present in the returned list. @@ -68,12 +68,12 @@ -} recurseDirStat :: HVFS a => a -> FilePath -> IO [(FilePath, HVFSStatEncap)] -recurseDirStat h fn = +recurseDirStat h fn = do fs <- vGetSymbolicLinkStatus h fn - if withStat fs vIsDirectory + if withStat fs vIsDirectory then do dirc <- vGetDirectoryContents h fn - let contents = map ((++) (fn ++ [pathSeparator])) $ + let contents = map ((++) (fn ++ [pathSeparator])) $ filter (\x -> x /= "." && x /= "..") dirc subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents return $ (concat subdirs) ++ [(fn, fs)] @@ -85,7 +85,7 @@ recursiveRemove :: HVFS a => a -> FilePath -> IO () recursiveRemove h fn = recurseDirStat h fn >>= (mapM_ $ - \(fn, fs) -> if withStat fs vIsDirectory + \(fn, fs) -> if withStat fs vIsDirectory then vRemoveDirectory h fn else vRemoveFile h fn ) @@ -96,7 +96,7 @@ -} lsl :: HVFS a => a -> FilePath -> IO String lsl fs fp = - let showmodes mode = + let showmodes mode = let i m = (intersectFileModes mode m /= 0) in (if i ownerReadMode then 'r' else '-') : @@ -110,10 +110,10 @@ (if i otherReadMode then 'r' else '-') : (if i otherWriteMode then 'w' else '-') : (if i otherExecuteMode then 'x' else '-') : [] - showentry origdir fh (state, fp) = + showentry origdir fh (state, fp) = case state of - HVFSStatEncap se -> - let typechar = + HVFSStatEncap se -> + let typechar = if vIsDirectory se then 'd' else if vIsSymbolicLink se then 'l' else if vIsBlockDevice se then 'b' @@ -122,15 +122,15 @@ else if vIsNamedPipe se then 's' else '-' clocktime = epochToClockTime (vModificationTime se) - datestr c= formatCalendarTime defaultTimeLocale "%b %e %Y" + datestr c= formatCalendarTime defaultTimeLocale "%b %e %Y" c in do c <- toCalendarTime clocktime linkstr <- case vIsSymbolicLink se of False -> return "" - True -> do sl <- vReadSymbolicLink fh + True -> do sl <- vReadSymbolicLink fh (origdir fp) return $ " -> " ++ sl - return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s" + return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s" typechar (showmodes (vFileMode se)) (toInteger $ vFileOwner se) @@ -141,9 +141,9 @@ linkstr in do c <- vGetDirectoryContents fs fp pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp x) - return (ss, x) + return (ss, x) ) c linedata <- mapM (showentry fp fs) pairs return $ unlines $ ["total 1"] ++ linedata - - + + diff --git a/src/System/IO/HVIO.hs b/src/System/IO/HVIO.hs --- a/src/System/IO/HVIO.hs +++ b/src/System/IO/HVIO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Safe #-} + {- arch-tag: HVIO main file Copyright (c) 2004-2011 John Goerzen @@ -10,9 +11,8 @@ {- | Module : System.IO.HVIO Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -120,14 +120,14 @@ ) where -import System.IO -import System.IO.Error -import qualified Control.Exception (catch, IOException) -import Control.Concurrent.MVar -import Data.IORef -import Foreign.Ptr -import Foreign.C -import Foreign.Storable +import Control.Concurrent.MVar +import qualified Control.Exception (IOException, catch) +import Data.IORef +import Foreign.C +import Foreign.Ptr +import Foreign.Storable +import System.IO +import System.IO.Error {- | This is the generic I\/O support class. All objects that are to be used in the HVIO system must provide an instance of 'HVIO'. @@ -286,7 +286,7 @@ let func = do c <- vGetChar h case c of '\n' -> return accum - x -> accum `seq` loop (accum ++ [x]) + x -> accum `seq` loop (accum ++ [x]) handler e = if isEOFError e then return accum else ioError e in Control.Exception.catch func handler @@ -294,7 +294,7 @@ do firstchar <- vGetChar h case firstchar of '\n' -> return [] - x -> loop [x] + x -> loop [x] vGetContents h = let loop = @@ -357,9 +357,7 @@ instance HVIO Handle where vClose = hClose vIsEOF = hIsEOF -#ifdef __GLASGOW_HASKELL__ vShow = hShow -#endif vMkIOError h et desc mfp = mkIOError et desc (Just h) mfp vGetChar = hGetChar @@ -434,7 +432,7 @@ d <- vioc_get (srv h) return $ case d of [] -> True - _ -> False + _ -> False vIsOpen = vioc_isopen . srv vGetChar h = do vTestEOF h c <- vioc_get (srv h) @@ -542,7 +540,7 @@ let newpos = case seekmode of AbsoluteSeek -> seekpos RelativeSeek -> pos + seekpos - SeekFromEnd -> (length buf) + seekpos + SeekFromEnd -> (length buf) + seekpos let buf2 = buf ++ if newpos > (length buf) then replicate (newpos - (length buf)) '\0' else [] diff --git a/src/System/IO/PlafCompat.hs b/src/System/IO/PlafCompat.hs --- a/src/System/IO/PlafCompat.hs +++ b/src/System/IO/PlafCompat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {- Platform Compatibility Layer Copyright (c) 2005-2011 John Goerzen @@ -11,9 +11,8 @@ {- | Module : System.IO.PlafCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -35,11 +34,11 @@ module System.Posix.Types) where -import System.Posix.Types +import System.Posix.Types #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.IO.WindowsCompat +import System.IO.WindowsCompat #else -import System.Posix.Files +import System.Posix.Files #endif {- | The name of the null device. NUL: on Windows, \/dev\/null everywhere else. diff --git a/src/System/IO/StatCompat.hs b/src/System/IO/StatCompat.hs --- a/src/System/IO/StatCompat.hs +++ b/src/System/IO/StatCompat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen @@ -11,9 +11,8 @@ {- | Module : System.IO.StatCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -24,12 +23,12 @@ module System.IO.StatCompat where -import System.Posix.Types -import System.Posix.Consts +import System.Posix.Consts +import System.Posix.Types #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Files(intersectFileModes) +import System.Posix.Files (intersectFileModes) #endif -import Data.Bits ((.&.)) +import Data.Bits ((.&.)) #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) type LinkCount = Int @@ -38,15 +37,15 @@ #endif data FileStatusCompat = - FileStatusCompat {deviceID :: DeviceID, - fileID :: FileID, - fileMode :: FileMode, - linkCount :: LinkCount, - fileOwner :: UserID, - fileGroup :: GroupID, - specialDeviceID :: DeviceID, - fileSize :: FileOffset, - accessTime :: EpochTime, + FileStatusCompat {deviceID :: DeviceID, + fileID :: FileID, + fileMode :: FileMode, + linkCount :: LinkCount, + fileOwner :: UserID, + fileGroup :: GroupID, + specialDeviceID :: DeviceID, + fileSize :: FileOffset, + accessTime :: EpochTime, modificationTime :: EpochTime, statusChangeTime :: EpochTime } diff --git a/src/System/IO/Utils.hs b/src/System/IO/Utils.hs --- a/src/System/IO/Utils.hs +++ b/src/System/IO/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} + {- Copyright (c) 2004-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : System.IO.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable -} @@ -34,10 +35,10 @@ optimizeForBatch, optimizeForInteraction ) where -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO -import Data.List (genericLength) -import System.IO.HVIO +import Data.List (genericLength) +import System.IO +import System.IO.HVIO +import System.IO.Unsafe (unsafeInterleaveIO) {- | Given a list of strings, output a line containing each item, adding newlines as appropriate. The list is not expected to have newlines already. diff --git a/src/System/IO/WindowsCompat.hs b/src/System/IO/WindowsCompat.hs --- a/src/System/IO/WindowsCompat.hs +++ b/src/System/IO/WindowsCompat.hs @@ -11,9 +11,8 @@ {- | Module : System.IO.WindowsCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable diff --git a/src/System/Path.hs b/src/System/Path.hs --- a/src/System/Path.hs +++ b/src/System/Path.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} {- arch-tag: Path utilities main file Copyright (C) 2004-2011 John Goerzen @@ -10,9 +11,8 @@ {- | Module : System.Path Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -31,21 +31,21 @@ mktmpdir, brackettmpdir, brackettmpdirCWD ) where -import Data.List -import Data.List.Utils +import Data.List +import Data.List.Utils #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Files -import System.Posix.Directory (createDirectory) -import System.Posix.Temp -import System.Directory hiding (createDirectory) +import System.Directory hiding (createDirectory) +import System.Posix.Directory (createDirectory) +import System.Posix.Files +import System.Posix.Temp #else -import System.Directory +import System.Directory #endif -import System.FilePath ((), pathSeparator, isPathSeparator) -import Control.Exception -import System.IO -import System.Path.NameManip -import System.IO.HVFS.Utils +import Control.Exception +import System.FilePath (isPathSeparator, pathSeparator, ()) +import System.IO +import System.IO.HVFS.Utils +import System.Path.NameManip {- | Splits a pathname into a tuple representing the root of the name and the extension. The extension is considered to be all characters from the last @@ -79,7 +79,7 @@ let abs = absolute_path_by base thepath in case guess_dotdot (normalise_path abs) of Just "." -> Just [pathSeparator] - x -> x + x -> x {- | Like absNormPath, but returns Nothing if the generated result is not the passed base path or a subdirectory thereof. -} @@ -111,16 +111,12 @@ createDirectory dirname 0o700 return dirname #else -#ifdef __GLASGOW_HASKELL__ mktmpdir x = do (fp, h) <- openTempFile "" x hClose h removeFile fp createDirectory fp return fp -#else -mktmpdir _ = fail "mktmpdir not supported on Windows unless you have GHC" -#endif #endif {- | Creates a temporary directory for your use via 'mktmpdir', diff --git a/src/System/Path/Glob.hs b/src/System/Path/Glob.hs --- a/src/System/Path/Glob.hs +++ b/src/System/Path/Glob.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- Copyright (c) 2006-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : System.Path.Glob Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -24,12 +25,13 @@ module System.Path.Glob (glob, vGlob) where -import Data.List.Utils (hasAny) -import System.IO.HVFS -import System.FilePath (splitFileName, (), pathSeparator, isPathSeparator) -import Control.Exception (tryJust) -import System.Path.WildMatch (wildCheckCase) -import Data.List (isSuffixOf) +import Control.Exception (tryJust) +import Data.List (isSuffixOf) +import Data.List.Utils (hasAny) +import System.FilePath (isPathSeparator, pathSeparator, + splitFileName, ()) +import System.IO.HVFS +import System.Path.WildMatch (wildCheckCase) hasWild :: String -> Bool hasWild = hasAny "*?[" diff --git a/src/System/Path/NameManip.hs b/src/System/Path/NameManip.hs --- a/src/System/Path/NameManip.hs +++ b/src/System/Path/NameManip.hs @@ -2,9 +2,8 @@ {- | Module : System.Path.NameManip Copyright : Copyright (C) 2004 Volker Wysk - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -15,9 +14,9 @@ module System.Path.NameManip where -import Data.List (intercalate, unfoldr) -import System.Directory (getCurrentDirectory) -import System.FilePath ((), pathSeparator, isPathSeparator) +import Data.List (intercalate, unfoldr) +import System.Directory (getCurrentDirectory) +import System.FilePath (isPathSeparator, pathSeparator, ()) {- | Split a path in components. Repeated \"@\/@\" characters don\'t lead to empty components. \"@.@\" path components are removed. If the path is absolute, the first component @@ -42,7 +41,7 @@ slice_path "" = [] slice_path (c:cs) = if isPathSeparator c then case slice_path' cs of - [] -> [[c]] + [] -> [[c]] (p:ps) -> (c:p):ps else slice_path' (c:cs) where diff --git a/src/System/Path/WildMatch.hs b/src/System/Path/WildMatch.hs --- a/src/System/Path/WildMatch.hs +++ b/src/System/Path/WildMatch.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} + {- Copyright (c) 2006-2011 John Goerzen @@ -9,9 +11,8 @@ {- | Module : System.Path.WildMatch Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -55,8 +56,8 @@ wildToRegex) where -import Text.Regex -import Data.String.Utils +import Data.String.Utils +import Text.Regex {- | Convert a wildcard to an (uncompiled) regular expression. @@ -74,20 +75,20 @@ wildCheckCase patt name = case matchRegex (mkRegex $ "^" ++ wildToRegex patt) name of Nothing -> False - Just _ -> True + Just _ -> True -- This is SO MUCH CLEANER than the python implementation! convwild :: String -> String -convwild [] = [] -convwild ('*':xs) = ".*" ++ convwild xs -convwild ('?':xs) = "." ++ convwild xs +convwild [] = [] +convwild ('*':xs) = ".*" ++ convwild xs +convwild ('?':xs) = "." ++ convwild xs convwild ('[':'!':xs) = "[^" ++ convpat xs -convwild ('[':xs) = '[' : convpat xs -convwild ('.':xs) = "\\." ++ convwild xs -convwild (x:xs) = escapeRe [x] ++ convwild xs +convwild ('[':xs) = '[' : convpat xs +convwild ('.':xs) = "\\." ++ convwild xs +convwild (x:xs) = escapeRe [x] ++ convwild xs convpat :: String -> String convpat ('\\':xs) = "\\\\" ++ convpat xs -convpat (']':xs) = ']' : convwild xs -convpat (x:xs) = x : convpat xs -convpat [] = [] +convpat (']':xs) = ']' : convwild xs +convpat (x:xs) = x : convpat xs +convpat [] = [] diff --git a/src/System/Posix/Consts.hs b/src/System/Posix/Consts.hs --- a/src/System/Posix/Consts.hs +++ b/src/System/Posix/Consts.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {- Posix consts not included with Haskell Copyright (c) 2005-2011 John Goerzen @@ -11,9 +10,8 @@ {- | Module : System.Posix.Consts Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -23,7 +21,7 @@ -} module System.Posix.Consts where -import System.Posix.Types +import System.Posix.Types blockSpecialMode :: FileMode blockSpecialMode = 0o0060000 diff --git a/src/System/Time/Utils.hs b/src/System/Time/Utils.hs --- a/src/System/Time/Utils.hs +++ b/src/System/Time/Utils.hs @@ -10,9 +10,8 @@ {- | Module : System.Time.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -32,8 +31,8 @@ renderSecs, renderTD ) where -import System.Time -import Data.Ratio +import Data.Ratio +import System.Time {- | January 1, 1970, midnight, UTC, represented as a CalendarTime. -} epoch :: CalendarTime @@ -57,7 +56,7 @@ timegm ct = timeDiffToSecs (diffClockTimes (toClockTime ct) (toClockTime epoch)) -{- | Converts the specified CalendarTime (see System.Time) to +{- | Converts the specified CalendarTime (see System.Time) to seconds-since-epoch format. The input CalendarTime is assumed to be the time as given in your local @@ -77,12 +76,12 @@ let newct = ct {ctTZ = ctTZ guessct} return $ timegm newct where guesscl = toClockTime ct - -{- | Converts the given timeDiff to the number of seconds it represents. +{- | Converts the given timeDiff to the number of seconds it represents. + Uses the same algorithm as normalizeTimeDiff in GHC. -} timeDiffToSecs :: TimeDiff -> Integer -timeDiffToSecs td = +timeDiffToSecs td = (fromIntegral $ tdSec td) + 60 * ((fromIntegral $ tdMin td) + 60 * ((fromIntegral $ tdHour td) + @@ -100,7 +99,7 @@ seconds = floor ratval secfrac = floor $ (ratval - (seconds % 1) ) * picosecondfactor picosecondfactor = 10 ^ 12 - + {- | Converts a ClockTime to something represented with an arbitrary Real. The result could be treated as a CTime from Foreign.C.Types or EpochTime from System.Posix.Types. The inverse of 'epochToClockTime'. @@ -125,7 +124,7 @@ renderTD itd = case workinglist of [] -> "0s" - _ -> concat . map (\(q, s) -> show q ++ [s]) $ workinglist + _ -> concat . map (\(q, s) -> show q ++ [s]) $ workinglist where td = normalizeTimeDiff itd suffixlist = "yMdhms" quantlist = (\(TimeDiff y mo d h m s _) -> [y, mo, d, h, m, s]) td diff --git a/src/Text/ParserCombinators/Parsec/Utils.hs b/src/Text/ParserCombinators/Parsec/Utils.hs --- a/src/Text/ParserCombinators/Parsec/Utils.hs +++ b/src/Text/ParserCombinators/Parsec/Utils.hs @@ -10,9 +10,8 @@ {- | Module : Text.ParserCombinators.Parsec.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen Stability : provisional Portability: portable @@ -30,7 +29,7 @@ notMatching ) where -import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec type GeneralizedToken a = (SourcePos, a) type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b @@ -86,8 +85,8 @@ If it fails, returns (). If it succeds, cause a failure and raise the given error message. It will not consume input in either case. -} notMatching :: GenParser a b c -> String -> GenParser a b () -notMatching p errormsg = - let maybeRead = try (do +notMatching p errormsg = + let maybeRead = try (do x <- p return (Just x) ) @@ -96,7 +95,7 @@ x <- maybeRead case x of Nothing -> return () - Just _ -> unexpected errormsg + Just _ -> unexpected errormsg in try workerFunc diff --git a/testsrc/Eithertest.hs b/testsrc/Eithertest.hs --- a/testsrc/Eithertest.hs +++ b/testsrc/Eithertest.hs @@ -8,11 +8,11 @@ -} module Eithertest(tests) where -import Test.HUnit -import Data.Either.Utils -import Test.HUnit.Tools -import Control.Exception -import Control.Exception.ErrorCall.EqInstance +import Control.Exception +import Control.Exception.ErrorCall.EqInstance +import Data.Either.Utils +import Test.HUnit +import TestUtils test_maybeToEither = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp inp in @@ -22,7 +22,7 @@ f "Nothing diff types" (maybeToEither "error" (Nothing::Maybe Int)) (Left "error"), f "Just" (maybeToEither "error" (Just "good")) (Right "good"), - f "Diff types" (maybeToEither "error" (Just (5::Int))) + f "Diff types" (maybeToEither "error" (Just (5::Int))) (Right (5::Int)) ] @@ -30,9 +30,8 @@ let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp inp in [ f "Right" (forceEither ((Right "foo")::Either Int String)) "foo", - TestLabel "Left" $ TestCase $ assertRaises "" - (ErrorCallWithLocation "\"wrong\"" "CallStack (from HasCallStack):\n error, called at src/Data/Either/Utils.hs:51:24 in main:Data.Either.Utils") - ("" @=? forceEither (Left "wrong")) + + TestLabel "Left" $ TestCase $ assertRaises ((== "\"wrong\"") . errorCallMsg) ("" @=? forceEither (Left "wrong")) ] tests = TestList [TestLabel "test_maybeToEither" (TestList test_maybeToEither), diff --git a/testsrc/Globtest.hs b/testsrc/Globtest.hs --- a/testsrc/Globtest.hs +++ b/testsrc/Globtest.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- Copyright (C) 2006-2011 John Goerzen @@ -12,7 +14,7 @@ import Test.HUnit import System.Path.Glob import System.Path -import Test.HUnit.Tools +import TestUtils import System.IO.HVFS import System.Directory(createDirectory) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) diff --git a/testsrc/HVFStest.hs b/testsrc/HVFStest.hs --- a/testsrc/HVFStest.hs +++ b/testsrc/HVFStest.hs @@ -12,7 +12,7 @@ import System.IO.HVFS import System.IO.HVFS.InstanceHelpers import System.IO.HVFS.Combinators -import Test.HUnit.Tools +import TestUtils import System.IO import System.IO.Error import Control.Exception diff --git a/testsrc/HVIOtest.hs b/testsrc/HVIOtest.hs --- a/testsrc/HVIOtest.hs +++ b/testsrc/HVIOtest.hs @@ -7,12 +7,12 @@ -} module HVIOtest(tests) where -import Test.HUnit -import System.IO.HVIO -import Test.HUnit.Tools +import Control.Exception import System.IO import System.IO.Error -import Control.Exception +import System.IO.HVIO +import Test.HUnit +import TestUtils ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp @@ -24,7 +24,7 @@ in [ f "" (\x -> do True `ioeq` vIsOpen x - assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) + assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vPutStrLn x "Line1" vPutStrLn x "Line2" vRewind x @@ -41,10 +41,10 @@ vPutStr x "IN" vRewind x "LINe1" `ioeq` vGetLine x - "Line2" `ioeq` vGetLine x + "Line2" `ioeq` vGetLine x vSeek x SeekFromEnd 0 vPutChar x 'c' - assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) + assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) vRewind x "LINe1\nLine2\nc" `ioeq` vGetContents x ) @@ -53,14 +53,14 @@ test_StreamReader = let f inp testfunc = TestLabel inp $ TestCase $ do x <- newStreamReader inp testfunc x - in + in [ f "" (\x -> do True `ioeq` vIsEOF x True `ioeq` vIsOpen x - assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) + assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vClose x False `ioeq` vIsOpen x - + ) ,f "abcd" (\x -> do False `ioeq` vIsEOF x True `ioeq` vIsOpen x @@ -76,7 +76,7 @@ "" `ioeq` vGetLine x "line5" `ioeq` vGetLine x "lastline" `ioeq` vGetLine x - assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) + assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) ) ] diff --git a/testsrc/IOtest.hs b/testsrc/IOtest.hs --- a/testsrc/IOtest.hs +++ b/testsrc/IOtest.hs @@ -10,7 +10,7 @@ module IOtest() where import Test.HUnit import System.IO -import Test.HUnit.Tools +import TestUtils diff --git a/testsrc/Listtest.hs b/testsrc/Listtest.hs --- a/testsrc/Listtest.hs +++ b/testsrc/Listtest.hs @@ -7,14 +7,13 @@ -} module Listtest(tests) where -import Test.HUnit -import Data.List.Utils -import Data.List -import Test.HUnit -import Test.QuickCheck as QC -import Test.HUnit.Tools +import Data.List +import Data.List.Utils +import Test.HUnit +import Test.HUnit +-- import Test.QuickCheck as QC -test_delFromAL = +test_delFromAL = let f :: [(String, Int)] -> [(String, Int)] -> Test f inp exp = TestCase $ exp @=? (delFromAL inp "testkey") in [ @@ -115,7 +114,7 @@ ,f 2 [1, 2, 3, 4, 5] [1, 2] ,f 10 "Hello" "Hello" ,f 0 "" "" - ] + ] test_contains = let f msg sub testlist exp = TestCase $ assertEqual msg exp (contains sub testlist) in @@ -154,8 +153,8 @@ ,f 'f' ['f', 'b', 'f', 'f', 'b'] 3 ] -test_subIndex = - let f item inp exp = TestCase $ exp @=? subIndex item inp in +test_subIndex = + let f item inp exp = TestCase $ exp @=? subIndex item inp in [f "foo" "asdfoobar" (Just 3) ,f "foo" [] (Nothing) ,f "" [] (Just 0) @@ -179,7 +178,7 @@ ,f [1, 2, 3] "1234567890" ["1","23","456","7890"] ,f (repeat 2) "123456789" ["12","34","56","78","9"] ,f [] "123456789" ["123456789"] - ,f [5, 3, 6, 1] "Hello, This is a test." + ,f [5, 3, 6, 1] "Hello, This is a test." ["Hello",", T","his is"," ","a test."] ] @@ -208,23 +207,23 @@ f (contains "foo") "foo" ("f", "oo")] -test_merge = - qctest "prop_merge" prop_merge +-- test_merge = +-- qctest "prop_merge" prop_merge prop_merge xs ys = merge (sort xs) (sort ys) == sort (xs ++ ys) where types = xs :: [Int] -test_mergeBy = - qctest "test_mergeBy" prop_mergeBy +-- test_mergeBy = +-- qctest "test_mergeBy" prop_mergeBy prop_mergeBy xs ys = mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys) where types = xs :: [Int] cmp = compare -tests = TestList [test_merge, - test_mergeBy, +tests = TestList [-- test_merge, + -- test_mergeBy, TestLabel "delFromAL" (TestList test_delFromAL), TestLabel "uniq" (TestList test_uniq), TestLabel "addToAL" (TestList test_addToAL), diff --git a/testsrc/Strtest.hs b/testsrc/Strtest.hs --- a/testsrc/Strtest.hs +++ b/testsrc/Strtest.hs @@ -9,7 +9,7 @@ module Strtest(tests) where import Test.HUnit import Data.String.Utils -import Test.HUnit.Tools +import TestUtils import Text.Regex import Data.Char diff --git a/testsrc/TestUtils.hs b/testsrc/TestUtils.hs new file mode 100644 --- /dev/null +++ b/testsrc/TestUtils.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} + +module TestUtils (mapassertEqual, assertRaises, errorCallMsg) where + +import Control.Exception (ErrorCall (..), Exception, + Handler (Handler), SomeException, catches) +import Test.HUnit (Assertion, Test (TestCase), assertEqual, + assertFailure) + +mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test] +mapassertEqual label f xs + = [ TestCase $ assertEqual label result (f inp) | (inp,result) <- xs ] + + +assertRaises :: (Exception e, Show e) => (e -> Bool) -> IO a -> Assertion +assertRaises check act = do + res <- go `catches` [ Handler check', Handler anyEx ] + res + where + go = act >> return (assertFailure "action completed without exception") + + check' ex + | check ex = return (return ()) + | otherwise = return (assertFailure ("got exception of expected type *but* wrong value: " ++ show ex)) + + anyEx :: SomeException -> IO (Assertion) + anyEx ex = return (assertFailure ("got unexpected exception type: " ++ show ex)) + + +errorCallMsg :: ErrorCall -> String +errorCallMsg (ErrorCall msg) = msg +#if MIN_VERSION_base(4,9,0) +errorCallMsg (ErrorCallWithLocation msg _) = msg +#endif diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs --- a/testsrc/Tests.hs +++ b/testsrc/Tests.hs @@ -16,7 +16,6 @@ import qualified IOtest import qualified Bitstest import qualified Eithertest -import qualified CRC32POSIXtest import qualified CRC32GZIPtest import qualified GZiptest import qualified HVIOtest @@ -44,7 +43,6 @@ TestLabel "MIMETypes" MIMETypestest.tests, TestLabel "Bitstest" Bitstest.tests, TestLabel "Eithertest" Eithertest.tests, - TestLabel "CRC32POSIXtest" CRC32POSIXtest.tests, TestLabel "CRC32GZIPtest" CRC32GZIPtest.tests, TestLabel "GZiptest" GZiptest.tests] diff --git a/testsrc/WildMatchtest.hs b/testsrc/WildMatchtest.hs --- a/testsrc/WildMatchtest.hs +++ b/testsrc/WildMatchtest.hs @@ -11,7 +11,7 @@ module WildMatchtest(tests) where import Test.HUnit import System.Path.WildMatch -import Test.HUnit.Tools +import TestUtils test_wildCheckCase = let f patt name = TestCase $ assertBool (patt ++ "," ++ name ++ " was false") diff --git a/tolgpl b/tolgpl deleted file mode 100644 --- a/tolgpl +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/bash -ssed -i -e 's/GNU General/GNU Lesser General/g' \ - -e 's/ GPL/ LGPL/g' \ - -e 's/version 2 /version 2.1 /g' \ - -e 's/59 Temple Place, Suite 330, Boston, MA 02111-1307/51 Franklin St, Fifth Floor, Boston, MA 02110-1301/g' \ - $1 - diff --git a/winbuild.bat b/winbuild.bat deleted file mode 100644 --- a/winbuild.bat +++ /dev/null @@ -1,4 +0,0 @@ -ghc -package Cabal Setup.hs -o setup.exe -setup configure -setup build - diff --git a/wintest.bat b/wintest.bat deleted file mode 100644 --- a/wintest.bat +++ /dev/null @@ -1,5 +0,0 @@ -cd testsrc -ghc --make -package hslogger -package FilePath -package mtl -package HUnit -fallow-overlapping-instances -fallow-undecidable-instances -fglasgow-exts -cpp -o runtests.exe -i..\dist\build:..\src runtests.hs -cd .. -testsrc\runtests -