diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,110 @@ +# 1.6.0.3 + +_Andreas Abel, 2026-01-07_ + +- Allow `time < 2` +- Tested with GHC 8.0 - 9.14.1 + +# 1.6.0.2 + +_Andreas Abel, 2025-03-02_ + +- Drop support for GHC 7.10 +- Allow `containers < 1` +- Tested with GHC 8.0 - 9.12.1 + +# 1.6.0.1 + +_Andreas Abel, 2023-09-11_ + +- Repair build on Windows with GHC 9.6 (`directory-1.3.8.*`): + Revoke `Safe` status of these modules: + * `System.IO.WindowsCompat` + * `System.IO.PlafCompat` +- Tested with GHC 7.10 - 9.8 alpha1. + +# 1.6.0.0 + +_Andreas Abel, 2023-01-14_ + +- Allow `directory-1.3.8.0` which is no longer `Safe` Haskell. + Thus, we need to revoke `Safe` status of the following modules: + * `Data.MIME.Types` + * `Network.Email.Sendmail` + * `System.IO.HVFS` + * `System.IO.HVFS.Combinators` + * `System.IO.HVFS.InstanceHelpers` + * `System.Path` + * `System.Path.Glob` + * `System.Path.NameManip` +- Allow `unix-2.8.0.0` (enables `directory-1.3.8.0`). +- Tested with GHC 7.10 - 9.6 alpha1. + +### 1.5.0.1 + +_Andreas Abel, 2022-03-14_ + +- Repair build on Windows (regression in 1.5.0.0, [#59](https://github.com/haskell-hvr/missingh/issues/59)). +- Tested with GHC 7.10 - 9.2. + +# 1.5.0.0 + +_Andreas Abel, 2022-02-12_ + +- Dropped support for GHC ≤ 7.8. +- Support `mtl-2.3`: removed `Error` instance for `BinPackerError` and `GZipError`. +- Use `sortOn` in `packLargeFirst` ([#41](https://github.com/haskell-hvr/missingh/issues/41)). +- Fix warnings for `-Wall` and `-Wcompat`. +- Hardened code by making all imports explicit. +- Tested with GHC 7.10 - 9.2. + +### 1.4.3.1 + +_Andreas Abel, 2022-02-12_ + +- Remove spurious dependency on `random`. +- Bump upper bounds on `base` and `time`. +- Tested with GHC 7.0 - 9.2. + +## 1.4.3.0 + +_Herbert Valerio Riedel, 2020-04-09_ + +- New tuple construction helpers `Data.Tuple.Utils.dup` and `Data.Tuple.Utils.triple` +- Close sockets on connection failure in `connectTCPAddr` ([#50](https://github.com/haskell-hvr/missingh/issues/50)) + +### 1.4.2.1 + +_Herbert Valerio Riedel, 2019-05-20_ + +- GHC 7.0 only compat release + +## 1.4.2.0 + +_Herbert Valerio Riedel, 2019-05-14_ + +- 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 + +_John Goerzen, 2018-10-13_ + +- Support for GHC 8.6.1 / `base-4.12` ([#45](https://github.com/haskell-hvr/missingh/issues/45)) + +### 1.4.0.1 + +_John Goerzen, 2016-06-15_ + +- Restore compatibility with GHC 7.4.2 + +# 1.4.0.0 + +_John Goerzen, 2016-06-29_ + +- Removal of `Data.Hash.CRC32.Posix` and `System.Time.Utils.ParseDate` + +- Added explicit `SafeHaskell` annotations to modules diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -42,15 +42,6 @@ BSD license as MissingH itself. ---------------------------------------------------- -Data.Hash.CRC32.Posix is -(C) 2002 HardCore SoftWare, Doug Hoyte -and is "distributed under the terms of the GNU GPL." This license is -the same as the main license for MissingH. - -The code was obtained from -http://cvs.sourceforge.net/viewcvs.py/haskell-libs/libs/crypto/crc32.hs - ----------------------------------------------------- Data.Compression.Inflate is Copyright 2004 Ian Lynagh Licence: 3 clause BSD. @@ -77,12 +68,3 @@ The code was obtained from http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/md5/ ----------------------------------------------------- -System.Time.Utils.ParseDate is from -http://www.dtek.chalmers.se/~d00bring/projects.html - -Copyright (c) Bjrn Bringert -License: GNU General Public License, version 2 - -I (John Goerzen) have modified only the module name and Haddock -comments at the top of it. 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,141 +1,213 @@ -Name: MissingH -Version: 1.2.1.0 -License: BSD3 -Maintainer: John Goerzen -Author: John Goerzen -Copyright: Copyright (c) 2004-2014 John Goerzen +cabal-version: 1.24 +name: MissingH +version: 1.6.0.3 + +build-type: Simple +license: BSD3 +author: John Goerzen +copyright: Copyright (c) 2004-2018 John Goerzen +maintainer: Andreas Abel 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 == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.3 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.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/haskell-hvr/missingh/issues -Flag splitBase - description: Choose the new smaller, split-up base package. +extra-doc-files: + CHANGES.md + LICENSE + announcements/0.10.0.txt + announcements/0.8.0.txt + announcements/0.9.0.txt + 3rd-party-licenses/BSD + 3rd-party-licenses/LGPL-2.1 -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, System.Time.ParseDate, - Network.Utils, - Network.SocketServer, - Data.Either.Utils, - Data.Maybe.Utils, - Data.Tuple.Utils, - Data.Bits.Utils, - Data.Hash.CRC32.Posix, 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: + testsrc/gzfiles/empty.gz + testsrc/gzfiles/t1.gz + testsrc/gzfiles/t1bad.gz + testsrc/gzfiles/t2.gz + testsrc/gzfiles/zeros.gz + testsrc/mime.types.test + 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 - If flag(splitBase) - Build-Depends: base >= 4, base < 5, directory, random, process, old-time, - containers, old-locale, array, time - Else - Build-Depends: base < 3 - If ! os(windows) - Build-Depends: unix +source-repository head + type: git + location: https://github.com/haskell-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 + LambdaCase + MultiParamTypeClasses + Rank2Types + ScopedTypeVariables + UndecidableInstances + other-extensions: + CPP + Safe + Trustworthy + TypeSynonymInstances + + build-depends: + array >= 0.4.0.0 && < 0.6 + , base >= 4.9 && < 5 + , containers >= 0.4.2.1 && < 1 + , directory >= 1.1.0.2 && < 1.4 + , filepath >= 1.3.0.0 && < 1.6 + , hslogger >= 1.3.0.0 && < 1.4 + , mtl >= 1.1.1.0 && < 2.4 + , old-locale == 1.0.* + , old-time == 1.1.* + , parsec == 3.1.* && (< 3.1.12 || >= 3.1.13) + , process >= 1.1.0.1 && < 1.7 + , regex-compat >= 0.95.1 && < 0.96 + , time >= 1.4 && < 2 + + if flag(network--GE-3_0_0) + build-depends: network-bsd >= 2.8.1 && <2.9, + network >= 3.0 && <3.3 + else + build-depends: network >= 2.6.3.1 && <2.9 + + if !os(windows) + build-depends: unix >= 2.5.1.0 && < 2.9 + + ghc-options: + -Wall + -Wcompat + +---------------------------------------------------------------------------- + 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 - If flag(splitBase) - Build-Depends: base >= 4, base < 5, directory, random, process, old-time, - containers, old-locale, array, time - Else - Build-Depends: base < 3 - 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, - CRC32POSIXtest, - 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 + other-extensions: + CPP + + -- 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 + + if !os(windows) + build-depends: unix + + -- additional testsuite-specific dependencies + build-depends: + HUnit == 1.6.* + + ghc-options: + -Wall + -Wcompat diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -#!/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/examples/test3.hs b/examples/test3.hs --- a/examples/test3.hs +++ b/examples/test3.hs @@ -7,11 +7,11 @@ import MissingH.Str import System.Time -realhandler h = +realhandler h = let loop = do e <- hIsEOF h if e then return () else do c <- hGetLine h - case (rstrip c) of + case (rstrip c) of "QUIT" -> hPutStr h "Goodbye!\n" "COMMANDS" -> do hPutStrLn h "You can type TIME for the current time" loop 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Thread utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +10,9 @@ {- | 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 + Stability : stable Portability: portable This module provides various helpful utilities for dealing with threads. @@ -25,9 +25,9 @@ ) where -import Control.Concurrent +import safe Control.Concurrent ( forkIO, ThreadId ) -{- | 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- Copyright (c) 2008-2011 John Goerzen @@ -9,10 +10,9 @@ {- | Module : Data.BinPacking Copyright : Copyright (C) 2008-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Tools for packing into bins @@ -36,13 +36,13 @@ ) where -import Data.List -import Control.Monad.Error -{- | Potential errors returned as Left values by 'BinPacker' functions. +import Data.List (sortOn) + +{- | Potential errors returned as Left values by 'BinPacker' functions. Calling 'show' on this value will produce a nice error message suitable for display. -} -data (Num size, Ord size, Show size, Show obj) => BinPackerError size obj = +data (Num size, Ord size, Show size, Show obj) => BinPackerError size obj = BPTooFewBins [(size, obj)] -- ^ Ran out of bins; attached value is the list of objects that do not fit | BPSizeTooLarge size (size, obj) -- ^ Bin size1 exceeded by at least the given object and size | BPOther String -- ^ Other error @@ -55,21 +55,17 @@ ++ " at " ++ show obj show (BPOther x) = x -{- | Let us use this as part of the Either monad -} -instance (Num size, Ord size, Show size, Show obj) => Error (BinPackerError size obj) where - strMsg = BPOther - {- | The primary type for bin-packing functions. These functions take a list of size of bins. If every bin is the same size, you can pass @repeat binSize@ to pass an infinite list of bins if the -same size. Any surplus bins will simply be ignored. +same size. Any surplus bins will simply be ignored. > [size] is the sizes of bins > [(size, obj)] is the sizes and objects > result is Either error or results -} -type BinPacker = (Num size, Ord size, Show size, Show obj) => +type BinPacker = forall size obj. (Num size, Ord size, Show size, Show obj) => [size] -- The sizes of bins -> [(size, obj)] -- The sizes and objects -> Either (BinPackerError size obj) [[(size, obj)]] -- Either error or results @@ -85,7 +81,7 @@ packByOrder [] remainder = Left (BPTooFewBins remainder) packByOrder (thisbinsize:otherbins) sizes = let fillBin _ [] = Right [] - fillBin accumsize ((s, o):xs) + fillBin accumsize ((s, o):xs) | s > thisbinsize = Left $ BPSizeTooLarge thisbinsize (s, o) | s + accumsize > thisbinsize = Right [] | otherwise = do next <- fillBin (accumsize + s) xs @@ -99,8 +95,7 @@ be found to put in the bin. This is substantially more efficient than 'packByOrder', but requires sorting the input. -} packLargeFirst :: BinPacker -packLargeFirst bins sizes = packLargeFirst' bins (sortBy fstSort sizes) - where fstSort a b = compare (fst a) (fst b) +packLargeFirst bins sizes = packLargeFirst' bins (sortOn fst sizes) packLargeFirst' :: BinPacker packLargeFirst' _ [] = Right [] -- Ran out of sizes 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Bit utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +10,9 @@ {- | Module : Data.Bits.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable to platforms with rawSystem Bit-related utilities @@ -23,8 +23,9 @@ module Data.Bits.Utils(getBytes, fromBytes, c2w8, s2w8, w82c, w82s) where -import Data.Bits -import Data.Word +import safe Data.Bits + ( Bits((.|.), (.&.), shiftR, bitSizeMaybe, shiftL) ) +import safe Data.Word ( Word8 ) {- | Returns a list representing the bytes that comprise a data type. @@ -33,13 +34,13 @@ > getBytes (0x12345678::Int) -> [0x12, 0x34, 0x56, 0x78] -} getBytes :: (Integral a, Bounded a, Bits a) => a -> [a] -getBytes input = - let getByte _ 0 = [] - getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1) - in - if (bitSize input `mod` 8) /= 0 - then error "Input data bit size must be a multiple of 8" - else reverse $ getByte input (bitSize input `div` 8) +getBytes input + | Just size <- bitSizeMaybe input, size `mod` 8 == 0 = + reverse $ getByte input $ size `div` 8 + | otherwise = error "Input data bit size must be a multiple of 8" + where + getByte _ 0 = [] + getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1) {- | The opposite of 'getBytes', this function builds a number based on its component bytes. @@ -50,7 +51,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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: CSV and TSV utilities Copyright (c) 2005-2011 John Goerzen @@ -9,10 +10,9 @@ {- | Module : Data.CSV Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Haskell Parsec parsers for comma-separated value (CSV) files. @@ -21,7 +21,18 @@ -} module Data.CSV (csvFile, genCsvFile) where -import Text.ParserCombinators.Parsec +import safe Text.ParserCombinators.Parsec + ( char, + noneOf, + string, + endBy, + sepBy, + (), + (<|>), + many, + try, + GenParser, + CharParser ) import Data.List (intersperse) eol :: forall st. GenParser Char st String @@ -33,13 +44,13 @@ quotedchar :: GenParser Char st Char quotedchar = noneOf "\"" - <|> (try $ do string "\"\"" + <|> (try $ do _ <- string "\"\"" return '"' ) quotedcell :: CharParser st String -quotedcell = do char '"' +quotedcell = do _ <- char '"' content <- many quotedchar - char '"' + _ <- char '"' return content line :: GenParser Char st [String] @@ -49,7 +60,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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} -- arch-tag: Inflate implementation for Haskell {- @@ -15,12 +16,10 @@ {- | 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 + Stability : stable Portability: portable Inflate algorithm implementation @@ -33,15 +32,16 @@ inflate, Output, Bit, bits_to_word32) where -import Data.Array -import Data.List -import Data.Maybe +import safe Control.Monad ( ap, unless ) +import safe Data.Array ( Array, array, (!), (//) ) import qualified Data.Char -import Control.Applicative -import Control.Monad +import Data.List + ( mapAccumL, genericDrop, genericReplicate, genericSplitAt, genericTake + , sort ) +import safe Data.Maybe () -import Data.Bits -import Data.Word +import safe Data.Bits ( Bits(testBit) ) +import safe Data.Word ( Word8, Word32 ) inflate_string :: String -> String inflate_string = fst . inflate_string_remainder @@ -91,7 +91,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] @@ -110,10 +110,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)) @@ -123,10 +123,10 @@ InfM y = f x in y s' -- return :: a -> InfM a - return x = InfM $ \s -> (x, s) + return = pure instance Applicative InfM where - pure = return + pure x = InfM $ \s -> (x, s) (<*>) = ap instance Functor InfM where @@ -151,8 +151,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]) @@ -185,8 +185,10 @@ return (bits_to_word32 bs) get_bit :: InfM Bit -get_bit = do [x] <- get_bits 1 - return x +get_bit = do res <- get_bits 1 + case res of + [x] -> return x + _ -> error $ "get_bit: expected exactly one bit" {- \section{Inflate itself} @@ -204,24 +206,27 @@ inflate_blocks :: Bool -> InfM Output inflate_blocks True = return [] inflate_blocks False - = do [Bit is_last, Bit t1, Bit t2] <- get_bits 3 - case (t1, t2) of - (False, False) -> - do align_8_bits - len <- get_w32 16 - nlen <- get_w32 16 - unless (len + nlen == 2^(32 :: Int) - 1) - $ error "inflate_blocks: Mismatched lengths" - ws <- get_word32s 8 len - mapM_ output_w32 ws - return ws - (True, False) -> - inflate_codes is_last inflate_trees_fixed - (False, True) -> - do tables <- inflate_tables - inflate_codes is_last tables - (True, True) -> - error ("inflate_blocks: case 11 reserved") + = do res <- get_bits 3 + case res of + [Bit is_last, Bit t1, Bit t2] -> + case (t1, t2) of + (False, False) -> + do align_8_bits + len <- get_w32 16 + nlen <- get_w32 16 + unless (len + nlen == 2^(32 :: Int) - 1) + $ error "inflate_blocks: Mismatched lengths" + ws <- get_word32s 8 len + mapM_ output_w32 ws + return ws + (True, False) -> + inflate_codes is_last inflate_trees_fixed + (False, True) -> + do tables <- inflate_tables + inflate_codes is_last tables + (True, True) -> + error ("inflate_blocks: case 11 reserved") + _ -> error ("inflate_blocks: expected 3 bits") inflate_tables :: InfM Tables inflate_tables @@ -243,8 +248,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" @@ -342,7 +347,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) @@ -359,5 +364,3 @@ (one_tree, lcs_o) = make_tree (i+1) lcs_z in (Branch zero_tree one_tree, lcs_o) | otherwise = error "make_tree: can't happen" - - 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 @@ -1,4 +1,5 @@ -{- arch-tag: Euither utilities +{-# LANGUAGE Safe #-} +{- arch-tag: Either utilities Copyright (c) 2004-2011 John Goerzen All rights reserved. @@ -9,10 +10,9 @@ {- | Module : Data.Either.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Utilities for working with the Either data type @@ -26,8 +26,9 @@ eitherToMonadError, fromLeft, fromRight, fromEither ) where -import Control.Monad.Error +import Control.Monad.Except ( MonadError(..) ) + {- | Converts a Maybe value to an Either value, using the supplied parameter as the Left value if the Maybe is Nothing. @@ -42,39 +43,38 @@ 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: GZIP CRC32 implementation in pure Haskell Copyright (c) 2004-2011 John Goerzen @@ -9,25 +10,23 @@ {- | 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 + Stability : stable 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 safe Data.Array ( Array, array, (!) ) +import safe Data.Bits ( Bits(xor, (.&.), shiftR) ) +import safe Data.Char ( ord ) +import safe Data.Word ( Word32 ) update_crc :: Word32 -> Char -> Word32 update_crc crc ch = @@ -42,7 +41,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/CRC32/Posix.hs b/src/Data/Hash/CRC32/Posix.hs deleted file mode 100644 --- a/src/Data/Hash/CRC32/Posix.hs +++ /dev/null @@ -1,122 +0,0 @@ --- arch-tag: CRC32 implementation in pure Haskell --- from http://cvs.sourceforge.net/viewcvs.py/haskell-libs/libs/crypto/crc32.hs --- --- crc32.hs (C) 2002 HardCore SoftWare, Doug Hoyte --- --- This program is distributed under the terms of the GNU GPL. --- See www.gnu.org for more information. --- --- Haskell implementation of the 32-bit Cyclic Redundancy Check. --- This code was modeled after the cksum utility distributed with --- OpenBSD - the lookup table was in fact lifted from the OpenBSD --- implementation. --- --- Once compiled, this program is almost a drop-in replacement for --- the OpenBSD cksum utility. - --- $Id: crc32.hs,v 1.2 2003/03/24 00:08:55 eris Exp $ - -{- | - Module : Data.Hash.CRC32.Posix - Copyright : Copyright (C) 2002 HardCore SoftWare, Doug Hoyte - License : GNU GPL - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -CRC32 checksumming using POSIX 1003.2-1992 algorithm for the polynomial { 32 26 -23 22 16 12 11 10 8 7 5 4 2 1 }, also defined in ISO 8802-3: 1989. - -Copyright (c) 2002 HardCore SoftWare, Doug Hoyte --} - -{- -Modified December, 2004 by John Goerzen: - * Integrate with MissingH - * Removed code we don't need in a library - * Updated things that didn't compile any more --} - -module Data.Hash.CRC32.Posix where - -import Data.Array -import Data.Bits -import Data.Word - -iter_crc32 :: Word32 -> Char -> Word32 -iter_crc32 sumval ch = (sumval `shiftL` 8) `xor` - crctab ! fromIntegral ((sumval `shiftR` 24) `xor` - (fromIntegral (fromEnum ch))) - - -calc_crc32 :: [Char] -> Word32 -> Word32 -> Word32 -calc_crc32 [] ck 0 = ck `xor` 0xFFFFFFFF -calc_crc32 [] ck l = calc_crc32 - [] - (iter_crc32 ck (toEnum $ fromIntegral (l .&. 0xFF))) - (l `shiftR` 8) -calc_crc32 (x:xs) ck l = calc_crc32 xs (iter_crc32 ck x) (l+1) - - -crc32 :: [Char] -> Word32 -crc32 x = calc_crc32 x 0 0 - - -crctab :: Array Int Word32 -crctab = array (0,255) (zip [0..255] - [ - 0x0, - 0x04c11db7, 0x09823b6e, 0x0d4326d9, 0x130476dc, 0x17c56b6b, - 0x1a864db2, 0x1e475005, 0x2608edb8, 0x22c9f00f, 0x2f8ad6d6, - 0x2b4bcb61, 0x350c9b64, 0x31cd86d3, 0x3c8ea00a, 0x384fbdbd, - 0x4c11db70, 0x48d0c6c7, 0x4593e01e, 0x4152fda9, 0x5f15adac, - 0x5bd4b01b, 0x569796c2, 0x52568b75, 0x6a1936c8, 0x6ed82b7f, - 0x639b0da6, 0x675a1011, 0x791d4014, 0x7ddc5da3, 0x709f7b7a, - 0x745e66cd, 0x9823b6e0, 0x9ce2ab57, 0x91a18d8e, 0x95609039, - 0x8b27c03c, 0x8fe6dd8b, 0x82a5fb52, 0x8664e6e5, 0xbe2b5b58, - 0xbaea46ef, 0xb7a96036, 0xb3687d81, 0xad2f2d84, 0xa9ee3033, - 0xa4ad16ea, 0xa06c0b5d, 0xd4326d90, 0xd0f37027, 0xddb056fe, - 0xd9714b49, 0xc7361b4c, 0xc3f706fb, 0xceb42022, 0xca753d95, - 0xf23a8028, 0xf6fb9d9f, 0xfbb8bb46, 0xff79a6f1, 0xe13ef6f4, - 0xe5ffeb43, 0xe8bccd9a, 0xec7dd02d, 0x34867077, 0x30476dc0, - 0x3d044b19, 0x39c556ae, 0x278206ab, 0x23431b1c, 0x2e003dc5, - 0x2ac12072, 0x128e9dcf, 0x164f8078, 0x1b0ca6a1, 0x1fcdbb16, - 0x018aeb13, 0x054bf6a4, 0x0808d07d, 0x0cc9cdca, 0x7897ab07, - 0x7c56b6b0, 0x71159069, 0x75d48dde, 0x6b93dddb, 0x6f52c06c, - 0x6211e6b5, 0x66d0fb02, 0x5e9f46bf, 0x5a5e5b08, 0x571d7dd1, - 0x53dc6066, 0x4d9b3063, 0x495a2dd4, 0x44190b0d, 0x40d816ba, - 0xaca5c697, 0xa864db20, 0xa527fdf9, 0xa1e6e04e, 0xbfa1b04b, - 0xbb60adfc, 0xb6238b25, 0xb2e29692, 0x8aad2b2f, 0x8e6c3698, - 0x832f1041, 0x87ee0df6, 0x99a95df3, 0x9d684044, 0x902b669d, - 0x94ea7b2a, 0xe0b41de7, 0xe4750050, 0xe9362689, 0xedf73b3e, - 0xf3b06b3b, 0xf771768c, 0xfa325055, 0xfef34de2, 0xc6bcf05f, - 0xc27dede8, 0xcf3ecb31, 0xcbffd686, 0xd5b88683, 0xd1799b34, - 0xdc3abded, 0xd8fba05a, 0x690ce0ee, 0x6dcdfd59, 0x608edb80, - 0x644fc637, 0x7a089632, 0x7ec98b85, 0x738aad5c, 0x774bb0eb, - 0x4f040d56, 0x4bc510e1, 0x46863638, 0x42472b8f, 0x5c007b8a, - 0x58c1663d, 0x558240e4, 0x51435d53, 0x251d3b9e, 0x21dc2629, - 0x2c9f00f0, 0x285e1d47, 0x36194d42, 0x32d850f5, 0x3f9b762c, - 0x3b5a6b9b, 0x0315d626, 0x07d4cb91, 0x0a97ed48, 0x0e56f0ff, - 0x1011a0fa, 0x14d0bd4d, 0x19939b94, 0x1d528623, 0xf12f560e, - 0xf5ee4bb9, 0xf8ad6d60, 0xfc6c70d7, 0xe22b20d2, 0xe6ea3d65, - 0xeba91bbc, 0xef68060b, 0xd727bbb6, 0xd3e6a601, 0xdea580d8, - 0xda649d6f, 0xc423cd6a, 0xc0e2d0dd, 0xcda1f604, 0xc960ebb3, - 0xbd3e8d7e, 0xb9ff90c9, 0xb4bcb610, 0xb07daba7, 0xae3afba2, - 0xaafbe615, 0xa7b8c0cc, 0xa379dd7b, 0x9b3660c6, 0x9ff77d71, - 0x92b45ba8, 0x9675461f, 0x8832161a, 0x8cf30bad, 0x81b02d74, - 0x857130c3, 0x5d8a9099, 0x594b8d2e, 0x5408abf7, 0x50c9b640, - 0x4e8ee645, 0x4a4ffbf2, 0x470cdd2b, 0x43cdc09c, 0x7b827d21, - 0x7f436096, 0x7200464f, 0x76c15bf8, 0x68860bfd, 0x6c47164a, - 0x61043093, 0x65c52d24, 0x119b4be9, 0x155a565e, 0x18197087, - 0x1cd86d30, 0x029f3d35, 0x065e2082, 0x0b1d065b, 0x0fdc1bec, - 0x3793a651, 0x3352bbe6, 0x3e119d3f, 0x3ad08088, 0x2497d08d, - 0x2056cd3a, 0x2d15ebe3, 0x29d4f654, 0xc5a92679, 0xc1683bce, - 0xcc2b1d17, 0xc8ea00a0, 0xd6ad50a5, 0xd26c4d12, 0xdf2f6bcb, - 0xdbee767c, 0xe3a1cbc1, 0xe760d676, 0xea23f0af, 0xeee2ed18, - 0xf0a5bd1d, 0xf464a0aa, 0xf9278673, 0xfde69bc4, 0x89b8fd09, - 0x8d79e0be, 0x803ac667, 0x84fbdbd0, 0x9abc8bd5, 0x9e7d9662, - 0x933eb0bb, 0x97ffad0c, 0xafb010b1, 0xab710d06, 0xa6322bdf, - 0xa2f33668, 0xbcb4666d, 0xb8757bda, 0xb5365d03, 0xb1f740b4 - ]) - 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 : stable + 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 safe Data.Bits (Bits (complement, rotateL, shiftL, shiftR, xor, (.&.), (.|.))) +import safe Data.Char (chr, ord) +import safe Data.Word (Word32, Word64) + +-- | 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,58 @@ +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Obsolete legacy module +module Data.Hash.MD5.Zord64_HARD (Zord64) where + +import safe Data.Bits ( Bits(complement, (.&.), (.|.), shift) ) +import safe Data.Word ( Word32 ) + +data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) + +w64ToInteger :: Zord64 -> Integer +w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi + +integerToW64 :: Integer -> Zord64 +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@W64{lo=lo,hi=hi} x + | x == 0 = w + | 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} + | otherwise = error "impossible" + 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- arch-tag: List utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +11,9 @@ {- | Module : Data.List.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with lists. @@ -48,12 +49,13 @@ -- -- * 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 (elemIndices, findIndex, intercalate, + isInfixOf, isPrefixOf, isSuffixOf, nub, + tails) + {- | Merge two sorted lists into a single, sorted whole. Example: @@ -80,9 +82,9 @@ cmp (x1,_) (x2,_) = compare x1 x2 -} mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -mergeBy cmp [] ys = ys -mergeBy cmp xs [] = xs -mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) +mergeBy _ [] ys = ys +mergeBy _ xs [] = xs +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. @@ -90,7 +92,7 @@ | otherwise = y : mergeBy cmp allx ys {- | Returns true if the given list starts with the specified elements; -false otherwise. (This is an alias for "Data.List.isPrefixOf".) +false otherwise. (This is an alias for 'Data.List.isPrefixOf'.) Example: @@ -102,7 +104,7 @@ startswith = isPrefixOf {- | Returns true if the given list ends with the specified elements; -false otherwise. (This is an alias for "Data.List.isSuffixOf".) +false otherwise. (This is an alias for 'Data.List.isSuffixOf'.) Example: @@ -117,32 +119,32 @@ 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. +{- | Similar to 'Data.List.takeWhile', takes elements while the func is true. The function is given the remainder of the list to examine. -} takeWhileList :: ([a] -> Bool) -> [a] -> [a] takeWhileList _ [] = [] takeWhileList func list@(x:xs) = - if func list + if func list then x : takeWhileList func xs else [] -{- | Similar to Data.List.dropWhile, drops elements while the func is true. +{- | Similar to 'Data.List.dropWhile', drops elements while the func is true. The function is given the remainder of the list to examine. -} dropWhileList :: ([a] -> Bool) -> [a] -> [a] dropWhileList _ [] = [] -dropWhileList func list@(x:xs) = +dropWhileList func list@(_:xs) = if func list then dropWhileList func xs else list -{- | Similar to Data.List.span, but performs the test on the entire remaining -list instead of just one element. +{- | Similar to 'Data.List.span', but performs the test on the entire remaining +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]) @@ -153,7 +155,7 @@ else ([],list) where (ys,zs) = spanList func xs -{- | Similar to Data.List.break, but performs the test on the entire remaining +{- | Similar to 'Data.List.break', but performs the test on the entire remaining list instead of just one element. -} breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) @@ -171,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) @@ -196,14 +198,14 @@ replace old new l = join new . split old $ l {- | Given a delimiter and a list of items (or strings), join the items -by using the delimiter. +by using the delimiter. Alias for 'Data.List.intercalate'. Example: > join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" -} join :: [a] -> [[a]] -> [a] -join delim l = concat (intersperse delim l) +join = intercalate {- | Like 'join', but works with a list of anything showable, converting it to a String. @@ -217,18 +219,14 @@ genericJoin :: Show a => String -> [a] -> String genericJoin delim l = join delim (map show l) -{-# DEPRECATED contains "Use Data.List.isInfixOf, will be removed in MissingH 1.1.0" #-} {- | Returns true if the given parameter is a sublist of the given list; -false otherwise. +false otherwise. Alias for 'Data.List.isInfixOf'. Example: > contains "Haskell" "I really like Haskell." -> True > contains "Haskell" "OCaml is great." -> False -This function was submitted to GHC and was applied as -'Data.List.isInfixOf'. This function therefore is deprecated and will -be removed in future versions. -} contains :: Eq a => [a] -> [a] -> Bool @@ -279,7 +277,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 [] @@ -295,13 +293,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 @@ -323,7 +321,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. -} @@ -331,12 +329,12 @@ 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 list@(x:xs) = seq (seqList xs) list +seqList [] = [] +seqList list@(_:xs) = seq (seqList xs) list -------------------------------------------------- -- Advanced Conversions @@ -346,7 +344,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: @@ -400,8 +398,8 @@ > --> ["Hello",", T","his is"," ","a test."] -} fixedWidth :: [Int] -> WholeFunc a [a] -fixedWidth len = - WholeFunc (fixedWidthFunc len) +fixedWidth = + WholeFunc . fixedWidthFunc where -- Empty input: Empty output, stop fixedWidthFunc _ [] = ((fixedWidth []), [], []) -- Empty length: Stop here. @@ -465,13 +463,10 @@ This function is not compatible with infinite lists. -This is presently an alias for Data.List.nub +This is presently an alias for 'Data.List.nub'. -} uniq :: Eq a => [a] -> [a] uniq = nub ----- same as --uniq (x:xs) = x : [y | y <- uniq xs, y /= x] - - - 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 @@ -9,10 +9,9 @@ {- | Module : Data.MIME.Types Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Utilities for guessing MIME types of files. @@ -36,13 +35,14 @@ import qualified Data.Map as Map import qualified Control.Exception (try, IOException) -import Control.Monad +import Control.Monad ( foldM ) import System.IO -import System.IO.Error -import System.IO.Utils -import System.Path -import Data.Map.Utils -import Data.Char + ( Handle, hClose, openFile, IOMode(ReadMode) ) +import System.IO.Error () +import System.IO.Utils ( hGetLines ) +import System.Path ( splitExt ) +import Data.Map.Utils ( flippedLookupM ) +import Data.Char ( toLower ) ---------------------------------------------------------------------- -- Basic type declarations @@ -91,8 +91,9 @@ -> Bool -- ^ Whether to work on strict data -> Handle -- ^ Handle to read from -> IO MIMETypeData -- ^ New object -hReadMIMETypes mtd strict h = - let parseline :: MIMETypeData -> String -> MIMETypeData +hReadMIMETypes mtd strict h = foldl parseline mtd <$> hGetLines h + where + parseline :: MIMETypeData -> String -> MIMETypeData parseline obj line = let l1 = words line procwords [] = [] @@ -106,10 +107,6 @@ in foldl (\o suff -> addType o strict thetype ('.' : suff)) obj suffixlist else obj - in - do - lines <- hGetLines h - return (foldl parseline mtd lines) {- | Guess the type of a file given a filename or URL. The file is not opened; only the name is considered. -} 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,4 +1,5 @@ -{- +{-# LANGUAGE Safe #-} +{- Copyright (c) 2004-2011 John Goerzen All rights reserved. @@ -9,10 +10,9 @@ {- | Module : Data.Map.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with Data.Maps. @@ -28,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 @@ -70,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. @@ -79,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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Maybe utilities Copyright (c) 2005-2011 John Goerzen @@ -9,13 +10,12 @@ {- | Module : Data.Maybe.Utils Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable -Utilities for working with the Either data type +Utilities for working with the 'Maybe' data type. -} module Data.Maybe.Utils @@ -23,13 +23,16 @@ forceMaybe, forceMaybeMsg ) where -{- | Pulls a Just value out of a Maybe value. If the Maybe value is -Nothing, raises an exception with error. -} +import Data.Maybe (fromJust) + +{- | Pulls a 'Just' value out of a 'Maybe' value. If the 'Maybe' value is +'Nothing', raises an exception with error. + +Alias of 'Data.Maybe.fromJust'. -} forceMaybe :: Maybe a -> a -forceMaybe = forceMaybeMsg "forceMaybe: Got Nothing" +forceMaybe = fromJust {- | Like 'forceMaybe', but lets you customize the error message raised if -Nothing is supplied. -} +'Nothing' is supplied. -} forceMaybeMsg :: String -> Maybe a -> a -forceMaybeMsg msg Nothing = error msg -forceMaybeMsg _ (Just x) = x +forceMaybeMsg msg = maybe (error msg) id 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,10 +11,9 @@ {- | Module : Data.Progress.Meter Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Tool for maintaining a status bar, supporting multiple simultaneous tasks, @@ -39,13 +40,27 @@ killAutoDisplayMeter ) where -import Data.Progress.Tracker -import Control.Concurrent +import safe Data.Progress.Tracker + ( ProgressStatuses(..), + Progress, + ProgressStatus(totalUnits, completedUnits, trackerName), + getSpeed, + getETR ) +import safe Control.Concurrent + ( modifyMVar_, + withMVar, + newMVar, + MVar, + threadDelay, + forkIO, + myThreadId, + yield, + ThreadId ) import Control.Monad (when) import Data.String.Utils (join) import System.Time.Utils (renderSecs) import Data.Quantity (renderNums, binaryOpts) -import System.IO +import safe System.IO ( Handle, hFlush, hPutStr ) import Control.Monad (filterM) {- | The main data type for the progress meter. -} @@ -218,5 +233,3 @@ speed <- getSpeed pts return $ head (rfunc [floor (speed :: Double)]) ++ u ++ "/s " ++ renderSecs etr - - 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- Copyright (c) 2006-2011 John Goerzen @@ -9,15 +11,14 @@ {- | Module : Data.Progress.Tracker Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Tools for tracking the status of a long operation. -Written by John Goerzen, jgoerzen\@complete.org +Written by John Goerzen, jgoerzen\@complete.org See also "Data.Progress.Meter" -} @@ -47,10 +48,11 @@ ) where -import Control.Concurrent.MVar -import System.Time -import System.Time.Utils -import Data.Ratio +import safe Control.Concurrent.MVar + ( modifyMVar_, withMVar, newMVar, MVar ) +import safe System.Time ( getClockTime ) +import safe System.Time.Utils ( clockTimeToEpoch ) +import safe Data.Ratio ( (%) ) {- $introduction @@ -66,7 +68,7 @@ long-running. Downloading many large files over the Internet is a common example of this. -Any given ProgressTracker can be told about one or more parent trackers. +Any given ProgressTracker can be told about one or more parent trackers. When the child tracker's status is updated, the parent tracker's status is also updated in the same manner. Therefore, the progress on each individual component, as well as the overall progress, can all be kept in sync @@ -95,7 +97,7 @@ -- TYPES ---------------------------------------------------------------------- -{- | A function that, when called, yields the current time. +{- | A function that, when called, yields the current time. The default is 'defaultTimeSource'. -} type ProgressTimeSource = IO Integer @@ -112,7 +114,7 @@ type ProgressCallback = ProgressStatus -> ProgressStatus -> IO () {- | The main progress status record. -} -data ProgressStatus = +data ProgressStatus = ProgressStatus {completedUnits :: Integer, totalUnits :: Integer, startTime :: Integer, @@ -129,7 +131,7 @@ newtype Progress = Progress (MVar ProgressRecord) class ProgressStatuses a b where - {- | Lets you examine the 'ProgressStatus' that is contained + {- | Lets you examine the 'ProgressStatus' that is contained within a 'Progress' object. You can simply pass a 'Progress' object and a function to 'withStatus', and 'withStatus' will lock the 'Progress' object (blocking any @@ -139,20 +141,8 @@ to the function. -} withStatus :: a -> (ProgressStatus -> b) -> b -class ProgressRecords a b where - withRecord :: a -> (ProgressRecord -> b) -> b - -{- -instance ProgressStatuses ProgressRecord b where - withStatus x func = func (status x) -instance ProgressRecords ProgressRecord b where - withRecord x func = func x --} - instance ProgressStatuses Progress (IO b) where withStatus (Progress x) func = withMVar x (\y -> func (status y)) -instance ProgressRecords Progress (IO b) where - withRecord (Progress x) func = withMVar x func instance ProgressStatuses ProgressStatus b where withStatus x func = func x @@ -184,7 +174,7 @@ timeSource = defaultTimeSource}) [] -{- | Create a new 'Progress' object initialized with the given status and +{- | Create a new 'Progress' object initialized with the given status and callbacks. No adjustment to the 'startTime' will be made. If you want to use the system clock, you can initialize 'startTime' with @@ -200,7 +190,7 @@ {- | Adds an new callback to an existing 'Progress'. The callback will be called whenever the object's status is updated, except by the call to finishP. -Please note that the Progress object will be locked while the callback is +Please note that the Progress object will be locked while the callback is running, so the callback will not be able to make any modifications to it. -} addCallback :: Progress -> ProgressCallback -> IO () @@ -227,7 +217,7 @@ called. This ensures that the total expected counts on the parent are always correct. -Without doing this, if, say, a transfer ended earlier than expected, ETA +Without doing this, if, say, a transfer ended earlier than expected, ETA values on the parent would be off since it would be expecting more data than actually arrived. -} finishP :: Progress -> IO () @@ -235,10 +225,10 @@ modifyMVar_ mp modfunc where modfunc :: ProgressRecord -> IO ProgressRecord modfunc oldpr = - do let adjustment = (completedUnits . status $ oldpr) + do let adjustment = (completedUnits . status $ oldpr) - (totalUnits . status $ oldpr) callParents oldpr (\x -> incrTotal x adjustment) - return $ oldpr {status = (status oldpr) + return $ oldpr {status = (status oldpr) {totalUnits = completedUnits . status $ oldpr}} ---------------------------------------------------------------------- @@ -246,23 +236,23 @@ ---------------------------------------------------------------------- {- | Increment the completed unit count in the 'Progress' object by the amount given. If the value as given exceeds the total, then -the total will also be raised to match this value so that the +the total will also be raised to match this value so that the completed count never exceeds the total. You can decrease the completed unit count by supplying a negative number here. -} incrP :: Progress -> Integer -> IO () incrP po count = modStatus po statusfunc - where statusfunc s = + where statusfunc s = s {completedUnits = newcu s, totalUnits = if newcu s > totalUnits s then newcu s else totalUnits s} - newcu s = completedUnits s + count + newcu s = completedUnits s + count {- | Like 'incrP', but never modify the total. -} incrP' :: Progress -> Integer -> IO () -incrP' po count = +incrP' po count = modStatus po (\s -> s {completedUnits = completedUnits s + count}) {- | Set the completed unit count in the 'Progress' object to the specified @@ -283,10 +273,10 @@ setP' po count = modStatus po (\s -> s {completedUnits = count}) {- | Increment the total unit count in the 'Progress' object by the amount -given. This would rarely be needed, but could be needed in some special cases +given. This would rarely be needed, but could be needed in some special cases when the total number of units is not known in advance. -} incrTotal :: Progress -> Integer -> IO () -incrTotal po count = +incrTotal po count = modStatus po (\s -> s {totalUnits = totalUnits s + count}) {- | Set the total unit count in the 'Progress' object to the specified @@ -318,14 +308,14 @@ a number that is valid as any Fractional type, such as a Double, Float, or Rational. -} getSpeed :: (ProgressStatuses a (IO b), Fractional b) => a -> IO b -getSpeed po = withStatus po $ \status -> +getSpeed po = withStatus po $ \status -> do t <- timeSource status let elapsed = t - (startTime status) return $ if elapsed == 0 then fromRational 0 else fromRational ((completedUnits status) % elapsed) -{- | Returns the estimated time remaining, in standard time units. +{- | Returns the estimated time remaining, in standard time units. Returns 0 whenever 'getSpeed' would return 0. @@ -333,11 +323,11 @@ and result. -} getETR :: (ProgressStatuses a (IO Integer), ProgressStatuses a (IO Rational)) => a -> IO Integer -getETR po = +getETR po = do speed <- ((getSpeed po)::IO Rational) if speed == 0 then return 0 - else + else -- FIXME: potential for a race condition here, but it should -- be negligible withStatus po $ \status -> @@ -368,15 +358,12 @@ defaultTimeSource :: ProgressTimeSource defaultTimeSource = getClockTime >>= (return . clockTimeToEpoch) -now :: ProgressRecords a ProgressTimeSource => a -> ProgressTimeSource -now x = withRecord x (timeSource . status) - modStatus :: Progress -> (ProgressStatus -> ProgressStatus) -> IO () -- FIXME/TODO: handle parents modStatus (Progress mp) func = modifyMVar_ mp modfunc where modfunc :: ProgressRecord -> IO ProgressRecord - modfunc oldpr = + modfunc oldpr = do let newpr = oldpr {status = func (status oldpr)} mapM_ (\x -> x (status oldpr) (status newpr)) (callbacks oldpr) @@ -394,4 +381,3 @@ callParents :: ProgressRecord -> (Progress -> IO ()) -> IO () callParents pr func = mapM_ func (parents pr) - diff --git a/src/Data/Quantity.hs b/src/Data/Quantity.hs --- a/src/Data/Quantity.hs +++ b/src/Data/Quantity.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} {- Copyright (c) 2006-2011 John Goerzen @@ -9,10 +12,9 @@ {- | Module : Data.Quantity Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Tools for rendering sizes @@ -32,17 +34,17 @@ ) where -import Data.List -import Text.Printf -import Data.Char +import safe Data.Char ( toLower ) +import safe Data.List (find) +import safe Text.Printf ( 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 @@ -79,7 +81,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, @@ -87,7 +89,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) / @@ -122,7 +124,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 @@ -156,7 +158,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 @@ -167,7 +169,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 @@ -178,18 +180,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 @@ -200,12 +202,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 Safe #-} + {- arch-tag: String utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +11,9 @@ {- | Module : Data.String.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with strings. @@ -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 @@ -1,39 +1,52 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Tuple utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. -For license and copyright information, see the file LICENSE +For license and copyright information, see the file LICENSE. -} {- | Module : Data.Tuple.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable 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, +Written by Neil Mitchell. -} module Data.Tuple.Utils( + -- * Construction + dup, triple, -- * Extraction fst3, snd3, thd3 ) where +-- | Construct a pair by duplication of a single value +-- +-- @since 1.4.3.0 +dup :: a -> (a,a) +dup a = (a,a) +-- | Construct a 3-tuple from a single value +-- +-- @since 1.4.3.0 +triple :: a -> (a,a,a) +triple a = (a,a,a) + -- | Take the first item out of a 3 element tuple fst3 :: (a,b,c) -> a -fst3 (a,b,c) = a +fst3 (a,_,_) = a -- | Take the second item out of a 3 element tuple snd3 :: (a,b,c) -> b -snd3 (a,b,c) = b +snd3 (_,b,_) = b -- | Take the third item out of a 3 element tuple thd3 :: (a,b,c) -> c -thd3 (a,b,c) = c +thd3 (_,_,c) = c 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen @@ -9,10 +10,9 @@ {- | Module : Network.Email.Mailbox Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable General support for e-mail mailboxes @@ -26,7 +26,7 @@ where {- | The flags which may be assigned to a message. -} -data Flag = +data Flag = SEEN | ANSWERED | FLAGGED @@ -35,14 +35,14 @@ | FORWARDED | OTHERFLAG String deriving (Eq, Show) - + {- | Convenience shortcut -} type Flags = [Flag] {- | A Message is represented as a simple String. -} type Message = String -{- | Main class for readable mailboxes. +{- | Main class for readable mailboxes. The mailbox object /a/ represents zero or more 'Message's. Each message has a unique identifier /b/ in a format specific to each given mailbox. @@ -65,12 +65,12 @@ getMessages :: a -> [b] -> IO [(b, Flags, Message)] listIDs mb = listMessageFlags mb >>= return . map fst - listMessageFlags mb = getAll mb >>= return . + listMessageFlags mb = getAll mb >>= return . map (\(i, f, _) -> (i, f)) getMessages mb list = do messages <- getAll mb - return $ filter (\(id, f, m) -> id `elem` list) messages - + return $ filter (\(x, _, _) -> x `elem` list) messages + class (MailboxReader a b) => MailboxWriter a b where appendMessages :: a -> [(Flags, Message)] -> IO [b] deleteMessages :: a -> [b] -> IO () 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,5 @@ {-# LANGUAGE CPP #-} + {- arch-tag: Sendmail utility Copyright (c) 2004-2011 John Goerzen @@ -10,10 +11,9 @@ {- | Module : Network.Email.Sendmail Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This Haskell module provides an interface to transmitting a mail message. @@ -30,10 +30,11 @@ module Network.Email.Sendmail(sendmail) where -import System.Cmd.Utils +import System.Cmd.Utils ( PipeMode(WriteToPipe), pOpen ) import System.Directory -import System.IO -import System.IO.Error + ( doesFileExist, getPermissions, Permissions(executable) ) +import System.IO ( hPutStr ) +import System.IO.Error () import qualified Control.Exception(try, IOException) sendmails :: [String] @@ -100,4 +101,3 @@ return $! r #endif - 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,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {- arch-tag: Generic Server Support Copyright (c) 2004-2011 John Goerzen @@ -9,9 +12,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 +46,40 @@ handleHandler ) where -import Network.Socket +import Control.Concurrent ( forkIO ) +import Data.Functor (void) import Network.BSD -import Network.Utils -import Control.Concurrent + ( getProtocolNumber, Family(AF_INET), HostAddress, PortNumber ) +import Network.Socket + ( socketToHandle, + setSocketOption, + accept, + bind, + getSocketName, + listen, + socket, + close, + SocketOption(ReuseAddr), + SockAddr(SockAddrInet), + Socket, + SocketType(Stream) ) +import Network.Utils ( showSockAddr ) import System.IO + ( Handle, + hClose, + hSetBuffering, + BufferMode(LineBuffering), + IOMode(ReadWriteMode) ) 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 +92,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 +106,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 +116,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,16 +127,15 @@ 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 = - let opts = (optionsSS ss) - in do a <- accept (sockSS ss) - localaddr <- getSocketName (fst a) - func (fst a) (snd a) localaddr - +handleOne ss func = 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 +152,7 @@ -} serveTCPforever :: InetServerOptions -- ^ Server options -> HandlerT -- ^ Handler function - -> IO () + -> IO () serveTCPforever options func = do sockserv <- setupSocketServer options serveForever sockserv func @@ -152,24 +172,23 @@ -> 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 -> HandlerT -- ^ Resulting handler -threadedHandler nexth socket r_sockaddr l_sockaddr= - do forkIO (nexth socket r_sockaddr l_sockaddr) - return () +threadedHandler nexth socket r_sockaddr l_sockaddr = void $ + forkIO (nexth socket r_sockaddr l_sockaddr) {- | Give your handler function a Handle instead of a Socket. @@ -182,7 +201,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,10 +11,9 @@ {- | Module : Network.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: systems with networking This module provides various helpful utilities for dealing with networking @@ -24,13 +26,29 @@ listenTCPAddr, showSockAddr) where -import Network -import Network.Socket import Network.BSD -import System.IO + ( getHostByName, + getProtocolNumber, + hostAddress, + HostName, + Family(AF_INET), + PortNumber ) +import Network.Socket + ( getNameInfo, + withSocketsDo, + bind, + connect, + listen, + socket, + close, + NameInfoFlag(NI_NUMERICHOST), + SockAddr(..), + Socket, + SocketType(Stream) ) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import qualified System.Posix.Signals #endif +import Control.Exception (bracketOnError) {- | Sets up the system for networking. Similar to the built-in withSocketsDo (and actually, calls it), but also sets the SIGPIPE @@ -47,7 +65,7 @@ niceSocketsDo func = do #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -- No signals on Windows anyway - System.Posix.Signals.installHandler + _ <- System.Posix.Signals.installHandler System.Posix.Signals.sigPIPE System.Posix.Signals.Ignore Nothing @@ -62,15 +80,14 @@ connectTCPAddr :: SockAddr -> IO Socket connectTCPAddr addr = do proto <- getProtocolNumber "tcp" - s <- socket AF_INET Stream proto - connect s addr - return s + bracketOnError (socket AF_INET Stream proto) close + (\s -> connect s addr >> return s) listenTCPAddr :: SockAddr -> Int -> IO Socket 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 +95,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,18 +13,15 @@ {- | Module : System.Cmd.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable to platforms with POSIX process\/signal tools Command invocation utilities. Written by John Goerzen, jgoerzen\@complete.org -Please note: Most of this module is not compatible with Hugs. - Command lines executed will be logged using "System.Log.Logger" at the DEBUG level. Failure messages will be logged at the WARNING level in addition to being raised as an exception. Both are logged under @@ -94,18 +93,36 @@ -- FIXME - largely obsoleted by 6.4 - convert to wrappers. -import System.Exit +import System.Exit ( ExitCode(ExitFailure, ExitSuccess) ) +import System.Log.Logger ( debugM, warningM ) +#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Process (rawSystem) -import System.Log.Logger -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) +#else import System.Posix.IO + ( closeFd, + createPipe, + dupTo, + fdToHandle, + stdError, + stdInput, + stdOutput ) import System.Posix.Process + ( executeFile, forkProcess, getProcessStatus, ProcessStatus(..) ) import System.Posix.Signals -import qualified System.Posix.Signals + ( addSignal, + blockSignals, + emptySignalSet, + getSignalMask, + installHandler, + setSignalMask, + sigCHLD, + sigINT, + sigQUIT, + Handler(Ignore), + Signal ) #endif -import System.Posix.Types -import System.IO -import System.IO.Error +import System.Posix.Types ( Fd, ProcessID ) +import System.IO ( Handle, hClose, hGetContents, hPutStr ) import Control.Concurrent(forkIO) import Control.Exception(finally) import qualified Control.Exception(try, IOException) @@ -153,7 +170,6 @@ fail m #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Read data from a pipe. Returns a Handle and a 'PipeHandle'. When done, you must hClose the handle, and then use either 'forceSuccess' or @@ -161,13 +177,13 @@ This function logs as pipeFrom. -Not available on Windows or with Hugs. +Not available on Windows. -} hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle) hPipeFrom fp args = do pipepair <- createPipe logRunning "pipeFrom" fp args - let childstuff = do dupTo (snd pipepair) stdOutput + let childstuff = do _ <- dupTo (snd pipepair) stdOutput closeFd (fst pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) @@ -180,10 +196,8 @@ h <- fdToHandle (fst pipepair) return (PipeHandle pid fp args "pipeFrom", h) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Read data from a pipe. Returns a lazy string and a 'PipeHandle'. ONLY AFTER the string has been read completely, You must call either @@ -198,10 +212,8 @@ c <- hGetContents h return (pid, c) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Write data to a pipe. Returns a 'PipeHandle' and a new Handle to write to. @@ -216,7 +228,7 @@ hPipeTo fp args = do pipepair <- createPipe logRunning "pipeTo" fp args - let childstuff = do dupTo (fst pipepair) stdInput + let childstuff = do _ <- dupTo (fst pipepair) stdInput closeFd (snd pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) @@ -229,10 +241,8 @@ h <- fdToHandle (snd pipepair) return (PipeHandle pid fp args "pipeTo", h) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Write data to a pipe. Returns a ProcessID. You must call either @@ -248,10 +258,8 @@ (hClose h) return pid #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe). @@ -270,9 +278,9 @@ do frompair <- createPipe topair <- createPipe logRunning "pipeBoth" fp args - let childstuff = do dupTo (snd frompair) stdOutput + let childstuff = do _ <- dupTo (snd frompair) stdOutput closeFd (fst frompair) - dupTo (fst topair) stdInput + _ <- dupTo (fst topair) stdInput closeFd (snd topair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) @@ -287,10 +295,8 @@ toh <- fdToHandle (snd topair) return (PipeHandle pid fp args "pipeBoth", fromh, toh) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread to send data to the piped program, and simultaneously returns its output stream. @@ -301,12 +307,10 @@ pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String) pipeBoth fp args message = do (pid, fromh, toh) <- hPipeBoth fp args - forkIO $ finally (hPutStr toh message) - (hClose toh) + _ <- forkIO $ finally (hPutStr toh message) (hClose toh) c <- hGetContents fromh return (pid, c) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status @@ -345,7 +349,7 @@ safeSystem command args = do debugM (logbase ++ ".safeSystem") ("Running: " ++ command ++ " " ++ (show args)) -#if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) +#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) ec <- rawSystem command args case ec of ExitSuccess -> return () @@ -364,7 +368,6 @@ #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Invokes the specified command in a subprocess, waiting for the result. Return the result status. Never raises an exception. Only available on POSIX platforms. @@ -398,15 +401,13 @@ do restoresignals oldint oldquit oldset executeFile program True args Nothing restoresignals oldint oldquit oldset = - do installHandler sigINT oldint Nothing - installHandler sigQUIT oldquit Nothing + do _ <- installHandler sigINT oldint Nothing + _ <- installHandler sigQUIT oldquit Nothing setSignalMask oldset #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Invokes the specified command in a subprocess, without waiting for the result. Returns the PID of the subprocess -- it is YOUR responsibility to use getProcessStatus or getAnyProcessStatus on that at some point. Failure @@ -424,7 +425,6 @@ childaction = executeFile program True args Nothing #endif -#endif cmdfailed :: String -> FilePath -> [String] -> Int -> IO a cmdfailed funcname command args failcode = do @@ -435,7 +435,6 @@ ioError e #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a cmdsignalled funcname command args failcode = do let errormsg = "Command " ++ command ++ " " ++ (show args) ++ @@ -444,10 +443,8 @@ warningM (logbase ++ "." ++ funcname) errormsg ioError e #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Open a pipe to the specified command. Passes the handle on to the specified function. @@ -484,10 +481,8 @@ pOpen3 (Just (fst pipepair)) Nothing Nothing fp args callfunc (closeFd (snd pipepair)) #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Runs a command, redirecting things to pipes. Not available on Windows. @@ -510,10 +505,8 @@ forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3") return rv #endif -#endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ {- | Runs a command, redirecting things to pipes. Not available on Windows. @@ -534,7 +527,7 @@ pOpen3Raw pin pout perr fp args childfunc = let mayberedir Nothing _ = return () mayberedir (Just fromfd) tofd = do - dupTo fromfd tofd + _ <- dupTo fromfd tofd closeFd fromfd return () childstuff = do @@ -561,7 +554,6 @@ Left (e :: Control.Exception.IOException) -> fail ("Error in fork: " ++ (show e)) return pid -#endif #endif showCmd :: FilePath -> [String] -> String 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,4 +1,5 @@ -{- +{-# LANGUAGE Safe #-} +{- Copyright (c) 2005-2011 John Goerzen All rights reserved. @@ -9,10 +10,9 @@ {- | Module : MissingH.getOpt Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Written by John Goerzen, jgoerzen\@complete.org @@ -27,8 +27,9 @@ stdOptional ) where -import System.Console.GetOpt -import System.Environment +import safe System.Console.GetOpt + ( getOpt, usageInfo, ArgOrder, OptDescr ) +import safe System.Environment ( getArgs ) {- | Simple command line parser -- a basic wrapper around the system's default getOpt. See the System.Console.GetOpt manual for a description of the @@ -39,11 +40,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 @@ -79,5 +80,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,25 +12,18 @@ {- | Module : System.Daemon Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable to platforms with POSIX process\/signal tools Tools for writing daemons\/server processes Written by John Goerzen, jgoerzen\@complete.org -Please note: Most of this module is not compatible with Hugs. - Messages from this module are logged under @System.Daemon@. See 'System.Log.Logger' for details. -Based on background -from and -. - This module is not available on Windows. -} @@ -41,11 +36,20 @@ where #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Process +import System.Directory ( setCurrentDirectory ) +import System.Exit ( ExitCode(ExitSuccess) ) +import System.Log.Logger ( traplogging, Priority(ERROR) ) import System.Posix.IO -import System.Directory -import System.Log.Logger -import System.Exit + ( openFd, + closeFd, + defaultFileFlags, + dupTo, + stdError, + stdInput, + stdOutput, + OpenMode(ReadWrite) ) +import System.Posix.Process + ( createSession, exitImmediately, forkProcess ) trap :: IO a -> IO a @@ -69,20 +73,26 @@ -} detachDaemon :: IO () detachDaemon = trap $ - do forkProcess child1 + do _ <- forkProcess child1 exitImmediately ExitSuccess child1 :: IO () child1 = trap $ - do createSession - forkProcess child2 + do _ <- createSession + _ <- forkProcess child2 exitImmediately ExitSuccess child2 :: IO () child2 = trap $ do setCurrentDirectory "/" mapM_ closeFd [stdInput, stdOutput, stdError] - nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags + nullFd <- openFd + "/dev/null" + ReadWrite +#if !MIN_VERSION_unix(2,8,0) + Nothing +#endif + defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd #endif diff --git a/src/System/Debian.hs b/src/System/Debian.hs --- a/src/System/Debian.hs +++ b/src/System/Debian.hs @@ -9,10 +9,9 @@ {- | Module : System.Debian Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with Debian @@ -28,9 +27,9 @@ ) where -import System.Process -import System.IO.Unsafe -import System.Exit +import System.Exit ( ExitCode(ExitFailure, ExitSuccess) ) +import System.IO.Unsafe (unsafePerformIO) +import System.Process ( rawSystem ) {- | 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,10 +11,9 @@ {- | Module : System.Debian.ControlParser Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with Debian @@ -24,41 +25,53 @@ module System.Debian.ControlParser(control, depPart) where -import Text.ParserCombinators.Parsec -import Data.String.Utils (split) +import safe Data.List.Utils ( split ) +import safe Text.ParserCombinators.Parsec + ( char, + noneOf, + oneOf, + string, + many1, + manyTill, + (), + (<|>), + many, + try, + GenParser, + CharParser ) eol, extline :: GenParser Char st String eol = (try (string "\r\n")) <|> string "\n" "EOL" -extline = try (do char ' ' +extline = try (do _ <- char ' ' content <- many (noneOf "\r\n") - eol + _ <- eol return content ) entry :: GenParser Char st (String, String) entry = do key <- many1 (noneOf ":\r\n") - char ':' + _ <- char ':' val <- many (noneOf "\r\n") - eol + _ <- eol exts <- many extline return (key, unlines ([val] ++ exts)) {- | Main parser for the control file -} control :: CharParser a [(String, String)] -control = do many header +control = do _ <- many header retval <- many entry return retval headerPGP, blankLine, header, headerHash :: GenParser Char st () -headerPGP = do string "-----BEGIN PGP" - manyTill (noneOf "\r\n") eol +headerPGP = do _ <- string "-----BEGIN PGP" + _ <- manyTill (noneOf "\r\n") eol return () -blankLine = do many (oneOf " \t") - eol +blankLine = do _ <- many (oneOf " \t") + _ <- eol return () -headerHash = do string "Hash: " - manyTill (noneOf "\r\n") eol +headerHash = do _ <- string "Hash: " + _ <- manyTill (noneOf "\r\n") eol return () header = (try headerPGP) <|> (try blankLine) <|> (try headerHash) @@ -69,20 +82,20 @@ version is (operator, operand) -} depPart :: CharParser a (String, (Maybe (String, String)), [String]) depPart = do packagename <- many1 (noneOf " (") - many (char ' ') - version <- (do char '(' + _ <- many (char ' ') + version <- (do _ <- char '(' op <- many1 (oneOf "<>=") - many (char ' ') + _ <- many (char ' ') vers <- many1 (noneOf ") ") - many (char ' ') - char ')' + _ <- many (char ' ') + _ <- char ')' return $ Just (op, vers) ) <|> return Nothing - many (char ' ') - archs <- (do char '[' + _ <- many (char ' ') + archs <- (do _ <- char '[' t <- many1 (noneOf "]") - many (char ' ') - char ']' + _ <- many (char ' ') + _ <- char ']' return (split " " t) ) <|> return [] return (packagename, version, archs) 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: GZip file support in Haskell Copyright (c) 2004-2011 John Goerzen @@ -9,10 +11,9 @@ {- | Module : System.FileArchive.GZip Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable GZip file decompression @@ -38,14 +39,14 @@ ) where +import Control.Monad.Except (MonadError(..)) +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.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 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 @@ -53,10 +54,6 @@ | UnknownError String -- ^ Other problem arose deriving (Eq, Show) -instance Error GZipError where - noMsg = UnknownError "" - strMsg = UnknownError - -- | First two bytes of file magic :: String magic = "\x1f\x8b" @@ -72,20 +69,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 } @@ -194,12 +191,12 @@ read_header :: String -> Either GZipError (Header, String) read_header s = let ok = Right "ok" in - do let (mag, rem) = splitAt 2 s - if mag /= magic + do let (mag, rem1) = splitAt 2 s + _ <- if mag /= magic then throwError NotGZIPFile else ok - let (method, rem2) = split1 rem - if (ord(method) /= 8) + let (method, rem2) = split1 rem1 + _ <- if (ord(method) /= 8) then throwError UnknownMethod else ok let (flag_S, rem3) = split1 rem2 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,10 +11,9 @@ {- | Module : System.IO.Binary Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable to platforms supporting binary I\/O This module provides various helpful utilities for dealing with binary @@ -28,21 +29,6 @@ Versions of MissingH prior 0.11.6 lacked the 'BinaryConvertible' class and worked only with Strings and Handles. -Important note: /binary functions are not supported in all Haskell -implementations/. Do not import or use this module unless you know you -are using an implementation that supports them. At this time, here -is the support status: - - * GHC 6.2 and above: yes - - * GHC 6.x, earlier versions: unknown - - * GHC 5.x: no - - * nhc98: no - - * Hugs: partial (maybe complete; needs more testing) - Non-binary functions may be found in "System.IO". See also: "System.IO.BlockIO" @@ -74,11 +60,21 @@ import Foreign.C.String (peekCStringLen, withCString) import Foreign.C.Types (CChar()) import Foreign.ForeignPtr + ( ForeignPtr, mallocForeignPtrArray, withForeignPtr ) import Foreign.Marshal.Array (peekArray, withArray) -import Foreign.Ptr +import Foreign.Ptr ( Ptr, castPtr ) import System.IO + ( stdout, + hClose, + openBinaryFile, + stdin, + IOMode(WriteMode, ReadMode) ) import System.IO.HVFS + ( SystemFS(SystemFS), + HVFSOpenable(vOpenBinaryFile), + HVFSOpenEncap(HVFSOpenEncap) ) import System.IO.HVIO + ( HVIO(vClose, vGetBuf, vPutBuf, vGetContents, vPutStr) ) import System.IO.Unsafe (unsafeInterleaveIO) {- | Provides support for handling binary blocks with convenient 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 #-} +{-# LANGUAGE TypeSynonymInstances #-} {- arch-tag: HVFS main file Copyright (c) 2004-2011 John Goerzen @@ -10,10 +11,9 @@ {- | Module : System.IO.HVFS Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Haskell Virtual FS -- generic support for real or virtual filesystem in Haskell @@ -41,7 +41,7 @@ -} module System.IO.HVFS(-- * Implementation Classes \/ Types - HVFS(..), HVFSStat(..), + HVFS(..), HVFSStat(..), HVFSOpenable(..), HVFSOpenEncap(..),HVFSStatEncap(..), withStat, withOpen, SystemFS(..), @@ -53,14 +53,49 @@ where import qualified Control.Exception (catch, IOException) -import System.IO.HVIO -import System.Time.Utils +import System.IO.HVIO ( HVIO(vGetContents, vPutStr, vClose) ) +import System.Time.Utils ( epochToClockTime ) import System.IO + ( openBinaryFile, openFile, IOMode(ReadMode, WriteMode) ) import System.IO.Error + ( IOErrorType, illegalOperationErrorType, mkIOError ) import System.IO.PlafCompat -import System.Posix.Types -import System.Time -import System.Directory + ( DeviceID, + EpochTime, + FileID, + FileMode, + FileOffset, + GroupID, + LinkCount, + UserID, +#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) + createLink, + createSymbolicLink, + getSymbolicLinkStatus, + readSymbolicLink, +#endif + accessTime, + deviceID, + fileGroup, + fileID, + fileMode, + fileOwner, + fileSize, + getFileStatus, + isBlockDevice, + isCharacterDevice, + isDirectory, + isNamedPipe, + isRegularFile, + isSocket, + isSymbolicLink, + linkCount, + modificationTime, + specialDeviceID, + statusChangeTime, + FileStatus ) +import System.Time ( ClockTime(..) ) +import qualified System.Directory as D #if MIN_VERSION_directory(1,2,0) import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) @@ -75,11 +110,11 @@ data HVFSStatEncap = forall a. HVFSStat a => HVFSStatEncap a {- | Convenience function for working with stat -- takes a stat result -and a function that uses it, and returns the result. +and a function that uses it, and returns the result. Here is an example from the HVFS source: -> vGetModificationTime fs fp = +> vGetModificationTime fs fp = > do s <- vGetFileStatus fs fp > return $ epochToClockTime (withStat s vModificationTime) @@ -204,7 +239,7 @@ vReadSymbolicLink :: a -> FilePath -> IO FilePath vCreateLink :: a -> FilePath -> FilePath -> IO () - vGetModificationTime fs fp = + vGetModificationTime fs fp = do s <- vGetFileStatus fs fp return $ epochToClockTime (withStat s vModificationTime) vRaiseError _ et desc mfp = @@ -213,16 +248,16 @@ vGetCurrentDirectory fs = eh fs "vGetCurrentDirectory" vSetCurrentDirectory fs _ = eh fs "vSetCurrentDirectory" vGetDirectoryContents fs _ = eh fs "vGetDirectoryContents" - vDoesFileExist fs fp = + vDoesFileExist fs fp = Control.Exception.catch (do s <- vGetFileStatus fs fp return $ withStat s vIsRegularFile ) (\(_ :: Control.Exception.IOException) -> return False) - vDoesDirectoryExist fs fp = + vDoesDirectoryExist fs fp = Control.Exception.catch (do s <- vGetFileStatus fs fp return $ withStat s vIsDirectory ) (\(_ :: Control.Exception.IOException) -> return False) vDoesExist fs fp = - Control.Exception.catch (do s <- vGetSymbolicLinkStatus fs fp + Control.Exception.catch (do _ <- vGetSymbolicLinkStatus fs fp return True ) (\(_ :: Control.Exception.IOException) -> return False) vCreateDirectory fs _ = eh fs "vCreateDirectory" @@ -237,7 +272,7 @@ -- | Error handler helper eh :: HVFS a => a -> String -> IO c -eh fs desc = vRaiseError fs illegalOperationErrorType +eh fs desc = vRaiseError fs illegalOperationErrorType (desc ++ " is not implemented in this HVFS class") Nothing {- | Types that can open a HVIO object should be instances of this class. @@ -249,7 +284,7 @@ vWriteFile :: a -> FilePath -> String -> IO () vOpenBinaryFile :: a -> FilePath -> IOMode -> IO HVFSOpenEncap - vReadFile h fp = + vReadFile h fp = do oe <- vOpen h fp ReadMode withOpen oe (\fh -> vGetContents fh) @@ -291,16 +326,16 @@ deriving (Eq, Show) instance HVFS SystemFS where - vGetCurrentDirectory _ = getCurrentDirectory - vSetCurrentDirectory _ = setCurrentDirectory - vGetDirectoryContents _ = getDirectoryContents - vDoesFileExist _ = doesFileExist - vDoesDirectoryExist _ = doesDirectoryExist - vCreateDirectory _ = createDirectory - vRemoveDirectory _ = removeDirectory - vRenameDirectory _ = renameDirectory - vRemoveFile _ = removeFile - vRenameFile _ = renameFile + vGetCurrentDirectory _ = D.getCurrentDirectory + vSetCurrentDirectory _ = D.setCurrentDirectory + vGetDirectoryContents _ = D.getDirectoryContents + vDoesFileExist _ = D.doesFileExist + vDoesDirectoryExist _ = D.doesDirectoryExist + vCreateDirectory _ = D.createDirectory + vRemoveDirectory _ = D.removeDirectory + vRenameDirectory _ = D.renameDirectory + vRemoveFile _ = D.removeFile + vRenameFile _ = D.renameFile vGetFileStatus _ fp = getFileStatus fp >>= return . HVFSStatEncap #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vGetSymbolicLinkStatus _ fp = getSymbolicLinkStatus fp >>= return . HVFSStatEncap @@ -310,9 +345,9 @@ #endif #if MIN_VERSION_directory(1,2,0) - vGetModificationTime _ p = getModificationTime p >>= (\modUTCTime -> return $ TOD ((toEnum . fromEnum . utcTimeToPOSIXSeconds) modUTCTime) 0) + vGetModificationTime _ p = D.getModificationTime p >>= (\modUTCTime -> return $ TOD ((toEnum . fromEnum . utcTimeToPOSIXSeconds) modUTCTime) 0) #else - vGetModificationTime _ = getModificationTime + vGetModificationTime _ = D.getModificationTime #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vCreateSymbolicLink _ = createSymbolicLink @@ -327,4 +362,3 @@ instance HVFSOpenable SystemFS where vOpen _ fp iomode = openFile fp iomode >>= return . HVFSOpenEncap vOpenBinaryFile _ fp iomode = openBinaryFile fp iomode >>= return . HVFSOpenEncap - 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 @@ -9,10 +9,9 @@ {- | 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 + Stability : stable Portability: portable Support for combining different HVFS modules together @@ -26,16 +25,22 @@ HVFSChroot, newHVFSChroot) where -import System.IO +import System.IO ( IOMode(ReadMode) ) import System.IO.Error + ( doesNotExistErrorType, permissionErrorType ) 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 - -- so, but I'm not sure... -#endif -import System.Path (secureAbsNormPath) -import System.Path.NameManip (normalise_path) + ( HVFSOpenable(vOpen), + HVFS(vRemoveFile, vCreateLink, vCreateSymbolicLink, vRenameFile, + vRenameDirectory, vRemoveDirectory, vCreateDirectory, + vGetCurrentDirectory, vGetDirectoryContents, vDoesFileExist, + vGetFileStatus, vGetSymbolicLinkStatus, vGetModificationTime, + vReadSymbolicLink, vRaiseError, vDoesDirectoryExist, + vSetCurrentDirectory) ) +import System.IO.HVFS.InstanceHelpers (getFullPath) +import System.FilePath (isPathSeparator, pathSeparator, + ()) +import System.Path (secureAbsNormPath) +import System.Path.NameManip (normalise_path) ---------------------------------------------------------------------- -- Providing read-only access @@ -78,7 +83,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 @@ -97,7 +102,7 @@ isdir <- vDoesDirectoryExist fh full if isdir then do let newobj = (HVFSChroot full fh) - vSetCurrentDirectory newobj "/" + vSetCurrentDirectory newobj [pathSeparator] return newobj else vRaiseError fh doesNotExistErrorType ("Attempt to instantiate HVFSChroot over non-directory " ++ full) @@ -110,10 +115,9 @@ {- | Convert a local (chroot) path to a full path. -} dch2fp, fp2dch :: (HVFS t) => HVFSChroot t -> String -> IO String dch2fp mainh@(HVFSChroot fp h) locfp = - do full <- case (head locfp) of - '/' -> return (fp ++ locfp) - _ -> do y <- getFullPath mainh locfp - return $ fp ++ y + do full <- (fp ++) `fmap` if isPathSeparator (head locfp) + then return locfp + else getFullPath mainh locfp case secureAbsNormPath fp full of Nothing -> vRaiseError h doesNotExistErrorType ("Trouble normalizing path in chroot") @@ -125,14 +129,14 @@ do newpath <- case secureAbsNormPath fp locfp of Nothing -> vRaiseError h doesNotExistErrorType ("Unable to securely normalize path") - (Just (fp ++ "/" ++ locfp)) + (Just (fp locfp)) Just x -> return x if (take (length fp) newpath /= fp) then vRaiseError h doesNotExistErrorType ("Local path is not subdirectory of parent path") (Just newpath) else let newpath2 = drop (length fp) newpath - in return $ normalise_path ("/" ++ newpath2) + in return $ normalise_path ([pathSeparator] ++ newpath2) dch2fph :: (HVFS t) => (t -> String -> IO t1) -> HVFSChroot t -> [Char] -> IO t1 dch2fph func fh@(HVFSChroot _ h) locfp = 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,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: HVFS instance helpers Copyright (c) 2004-2011 John Goerzen @@ -9,10 +11,9 @@ {- | 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 + Stability : stable Portability: portable Utilities for creating instances of the items defined in @@ -33,20 +34,30 @@ 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 Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (genericLength) +import System.FilePath (isPathSeparator, pathSeparator, ()) +import System.IO ( IOMode(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) + ( FileOffset, + HVFSOpenable(vOpen), + HVFS(vGetDirectoryContents, vGetFileStatus, vSetCurrentDirectory, + vRaiseError, vGetCurrentDirectory), + HVFSStat(vIsRegularFile, vFileSize, vIsDirectory), + HVFSOpenEncap(HVFSOpenEncap), + HVFSStatEncap(HVFSStatEncap) ) +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 @@ -70,7 +81,7 @@ resizable ramdisk written in Haskell. -} data MemoryVFS = MemoryVFS { content :: IORef [MemoryNode], - cwd :: IORef FilePath + cwd :: IORef FilePath } instance Show MemoryVFS where @@ -86,7 +97,7 @@ -- existing tree. newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS newMemoryVFSRef r = do - c <- newIORef "/" + c <- newIORef [pathSeparator] return (MemoryVFS {content = r, cwd = c}) {- | Similar to 'System.Path.NameManip' but the first element @@ -96,23 +107,24 @@ >nice_slice "/foo/bar" -> ["foo", "bar"] -} nice_slice :: String -> [String] -nice_slice "/" = [] -nice_slice path = - let sliced1 = slice_path path - h = head sliced1 - t = tail sliced1 - newh = if head h == '/' then tail h else h - sliced2 = newh : t - in sliced2 +nice_slice path + | path == [pathSeparator] = [] + | otherwise = + let sliced1 = slice_path path + h = head sliced1 + t = tail sliced1 + newh = if isPathSeparator (head h) then tail h else h + sliced2 = newh : t + in sliced2 {- | Gets a full path, after investigating the cwd. -} getFullPath :: HVFS a => a -> String -> IO String getFullPath fs path = - do cwd <- vGetCurrentDirectory fs - case (absNormPath cwd path) of + do dir <- vGetCurrentDirectory fs + case (absNormPath dir path) of Nothing -> vRaiseError fs doesNotExistErrorType - ("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path)) + ("Trouble normalizing path " ++ path) (Just (dir path)) Just newpath -> return newpath {- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'. @@ -124,34 +136,34 @@ -- | Find an element on the tree, assuming a normalized path findMelem :: MemoryVFS -> String -> IO MemoryEntry -findMelem x "/" = readIORef (content x) >>= return . MemoryDirectory -findMelem x path = +findMelem x path + | path == [pathSeparator] = readIORef (content x) >>= return . MemoryDirectory + | otherwise = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 - newh = if (h /= "/") && head h == '/' then tail h else h + newh = if (h /= [pathSeparator]) && isPathSeparator (head h) then tail h else h sliced2 = newh : t -- Walk the tree walk :: MemoryEntry -> [String] -> Either String MemoryEntry -- Empty list -- return the item we have - walk y [] = Right y - -- Root directory -- return the item we have - walk y ["/"] = Right y - -- File but stuff: error - walk (MemoryFile _) (z : _) = - Left $ "Attempt to look up name " ++ z ++ " in file" - walk (MemoryDirectory y) (z : zs) = - let newentry = case lookup z y of - Nothing -> Left $ "Couldn't find entry " ++ z - Just a -> Right a + walk y zs + | null zs = Right y + | zs == [[pathSeparator]] = Right y + | otherwise = case y of + MemoryFile _ -> Left $ "Attempt to look up name " ++ head zs ++ " in file" + MemoryDirectory y -> + let newentry = case lookup (head zs) y of + Nothing -> Left $ "Couldn't find entry " ++ head zs + Just a -> Right a in do newobj <- newentry - walk newobj zs - in do - c <- readIORef $ content x - case walk (MemoryDirectory c) (sliced2) of - Left err -> vRaiseError x doesNotExistErrorType err Nothing - Right result -> return result + walk newobj (tail zs) + in do + c <- readIORef $ content x + case walk (MemoryDirectory c) (sliced2) of + Left err -> vRaiseError x doesNotExistErrorType err Nothing + Right result -> return result -- | Find an element on the tree, normalizing the path first getMelem :: MemoryVFS -> String -> IO MemoryEntry @@ -179,8 +191,7 @@ "Bad internal error" (Just fp) Just y -> writeIORef (cwd x) y vGetFileStatus x fp = - do elem <- getMelem x fp - case elem of + getMelem x fp >>= \case (MemoryFile y) -> return $ HVFSStatEncap $ SimpleStat {isFile = True, fileSize = (genericLength y)} @@ -188,8 +199,7 @@ SimpleStat {isFile = False, fileSize = 0} vGetDirectoryContents x fp = - do elem <- getMelem x fp - case elem of + getMelem x fp >>= \case MemoryFile _ -> vRaiseError x doesNotExistErrorType "Can't list contents of a file" (Just fp) @@ -197,8 +207,7 @@ instance HVFSOpenable MemoryVFS where vOpen x fp (ReadMode) = - do elem <- getMelem x fp - case elem of + getMelem x fp >>= \case MemoryDirectory _ -> vRaiseError x doesNotExistErrorType "Can't open a directory" (Just fp) @@ -206,4 +215,3 @@ vOpen x fp _ = vRaiseError x permissionErrorType "Only ReadMode is supported with MemoryVFS files" (Just fp) - 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,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {- arch-tag: HVFS utilities main file Copyright (c) 2004-2011 John Goerzen @@ -10,13 +12,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 + Stability : stable 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,15 +34,36 @@ ) where +import System.FilePath (pathSeparator, ()) import System.IO.HVFS -import System.Time.Utils + ( SystemFS(..), + HVFS(vGetSymbolicLinkStatus, vRemoveDirectory, vRemoveFile, + vReadSymbolicLink, vGetDirectoryContents), + HVFSStat(vFileSize, vIsDirectory, vIsBlockDevice, + vIsCharacterDevice, vIsSocket, vIsNamedPipe, vModificationTime, + vIsSymbolicLink, vFileMode, vFileOwner, vFileGroup), + HVFSStatEncap(..), + withStat ) import System.IO.PlafCompat -import Text.Printf -import System.Time -import System.Locale -import System.IO.Unsafe + ( groupExecuteMode, + groupReadMode, + groupWriteMode, + intersectFileModes, + otherExecuteMode, + otherReadMode, + otherWriteMode, + ownerExecuteMode, + ownerReadMode, + ownerWriteMode, + setGroupIDMode, + setUserIDMode ) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Locale ( defaultTimeLocale ) +import System.Time ( formatCalendarTime, toCalendarTime ) +import System.Time.Utils ( epochToClockTime ) +import Text.Printf ( 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. @@ -67,12 +89,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 ++ "/")) $ + let contents = map ((++) (fn ++ [pathSeparator])) $ filter (\x -> x /= "." && x /= "..") dirc subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents return $ (concat subdirs) ++ [(fn, fs)] @@ -82,9 +104,9 @@ child files\/directories. -} recursiveRemove :: HVFS a => a -> FilePath -> IO () -recursiveRemove h fn = - recurseDirStat h fn >>= (mapM_ $ - \(fn, fs) -> if withStat fs vIsDirectory +recursiveRemove h path = + recurseDirStat h path >>= (mapM_ $ + \(fn, fs) -> if withStat fs vIsDirectory then vRemoveDirectory h fn else vRemoveFile h fn ) @@ -95,7 +117,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 '-') : @@ -109,10 +131,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' @@ -121,15 +143,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 - (origdir ++ "/" ++ fp) + 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) @@ -139,10 +161,8 @@ fp linkstr in do c <- vGetDirectoryContents fs fp - pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp ++ "/" ++ x) - return (ss, x) + pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp 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,3 +1,5 @@ +{-# LANGUAGE Safe #-} + {- arch-tag: HVIO main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +11,9 @@ {- | Module : System.IO.HVIO Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Haskell Virtual I\/O -- a system to increase the flexibility of input and @@ -119,14 +120,46 @@ ) 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 safe Control.Concurrent.MVar + ( newEmptyMVar, putMVar, readMVar, takeMVar, MVar ) +import qualified Control.Exception (catch) +import safe Data.IORef ( IORef, modifyIORef, newIORef, readIORef ) +import safe Foreign.C ( castCharToCChar, peekCStringLen ) +import safe Foreign.Ptr ( Ptr, castPtr, plusPtr ) +import safe Foreign.Storable ( Storable(poke) ) +import safe System.IO + ( Handle, + hClose, + hFlush, + hGetBuffering, + hIsClosed, + hIsEOF, + hIsOpen, + hIsReadable, + hIsSeekable, + hIsWritable, + hSeek, + hSetBuffering, + hShow, + hTell, + hGetBuf, + hGetChar, + hGetContents, + hGetLine, + hPutBuf, + hPutChar, + hPutStr, + hPutStrLn, + hPrint, + hReady, + SeekMode(..), + BufferMode(NoBuffering) ) +import safe System.IO.Error + ( IOErrorType, + eofErrorType, + illegalOperationErrorType, + isEOFError, + mkIOError ) {- | 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'. @@ -285,7 +318,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 @@ -293,7 +326,7 @@ do firstchar <- vGetChar h case firstchar of '\n' -> return [] - x -> loop [x] + x -> loop [x] vGetContents h = let loop = @@ -356,9 +389,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 @@ -433,7 +464,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) @@ -541,7 +572,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,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} + {- Platform Compatibility Layer Copyright (c) 2005-2011 John Goerzen @@ -10,10 +11,9 @@ {- | Module : System.IO.PlafCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable On Unix, exports System.Posix.Types and System.Posix.Files. @@ -34,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,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen @@ -10,10 +11,9 @@ {- | Module : System.IO.StatCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Provide a stat-like structure for use in MissingH. Especially @@ -21,31 +21,48 @@ -} -module System.IO.StatCompat -where -import System.Posix.Types -import System.Posix.Consts +module System.IO.StatCompat where + +import safe System.Posix.Consts + ( blockSpecialMode, + characterSpecialMode, + namedPipeMode, + regularFileMode, + directoryMode, + fileTypeModes, + socketMode, + symbolicLinkMode ) +import safe System.Posix.Types + ( DeviceID, + EpochTime, + FileID, + FileMode, + FileOffset ) + #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.Files(intersectFileModes) -#endif -import Data.Bits ((.&.)) +import safe System.Posix.Types ( LinkCount, UserID, GroupID ) +import safe System.Posix.Files ( intersectFileModes ) +#else +import safe Data.Bits ( (.&.) ) -#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) type LinkCount = Int type UserID = Int type GroupID = Int + +intersectFileModes :: FileMode -> FileMode -> FileMode +intersectFileModes m1 m2 = m1 .&. m2 #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 } @@ -62,8 +79,3 @@ isDirectory = sc_helper directoryMode isSymbolicLink = sc_helper symbolicLinkMode isSocket = sc_helper socketMode - -#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -intersectFileModes :: FileMode -> FileMode -> FileMode -intersectFileModes m1 m2 = m1 .&. m2 -#endif 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,10 +11,9 @@ {- | Module : System.IO.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable -} @@ -34,10 +35,12 @@ 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 (BufferMode (BlockBuffering, LineBuffering), + IOMode (ReadMode, WriteMode), hClose, + hSetBuffering, openFile, stdin, stdout) +import System.IO.HVIO (HVIO (vGetContents, vGetLine, vIsEOF, vPutStr, vPutStrLn)) +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. @@ -117,8 +120,8 @@ hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO () hLineInteract finput foutput func = do - lines <- hGetLines finput - hPutStrLns foutput (func lines) + ls <- hGetLines finput + hPutStrLns foutput (func ls) {- | Copies from one handle to another in raw mode (using hGetContents). 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + {- Windows compatibility layer Copyright (c) 2005-2011 John Goerzen @@ -10,10 +11,9 @@ {- | Module : System.IO.WindowsCompat Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Provides some types and related items on Windows to be compatible with diff --git a/src/System/Path.hs b/src/System/Path.hs --- a/src/System/Path.hs +++ b/src/System/Path.hs @@ -10,10 +10,9 @@ {- | Module : System.Path Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various helpful utilities for dealing with path and @@ -31,20 +30,23 @@ mktmpdir, brackettmpdir, brackettmpdirCWD ) where -import Data.List -import Data.List.Utils +import Data.List.Utils ( startswith, alwaysElemRIndex ) #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 + ( getCurrentDirectory, removeFile, setCurrentDirectory ) +import System.Posix.Directory ( createDirectory ) +import System.Posix.Temp ( mkstemp ) #else import System.Directory +import System.IO ( openTempFile ) #endif -import Control.Exception -import System.IO -import System.Path.NameManip +import Control.Exception ( finally ) +import System.FilePath ( pathSeparator ) +import System.IO ( hClose ) import System.IO.HVFS.Utils + ( SystemFS(SystemFS), recurseDir, recurseDirStat, recursiveRemove ) +import System.Path.NameManip + ( normalise_path, absolute_path_by, guess_dotdot ) {- | 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 @@ -53,7 +55,7 @@ splitExt :: String -> (String, String) splitExt path = let dotindex = alwaysElemRIndex '.' path - slashindex = alwaysElemRIndex '/' path + slashindex = alwaysElemRIndex pathSeparator path in if dotindex <= slashindex then (path, "") @@ -75,10 +77,10 @@ -> String -- ^ The path name to make absolute -> Maybe String -- ^ Result absNormPath base thepath = - let abs = absolute_path_by base thepath - in case guess_dotdot (normalise_path abs) of - Just "." -> Just "/" - x -> x + let path = absolute_path_by base thepath + in case guess_dotdot (normalise_path path) of + Just "." -> Just [pathSeparator] + x -> x {- | Like absNormPath, but returns Nothing if the generated result is not the passed base path or a subdirectory thereof. -} @@ -110,16 +112,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 @@ -9,10 +9,9 @@ {- | Module : System.Path.Glob Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Functions for expanding wildcards, filenames, and pathnames. @@ -24,13 +23,15 @@ module System.Path.Glob (glob, vGlob) where -import Data.List.Utils (hasAny) -import System.IO.HVFS -import System.FilePath (splitFileName) -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 (pathSeparator, splitFileName, ()) +import System.IO.HVFS (HVFS (vDoesDirectoryExist, vDoesExist, vGetDirectoryContents), + SystemFS (SystemFS)) +import System.Path.WildMatch (wildCheckCase) + hasWild :: String -> Bool hasWild = hasAny "*?[" @@ -60,27 +61,24 @@ else expandGlob fs fn -- It's there expandGlob :: HVFS a => a -> FilePath -> IO [FilePath] -expandGlob fs fn = - case dirnameslash of - "./" -> runGlob fs "." basename - "/" -> do - rgs <- runGlob fs "/" basename - return $ map ('/' :) rgs - _ -> do dirlist <- if hasWild dirname - then expandGlob fs dirname - else return [dirname] - if hasWild basename - then do r <- mapM expandWildBase dirlist - return $ concat r - else do r <- mapM expandNormalBase dirlist - return $ concat r +expandGlob fs fn + | dirnameslash == '.':pathSeparator:[] = runGlob fs "." basename + | dirnameslash == [pathSeparator] = do + rgs <- runGlob fs [pathSeparator] basename + return $ map (pathSeparator :) rgs + | otherwise = do dirlist <- if hasWild dirname + then expandGlob fs dirname + else return [dirname] + if hasWild basename + then concat `fmap` mapM expandWildBase dirlist + else concat `fmap` mapM expandNormalBase dirlist where (dirnameslash, basename) = splitFileName fn - dirname = case dirnameslash of - "/" -> "/" - x -> if isSuffixOf "/" x - then take (length x - 1) x - else x + dirname = if dirnameslash == [pathSeparator] + then [pathSeparator] + else if isSuffixOf [pathSeparator] dirnameslash + then init dirnameslash + else dirnameslash expandWildBase :: FilePath -> IO [FilePath] expandWildBase dname = @@ -88,15 +86,15 @@ return $ map withD dirglobs where withD = case dname of "" -> id - _ -> \globfn -> dname ++ "/" ++ globfn + _ -> \globfn -> dname ++ [pathSeparator] ++ globfn expandNormalBase :: FilePath -> IO [FilePath] expandNormalBase dname = do isdir <- vDoesDirectoryExist fs dname - let newname = dname ++ "/" ++ basename + let newname = dname basename isexists <- vDoesExist fs newname if isexists && ((basename /= "." && basename /= "") || isdir) - then return [dname ++ "/" ++ basename] + then return [dname basename] else return [] runGlob :: HVFS a => a -> FilePath -> FilePath -> IO [FilePath] 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 @@ -1,10 +1,11 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- | Module : System.Path.NameManip Copyright : Copyright (C) 2004 Volker Wysk - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Low-level path name manipulations. @@ -14,8 +15,9 @@ module System.Path.NameManip where -import Data.List (intersperse) -import System.Directory (getCurrentDirectory) +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 @@ -37,21 +39,23 @@ -} slice_path :: String -- ^ The path to be broken to components. -> [String] -- ^ List of path components. -slice_path p = - case p of - ('/':p') -> case slice_path' p' of - [] -> ["/"] - (c:cs) -> (('/':c):cs) - _ -> slice_path' p - where +slice_path "" = [] +slice_path (c:cs) = if isPathSeparator c + then case slice_path' cs of + [] -> [[c]] + (p:ps) -> (c:p):ps + else slice_path' (c:cs) + where slice_path' o = filter (\c -> c /= "" && c /= ".") (split o) - split "" = [] - split ('/':o) = "" : split o - split (x:xs) = case split xs of - [] -> [[x]] - (y:ys) -> ((x:y):ys) + split xs = unfoldr f xs + where + f "" = Nothing + f xs = Just $ fmap tail' $ break isPathSeparator xs + tail' [] = [] + tail' xs = tail xs + {- | Form a path from path components. This isn't the inverse of 'slice_path', since @'unslice_path' . 'slice_path'@ normalises the path. @@ -61,7 +65,7 @@ unslice_path :: [String] -- ^ List of path components -> String -- ^ The path which consists of the supplied path components unslice_path [] = "." -unslice_path cs = concat (intersperse "/" cs) +unslice_path cs = intercalate [pathSeparator] cs {- | Normalise a path. This is done by reducing repeated @\/@ characters to one, and removing @@ -121,8 +125,7 @@ -} slice_filename' :: String -- ^ File name without path -> [String] -- ^ List of components the file name is made up of -slice_filename' filename = - case filename of +slice_filename' = \case ('.':filename') -> case slice_filename'' filename' of [] -> ["."] (t:ts) -> ('.':t) : ts @@ -152,7 +155,7 @@ -} unslice_filename :: [String] -- ^ List of file name components -> String -- ^ Name of the file which consists of the supplied components -unslice_filename = concat . intersperse "." +unslice_filename = intercalate "." {- | Split a path in directory and file name. Only in the case that the @@ -188,13 +191,12 @@ split_path "" = ("","") split_path path = case slice_path path of - [] -> (".",".") - ["/"] -> ("/", ".") - ['/':p] -> ("/", p) - [fn] -> (".", fn) - parts -> ( unslice_path (init parts) - , last parts - ) + [] -> (".", ".") + [""] -> (".", "") + [f:fs] -> if isPathSeparator f then ([pathSeparator], fs) else (".", f:fs) + parts -> ( unslice_path (init parts) + , last parts + ) {- | Get the directory part of a path. @@ -251,7 +253,7 @@ unsplit_path ("", q) = q unsplit_path (p, "") = p unsplit_path (p, ".") = p -unsplit_path (p, q) = p ++ "/" ++ q +unsplit_path (p, q) = p q {- | Split a file name in prefix and suffix. If there isn't any suffix in @@ -287,7 +289,7 @@ case slice_path path of [] -> (".","") comps -> let (pref_fn, suff_fn) = split_filename' (last comps) - in ( concat (intersperse "/" (init comps ++ [pref_fn])) + in ( intercalate [pathSeparator] (init comps ++ [pref_fn]) , suff_fn ) @@ -367,10 +369,7 @@ -} absolute_path :: String -- ^ The path to be made absolute -> IO String -- ^ Absulte path -absolute_path path@('/':_) = return path -absolute_path path = do - cwd <- getCurrentDirectory - return (cwd ++ "/" ++ path) +absolute_path path = fmap (absolute_path' path) getCurrentDirectory {- | Make a path absolute. @@ -381,8 +380,7 @@ absolute_path_by :: String -- ^ The directory relative to which the path is made absolute -> String -- ^ The path to be made absolute -> String -- ^ Absolute path -absolute_path_by _ path@('/':_) = path -absolute_path_by dir path = dir ++ "/" ++ path +absolute_path_by = () {- | Make a path absolute. @@ -395,8 +393,7 @@ absolute_path' :: String -- ^ The path to be made absolute -> String -- ^ The directory relative to which the path is made absolute -> String -- ^ Absolute path -absolute_path' path@('/':_) _ = path -absolute_path' path dir = dir ++ "/" ++ path +absolute_path' = flip absolute_path_by {- | Guess the @\"..\"@-component free form of a path, specified as a list of path components, by syntactically removing them, along with the preceding 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 Safe #-} + {- Copyright (c) 2006-2011 John Goerzen @@ -9,10 +11,9 @@ {- | Module : System.Path.WildMatch Copyright : Copyright (C) 2006-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Matching filenames with wildcards. See also "System.Path.Glob" for @@ -55,8 +56,8 @@ wildToRegex) where -import Text.Regex -import Data.String.Utils +import Data.String.Utils ( escapeRe ) +import Text.Regex ( matchRegex, mkRegex ) {- | 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,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} {- Posix consts not included with Haskell Copyright (c) 2005-2011 John Goerzen @@ -10,10 +10,9 @@ {- | Module : System.Posix.Consts Copyright : Copyright (C) 2005-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable Exports some POSIX constants and functions that are not exported in fptools @@ -22,8 +21,9 @@ -} module System.Posix.Consts where -import System.Posix.Types +import safe System.Posix.Types ( FileMode ) + blockSpecialMode :: FileMode blockSpecialMode = 0o0060000 @@ -47,5 +47,3 @@ symbolicLinkMode :: FileMode symbolicLinkMode = 0o0120000 - - diff --git a/src/System/Time/ParseDate.hs b/src/System/Time/ParseDate.hs deleted file mode 100644 --- a/src/System/Time/ParseDate.hs +++ /dev/null @@ -1,284 +0,0 @@ -{- | - Module : System.Time.ParseDate - Copyright : (c) by Björn Bringert - License : GPL2 - - Maintainer : Björn Bringert - Stability : provisional - Portability : portable - -Utility for parsing dates. --} -module System.Time.ParseDate (parseCalendarTime) where - -import Control.Monad (liftM) -import Data.Char (isSpace) -import System.Locale -import System.Time -import Text.ParserCombinators.Parsec - -{- | Parse a date string as formatted by 'formatCalendarTime'. - - The resulting 'CalendarTime' will only have those fields set that - are represented by a format specifier in the format string, and those - fields will be set to the values given in the date string. - If the same field is specified multiple times, the rightmost - occurence takes precedence. - - The resulting date is not neccessarily a valid date. For example, - if there is no day of the week specifier in the format string, - the value of 'ctWDay' will most likely be invalid. - - Format specifiers are % followed by some character. All other - characters are treated literally. Whitespace in the format string - matches zero or more arbitrary whitespace characters. - - Format specifiers marked with * are matched, but do not set any - field in the output. - - Some of the format specifiers are marked as space-padded or - zero-padded. Regardless of this, space-padded, zero-padded - or unpadded inputs are accepted. Note that strings using - unpadded fields without separating the fields may cause - strange parsing. - - Supported format specfiers: - - [%%] a % character. - - [%a] locale's abbreviated weekday name (Sun ... Sat) - - [%A] locale's full weekday name (Sunday .. Saturday) - - [%b] locale's abbreviated month name (Jan..Dec) - - [%B] locale's full month name (January..December) - - [%c] locale's date and time format (Thu Mar 25 17:47:03 CET 2004) - - [%C] century [00-99] - - [%d] day of month, zero padded (01..31) - - [%D] date (%m\/%d\/%y) - - [%e] day of month, space padded ( 1..31) - - [%h] same as %b - - [%H] hour, 24-hour clock, zero padded (00..23) - - [%I] hour, 12-hour clock, zero padded (01..12) - - [%j] day of the year, zero padded (001..366) - - [%k] hour, 24-hour clock, space padded ( 0..23) - - [%l] hour, 12-hour clock, space padded ( 1..12) - - [%m] month, zero padded (01..12) - - [%M] minute, zero padded (00..59) - - [%n] a newline character - - [%p] locale's AM or PM indicator - - [%r] locale's 12-hour time format (hh:mm:ss AM\/PM) - - [%R] hours and minutes, 24-hour clock (hh:mm) - - [%s] * seconds since '00:00:00 1970-01-01 UTC' - - [%S] seconds, zero padded (00..59) - - [%t] a horizontal tab character - - [%T] time, 24-hour clock (hh:mm:ss) - - [%u] numeric day of the week (1=Monday, 7=Sunday) - - [%U] * week number, weeks starting on Sunday, zero padded (01-53) - - [%V] * week number (as per ISO-8601), - week 1 is the first week with a Thursday, - zero padded, (01-53) - - [%w] numeric day of the week, (0=Sunday, 6=Monday) - - [%W] * week number, weeks starting on Monday, zero padded (01-53) - - [%x] locale's preferred way of printing dates (%m\/%d\/%y) - - [%X] locale's preferred way of printing time. (%H:%M:%S) - - [%y] year, within century, zero padded (00..99) - - [%Y] year, including century. Not padded - (this is probably a bug, but formatCalendarTime does - it this way). (0-9999) - - [%Z] time zone abbreviation (e.g. CET) or RFC-822 style numeric - timezone (-0500) -} -parseCalendarTime :: - TimeLocale -- ^ Time locale - -> String -- ^ Date format - -> String -- ^ String to parse - -> Maybe CalendarTime -- ^ 'Nothing' if parsing failed. -parseCalendarTime l fmt s = - case runParser parser epoch "" s of - Left _ -> Nothing - Right p -> Just p - where parser = pCalendarTime l fmt >> getState - --- FIXME: verify input --- FIXME: years outside 1000-9999 probably don't work --- FIXME: what about extra whitespace in input? --- FIXME: set ctYDay --- FIXME: set ctIsDST --- FIXME: missing formats from GNU date(1): --- %F same as %Y-%m-%d --- %g the 2-digit year corresponding to the %V week number --- %G the 4-digit year corresponding to the %V week number --- %N nanoseconds (000000000..999999999) --- %P locale's lower case am or pm indicator (blank in many locales) --- %z RFC-822 style numeric timezone (-0500) (a nonstandard extension) -pCalendarTime :: TimeLocale -> String -> GenParser Char CalendarTime () -pCalendarTime l fmt = doFmt fmt - where - -- not padded - -- FIXME: implement - doFmt ('%':'-':cs) = doFmt ('%':cs) - -- space padded - -- FIXME: implement - doFmt ('%':'_':cs) = doFmt ('%':cs) - doFmt ('%':c:cs) = decode c >> doFmt cs - doFmt (c:cs) = char c >> doFmt cs - doFmt "" = return () - - decode '%' = char '%' >> return () - decode 'a' = (parseEnum $ map snd $ wDays l) >>= setWDay - decode 'A' = (parseEnum $ map fst $ wDays l) >>= setWDay - decode 'b' = (parseEnum $ map snd $ months l) >>= setMonth - decode 'B' = (parseEnum $ map fst $ months l) >>= setMonth - decode 'c' = doFmt (dateTimeFmt l) - decode 'C' = read2 >>= \c -> updateYear (\y -> c * 100 + y `rem` 100) - decode 'd' = read2 >>= \day -> if day > 31 || day < 1 - then fail $ "Invalid day " ++ (show day) - else setDay day - decode 'D' = doFmt "%m/%d/%y" - decode 'e' = read2 >>= setDay - decode 'h' = decode 'b' - decode 'H' = read2 >>= setHour - decode 'I' = read2 >>= setHour12 - decode 'j' = read3 >>= setYDay - decode 'k' = read2 >>= setHour - decode 'l' = read2 >>= setHour12 - decode 'm' = read2 >>= \mon -> if (mon-1) > fromEnum (maxBound :: Month) - then fail $ "Invalid month " ++ (show mon) - else setMonth (toEnum (mon-1)) - decode 'M' = read2 >>= setMin - -- FIXME: strptime(3) accepts "arbitrary whitespace" for %n - decode 'n' = char '\n' >> return () - decode 'p' = do - x <- (string am >> return 0) <|> (string pm >> return 12) - updateHour (\h -> x + h `rem` 12) - where (am,pm) = amPm l - decode 'r' = doFmt (time12Fmt l) - decode 'R' = doFmt "%H:%M" - -- FIXME: implement %s. - -- FIXME: implement %s in formatCalendarTime - decode 's' = int >> return () - decode 'S' = read2 >>= setSec - -- FIXME: strptime(3) accepts "arbitrary whitespace" for %t - decode 't' = char '\t' >> return () - decode 'T' = doFmt "%H:%M:%S" - decode 'u' = readN 1 >>= setWDay . toEnum . (\w -> if w == 7 then 0 else w) - -- FIXME: implement %U. - decode 'U' = read2 >> return () - -- FIXME: implement %V. - decode 'V' = read2 >> return () - decode 'w' = readN 1 >>= setWDay . toEnum - -- FIXME: implement %W. - decode 'W' = read2 >> return () - decode 'x' = doFmt (dateFmt l) - decode 'X' = doFmt (timeFmt l) - -- FIXME: should probably be zero padded, - -- need to change formatCalendarTime too - decode 'Y' = int >>= setYear - -- FIXME: maybe 04 should be 2004, not 1904? - decode 'y' = read2 >>= \c -> updateYear (\y -> (y `quot` 100) * 100 + c) - -- FIXME: are timezone names always [A-Z]+ ? - -- FIXME: set ctTZ when parsing timezone name and - -- ctTZName when parsing offset - decode 'Z' = tzname <|> tzoffset - where tzname = many1 (oneOf ['A'..'Z']) >>= setTZName - tzoffset = do - s <- sign - h <- read2 - m <- read2 - setTZ (s * (h * 3600 + m * 60)) - -- following the example of strptime(3), - -- whitespace matches zero or more whitespace - -- characters in the input string - decode c | isSpace c = spaces >> return () - decode c = char c >> return () - -epoch :: CalendarTime -epoch = CalendarTime { - ctYear = 1970, - ctMonth = January, - ctDay = 1, - ctHour = 0, - ctMin = 0, - ctSec = 0, - ctPicosec = 0, - ctWDay = Thursday, - ctYDay = 1, - ctTZName = "UTC", - ctTZ = 0, - ctIsDST = False - } - -parseEnum :: Enum a => [String] -> CharParser st a -parseEnum ss = choice (zipWith tryString ss (enumFrom (toEnum 0))) - where tryString s x = try (string s) >> return x - -setYear,setDay,setHour,setHour12,setMin,setSec,setYDay,setTZ :: Int -> GenParser tok CalendarTime () -setYear x = updateState (\t -> t{ ctYear = x }) -setMonth :: Month -> GenParser tok CalendarTime () -setMonth x = updateState (\t -> t{ ctMonth = x }) -setDay x = updateState (\t -> t{ ctDay = x }) -setHour x = updateState (\t -> t{ ctHour = x }) -setMin x = updateState (\t -> t{ ctMin = x }) -setSec x = updateState (\t -> t{ ctSec = x }) -setWDay :: Day -> GenParser tok CalendarTime () -setWDay x = updateState (\t -> t{ ctWDay = x }) -setYDay x = updateState (\t -> t{ ctYDay = x }) -setTZName :: String -> GenParser tok CalendarTime () -setTZName x = updateState (\t -> t{ ctTZName = x }) -setTZ x = updateState (\t -> t{ ctTZ = x }) - -updateYear :: (Int -> Int) -> GenParser tok CalendarTime () -updateYear f = updateState (\t -> t{ ctYear = f (ctYear t) }) -updateHour :: (Int -> Int) -> GenParser tok CalendarTime () -updateHour f = updateState (\t -> t{ ctHour = f (ctHour t) }) - -setHour12 x = updateHour (\h -> (h `quot` 12) * 12 + from12 x) - where from12 h = if h == 12 then 0 else h - -read2, read3 :: GenParser Char st Int -read2 = readN 2 -read3 = readN 3 - --- | Read up to a given number of digits, optionally left-padded --- with whitespace and interpret them as an 'Int'. -readN :: Int -> GenParser Char st Int -readN n = - liftM read (spaces >> choice [try (count m digit) | m <- [n,n-1..1]]) - -int :: GenParser Char st Int -int = liftM read (many1 digit) - -sign :: GenParser Char st Int -sign = (char '+' >> return 1) <|> (char '-' >> return (-1)) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Time utilities main file Copyright (c) 2004-2011 John Goerzen @@ -9,10 +10,9 @@ {- | Module : System.Time.Utils Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 + SPDX-License-Identifier: BSD-3-Clause - Maintainer : John Goerzen - Stability : provisional + Stability : stable Portability: portable This module provides various Haskell utilities for dealing with times and @@ -31,8 +31,17 @@ renderSecs, renderTD ) where -import System.Time -import Data.Ratio +import safe Data.Ratio ( (%) ) +import safe System.Time + ( diffClockTimes, + normalizeTimeDiff, + toCalendarTime, + toClockTime, + CalendarTime(..), + ClockTime(..), + Day(Thursday), + Month(January), + TimeDiff(TimeDiff, tdSec, tdMin, tdHour, tdDay, tdMonth, tdYear) ) {- | January 1, 1970, midnight, UTC, represented as a CalendarTime. -} epoch :: CalendarTime @@ -56,7 +65,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 @@ -76,12 +85,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) + @@ -98,8 +107,8 @@ where ratval = toRational x seconds = floor ratval secfrac = floor $ (ratval - (seconds % 1) ) * picosecondfactor - picosecondfactor = 10 ^ 12 - + picosecondfactor = 10 ^ (12 :: Integer) + {- | 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'. @@ -124,11 +133,10 @@ 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 zippedlist = zip quantlist suffixlist -- Drop all leading elements that are 0, then take at most 2 workinglist = take 2 . dropWhile (\(q, _) -> q == 0) $ zippedlist - 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {- arch-tag: Parsec utilities Copyright (c) 2004-2011 John Goerzen @@ -9,10 +10,9 @@ {- | 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 + Stability : stable Portability: portable Written by John Goerzen, jgoerzen\@complete.org @@ -29,7 +29,16 @@ notMatching ) where -import Text.ParserCombinators.Parsec +import safe Text.ParserCombinators.Parsec + ( (), + (<|>), + getPosition, + many, + token, + unexpected, + try, + SourcePos, + GenParser ) type GeneralizedToken a = (SourcePos, a) type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b @@ -85,8 +94,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) ) @@ -95,7 +104,6 @@ x <- maybeRead case x of Nothing -> return () - Just _ -> unexpected errormsg + Just _ -> unexpected errormsg in try workerFunc - diff --git a/testsrc/CRC32POSIXtest.hs b/testsrc/CRC32POSIXtest.hs deleted file mode 100644 --- a/testsrc/CRC32POSIXtest.hs +++ /dev/null @@ -1,26 +0,0 @@ -{- arch-tag: Tests for CRC-32 module -Copyright (C) 2004-2011 John Goerzen - -All rights reserved. - -For license and copyright information, see the file LICENSE --} - -module CRC32POSIXtest(tests) where -import Test.HUnit -import Data.Hash.CRC32.Posix - -test_crc32 = - let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp (crc32 inp) in - [ - f "Empty" "" 4294967295, - f "1" "1" 433426081, - f "some numbers" "153141341309874102987412" 2083856642, - f "Some text" "This is a test of the crc32 thing\n" 2449124888 - - ] - -tests = TestList [TestLabel "crc32" (TestList test_crc32) - - ] - diff --git a/testsrc/Eithertest.hs b/testsrc/Eithertest.hs --- a/testsrc/Eithertest.hs +++ b/testsrc/Eithertest.hs @@ -6,14 +6,18 @@ For license and copyright information, see the file LICENSE -} +{-# LANGUAGE CPP #-} 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 +#if !MIN_VERSION_base(4,7,0) +import Control.Exception.ErrorCall.EqInstance +#endif +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 +26,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,11 +34,10 @@ 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 "" (ErrorCall "\"wrong\"") - ("" @=? forceEither (Left "wrong")) + + TestLabel "Left" $ TestCase $ assertRaises ((== "\"wrong\"") . errorCallMsg) ("" @=? forceEither (Left "wrong")) ] tests = TestList [TestLabel "test_maybeToEither" (TestList test_maybeToEither), TestLabel "test_forceEither" (TestList test_forceEither) ] - diff --git a/testsrc/GZiptest.hs b/testsrc/GZiptest.hs --- a/testsrc/GZiptest.hs +++ b/testsrc/GZiptest.hs @@ -38,7 +38,7 @@ in map f2 [0..1000] -} -test_inflate = +test_inflate = let f fn exp conv = mf fn exp (conv . snd . forceEither . read_header) in [ f "t1.gz" "Test 1" inflate_string @@ -60,7 +60,7 @@ filename = Nothing, comment = Nothing, mtime = 1102111446, xfl = 2, os = 3} ,f "empty.gz" Header {method = 8, flags = 8, extra = Nothing, - filename = Just "empty", + filename = Just "empty", comment = Nothing, mtime = 1102127257, xfl = 0, os = 3} ] diff --git a/testsrc/Globtest.hs b/testsrc/Globtest.hs --- a/testsrc/Globtest.hs +++ b/testsrc/Globtest.hs @@ -1,4 +1,6 @@ -{- +{-# LANGUAGE CPP #-} + +{- Copyright (C) 2006-2011 John Goerzen All rights reserved. @@ -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__)) @@ -21,16 +23,19 @@ #endif import Control.Exception import Data.List +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + bp = "testtmp" -touch x = writeFile x "" +touch x = writeFile (sep x) "" -globtest thetest = +globtest thetest = bracket_ (setupfs) (recursiveRemove SystemFS bp) thetest where setupfs = - do mapM_ (\x -> createDirectory x) + do mapM_ (\x -> createDirectory (sep x)) [bp, bp ++ "/a", bp ++ "/aab", bp ++ "/aaa", bp ++ "/ZZZ", bp ++ "/a/bcd", bp ++ "/a/bcd/efg"] @@ -42,12 +47,12 @@ createSymbolicLink (preppath "broken") (preppath "sym1") createSymbolicLink (preppath "broken") (preppath "sym2") #endif - + eq msg exp res = assertEqual msg (sort exp) (sort res) mf msg func = TestLabel msg $ TestCase $ globtest func f func = TestCase $ globtest func -preppath x = bp ++ "/" ++ x +preppath x = sep (bp ++ "/" ++ x) test_literal = map f @@ -73,7 +78,7 @@ glob (preppath "a/*.foo") >>= eq "a/*.foo" [preppath "a/a.foo"] ] -test_dirnames = +test_dirnames = map f [glob (preppath "*/D") >>= eq "*/D" [preppath "a/D"], glob (preppath "*/*a") >>= eq "*/*a" [], @@ -91,14 +96,11 @@ #else [] #endif - + tests = TestList [TestLabel "test_literal" (TestList test_literal), TestLabel "test_one_dir" (TestList test_one_dir), TestLabel "test_nested_dir" (TestList test_nested_dir), TestLabel "test_dirnames" (TestList test_dirnames), TestLabel "test_brokensymlinks" (TestList test_brokensymlinks)] - - - diff --git a/testsrc/HVFStest.hs b/testsrc/HVFStest.hs --- a/testsrc/HVFStest.hs +++ b/testsrc/HVFStest.hs @@ -12,11 +12,14 @@ 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 +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x @@ -33,19 +36,23 @@ ] test_nice_slice = - let f exp fp = TestLabel fp $ TestCase $ exp @=? nice_slice fp + let f exp fp' = TestLabel fp $ TestCase $ exp @=? nice_slice fp + where + fp = sep fp' in [ f [] "/" ,f ["foo", "bar"] "/foo/bar" --,f [] "." ] -test_content = - let f exp fp = TestLabel fp $ TestCase $ +test_content = + let f exp fp' = TestLabel fp $ TestCase $ do x <- newMemoryVFS testTree h <- vOpen x fp ReadMode case h of HVFSOpenEncap h2 -> exp `ioeq` vGetContents h2 + where + fp = sep fp' in [ f "line1\nline2\n" "test.txt", @@ -55,33 +62,33 @@ ] test_chroot = - let f msg testfunc = TestLabel msg $ TestCase $ + let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree - vSetCurrentDirectory x "/emptydir" - y <- newHVFSChroot x "/dir1" + vSetCurrentDirectory x (sep "/emptydir") + y <- newHVFSChroot x (sep "/dir1") testfunc y in [ f "root" (\x -> ["file3.txt", "test.txt", "dir2"] - `ioeq` vGetDirectoryContents x "/") - ,f "cwd" (\x -> "/" `ioeq` vGetCurrentDirectory x) - ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x "/dir2") + `ioeq` vGetDirectoryContents x (sep "/")) + ,f "cwd" (\x -> sep "/" `ioeq` vGetCurrentDirectory x) + ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir2")) ,f "dot" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x ".") ,f "cwd tests" $ - (\x -> do a <- vGetDirectoryContents x "/" + (\x -> do a <- vGetDirectoryContents x (sep "/") ["file3.txt", "test.txt", "dir2"] @=? a - vSetCurrentDirectory x "/dir2" + vSetCurrentDirectory x (sep "/dir2") cwd <- vGetCurrentDirectory x - "/dir2" @=? cwd + sep "/dir2" @=? cwd y <- vGetDirectoryContents x "." [] @=? y vSetCurrentDirectory x ".." - "/" `ioeq` vGetCurrentDirectory x + sep "/" `ioeq` vGetCurrentDirectory x --vSetCurrentDirectory x ".." --"/" `ioeq` vGetCurrentDirectory x ) - --,f "test.txt" (\x -> "subdir test" `ioeq` + --,f "test.txt" (\x -> "subdir test" `ioeq` -- (vOpen x "/test.txt" ReadMode >>= vGetContents)) ] @@ -92,22 +99,22 @@ in [ f "root" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] - `ioeq` vGetDirectoryContents x "/") + `ioeq` vGetDirectoryContents x (sep ("/"))) ,f "dot" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] `ioeq` vGetDirectoryContents x ".") ,f "dot2" (\x -> ["file3.txt", "test.txt", "dir2"] - `ioeq` do vSetCurrentDirectory x "./dir1" + `ioeq` do vSetCurrentDirectory x (sep "./dir1") vGetDirectoryContents x ".") - ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x "/emptydir") + ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/emptydir")) ,f "dir1" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x "/dir1") - ,f "dir1/dir2" (\x -> [] `ioeq` vGetDirectoryContents x "/dir1/dir2") - ,f "relative tests" (\x -> + ,f (sep "dir1/dir2") (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir1/dir2")) + ,f "relative tests" (\x -> do vSetCurrentDirectory x "dir1" [] `ioeq` vGetDirectoryContents x "dir2" ) ] - + tests = TestList [TestLabel "nice_slice" (TestList test_nice_slice) ,TestLabel "structure" (TestList test_structure) 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,10 +10,5 @@ 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), @@ -241,6 +240,4 @@ TestLabel "fixedWidth" (TestList test_fixedWidth), TestLabel "subIndex" (TestList test_subIndex), TestLabel "spanList" (TestList test_spanList)] - - diff --git a/testsrc/MIMETypestest.hs b/testsrc/MIMETypestest.hs --- a/testsrc/MIMETypestest.hs +++ b/testsrc/MIMETypestest.hs @@ -13,7 +13,7 @@ test_readMIMETypes = let omtd = readMIMETypes defaultmtd True "testsrc/mime.types.test" - f = \strict inp exp -> TestCase $ do + f = \strict inp exp -> TestCase $ do mtd <- omtd exp @=? guessType mtd strict inp fe = \strict inp exp -> TestCase $ do mtd <- omtd @@ -43,7 +43,7 @@ ] test_guessType = - let f strict inp exp = TestCase $ exp @=? guessType defaultmtd strict inp in + let f strict inp exp = TestCase $ exp @=? guessType defaultmtd strict inp in [ f True "" (Nothing, Nothing) ,f True "foo" (Nothing, Nothing) diff --git a/testsrc/Pathtest.hs b/testsrc/Pathtest.hs --- a/testsrc/Pathtest.hs +++ b/testsrc/Pathtest.hs @@ -10,11 +10,18 @@ module Pathtest(tests) where import Test.HUnit import System.Path +import System.FilePath (pathSeparator) +sep = map (\c -> if c == '/' then pathSeparator else c) + test_absNormPath = - let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p + let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p + where + base = sep base' + p = sep p' + exp = fmap sep exp' f2 = f "/usr/1/2" in - [ + [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." (Just "/usr") @@ -31,9 +38,13 @@ ] test_secureAbsNormPath = - let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p + let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p + where + base = sep base' + p = sep p' + exp = fmap sep exp' f2 = f "/usr/1/2" in - [ + [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." Nothing @@ -52,8 +63,11 @@ ] test_splitExt = - let f inp exp = TestCase $ exp @=? splitExt inp in - [ + let f inp' exp' = TestCase $ exp @=? splitExt inp + where + inp = sep inp' + exp = (\(x,y) -> (sep x, y)) exp' + in [ f "" ("", "") ,f "/usr/local" ("/usr/local", "") ,f "../foo.txt" ("../foo", ".txt") diff --git a/testsrc/ProgressTrackertest.hs b/testsrc/ProgressTrackertest.hs --- a/testsrc/ProgressTrackertest.hs +++ b/testsrc/ProgressTrackertest.hs @@ -1,4 +1,4 @@ -{- +{- Copyright (C) 2006-2011 John Goerzen All rights reserved. @@ -19,7 +19,7 @@ settime timem newval = swapMVar timem newval >> return () -test_incrP = +test_incrP = do (po, timem) <- setup incrP po 5 withStatus po $ \s -> @@ -92,14 +92,14 @@ getETR po >>= assertEqual "etr 2" 44 getETA po >>= assertEqual "eta 2" 444 -test_callback = +test_callback = do (po, _) <- setup mcounter <- newMVar (0::Int) mcounter1 <- newMVar (0::Int) mcounter2 <- newMVar (0::Int) (po2, _) <- setup (po3, _) <- setup - + addCallback po (minc mcounter) addParent po po2 incrP po 5 @@ -107,13 +107,13 @@ withStatus po (\x -> 5 @=? completedUnits x) withStatus po2 (\x -> do 5 @=? completedUnits x 200 @=? totalUnits x) - + addCallback po2 (minc mcounter2) incrP po 100 readMVar mcounter2 >>= (\x -> assertBool "cb2" (0 /= x)) withStatus po2 (\x -> do 105 @=? completedUnits x 205 @=? totalUnits x) - + incrP' po 5 withStatus po2 (\x -> do 110 @=? completedUnits x 205 @=? totalUnits x) @@ -121,14 +121,12 @@ finishP po withStatus po2 (\x -> do 110 @=? completedUnits x 210 @=? totalUnits x) - - + + where minc mv _ _ = modifyMVar_ mv (\x -> return $ x + 1) tests = TestList [TestLabel "incrP" (TestCase test_incrP), TestLabel "setP" (TestCase test_setP), TestLabel "speed" (TestCase test_speed), TestLabel "test_callback" (TestCase test_callback)] - - diff --git a/testsrc/Str/CSVtest.hs b/testsrc/Str/CSVtest.hs --- a/testsrc/Str/CSVtest.hs +++ b/testsrc/Str/CSVtest.hs @@ -13,7 +13,7 @@ import Text.ParserCombinators.Parsec test_csv = - let f inp exp = TestLabel inp $ TestCase $ + let f inp exp = TestLabel inp $ TestCase $ exp @=? case parse csvFile "" inp of Right x -> Right x Left y -> Left (show y) 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 @@ -53,15 +53,15 @@ test_escapeRe = - map (\i -> TestLabel (show $ chr i) $ TestCase $ assertEqual [chr i] (Just []) + map (\i -> TestLabel (show $ chr i) $ TestCase $ assertEqual [chr i] (Just []) (matchRegex (mkRegex $ escapeRe $ [chr i]) [chr i])) - [1..255] + [1..127] ++ - [TestCase $ assertEqual "big string" + [TestCase $ assertEqual "big string" (Just ([], teststr, [], [])) (matchRegexAll (mkRegex $ escapeRe teststr) teststr) ] - where teststr = map chr [1..255] + where teststr = map chr [1..127] tests = TestList [TestLabel "lstrip" (TestList test_lstrip), TestLabel "rstrip" $ TestList test_rstrip, @@ -69,7 +69,3 @@ TestLabel "splitWs" $ TestList test_splitWs, TestLabel "escapeRe" $ TestList test_escapeRe ] - - - - 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,8 +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/Timetest.hs b/testsrc/Timetest.hs --- a/testsrc/Timetest.hs +++ b/testsrc/Timetest.hs @@ -22,7 +22,7 @@ f (base {ctYear = 2005, ctMonth = January, ctDay = 21, ctHour = 1, ctMin = 1, ctSec = 20}) 1106269280 - + ,f (base {ctYear = 2004, ctMonth = July, ctDay = 1, ctHour = 17, ctMin = 0, ctSec = 0}) 1088701200 @@ -30,7 +30,7 @@ ] test_ct2e = - let f base exp = TestLabel (show base) $ TestCase $ + let f base exp = TestLabel (show base) $ TestCase $ do r <- timelocal base exp @=? r in [ 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") @@ -35,9 +35,6 @@ f0 "[!\\]" "\\", f0 "*.deb" "thedebianthing", f0 "a/*.foo" "testtmp/a/D"] - -tests = TestList [TestLabel "wildCheckCase" (TestList test_wildCheckCase)] - - +tests = TestList [TestLabel "wildCheckCase" (TestList test_wildCheckCase)] diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs --- a/testsrc/runtests.hs +++ b/testsrc/runtests.hs @@ -7,7 +7,7 @@ -} -module Main where +module Main where import Test.HUnit import Tests 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 -