MissingH-1.2.0.0/0000755000175000017500000000000012027213047013617 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/tolgpl0000644000175000017500000000041512027213047015043 0ustar jgoerzenjgoerzen#!/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 MissingH-1.2.0.0/src/0000755000175000017500000000000012027213047014406 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Text/0000755000175000017500000000000012027213047015332 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Text/ParserCombinators/0000755000175000017500000000000012027213047020767 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Text/ParserCombinators/Parsec/0000755000175000017500000000000012027213047022204 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Text/ParserCombinators/Parsec/Utils.hs0000644000175000017500000000673112027213047023647 0ustar jgoerzenjgoerzen{- arch-tag: Parsec utilities Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Text.ParserCombinators.Parsec.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Written by John Goerzen, jgoerzen\@complete.org -} module Text.ParserCombinators.Parsec.Utils(-- * Generalized Utilities -- | These functions are generalized versions of -- ones you might see in the Char parser. GeneralizedToken, GeneralizedTokenParser, togtok, tokeng, satisfyg, oneOfg, noneOfg, specificg, allg, -- * Other Utilities notMatching ) where import Text.ParserCombinators.Parsec type GeneralizedToken a = (SourcePos, a) type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b {- | Generate (return) a 'GeneralizedToken'. -} togtok :: a -> GenParser b st (GeneralizedToken a) togtok tok = do x <- getPosition return (x, tok) {- | Retrieve the next token from a 'GeneralizedToken' stream. The given function should return the value to use, or Nothing to cause an error. -} tokeng :: (Show a) => (a -> Maybe b) -> GeneralizedTokenParser a st b tokeng test = token (show . snd) (fst) (test . snd) {- | A shortcut to 'tokeng'; the test here is just a function that returns a Bool. If the result is true; return that value -- otherwise, an error. -} satisfyg :: (Show a) => (a -> Bool) -> GeneralizedTokenParser a st a satisfyg test = tokeng (\t -> if test t then Just t else Nothing) {- | Matches one item in a list and returns it. -} oneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a oneOfg i = satisfyg (\x -> elem x i) {- | Matches all items and returns them -} allg :: (Show a) => GeneralizedTokenParser a st [a] allg = many $ satisfyg (\_ -> True) {- | Matches one item not in a list and returns it. -} noneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a noneOfg l = satisfyg (\x -> not (elem x l)) {- | Matches one specific token and returns it. -} specificg :: (Eq a, Show a) => a -> GeneralizedTokenParser a st a specificg i = satisfyg (== i) show i {- Matches a list of tokens and returns it. -} {- listg :: (Eq a, Show a) => [GeneralizedToken a] -> GeneralizedTokenParser a st [GeneralizedToken a] listg l = tokens (show . map fst) nextpos l where tokpos = fst nextpos nextposs _ _ (tok:toks) = tokpos tok nextposs _ tok [] = tokpos tok nextpos pos x = nextposs pos [x] -} {- | Running @notMatching p msg@ will try to apply parser p. 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 x <- p return (Just x) ) <|> return Nothing workerFunc = do x <- maybeRead case x of Nothing -> return () Just _ -> unexpected errormsg in try workerFunc MissingH-1.2.0.0/src/Network/0000755000175000017500000000000012027213047016037 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Network/Utils.hs0000644000175000017500000000507412027213047017501 0ustar jgoerzenjgoerzen{- arch-tag: Network utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: systems with networking This module provides various helpful utilities for dealing with networking Written by John Goerzen, jgoerzen\@complete.org -} module Network.Utils (niceSocketsDo, connectTCP, connectTCPAddr, listenTCPAddr, showSockAddr) where import Network import Network.Socket import Network.BSD import System.IO #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import qualified System.Posix.Signals #endif {- | Sets up the system for networking. Similar to the built-in withSocketsDo (and actually, calls it), but also sets the SIGPIPE handler so that signal is ignored. Example: > main = niceSocketsDo $ do { ... } -} -- FIXME integrate with WebCont.Util.UDP niceSocketsDo :: IO a -> IO a 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.sigPIPE System.Posix.Signals.Ignore Nothing #endif withSocketsDo func connectTCP :: HostName -> PortNumber -> IO Socket connectTCP host port = do he <- getHostByName host connectTCPAddr (SockAddrInet port (hostAddress he)) connectTCPAddr :: SockAddr -> IO Socket connectTCPAddr addr = do proto <- getProtocolNumber "tcp" s <- socket AF_INET Stream proto 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 listen s queuelen return s showSockAddr :: SockAddr -> IO String #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 return $ "IPv4 host " ++ h ++ ", port " ++ (show port) MissingH-1.2.0.0/src/Network/SocketServer.hs0000644000175000017500000001652312027213047021021 0ustar jgoerzenjgoerzen{- arch-tag: Generic Server Support Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.SocketServer Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : experimental Portability: systems with networking This module provides an infrastructure to simplify server design. Written by John Goerzen, jgoerzen\@complete.org Please note: this module is designed to work with TCP, UDP, and Unix domain sockets, but only TCP sockets have been tested to date. This module is presently under-documented. For an example of usage, please see the description of "Network.FTP.Server". -} module Network.SocketServer(-- * Generic Options and Types InetServerOptions(..), simpleTCPOptions, SocketServer(..), HandlerT, -- * TCP server convenient setup serveTCPforever, -- * Lower-Level Processing setupSocketServer, handleOne, serveForever, closeSocketServer, -- * Combinators loggingHandler, threadedHandler, handleHandler ) where import Network.Socket import Network.BSD import Network.Utils import Control.Concurrent import System.IO import qualified System.Log.Logger {- | Options for your server. -} data InetServerOptions = InetServerOptions {listenQueueSize :: Int, portNumber :: PortNumber, interface :: HostAddress, reuse :: Bool, family :: Family, sockType :: SocketType, protoStr :: String } deriving (Eq, Show) {- | The main handler type. The first parameter is the socket itself. The second is the address of the remote endpoint. 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, reuse = False, family = AF_INET, sockType = Stream, protoStr = "tcp" } data SocketServer = SocketServer {optionsSS :: InetServerOptions, sockSS :: Socket} deriving (Eq, Show) {- | Takes some options and sets up the 'SocketServer'. I will bind and begin listening, but will not accept any connections itself. -} setupSocketServer :: InetServerOptions -> IO SocketServer setupSocketServer opts = do proto <- getProtocolNumber (protoStr opts) s <- socket (family opts) (sockType opts) proto setSocketOption s ReuseAddr (case (reuse opts) of True -> 1 False -> 0) bindSocket s (SockAddrInet (portNumber opts) (interface opts)) listen s (listenQueueSize opts) return $ SocketServer {optionsSS = opts, sockSS = s} {- | Close the socket server. Does not terminate active handlers, if any. -} closeSocketServer :: SocketServer -> IO () closeSocketServer ss = sClose (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 {- | Handle all incoming requests from the given 'SocketServer'. -} serveForever :: SocketServer -> HandlerT -> IO () serveForever ss func = sequence_ (repeat (handleOne ss func)) {- | Convenience function to completely set up a TCP 'SocketServer' and handle all incoming requests. This function is literally this: >serveTCPforever options func = > do sockserv <- setupSocketServer options > serveForever sockserv func -} serveTCPforever :: InetServerOptions -- ^ Server options -> HandlerT -- ^ Handler function -> IO () serveTCPforever options func = do sockserv <- setupSocketServer options serveForever sockserv func ---------------------------------------------------------------------- -- Combinators ---------------------------------------------------------------------- {- | Log each incoming connection using the interface in "System.Log.Logger". Log when the incoming connection disconnects. Also, log any failures that may occur in the child handler. -} loggingHandler :: String -- ^ Name of logger to use -> 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 = do sockStr <- showSockAddr r_sockaddr System.Log.Logger.logM hname prio ("Received connection from " ++ sockStr) 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 () {- | Give your handler function a Handle instead of a Socket. The Handle will be opened with ReadWriteMode (you use one handle for both directions of the Socket). Also, it will be initialized with LineBuffering. Unlike other handlers, the handle will be closed when the function returns. Therefore, if you are doing threading, you should to it before you call this handler. -} handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -- ^ Handler to call -> HandlerT handleHandler func socket r_sockaddr l_sockaddr = do h <- socketToHandle socket ReadWriteMode hSetBuffering h LineBuffering func h r_sockaddr l_sockaddr hClose h MissingH-1.2.0.0/src/Network/Email/0000755000175000017500000000000012027213047017066 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Network/Email/Mailbox.hs0000644000175000017500000000467612027213047021032 0ustar jgoerzenjgoerzen{- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Email.Mailbox Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable General support for e-mail mailboxes Written by John Goerzen, jgoerzen\@complete.org -} module Network.Email.Mailbox(Flag(..), Flags, Message, MailboxReader(..), MailboxWriter(..)) where {- | The flags which may be assigned to a message. -} data Flag = SEEN | ANSWERED | FLAGGED | DELETED | DRAFT | 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. 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. This identifier may or may not be persistent. Functions which return a list are encouraged -- but not guaranteed -- to do so lazily. Implementing classes must provide, at minimum, 'getAll'. -} class (Show a, Show b, Eq b) => MailboxReader a b where {- | Returns a list of all unique identifiers. -} listIDs :: a -> IO [b] {- | Returns a list of all unique identifiers as well as all flags. -} listMessageFlags :: a -> IO [(b, Flags)] {- | Returns a list of all messages, including their content, flags, and unique identifiers. -} getAll :: a -> IO [(b, Flags, Message)] {- | Returns information about specific messages. -} getMessages :: a -> [b] -> IO [(b, Flags, Message)] listIDs mb = listMessageFlags mb >>= return . map fst 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 class (MailboxReader a b) => MailboxWriter a b where appendMessages :: a -> [(Flags, Message)] -> IO [b] deleteMessages :: a -> [b] -> IO () addFlags :: a -> [b] -> Flags -> IO () removeFlags :: a -> [b] -> Flags -> IO () setFlags :: a -> [b] -> Flags -> IO () MissingH-1.2.0.0/src/Network/Email/Sendmail.hs0000644000175000017500000000651312027213047021163 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- arch-tag: Sendmail utility Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Email.Sendmail Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This Haskell module provides an interface to transmitting a mail message. This is not compatible with Windows at this time. Written by John Goerzen, jgoerzen\@complete.org -} #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) module Network.Email.Sendmail where #else module Network.Email.Sendmail(sendmail) where import System.Cmd.Utils import System.Directory import System.IO import System.IO.Error import qualified Control.Exception(try, IOException) sendmails :: [String] sendmails = ["/usr/sbin/sendmail", "/usr/local/sbin/sendmail", "/usr/local/bin/sendmail", "/usr/bin/sendmail", "/etc/sendmail", "/usr/etc/sendmail"] findsendmail :: IO String findsendmail = let worker [] = return "sendmail" worker (this:next) = do e <- doesFileExist this if e then do p <- getPermissions this if executable p then return this else worker next else worker next in worker sendmails {- | Transmits an e-mail message using the system's mail transport agent. This function takes a message, a list of recipients, and an optional sender, and transmits it using the system's MTA, sendmail. If @sendmail@ is on the @PATH@, it will be used; otherwise, a list of system default locations will be searched. A failure will be logged, since this function uses 'System.Cmd.Utils.safeSystem' internally. This function will first try @sendmail@. If it does not exist, an error is logged under @System.Cmd.Utils.pOpen3@ and various default @sendmail@ locations are tried. If that still fails, an error is logged and an exception raised. -} sendmail :: Maybe String -- ^ The envelope from address. If not specified, takes the system's default, which is usually based on the effective userid of the current process. This is not necessarily what you want, so I recommend specifying it. -> [String] -- ^ A list of recipients for your message. An empty list is an error. -> String -- ^ The message itself. -> IO () sendmail _ [] _ = fail "sendmail: no recipients specified" sendmail Nothing recipients msg = sendmail_worker recipients msg sendmail (Just from) recipients msg = sendmail_worker (("-f" ++ from) : recipients) msg sendmail_worker :: [String] -> String -> IO () sendmail_worker args msg = let func h = hPutStr h msg in do --pOpen WriteToPipe "/usr/sbin/sendmail" args func rv <- Control.Exception.try (pOpen WriteToPipe "sendmail" args func) case rv of Right x -> return x Left (_ :: Control.Exception.IOException) -> do sn <- findsendmail r <- pOpen WriteToPipe sn args func return $! r #endif MissingH-1.2.0.0/src/System/0000755000175000017500000000000012027213047015672 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/FileArchive/0000755000175000017500000000000012027213047020053 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/FileArchive/GZip.hs0000644000175000017500000002432412027213047021265 0ustar jgoerzenjgoerzen{- arch-tag: GZip file support in Haskell Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.FileArchive.GZip Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable GZip file decompression Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org The GZip format is described in RFC1952. -} module System.FileArchive.GZip ( -- * GZip Files -- $gzipfiles -- * Types Header(..), Section, GZipError(..), Footer(..), -- * Whole-File Processing decompress, hDecompress, read_sections, -- * Section Processing read_header, read_section ) where import Data.Compression.Inflate (inflate_string_remainder) import Data.Hash.CRC32.GZip (update_crc) import Data.Bits ((.&.)) import Control.Monad.Error -- (Error(), strMsg, throwError) import Data.Char (ord) import Data.Word (Word32()) import Data.Bits.Utils (fromBytes) import System.IO (hGetContents, hPutStr, Handle()) 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 -- | First two bytes of file magic :: String magic = "\x1f\x8b" -- | Flags fFHCRC, fFEXTRA, fFNAME, fFCOMMENT :: Int -- fFTEXT = 1 :: Int fFHCRC = 2 fFEXTRA = 4 fFNAME = 8 fFCOMMENT = 16 {- | 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, filename :: Maybe String, 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 crc32valid :: Bool -- ^ Whether or not the stored CRC-32 matches the calculated CRC-32 of the data } {- | A section represents a compressed component in a GZip file. Every GZip file has at least one. -} type Section = (Header, String, Footer) split1 :: String -> (Char, String) split1 s = (head s, tail s) {- | Read a GZip file, decompressing all sections found. Writes the decompressed data stream to the given output handle. Returns Nothing if the action was successful, or Just GZipError if there was a problem. If there was a problem, the data written to the output handle should be discarded. -} hDecompress :: Handle -- ^ Input handle -> Handle -- ^ Output handle -> IO (Maybe GZipError) hDecompress infd outfd = do inc <- hGetContents infd let (outstr, err) = decompress inc hPutStr outfd outstr return err {- | Read a GZip file, decompressing all sections that are found. Returns a decompresed data stream and Nothing, or an unreliable string and Just (error). If you get anything other than Nothing, the String returned should be discarded. -} decompress :: String -> (String, Maybe GZipError) {- decompress s = do x <- read_header s let rem = snd x return $ inflate_string rem -} decompress s = let procs :: [Section] -> (String, Bool) procs [] = ([], True) procs ((_, content, foot):xs) = let (nexth, nextb) = procs xs in (content ++ nexth, (crc32valid foot) && nextb) in case read_sections s of Left x -> ("", Just x) Right x -> let (decomp, iscrcok) = procs x in (decomp, if iscrcok then Nothing else Just CRCError) {- decompress s = do x <- read_sections s return $ concatMap (\(_, x, _) -> x) x -} -- | Read all sections. read_sections :: String -> Either GZipError [Section] read_sections [] = Right [] read_sections s = do x <- read_section s case x of (sect, remain) -> do next <- read_sections remain return $ sect : next parseword :: String -> Word32 parseword s = fromBytes $ map (fromIntegral . ord) $ reverse s -- | Read one section, returning (ThisSection, Remainder) read_section :: String -> Either GZipError (Section, String) read_section s = do x <- read_header s let headerrem = snd x let (decompressed, crc, remainder) = read_data headerrem let (crc32str, rm) = splitAt 4 remainder let (sizestr, rem2) = splitAt 4 rm let filecrc32 = parseword crc32str let filesize = parseword sizestr return ((fst x, decompressed, Footer {size = filesize, crc32 = filecrc32, crc32valid = filecrc32 == crc}) ,rem2) -- | Read the file's compressed data, returning -- (Decompressed, Calculated CRC32, Remainder) read_data :: String -> (String, Word32, String) read_data x = let (decompressed1, remainder) = inflate_string_remainder x (decompressed, crc32) = read_data_internal decompressed1 0 in (decompressed, crc32, remainder) where read_data_internal [] ck = ([], ck) read_data_internal (y:ys) ck = let newcrc = update_crc ck y n = newcrc `seq` read_data_internal ys newcrc in (y : fst n, snd n) {- | Read the GZip header. Return (Header, Remainder). -} 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 then throwError NotGZIPFile else ok let (method, rem2) = split1 rem if (ord(method) /= 8) then throwError UnknownMethod else ok let (flag_S, rem3) = split1 rem2 let flag = ord flag_S let (mtimea, rem3a) = splitAt 4 rem3 let mtime = parseword mtimea let (xfla, rem3b) = split1 rem3a let xfl = ord xfla let (osa, _) = split1 rem3b let os = ord osa -- skip modtime (4), extraflag (1), and os (1) let rem4 = drop 6 rem3 let (extra, rem5) = if (flag .&. fFEXTRA /= 0) -- Skip past the extra field if we have it. then let (xlen_S, _) = split1 rem4 (xlen2_S, rem4b) = split1 rem4 xlen = (ord xlen_S) + 256 * (ord xlen2_S) (ex, rrem) = splitAt xlen rem4b in (Just ex, rrem) else (Nothing, rem4) let (filename, rem6) = if (flag .&. fFNAME /= 0) -- Skip past the null-terminated filename then let fn = takeWhile (/= '\x00') rem5 in (Just fn, drop ((length fn) + 1) rem5) else (Nothing, rem5) let (comment, rem7) = if (flag .&. fFCOMMENT /= 0) -- Skip past the null-terminated comment then let cm = takeWhile (/= '\x00') rem6 in (Just cm, drop ((length cm) + 1) rem6) else (Nothing, rem6) rem8 <- if (flag .&. fFHCRC /= 0) -- Skip past the header CRC then return $ drop 2 rem7 else return rem7 return (Header {method = ord method, flags = flag, extra = extra, filename = filename, comment = comment, mtime = mtime, xfl = xfl, os = os}, rem8) ---------------------------------------------------------------------- -- Documentation ---------------------------------------------------------------------- {- $gzipfiles GZip files contain one or more 'Section's. Each 'Section', on disk, begins with a GZip 'Header', then stores the compressed data itself, and finally stores a GZip 'Footer'. The 'Header' identifies the file as a GZip file, records the original modification date and time, and, in some cases, also records the original filename and comments. The 'Footer' contains a GZip CRC32 checksum over the decompressed data as well as a 32-bit length of the decompressed data. The module 'Data.Hash.CRC32.GZip' is used to validate stored CRC32 values. The vast majority of GZip files contain only one 'Section'. Standard tools that work with GZip files create single-section files by default. Multi-section files can be created by simply concatenating two existing GZip files together. The standard gunzip and zcat tools will simply concatenate the decompressed data when reading these files back. The 'decompress' function in this module will do the same. When reading data from this module, please use caution regarding how you access it. For instance, if you are wanting to write the decompressed stream to disk and validate its CRC32 value, you could use the 'decompress' function. However, you should process the entire stream before you check the value of the Bool it returns. Otherwise, you will force Haskell to buffer the entire file in memory just so it can check the CRC32. -} MissingH-1.2.0.0/src/System/Path.hs0000644000175000017500000001225512027213047017127 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- arch-tag: Path utilities main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with path and file names, directories, and related support. Written by John Goerzen, jgoerzen\@complete.org -} module System.Path(-- * Name processing splitExt, absNormPath, secureAbsNormPath, -- * Directory Processing recurseDir, recurseDirStat, recursiveRemove, bracketCWD, -- * Temporary Directories mktmpdir, brackettmpdir, brackettmpdirCWD ) where import Data.List import Data.List.Utils #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Files import System.Posix.Directory (createDirectory) import System.Posix.Temp import System.Directory hiding (createDirectory) #else import System.Directory #endif import Control.Exception import System.IO import System.Path.NameManip import System.IO.HVFS.Utils {- | 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 dot after the last slash to the end. Either returned string may be empty. -} -- FIXME: See 6.4 API when released. splitExt :: String -> (String, String) splitExt path = let dotindex = alwaysElemRIndex '.' path slashindex = alwaysElemRIndex '/' path in if dotindex <= slashindex then (path, "") else ((take dotindex path), (drop dotindex path)) {- | Make an absolute, normalized version of a path with all double slashes, dot, and dotdot entries removed. The first parameter is the base for the absolut calculation; in many cases, it would correspond to the current working directory. The second parameter is the pathname to transform. If it is already absolute, the first parameter is ignored. Nothing may be returned if there's an error; for instance, too many @..@ entries for the given path. -} absNormPath :: String -- ^ Absolute path for use with starting directory -> 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 {- | Like absNormPath, but returns Nothing if the generated result is not the passed base path or a subdirectory thereof. -} secureAbsNormPath :: String -- ^ Absolute path for use with starting directory -> String -- ^ The path to make absolute -> Maybe String secureAbsNormPath base s = do p <- absNormPath base s if startswith base p then return p else fail "" {- | Creates a temporary directory for your use. The passed string should be a template suitable for mkstemp; that is, end with @\"XXXXXX\"@. Your string should probably start with the value returned from System.Directory.getTemporaryDirectory. The name of the directory created will be returned. -} mktmpdir :: String -> IO String #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) mktmpdir x = do y <- mkstemp x let (dirname, h) = y hClose h removeFile dirname 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', runs the specified action (passing in the directory name), then removes the directory and all its contents when the action completes (or raises an exception. -} brackettmpdir :: String -> (String -> IO a) -> IO a brackettmpdir x action = do tmpdir <- mktmpdir x finally (action tmpdir) (recursiveRemove SystemFS tmpdir) {- | Changes the current working directory to the given path, executes the given I\/O action, then changes back to the original directory, even if the I\/O action raised an exception. -} bracketCWD :: FilePath -> IO a -> IO a bracketCWD fp action = do oldcwd <- getCurrentDirectory setCurrentDirectory fp finally action (setCurrentDirectory oldcwd) {- | Runs the given I\/O action with the CWD set to the given tmp dir, removing the tmp dir and changing CWD back afterwards, even if there was an exception. -} brackettmpdirCWD :: String -> IO a -> IO a brackettmpdirCWD template action = brackettmpdir template (\newdir -> bracketCWD newdir action) MissingH-1.2.0.0/src/System/Cmd/0000755000175000017500000000000012027213047016375 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Cmd/Utils.hs0000644000175000017500000005037012027213047020036 0ustar jgoerzenjgoerzen-- arch-tag: Command utilities main file {-# LANGUAGE CPP #-} {- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Cmd.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional 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 \"System.Cmd.Utils.funcname\" -- for instance, \"System.Cmd.Utils.safeSystem\". If you wish to suppress these messages globally, you can simply run: > updateGlobalLogger "System.Cmd.Utils.safeSystem" > (setLevel CRITICAL) See also: 'System.Log.Logger.updateGlobalLogger', "System.Log.Logger". It is possible to set up pipelines with these utilities. Example: > (pid1, x1) <- pipeFrom "ls" ["/etc"] > (pid2, x2) <- pipeBoth "grep" ["x"] x1 > putStr x2 > ... the grep output is displayed ... > forceSuccess pid2 > forceSuccess pid1 Remember, when you use the functions that return a String, you must not call 'forceSuccess' until after all data from the String has been consumed. Failure to wait will cause your program to appear to hang. Here is an example of the wrong way to do it: > (pid, x) <- pipeFrom "ls" ["/etc"] > forceSuccess pid -- Hangs; the called program hasn't terminated yet > processTheData x You must instead process the data before calling 'forceSuccess'. When using the hPipe family of functions, this is probably more obvious. Most of this module will be incompatible with Windows. -} module System.Cmd.Utils(-- * High-Level Tools PipeHandle(..), safeSystem, #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) forceSuccess, #ifndef __HUGS__ posixRawSystem, forkRawSystem, -- ** Piping with lazy strings pipeFrom, pipeLinesFrom, pipeTo, pipeBoth, -- ** Piping with handles hPipeFrom, hPipeTo, hPipeBoth, #endif #endif -- * Low-Level Tools PipeMode(..), #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) #ifndef __HUGS__ pOpen, pOpen3, pOpen3Raw #endif #endif ) where -- FIXME - largely obsoleted by 6.4 - convert to wrappers. import System.Exit import System.Cmd import System.Log.Logger #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.IO import System.Posix.Process import System.Posix.Signals import qualified System.Posix.Signals #endif import System.Posix.Types import System.IO import System.IO.Error import Control.Concurrent(forkIO) import Control.Exception(finally) import qualified Control.Exception(try, IOException) data PipeMode = ReadFromPipe | WriteToPipe logbase :: String logbase = "System.Cmd.Utils" {- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or 'pipeBoth'. Contains both a ProcessID and the original command that was executed. If you prefer not to use 'forceSuccess' on the result of one of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle', as a parameter to 'System.Posix.Process.getProcessStatus'. -} data PipeHandle = PipeHandle { processID :: ProcessID, phCommand :: FilePath, phArgs :: [String], phCreator :: String -- ^ Function that created it } deriving (Eq, Show) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) #ifndef __HUGS__ {- | Like 'pipeFrom', but returns data in lines instead of just a String. Shortcut for calling lines on the result from 'pipeFrom'. Note: this function logs as pipeFrom. Not available on Windows. -} pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String]) pipeLinesFrom fp args = do (pid, c) <- pipeFrom fp args return $ (pid, lines c) #endif #endif logRunning :: String -> FilePath -> [String] -> IO () logRunning func fp args = debugM (logbase ++ "." ++ func) (showCmd fp args) warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t warnFail funcname fp args msg = let m = showCmd fp args ++ ": " ++ msg in do warningM (logbase ++ "." ++ funcname) m 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 getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. This function logs as pipeFrom. Not available on Windows or with Hugs. -} hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle) hPipeFrom fp args = do pipepair <- createPipe logRunning "pipeFrom" fp args let childstuff = do dupTo (snd pipepair) stdOutput closeFd (fst pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeFrom" fp args $ "Error in fork: " ++ show e closeFd (snd pipepair) 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 'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'. Zombies will result otherwise. Not available on Windows. -} pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String) pipeFrom fp args = do (pid, h) <- hPipeFrom fp args 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. When done, you must hClose the handle, and then use either 'forceSuccess' or getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. This function logs as pipeTo. Not available on Windows. -} hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle) hPipeTo fp args = do pipepair <- createPipe logRunning "pipeTo" fp args let childstuff = do dupTo (fst pipepair) stdInput closeFd (snd pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeTo" fp args $ "Error in fork: " ++ show e closeFd (fst pipepair) 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 'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID. Zombies will result otherwise. Not available on Windows. -} pipeTo :: FilePath -> [String] -> String -> IO PipeHandle pipeTo fp args message = do (pid, h) <- hPipeTo fp args finally (hPutStr h message) (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). When done, you must hClose both handles, and then use either 'forceSuccess' or getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. Hint: you will usually need to ForkIO a thread to handle one of the Handles; otherwise, deadlock can result. This function logs as pipeBoth. Not available on Windows. -} hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle) hPipeBoth fp args = do frompair <- createPipe topair <- createPipe logRunning "pipeBoth" fp args let childstuff = do dupTo (snd frompair) stdOutput closeFd (fst frompair) dupTo (fst topair) stdInput closeFd (snd topair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeBoth" fp args $ "Error in fork: " ++ show e closeFd (snd frompair) closeFd (fst topair) fromh <- fdToHandle (fst frompair) 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. The same note about checking the return status applies here as with 'pipeFrom'. Not available on Windows. -} 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) 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 of the given process ID. If the process terminated normally, does nothing. Otherwise, raises an exception with an appropriate error message. This call will block waiting for the given pid to terminate. Not available on Windows. -} forceSuccess :: PipeHandle -> IO () forceSuccess (PipeHandle pid fp args funcname) = let warnfail = warnFail funcname in do status <- getProcessStatus True False pid case status of Nothing -> warnfail fp args $ "Got no process status" Just (Exited (ExitSuccess)) -> return () Just (Exited (ExitFailure fc)) -> cmdfailed funcname fp args fc Just (Terminated sig) -> warnfail fp args $ "Terminated by signal " ++ show sig Just (Stopped sig) -> warnfail fp args $ "Stopped by signal " ++ show sig #endif {- | Invokes the specified command in a subprocess, waiting for the result. If the command terminated successfully, return normally. Otherwise, raises a userError with the problem. Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise. -} safeSystem :: FilePath -> [String] -> IO () safeSystem command args = do debugM (logbase ++ ".safeSystem") ("Running: " ++ command ++ " " ++ (show args)) #if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) ec <- rawSystem command args case ec of ExitSuccess -> return () ExitFailure fc -> cmdfailed "safeSystem" command args fc #else ec <- posixRawSystem command args case ec of Exited ExitSuccess -> return () Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc Terminated s -> cmdsignalled "safeSystem" command args s Stopped s -> cmdsignalled "safeSystem" command args s #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. Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD during its execution. Logs as System.Cmd.Utils.posixRawSystem -} posixRawSystem :: FilePath -> [String] -> IO ProcessStatus posixRawSystem program args = do debugM (logbase ++ ".posixRawSystem") ("Running: " ++ program ++ " " ++ (show args)) oldint <- installHandler sigINT Ignore Nothing oldquit <- installHandler sigQUIT Ignore Nothing let sigset = addSignal sigCHLD emptySignalSet oldset <- getSignalMask blockSignals sigset childpid <- forkProcess (childaction oldint oldquit oldset) mps <- getProcessStatus True False childpid restoresignals oldint oldquit oldset let retval = case mps of Just x -> x Nothing -> error "Nothing returned from getProcessStatus" debugM (logbase ++ ".posixRawSystem") (program ++ ": exited with " ++ show retval) return retval where childaction oldint oldquit oldset = do restoresignals oldint oldquit oldset executeFile program True args Nothing restoresignals oldint oldquit oldset = 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 to do so will lead to resource leakage (zombie processes). This function does nothing with signals. That too is up to you. Logs as System.Cmd.Utils.forkRawSystem -} forkRawSystem :: FilePath -> [String] -> IO ProcessID forkRawSystem program args = do debugM (logbase ++ ".forkRawSystem") ("Running: " ++ program ++ " " ++ (show args)) forkProcess childaction where childaction = executeFile program True args Nothing #endif #endif cmdfailed :: String -> FilePath -> [String] -> Int -> IO a cmdfailed funcname command args failcode = do let errormsg = "Command " ++ command ++ " " ++ (show args) ++ " failed; exit code " ++ (show failcode) let e = userError (errormsg) warningM (logbase ++ "." ++ funcname) errormsg 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) ++ " failed due to signal " ++ (show failcode) let e = userError (errormsg) 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. The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe' sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout. Not available on Windows. -} pOpen :: PipeMode -> FilePath -> [String] -> (Handle -> IO a) -> IO a pOpen pm fp args func = do pipepair <- createPipe debugM (logbase ++ ".pOpen") ("Running: " ++ fp ++ " " ++ (show args)) case pm of ReadFromPipe -> do let callfunc _ = do closeFd (snd pipepair) h <- fdToHandle (fst pipepair) x <- func h hClose h return $! x pOpen3 Nothing (Just (snd pipepair)) Nothing fp args callfunc (closeFd (fst pipepair)) WriteToPipe -> do let callfunc _ = do closeFd (fst pipepair) h <- fdToHandle (snd pipepair) x <- func h hClose h return $! x 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. Note that you may not use the same fd on more than one item. If you want to redirect stdout and stderr, dup it first. -} pOpen3 :: Maybe Fd -- ^ Send stdin to this fd -> Maybe Fd -- ^ Get stdout from this fd -> Maybe Fd -- ^ Get stderr from this fd -> FilePath -- ^ Command to run -> [String] -- ^ Command args -> (ProcessID -> IO a) -- ^ Action to run in parent -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS -> IO a pOpen3 pin pout perr fp args func childfunc = do pid <- pOpen3Raw pin pout perr fp args childfunc retval <- func $! pid let rv = seq retval retval 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. Returns immediately with the PID of the child. Using 'waitProcess' on it is YOUR responsibility! Note that you may not use the same fd on more than one item. If you want to redirect stdout and stderr, dup it first. -} pOpen3Raw :: Maybe Fd -- ^ Send stdin to this fd -> Maybe Fd -- ^ Get stdout from this fd -> Maybe Fd -- ^ Get stderr from this fd -> FilePath -- ^ Command to run -> [String] -- ^ Command args -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS -> IO ProcessID pOpen3Raw pin pout perr fp args childfunc = let mayberedir Nothing _ = return () mayberedir (Just fromfd) tofd = do dupTo fromfd tofd closeFd fromfd return () childstuff = do mayberedir pin stdInput mayberedir pout stdOutput mayberedir perr stdError childfunc debugM (logbase ++ ".pOpen3") ("Running: " ++ fp ++ " " ++ (show args)) executeFile fp True args Nothing {- realfunc p = do System.Posix.Signals.installHandler System.Posix.Signals.sigPIPE System.Posix.Signals.Ignore Nothing func p -} in do p <- Control.Exception.try (forkProcess childstuff) pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> fail ("Error in fork: " ++ (show e)) return pid #endif #endif showCmd :: FilePath -> [String] -> String showCmd fp args = fp ++ " " ++ show args MissingH-1.2.0.0/src/System/Time/0000755000175000017500000000000012027213047016570 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Time/Utils.hs0000644000175000017500000001114512027213047020226 0ustar jgoerzenjgoerzen{- arch-tag: Time utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Time.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various Haskell utilities for dealing with times and dates. Written by John Goerzen, jgoerzen\@complete.org -} module System.Time.Utils( timelocal, timegm, timeDiffToSecs, epoch, epochToClockTime, clockTimeToEpoch, renderSecs, renderTD ) where import System.Time import Data.Ratio {- | January 1, 1970, midnight, UTC, represented as a CalendarTime. -} epoch :: CalendarTime epoch = CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 1, ctHour = 0, ctMin = 0, ctSec = 0, ctPicosec = 0, ctWDay = Thursday, ctYDay = 0, ctTZName = "UTC", ctTZ = 0, ctIsDST = False} {- | Converts the specified CalendarTime (see System.Time) to seconds-since-epoch time. This conversion does respect the timezone specified on the input object. If you want a conversion from UTC, specify ctTZ = 0 and ctIsDST = False. When called like that, the behavior is equivolent to the GNU C function timegm(). Unlike the C library, Haskell's CalendarTime supports timezone information, so if such information is specified, it will impact the result. -} timegm :: CalendarTime -> Integer timegm ct = timeDiffToSecs (diffClockTimes (toClockTime ct) (toClockTime epoch)) {- | 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 timezone. All timezone and DST fields in the object are ignored. This behavior is equivolent to the timelocal() and mktime() functions that C programmers are accustomed to. Please note that the behavior for this function during the hour immediately before or after a DST switchover may produce a result with a different hour than you expect. -} timelocal :: CalendarTime -> IO Integer timelocal ct = do guessct <- toCalendarTime guesscl let newct = ct {ctTZ = ctTZ guessct} return $ timegm newct where guesscl = toClockTime ct {- | Converts the given timeDiff to the number of seconds it represents. Uses the same algorithm as normalizeTimeDiff in GHC. -} timeDiffToSecs :: TimeDiff -> Integer timeDiffToSecs td = (fromIntegral $ tdSec td) + 60 * ((fromIntegral $ tdMin td) + 60 * ((fromIntegral $ tdHour td) + 24 * ((fromIntegral $ tdDay td) + 30 * ((fromIntegral $ tdMonth td) + 365 * (fromIntegral $ tdYear td))))) {- | Converts an Epoch time represented with an arbitrary Real to a ClockTime. This input could be a CTime from Foreign.C.Types or an EpochTime from System.Posix.Types. -} epochToClockTime :: Real a => a -> ClockTime epochToClockTime x = TOD seconds secfrac where ratval = toRational x seconds = floor ratval secfrac = floor $ (ratval - (seconds % 1) ) * picosecondfactor picosecondfactor = 10 ^ 12 {- | Converts a ClockTime to something represented with an arbitrary Real. The result could be treated as a CTime from Foreign.C.Types or EpochTime from System.Posix.Types. The inverse of 'epochToClockTime'. Fractions of a second are not preserved by this function. -} clockTimeToEpoch :: Num a => ClockTime -> a clockTimeToEpoch (TOD sec _) = fromInteger sec {- | Render a number of seconds as a human-readable amount. Shows the two most significant places. For instance: >renderSecs 121 = "2m1s" See also 'renderTD' for a function that works on a TimeDiff. -} renderSecs :: Integer -> String renderSecs i = renderTD $ diffClockTimes (TOD i 0) (TOD 0 0) {- | Like 'renderSecs', but takes a TimeDiff instead of an integer second count. -} renderTD :: TimeDiff -> String renderTD itd = case workinglist of [] -> "0s" _ -> 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 MissingH-1.2.0.0/src/System/Time/ParseDate.hs0000644000175000017500000002403712027213047021002 0ustar jgoerzenjgoerzen{- | 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)) MissingH-1.2.0.0/src/System/Console/0000755000175000017500000000000012027213047017274 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Console/GetOpt/0000755000175000017500000000000012027213047020476 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Console/GetOpt/Utils.hs0000644000175000017500000000565412027213047022144 0ustar jgoerzenjgoerzen{- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : MissingH.getOpt Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Written by John Goerzen, jgoerzen\@complete.org Utilities for command-line parsing, including wrappers around the standard System.Console.GetOpt module. -} module System.Console.GetOpt.Utils (parseCmdLine, validateCmdLine, StdOption, stdRequired, stdOptional ) where import System.Console.GetOpt import System.Environment {- | Simple command line parser -- a basic wrapper around the system's default getOpt. See the System.Console.GetOpt manual for a description of the first two parameters. The third parameter is a usage information header. 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 = do argv <- getArgs case getOpt order options argv of (o, n, []) -> return (o, n) (_, _, errors) -> ioError (userError (concat errors ++ usageInfo header options)) {- | Similar to 'parseCmdLine', but takes an additional function that validates the post-parse command-line arguments. This is useful, for example, in situations where there are two arguments that are mutually-exclusive and only one may legitimately be given at a time. The return value of the function indicates whether or not it detected an error condition. If it returns Nothing, there is no error. If it returns Just String, there was an error, described by the String. -} validateCmdLine :: ArgOrder a -> [OptDescr a] -> String -> (([a],[String]) -> Maybe String) -> IO ([a], [String]) validateCmdLine order options header func = do res <- parseCmdLine order options header case func res of Nothing -> return res Just errormsg -> ioError (userError (errormsg ++ "\n" ++ usageInfo header options)) {- | A type to standardize some common uses of GetOpt. The first component of the tuple is the long name of the option. The second component is empty if there is no arg, or has the arg otherwise. -} type StdOption = (String, String) {- | Handle a required argument. -} stdRequired :: String -- ^ Name of arg -> String -> StdOption stdRequired name value = (name, value) {- | Handle an optional argument. -} stdOptional :: String -- ^ Name of arg -> Maybe String -> StdOption stdOptional name Nothing = (name, "") stdOptional name (Just x) = (name, x) MissingH-1.2.0.0/src/System/Daemon.hs0000644000175000017500000000446512027213047017442 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Daemon Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional 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. -} module System.Daemon ( #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) detachDaemon #endif ) where #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Process import System.Posix.IO import System.Directory import System.Log.Logger import System.Exit trap :: IO a -> IO a trap = traplogging "System.Daemon" ERROR "detachDaemon" {- | Detach the process from a controlling terminal and run it in the background, handling it with standard Unix deamon semantics. After running this, please note the following side-effects: * The PID of the running process will change * stdin, stdout, and stderr will not work (they'll be set to \/dev\/null) * CWD will be changed to \/ I /highly/ suggest running this function before starting any threads. Note that this is not intended for a daemon invoked from inetd(1). -} detachDaemon :: IO () detachDaemon = trap $ do forkProcess child1 exitImmediately ExitSuccess child1 :: IO () child1 = trap $ do createSession forkProcess child2 exitImmediately ExitSuccess child2 :: IO () child2 = trap $ do setCurrentDirectory "/" mapM_ closeFd [stdInput, stdOutput, stdError] nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd #endif MissingH-1.2.0.0/src/System/Posix/0000755000175000017500000000000012027213047016774 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Posix/Consts.hs0000644000175000017500000000201612027213047020600 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- Posix consts not included with Haskell Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Posix.Consts Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Exports some POSIX constants and functions that are not exported in fptools by default. -} module System.Posix.Consts where import System.Posix.Types blockSpecialMode :: FileMode blockSpecialMode = 0o0060000 characterSpecialMode :: FileMode characterSpecialMode = 0o0020000 namedPipeMode :: FileMode namedPipeMode = 0o0010000 regularFileMode :: FileMode regularFileMode = 0o0100000 directoryMode :: FileMode directoryMode = 0o0040000 fileTypeModes :: FileMode fileTypeModes = 0o00170000 socketMode :: FileMode socketMode = 0o0140000 symbolicLinkMode :: FileMode symbolicLinkMode = 0o0120000 MissingH-1.2.0.0/src/System/Debian.hs0000644000175000017500000000457412027213047017422 0ustar jgoerzenjgoerzen{- arch-tag: Debian Package utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Debian Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with Debian files and programs. Written by John Goerzen, jgoerzen\@complete.org -} module System.Debian (-- * Control or Similar File Utilities ControlFile, -- * Version Number Utilities DebVersion, compareDebVersion, checkDebVersion ) where import System.Cmd import System.IO.Unsafe import System.Exit {- | The type representing the contents of a Debian control file, or any control-like file (such as the output from apt-cache show, etc.) -} type ControlFile = [(String, String)] ---------------------------------------------------------------------- -- VERSION NUMBERS ---------------------------------------------------------------------- {- | The type representing a Debian version number. This type is an instance of 'Prelude.Ord', but you can also use 'compareDebVersion' if you prefer. -} data DebVersion = DebVersion String deriving (Eq) instance Ord DebVersion where compare (DebVersion v1) (DebVersion v2) = {- This is OK since compareDebVersion should always be the same. -} unsafePerformIO $ compareDebVersion v1 v2 {- | Compare the versions of two packages. -} compareDebVersion :: String -> String -> IO Ordering compareDebVersion v1 v2 = let runit op = checkDebVersion v1 op v2 in do islt <- runit "lt" if islt then return LT else do isgt <- runit "gt" if isgt then return GT else return EQ checkDebVersion :: String -- ^ Version 1 -> String -- ^ Operator -> String -- ^ Version 2 -> IO Bool checkDebVersion v1 op v2 = do ec <- rawSystem "dpkg" ["--compare-versions", v1, op, v2] case ec of ExitSuccess -> return True ExitFailure _ -> return False MissingH-1.2.0.0/src/System/Path/0000755000175000017500000000000012027213047016566 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Path/NameManip.hs0000644000175000017500000003720112027213047020772 0ustar jgoerzenjgoerzen{- | Module : System.Path.NameManip Copyright : Copyright (C) 2004 Volker Wysk License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Low-level path name manipulations. Written by Volker Wysk -} module System.Path.NameManip where import Data.List (intersperse) import System.Directory (getCurrentDirectory) {- | 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 will start with \"@\/@\". \"@..@\" components are left intact. They can't be simply removed, because the preceding component might be a symlink. In this case, 'realpath' is probably what you need. The case that the path is empty, is probably an error. However, it is treated like \"@.@\", yielding an empty path components list. Examples: >slice_path "/" = ["/"] >slice_path "/foo/bar" = ["/foo","bar"] >slice_path "..//./" = [".."] >slice_path "." = [] See 'unslice_path', 'realpath', 'realpath_s'. -} 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' 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) {- | Form a path from path components. This isn't the inverse of 'slice_path', since @'unslice_path' . 'slice_path'@ normalises the path. See 'slice_path'. -} 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) {- | Normalise a path. This is done by reducing repeated @\/@ characters to one, and removing @.@ path components. @..@ path components are left intact, because of possible symlinks. @'normalise_path' = 'unslice_path' . 'slice_path'@ -} normalise_path :: String -- ^ Path to be normalised -> String -- ^ Path in normalised form normalise_path = unslice_path . slice_path {- | Split a file name in components. This are the base file name and the suffixes, which are separated by dots. If the name starts with a dot, it is regarded as part of the base name. The result is a list of file name components. The filename may be a path. In this case, everything up to the last path component will be returned as part of the base file name. The path gets normalised thereby. No empty suffixes are returned. If the file name contains several consecutive dots, they are regared as part of the preceding file name component. Concateneting the name components and adding dots, reproduces the original name, with a normalised path: @concat . intersperse \".\" . 'slice_filename' == 'normalise'@. Note that the last path component might be \"@..@\". Then it is not possible to deduce the refered directory's name from the path. An IO action for getting the real path is then necessary. Examples: @ 'slice_filename' \"a.b\/\/.\/.foo.tar.gz\" == [\"a.b\/.foo\",\"tar\",\"gz\"] 'slice_filename' \".x..y.\" == [\".x.\", \"y.\"] @ See 'unslice_filename', @slice_filename\'@. -} slice_filename :: String -- ^ Path -> [String] -- ^ List of components the file name is made up of slice_filename path = let comps = slice_path path in if comps == [] then [] else -- slice_filename' result not empty, because comps not empty let (base:suffixes) = slice_filename' (last comps) in (unslice_path (init comps ++ [base]) : suffixes) {- | This is a variant of 'slice_filename'. It is like 'slice_filename', except for being more efficient, and the filename must not contain any preceding path, since this case isn't considered. See 'slice_filename', 'unslice_filename'. -} slice_filename' :: String -- ^ File name without path -> [String] -- ^ List of components the file name is made up of slice_filename' filename = case filename of ('.':filename') -> case slice_filename'' filename' of [] -> ["."] (t:ts) -> ('.':t) : ts filename -> slice_filename'' filename where slice_filename'' :: String -> [String] slice_filename'' "" = [] slice_filename'' fn = let (beg,rest) = split1 fn in (beg : slice_filename'' rest) split1 :: String -> (String, String) split1 (x:y:r) = if x == '.' && y /= '.' then ("", y:r) else let (beg,rest) = split1 (y:r) in (x:beg,rest) split1 str = (str, "") {- | Form file name from file name components, interspersing dots. This is the inverse of 'slice_filename', except for normalisation of any path. > unslice_filename = concat . intersperse "." See 'slice_filename'. -} unslice_filename :: [String] -- ^ List of file name components -> String -- ^ Name of the file which consists of the supplied components unslice_filename = concat . intersperse "." {- | Split a path in directory and file name. Only in the case that the supplied path is empty, both parts are empty strings. Otherwise, @\".\"@ is filled in for the corresponding part, if necessary. Unless the path is empty, concatenating the returned path and file name components with a slash in between, makes a valid path to the file. @split_path@ splits off the last path component. This isn't the same as the text after the last @\/@. Note that the last path component might be @\"..\"@. Then it is not possible to deduce the refered directory's name from the path. Then an IO action for getting the real path is necessary. Examples: >split_path "/a/b/c" == ("/a/b", "c") >split_path "foo" == (".", "foo") >split_path "foo/bar" == ("foo", "bar") >split_path "foo/.." == ("foo", "..") >split_path "." == (".", ".") >split_path "" == ("", "") >split_path "/foo" == ("/", "foo") >split_path "foo/" == (".", "foo") >split_path "foo/." == (".", "foo") >split_path "foo///./bar" == ("foo", "bar") See 'slice_path'. -} split_path :: String -- ^ Path to be split -> (String, String) -- ^ Directory and file name components of the path. The directory path is normalized. split_path "" = ("","") split_path path = case slice_path path of [] -> (".",".") ["/"] -> ("/", ".") ['/':p] -> ("/", p) [fn] -> (".", fn) parts -> ( unslice_path (init parts) , last parts ) {- | Get the directory part of a path. >dir_part = fst . split_path See 'split_path'. -} dir_part :: String -> String dir_part = fst . split_path {- | Get the last path component of a path. >filename_part = snd . split_path Examples: >filename_part "foo/bar" == "bar" >filename_part "." == "." See 'split_path'. -} filename_part :: String -> String filename_part = snd . split_path {- | Inverse of 'split_path', except for normalisation. This concatenates two paths, and takes care of @\".\"@ and empty paths. When the two components are the result of @split_path@, then @unsplit_path@ creates a normalised path. It is best documented by its definition: >unsplit_path (".", "") = "." >unsplit_path ("", ".") = "." >unsplit_path (".", q) = q >unsplit_path ("", q) = q >unsplit_path (p, "") = p >unsplit_path (p, ".") = p >unsplit_path (p, q) = p ++ "/" ++ q Examples: >unsplit_path ("", "") == "" >unsplit_path (".", "") == "." >unsplit_path (".", ".") == "." >unsplit_path ("foo", ".") == "foo" See 'split_path'. -} unsplit_path :: ( String, String ) -- ^ Directory and file name -> String -- ^ Path formed from the directory and file name parts unsplit_path (".", "") = "." unsplit_path ("", ".") = "." unsplit_path (".", q) = q unsplit_path ("", q) = q unsplit_path (p, "") = p unsplit_path (p, ".") = p unsplit_path (p, q) = p ++ "/" ++ q {- | Split a file name in prefix and suffix. If there isn't any suffix in the file name, then return an empty suffix. A dot at the beginning or at the end is not regarded as introducing a suffix. The last path component is what is being split. This isn't the same as splitting the string at the last dot. For instance, if the file name doesn't contain any dot, dots in previous path component's aren't mistaken as introducing suffixes. The path part is returned in normalised form. This means, @\".\"@ components are removed, and multiple \"@\/@\"s are reduced to one. Note that there isn't any plausibility check performed on the suffix. If the file name doesn't have a suffix, but happens to contain a dot, then this dot is mistaken as introducing a suffix. Examples: >split_filename "path/to/foo.bar" = ("path/to/foo","bar") >split_filename "path/to/foo" = ("path/to/foo","") >split_filename "/path.to/foo" = ("/path.to/foo","") >split_filename "a///./x" = ("a/x","") >split_filename "dir.suffix/./" = ("dir","suffix") >split_filename "Photographie, Das 20. Jahrhundert (300 dpi)" = ("Photographie, Das 20", " Jahrhundert (300 dpi)") See 'slice_path', 'split_filename\'' -} split_filename :: String -- ^ Path including the file name to be split -> (String, String) -- ^ The normalised path with the file prefix, and the file suffix. split_filename "" = ("", "") split_filename path = case slice_path path of [] -> (".","") comps -> let (pref_fn, suff_fn) = split_filename' (last comps) in ( concat (intersperse "/" (init comps ++ [pref_fn])) , suff_fn ) {- | Variant of 'split_filename'. This is a more efficient version of 'split_filename', for the case that you know the string is is a pure file name without any slashes. See 'split_filename'. -} split_filename' :: String -- ^ Filename to be split -> (String, String) -- ^ Base name and the last suffix split_filename' "" = ("", "") split_filename' fn = let parts = slice_filename' fn in case parts of [] -> (".", "") [base] -> (base, "") p -> (unslice_filename (init p), last p) {- | Inverse of 'split_filename'. Concatenate prefix and suffix, adding a dot in between, iff the suffix is not empty. The path part of the prefix is normalised. See 'split_filename'. -} unsplit_filename :: (String, String) -- ^ File name prefix and suffix -> String -- ^ Path unsplit_filename (prefix, suffix) = if suffix == "" then prefix else prefix ++ "." ++ suffix {- | Split a path in directory, base file name and suffix. -} split3 :: String -- ^ Path to split -> (String, String, String) -- ^ Directory part, base file name part and suffix part split3 "" = ("","","") split3 path = let comps = slice_path path (base, suffix) = split_filename' (last comps) in (unslice_path (init comps), base, suffix) {- | Form path from directory, base file name and suffix parts. -} unsplit3 :: (String, String, String) -- ^ Directory part, base file name part and suffix part -> String -- ^ Path consisting of dir, base and suffix unsplit3 (dir, base, suffix) = unsplit_path (dir, (unsplit_filename (base,suffix))) {- | Test a path for a specific suffix and split it off. If the path ends with the suffix, then the result is @Just prefix@, where @prefix@ is the normalised path without the suffix. Otherwise it's @Nothing@. -} test_suffix :: String -- ^ Suffix to split off -> String -- ^ Path to test -> Maybe String -- ^ Prefix without the suffix or @Nothing@ test_suffix suffix path = let (prefix, suff) = split_filename path in if suff == suffix then Just prefix else Nothing {- | Make a path absolute, using the current working directory. This makes a relative path absolute with respect to the current working directory. An absolute path is returned unmodified. The current working directory is determined with @getCurrentDirectory@ which means that symbolic links in it are expanded and the path is normalised. This is different from @pwd@. -} 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) {- | Make a path absolute. This makes a relative path absolute with respect to a specified directory. An absolute path is returned unmodified. -} 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 {- | Make a path absolute. This makes a relative path absolute with respect to a specified directory. An absolute path is returned unmodified. The order of the arguments can be confusing. You should rather use 'absolute_path_by'. @absolute_path\'@ is included for backwards compatibility. -} 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 {- | Guess the @\"..\"@-component free form of a path, specified as a list of path components, by syntactically removing them, along with the preceding path components. This will produce erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing@. -} guess_dotdot_comps :: [String] -- ^ List of path components -> Maybe [String] -- ^ In case the path could be transformed, the @\"..\"@-component free list of path components. guess_dotdot_comps = guess_dotdot_comps' [] where guess_dotdot_comps' schon [] = Just schon guess_dotdot_comps' [] ("..":_) = Nothing guess_dotdot_comps' schon ("..":teile) = guess_dotdot_comps' (reverse . tail . reverse $ schon) teile guess_dotdot_comps' schon (teil:teile) = guess_dotdot_comps' (schon ++ [teil]) teile {- | Guess the @\"..\"@-component free, normalised form of a path. The transformation is purely syntactic. @\"..\"@ path components will be removed, along with their preceding path components. This will produce erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing@. >guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path -} guess_dotdot :: String -- ^ Path to be normalised -> Maybe String -- ^ In case the path could be transformed, the normalised, @\"..\"@-component free form of the path. guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path MissingH-1.2.0.0/src/System/Path/WildMatch.hs0000644000175000017500000000563012027213047021002 0ustar jgoerzenjgoerzen{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path.WildMatch Copyright : Copyright (C) 2006-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Matching filenames with wildcards. See also "System.Path.Glob" for support for generating lists of files based on wildcards. Inspired by fnmatch.py, part of the Python standard library. Written by John Goerzen, jgoerzen\@complete.org The input wildcard for functions in this module is expected to be in the standard style of Posix shells. That is: >? matches exactly one character >\* matches zero or more characters >[list] matches any character in list >[!list] matches any character not in the list The returned regular expression will always end in \$ but never begins with ^, making it suitable for appending to the end of paths. If you want to match a given filename directly, you should prepend the ^ character to the returned value from this function. Please note: * Neither the path separator (the slash or backslash) nor the period carry any special meaning for the functions in this module. That is, @*@ will match @\/@ in a filename. If this is not the behavior you want, you probably want "System.Path.Glob" instead of this module. * Unlike the Unix shell, filenames that begin with a period are not ignored by this module. That is, @*.txt@ will match @.test.txt@. * This module does not current permit escaping of special characters. -} module System.Path.WildMatch (-- * Wildcard matching wildCheckCase, wildToRegex) where import Text.Regex import Data.String.Utils {- | Convert a wildcard to an (uncompiled) regular expression. -} wildToRegex :: String -> String wildToRegex i = convwild i ++ "$" {- | Check the given name against the given pattern, being case-sensitive. The given pattern is forced to match the given name starting at the beginning. -} wildCheckCase :: String -- ^ The wildcard pattern to use as the base -> String -- ^ The filename to check against it -> Bool -- ^ Result wildCheckCase patt name = case matchRegex (mkRegex $ "^" ++ wildToRegex patt) name of Nothing -> False Just _ -> True -- This is SO MUCH CLEANER than the python implementation! convwild :: String -> String 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 convpat :: String -> String convpat ('\\':xs) = "\\\\" ++ convpat xs convpat (']':xs) = ']' : convwild xs convpat (x:xs) = x : convpat xs convpat [] = [] MissingH-1.2.0.0/src/System/Path/Glob.hs0000644000175000017500000000753612027213047020020 0ustar jgoerzenjgoerzen{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path.Glob Copyright : Copyright (C) 2006-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Functions for expanding wildcards, filenames, and pathnames. For information on the metacharacters recognized, please see the notes in "System.Path.WildMatch". -} 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) hasWild :: String -> Bool hasWild = hasAny "*?[" {- | Takes a pattern. Returns a list of names that match that pattern. The pattern is evaluated by "System.Path.WildMatch". This function does not perform tilde or environment variable expansion. Filenames that begin with a dot are not included in the result set unless that component of the pattern also begins with a dot. In MissingH, this function is defined as: >glob = vGlob SystemFS -} glob :: FilePath -> IO [FilePath] glob = vGlob SystemFS {- | Like 'glob', but works on both the system ("real") and HVFS virtual filesystems. -} vGlob :: HVFS a => a -> FilePath -> IO [FilePath] vGlob fs fn = if not (hasWild fn) -- Don't try globbing if there are no wilds then do de <- vDoesExist fs fn if de then return [fn] else return [] 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 where (dirnameslash, basename) = splitFileName fn dirname = case dirnameslash of "/" -> "/" x -> if isSuffixOf "/" x then take (length x - 1) x else x expandWildBase :: FilePath -> IO [FilePath] expandWildBase dname = do dirglobs <- runGlob fs dname basename return $ map withD dirglobs where withD = case dname of "" -> id _ -> \globfn -> dname ++ "/" ++ globfn expandNormalBase :: FilePath -> IO [FilePath] expandNormalBase dname = do isdir <- vDoesDirectoryExist fs dname let newname = dname ++ "/" ++ basename isexists <- vDoesExist fs newname if isexists && ((basename /= "." && basename /= "") || isdir) then return [dname ++ "/" ++ basename] else return [] runGlob :: HVFS a => a -> FilePath -> FilePath -> IO [FilePath] runGlob fs "" patt = runGlob fs "." patt runGlob fs dirname patt = do r <- tryJust ioErrors (vGetDirectoryContents fs dirname) case r of Left _ -> return [] Right names -> let matches = filter (wildCheckCase patt) $ names in if head patt == '.' then return matches else return $ filter (\x -> head x /= '.') matches where ioErrors :: IOError -> Maybe IOError ioErrors e = Just e MissingH-1.2.0.0/src/System/IO/0000755000175000017500000000000012027213047016201 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/IO/HVIO.hs0000644000175000017500000006050512027213047017310 0ustar jgoerzenjgoerzen{- arch-tag: HVIO main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVIO Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Haskell Virtual I\/O -- a system to increase the flexibility of input and output in Haskell Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org HVIO provides the following general features: * The ability to use a single set of functions on various different types of objects, including standard Handles, in-memory buffers, compressed files, network data streams, etc. * The ability to transparently add filters to the I\/O process. These filters could include things such as character set conversions, compression or decompression of a data stream, and more. * The ability to define new objects that have the properties of I\/O objects and can be used interchangably with them. * Specification compatibility with, and complete support for, existing I\/O on Handles. * Provide easier unit testing capabilities for I\/O actions HVIO defines several basic type classes that you can use. You will mostly be interested in 'HVIO'. It's trivial to adapt old code to work with HVIO. For instance, consider this example of old and new code: >printMsg :: Handle -> String -> IO () >printMsg h msg = hPutStr h ("msg: " ++ msg) And now, the new way: >printMsg :: HVIO h => h -> String -> IO () >printMsg h msg = vPutStr h ("msg: " ++ msg) There are several points to note about this conversion: * The new method can still accept a Handle in exactly the same way as the old method. Changing your functions to use HVIO will require no changes from functions that call them with Handles. * Most \"h\" functions have equivolent \"v\" functions that operate on HVIO classes instead of the more specific Handle. The \"v\" functions behave identically to the \"h\" functions whenever possible. * There is no equivolent of \"openFile\" in any HVIO class. You must create your Handle (or other HVIO object) using normal means. This is because the creation is so different that it cannot be standardized. In addition to Handle, there are several pre-defined classes for your use. 'StreamReader' is a particularly interesting one. At creation time, you pass it a String. Its contents are read lazily whenever a read call is made. It can be used, therefore, to implement filters (simply initialize it with the result from, say, a map over hGetContents from another HVIO object), codecs, and simple I\/O testing. Because it is lazy, it need not hold the entire string in memory. You can create a 'StreamReader' with a call to 'newStreamReader'. 'MemoryBuffer' is a similar class, but with a different purpose. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you prefer a String representation. You can create a 'MemoryBuffer' with a call to 'newMemoryBuffer'. Finally, there are pipes. These pipes are analogous to the Unix pipes that are available from System.Posix, but don't require Unix and work only in Haskell. When you create a pipe, you actually get two HVIO objects: a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one thread and the 'PipeReader' in another thread. Data that's written to the 'PipeWriter' will then be available for reading with the 'PipeReader'. The pipes are implemented completely with existing Haskell threading primitives, and require no special operating system support. Unlike Unix pipes, these pipes cannot be used across a fork(). Also unlike Unix pipes, these pipes are portable and interact well with Haskell threads. A new pipe can be created with a call to 'newHVIOPipe'. Together with "System.IO.HVFS", this module is part of a complete virtual filesystem solution. -} module System.IO.HVIO(-- * Implementation Classes HVIO(..), -- * Standard HVIO Implementations -- ** Handle -- | Handle is a member of 'HVIO'. -- ** Stream Reader StreamReader, newStreamReader, -- ** Memory Buffer MemoryBuffer, newMemoryBuffer, mbDefaultCloseFunc, getMemoryBuffer, -- ** Haskell Pipe PipeReader, PipeWriter, newHVIOPipe ) 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 {- | 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'. Functions in this class provide an interface with the same specification as the similar functions in System.IO. Please refer to that documentation for a more complete specification than is provided here. Instances of 'HVIO' must provide 'vClose', 'vIsEOF', and either 'vIsOpen' or 'vIsClosed'. Implementators of readable objects must provide at least 'vGetChar' and 'vIsReadable'. An implementation of 'vGetContents' is also highly suggested, since the default cannot implement proper partial closing semantics. Implementators of writable objects must provide at least 'vPutChar' and 'vIsWritable'. Implementators of seekable objects must provide at least 'vIsSeekable', 'vTell', and 'vSeek'. -} class (Show a) => HVIO a where -- | Close a file vClose :: a -> IO () -- | Test if a file is open vIsOpen :: a -> IO Bool -- | Test if a file is closed vIsClosed :: a -> IO Bool -- | Raise an error if the file is not open. -- This is a new HVIO function and is implemented in terms of -- 'vIsOpen'. vTestOpen :: a -> IO () -- | Whether or not we're at EOF. This may raise on exception -- on some items, most notably write-only Handles such as stdout. -- In general, this is most reliable on items opened for reading. -- vIsEOF implementations must implicitly call vTestOpen. vIsEOF :: a -> IO Bool -- | Detailed show output. vShow :: a -> IO String -- | Make an IOError. vMkIOError :: a -> IOErrorType -> String -> Maybe FilePath -> IOError -- | Throw an IOError. vThrow :: a -> IOErrorType -> IO b -- | Get the filename\/object\/whatever that this corresponds to. -- May be Nothing. vGetFP :: a -> IO (Maybe FilePath) -- | Throw an isEOFError if we're at EOF; returns nothing otherwise. -- If an implementation overrides the default, make sure that it -- calls vTestOpen at some point. The default implementation is -- a wrapper around a call to 'vIsEOF'. vTestEOF :: a -> IO () -- | Read one character vGetChar :: a -> IO Char -- | Read one line vGetLine :: a -> IO String {- | Get the remaining contents. Please note that as a user of this function, the same partial-closing semantics as are used in the standard 'hGetContents' are /encouraged/ from implementators, but are not /required/. That means that, for instance, a 'vGetChar' after a 'vGetContents' may return some undefined result instead of the error you would normally get. You should use caution to make sure your code doesn't fall into that trap, or make sure to test your code with Handle or one of the default instances defined in this module. Also, some implementations may essentially provide a complete close after a call to 'vGetContents'. The bottom line: after a call to 'vGetContents', you should do nothing else with the object save closing it with 'vClose'. For implementators, you are highly encouraged to provide a correct implementation. -} vGetContents :: a -> IO String -- | Indicate whether at least one item is ready for reading. -- This will always be True for a great many implementations. vReady :: a -> IO Bool -- | Indicate whether a particular item is available for reading. vIsReadable :: a -> IO Bool -- | Write one character vPutChar :: a -> Char -> IO () -- | Write a string vPutStr :: a -> String -> IO () -- | Write a string with newline character after it vPutStrLn :: a -> String -> IO () -- | Write a string representation of the argument, plus a newline. vPrint :: Show b => a -> b -> IO () -- | Flush any output buffers. -- Note: implementations should assure that a vFlush is automatically -- performed -- on file close, if necessary to ensure all data sent is written. vFlush :: a -> IO () -- | Indicate whether or not this particular object supports writing. vIsWritable :: a -> IO Bool -- | Seek to a specific location. vSeek :: a -> SeekMode -> Integer -> IO () -- | Get the current position. vTell :: a -> IO Integer -- | Convenience function to reset the file pointer to the beginning -- of the file. A call to @vRewind h@ is the -- same as @'vSeek' h AbsoluteSeek 0@. vRewind :: a -> IO () -- | Indicate whether this instance supports seeking. vIsSeekable :: a -> IO Bool -- | Set buffering; the default action is a no-op. vSetBuffering :: a -> BufferMode -> IO () -- | Get buffering; the default action always returns NoBuffering. vGetBuffering :: a -> IO BufferMode -- | Binary output: write the specified number of octets from the specified -- buffer location. vPutBuf :: a -> Ptr b -> Int -> IO () -- | Binary input: read the specified number of octets from the -- specified buffer location, continuing to read -- until it either consumes that much data or EOF is encountered. -- Returns the number of octets actually read. EOF errors are never -- raised; fewer bytes than requested are returned on EOF. vGetBuf :: a -> Ptr b -> Int -> IO Int vSetBuffering _ _ = return () vGetBuffering _ = return NoBuffering vShow x = return (show x) vMkIOError _ et desc mfp = mkIOError et desc Nothing mfp vGetFP _ = return Nothing vThrow h et = do fp <- vGetFP h ioError (vMkIOError h et "" fp) vTestEOF h = do e <- vIsEOF h if e then vThrow h eofErrorType else return () vIsOpen h = vIsClosed h >>= return . not vIsClosed h = vIsOpen h >>= return . not vTestOpen h = do e <- vIsClosed h if e then vThrow h illegalOperationErrorType else return () vIsReadable _ = return False vGetLine h = let loop accum = let func = do c <- vGetChar h case c of '\n' -> return accum x -> accum `seq` loop (accum ++ [x]) handler e = if isEOFError e then return accum else ioError e in Control.Exception.catch func handler in do firstchar <- vGetChar h case firstchar of '\n' -> return [] x -> loop [x] vGetContents h = let loop = let func = do c <- vGetChar h next <- loop c `seq` return (c : next) handler e = if isEOFError e then return [] else ioError e in Control.Exception.catch func handler in do loop vReady h = do vTestEOF h return True vIsWritable _ = return False vPutStr _ [] = return () vPutStr h (x:xs) = do vPutChar h x vPutStr h xs vPutStrLn h s = vPutStr h (s ++ "\n") vPrint h s = vPutStrLn h (show s) vFlush = vTestOpen vIsSeekable _ = return False vRewind h = vSeek h AbsoluteSeek 0 vPutChar h _ = vThrow h illegalOperationErrorType vSeek h _ _ = vThrow h illegalOperationErrorType vTell h = vThrow h illegalOperationErrorType vGetChar h = vThrow h illegalOperationErrorType vPutBuf h buf len = do str <- peekCStringLen (castPtr buf, len) vPutStr h str vGetBuf h b l = worker b l 0 where worker _ 0 accum = return accum worker buf len accum = do iseof <- vIsEOF h if iseof then return accum else do c <- vGetChar h let cc = castCharToCChar c poke (castPtr buf) cc let newptr = plusPtr buf 1 worker newptr (len - 1) (accum + 1) ---------------------------------------------------------------------- -- Handle instances ---------------------------------------------------------------------- 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 vGetLine = hGetLine vGetContents = hGetContents vReady = hReady vIsReadable = hIsReadable vPutChar = hPutChar vPutStr = hPutStr vPutStrLn = hPutStrLn vPrint = hPrint vFlush = hFlush vIsWritable = hIsWritable vSeek = hSeek vTell = hTell vIsSeekable = hIsSeekable vSetBuffering = hSetBuffering vGetBuffering = hGetBuffering vGetBuf = hGetBuf vPutBuf = hPutBuf vIsOpen = hIsOpen vIsClosed = hIsClosed ---------------------------------------------------------------------- -- VIO Support ---------------------------------------------------------------------- type VIOCloseSupport a = IORef (Bool, a) vioc_isopen :: VIOCloseSupport a -> IO Bool vioc_isopen x = readIORef x >>= return . fst vioc_get :: VIOCloseSupport a -> IO a vioc_get x = readIORef x >>= return . snd vioc_close :: VIOCloseSupport a -> IO () vioc_close x = modifyIORef x (\ (_, dat) -> (False, dat)) vioc_set :: VIOCloseSupport a -> a -> IO () vioc_set x newdat = modifyIORef x (\ (stat, _) -> (stat, newdat)) ---------------------------------------------------------------------- -- Stream Readers ---------------------------------------------------------------------- {- | Simulate I\/O based on a string buffer. When a 'StreamReader' is created, it is initialized based on the contents of a 'String'. Its contents are read lazily whenever a request is made to read something from the 'StreamReader'. It can be used, therefore, to implement filters (simply initialize it with the result from, say, a map over hGetContents from another HVIO object), codecs, and simple I\/O testing. Because it is lazy, it need not hold the entire string in memory. You can create a 'StreamReader' with a call to 'newStreamReader'. -} newtype StreamReader = StreamReader (VIOCloseSupport String) {- | Create a new 'StreamReader' object. -} newStreamReader :: String -- ^ Initial contents of the 'StreamReader' -> IO StreamReader newStreamReader s = do ref <- newIORef (True, s) return (StreamReader ref) srv :: StreamReader -> VIOCloseSupport String srv (StreamReader x) = x instance Show StreamReader where show _ = "" instance HVIO StreamReader where vClose = vioc_close . srv vIsEOF h = do vTestOpen h d <- vioc_get (srv h) return $ case d of [] -> True _ -> False vIsOpen = vioc_isopen . srv vGetChar h = do vTestEOF h c <- vioc_get (srv h) let retval = head c vioc_set (srv h) (tail c) return retval vGetContents h = do vTestEOF h c <- vioc_get (srv h) vClose h return c vIsReadable _ = return True ---------------------------------------------------------------------- -- Buffers ---------------------------------------------------------------------- {- | A 'MemoryBuffer' simulates true I\/O, but uses an in-memory buffer instead of on-disk storage. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you prefer a String representation. You can create a 'MemoryBuffer' with a call to 'newMemoryBuffer'. The present 'MemoryBuffer' implementation is rather inefficient, particularly when reading towards the end of large files. It's best used for smallish data storage. This problem will be fixed eventually. -} data MemoryBuffer = MemoryBuffer (String -> IO ()) (VIOCloseSupport (Int, String)) {- | Create a new 'MemoryBuffer' instance. The buffer is initialized to the value passed, and the pointer is placed at the beginning of the file. You can put things in it by using the normal 'vPutStr' calls, and reset to the beginning by using the normal 'vRewind' call. The function is called when 'vClose' is called, and is passed the contents of the buffer at close time. You can use 'mbDefaultCloseFunc' if you don't want to do anything. To create an empty buffer, pass the initial value @\"\"@. -} newMemoryBuffer :: String -- ^ Initial Contents -> (String -> IO ()) -- ^ close func -> IO MemoryBuffer newMemoryBuffer initval closefunc = do ref <- newIORef (True, (0, initval)) return (MemoryBuffer closefunc ref) {- | Default (no-op) memory buf close function. -} mbDefaultCloseFunc :: String -> IO () mbDefaultCloseFunc _ = return () vrv :: MemoryBuffer -> VIOCloseSupport (Int, String) vrv (MemoryBuffer _ x) = x {- | Grab the entire contents of the buffer as a string. Unlike 'vGetContents', this has no effect on the open status of the item, the EOF status, or the current position of the file pointer. -} getMemoryBuffer :: MemoryBuffer -> IO String getMemoryBuffer h = do c <- vioc_get (vrv h) return (snd c) instance Show MemoryBuffer where show _ = "" instance HVIO MemoryBuffer where vClose x = do wasopen <- vIsOpen x vioc_close (vrv x) if wasopen then do c <- getMemoryBuffer x case x of MemoryBuffer cf _ -> cf c else return () vIsEOF h = do vTestOpen h c <- vioc_get (vrv h) return ((length (snd c)) == (fst c)) vIsOpen = vioc_isopen . vrv vGetChar h = do vTestEOF h c <- vioc_get (vrv h) let retval = (snd c) !! (fst c) vioc_set (vrv h) (succ (fst c), snd c) return retval vGetContents h = do vTestEOF h v <- vioc_get (vrv h) let retval = drop (fst v) (snd v) vioc_set (vrv h) (-1, "") vClose h return retval vIsReadable _ = return True vPutStr h s = do (pos, buf) <- vioc_get (vrv h) let (pre, post) = splitAt pos buf let newbuf = pre ++ s ++ (drop (length s) post) vioc_set (vrv h) (pos + (length s), newbuf) vPutChar h c = vPutStr h [c] vIsWritable _ = return True vTell h = do v <- vioc_get (vrv h) return . fromIntegral $ (fst v) vSeek h seekmode seekposp = do (pos, buf) <- vioc_get (vrv h) let seekpos = fromInteger seekposp let newpos = case seekmode of AbsoluteSeek -> seekpos RelativeSeek -> pos + seekpos SeekFromEnd -> (length buf) + seekpos let buf2 = buf ++ if newpos > (length buf) then replicate (newpos - (length buf)) '\0' else [] vioc_set (vrv h) (newpos, buf2) vIsSeekable _ = return True ---------------------------------------------------------------------- -- Pipes ---------------------------------------------------------------------- {- | Create a Haskell pipe. These pipes are analogous to the Unix pipes that are available from System.Posix, but don't require Unix and work only in Haskell. When you create a pipe, you actually get two HVIO objects: a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one thread and the 'PipeReader' in another thread. Data that's written to the 'PipeWriter' will then be available for reading with the 'PipeReader'. The pipes are implemented completely with existing Haskell threading primitives, and require no special operating system support. Unlike Unix pipes, these pipes cannot be used across a fork(). Also unlike Unix pipes, these pipes are portable and interact well with Haskell threads. -} newHVIOPipe :: IO (PipeReader, PipeWriter) newHVIOPipe = do mv <- newEmptyMVar readerref <- newIORef (True, mv) let reader = PipeReader readerref writerref <- newIORef (True, reader) return (reader, PipeWriter writerref) data PipeBit = PipeBit Char | PipeEOF deriving (Eq, Show) {- | The reading side of a Haskell pipe. Please see 'newHVIOPipe' for more details. -} newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit)) {- | The writing side of a Haskell pipe. Please see 'newHVIOPipe' for more details. -} newtype PipeWriter = PipeWriter (VIOCloseSupport PipeReader) ------------------------------ -- Pipe Reader ------------------------------ prv :: PipeReader -> VIOCloseSupport (MVar PipeBit) prv (PipeReader x) = x instance Show PipeReader where show _ = "" pr_getc :: PipeReader -> IO PipeBit pr_getc h = do mv <- vioc_get (prv h) takeMVar mv instance HVIO PipeReader where vClose = vioc_close . prv vIsOpen = vioc_isopen . prv vIsEOF h = do vTestOpen h mv <- vioc_get (prv h) dat <- readMVar mv return (dat == PipeEOF) vGetChar h = do vTestEOF h c <- pr_getc h case c of PipeBit x -> return x -- vTestEOF should eliminate this case _ -> fail "Internal error in HVIOReader vGetChar" vGetContents h = let loop = do c <- pr_getc h case c of PipeEOF -> return [] PipeBit x -> do next <- loop return (x : next) in do vTestEOF h loop vIsReadable _ = return True ------------------------------ -- Pipe Writer ------------------------------ pwv :: PipeWriter -> VIOCloseSupport PipeReader pwv (PipeWriter x) = x pwmv :: PipeWriter -> IO (MVar PipeBit) pwmv (PipeWriter x) = do mv1 <- vioc_get x vioc_get (prv mv1) instance Show PipeWriter where show _ = "" instance HVIO PipeWriter where vClose h = do o <- vIsOpen h if o then do mv <- pwmv h putMVar mv PipeEOF vioc_close (pwv h) else return () vIsOpen = vioc_isopen . pwv vIsEOF h = do vTestOpen h return False -- FIXME: race condition below (could be closed after testing) vPutChar h c = do vTestOpen h child <- vioc_get (pwv h) copen <- vIsOpen child if copen then do mv <- pwmv h putMVar mv (PipeBit c) else fail "PipeWriter: Couldn't write to pipe because child end is closed" vIsWritable _ = return True MissingH-1.2.0.0/src/System/IO/PlafCompat.hs0000644000175000017500000000245712027213047020573 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- Platform Compatibility Layer Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.PlafCompat Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable On Unix, exports System.Posix.Types and System.Posix.Files. On Windows, exports System.Posix.Types and "System.IO.WindowsCompat". The result should be roughly the same set of defined variables and types. -} module System.IO.PlafCompat (nullFileName, #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) module System.IO.WindowsCompat, #else module System.Posix.Files, #endif module System.Posix.Types) where import System.Posix.Types #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.IO.WindowsCompat #else import System.Posix.Files #endif {- | The name of the null device. NUL: on Windows, \/dev\/null everywhere else. -} nullFileName :: String #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) nullFileName = "NUL:" #else nullFileName = "/dev/null" #endif MissingH-1.2.0.0/src/System/IO/WindowsCompat.hs0000644000175000017500000000730512027213047021340 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- Windows compatibility layer Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.WindowsCompat Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Provides some types and related items on Windows to be compatible with the System.Posix.* libraries See also "System.IO.StatCompat", which this module re-exports. On non-Windows platforms, this module does nothing. On Windows, it re-exports "System.IO.StatCompat". It also provides various file type information modes that are otherwise in "System.Posix.Types" or "System.Posix.Files". It also provides a rudimentary implemention of getFileStatus that emulates the Posix call to stat(2). Common usage might be like this: >import System.Posix.Types >#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) >import System.IO.WindowsCompat >#else >import System.Posix.Files >#endif Or, to avoid having to use CPP and make things even easier, just import "System.IO.PlafCompat", which essentially does the above. -} module System.IO.WindowsCompat #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) where #else (module System.IO.StatCompat, module System.IO.WindowsCompat) where import System.Posix.Types import Data.Bits import System.IO.StatCompat import System.Posix.Consts import System.Time.Utils import System.Directory -- these types aren't defined here nullFileMode :: FileMode nullFileMode = 0 ownerReadMode :: FileMode ownerReadMode = 0o00400 ownerWriteMode :: FileMode ownerWriteMode = 0o00200 ownerExecuteMode :: FileMode ownerExecuteMode = 0o00100 groupReadMode :: FileMode groupReadMode = 0o00040 groupWriteMode :: FileMode groupWriteMode = 0o00020 groupExecuteMode :: FileMode groupExecuteMode = 0o00010 otherReadMode :: FileMode otherReadMode = 0o00004 otherWriteMode :: FileMode otherWriteMode = 0o00002 otherExecuteMode :: FileMode otherExecuteMode = 0o00001 setUserIDMode :: FileMode setUserIDMode = 0o0004000 setGroupIDMode :: FileMode setGroupIDMode = 0o0002000 stdFileMode :: FileMode stdFileMode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. groupWriteMode .|. otherReadMode .|. otherWriteMode ownerModes :: FileMode ownerModes = 0o00700 groupModes :: FileMode groupModes = 0o00070 otherModes :: FileMode otherModes = 0o00007 accessModes :: FileMode accessModes = ownerModes .|. groupModes .|. otherModes ----------- stat type FileStatus = FileStatusCompat getFileStatus :: FilePath -> IO FileStatus getFileStatus fp = do isfile <- doesFileExist fp isdir <- doesDirectoryExist fp perms <- getPermissions fp modct <- getModificationTime fp let epochtime = clockTimeToEpoch modct return $ FileStatusCompat {deviceID = -1, fileID = -1, fileMode = if isfile then regularFileMode else directoryMode, linkCount = 1, fileOwner = 0, fileGroup = 0, specialDeviceID = -1, fileSize = 0, -- fixme: hFileSize? accessTime = fromInteger epochtime, modificationTime = fromInteger epochtime, statusChangeTime = fromInteger epochtime } #endif MissingH-1.2.0.0/src/System/IO/HVFS.hs0000644000175000017500000002747012027213047017315 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances #-} {- arch-tag: HVFS main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Haskell Virtual FS -- generic support for real or virtual filesystem in Haskell Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org The idea of this module is to provide virtualization of filesystem calls. In addition to the \"real\" system filesystem, you can also provide access to other, virtual, filesystems using the same set of calls. Examples of such virtual filesystems might include a remote FTP server, WebDAV server, a local Hashtable, a ConfigParser object, or any other data structure you can represent as a tree of named nodes containing strings. Each 'HVFS' function takes a 'HVFS' \"handle\" ('HVFS' instance) as its first parameter. If you wish to operate on the standard system filesystem, you can just use 'SystemFS'. The "MissingH.HVFS.IO.InstanceHelpers" module contains some code to help you make your own HVFS instances. The 'HVFSOpenable' class works together with the "System.IO.HVIO" module to provide a complete virtual filesystem and I\/O model that allows you to open up virtual filesystem files and act upon them in a manner similar to standard Handles. -} module System.IO.HVFS(-- * Implementation Classes \/ Types HVFS(..), HVFSStat(..), HVFSOpenable(..), HVFSOpenEncap(..),HVFSStatEncap(..), withStat, withOpen, SystemFS(..), -- * Re-exported types from other modules FilePath, DeviceID, FileID, FileMode, LinkCount, UserID, GroupID, FileOffset, EpochTime, IOMode ) where import qualified Control.Exception (catch, IOException) import System.IO.HVIO import System.Time.Utils import System.IO import System.IO.Error import System.IO.PlafCompat import System.Posix.Types import System.Time import System.Directory #if MIN_VERSION_directory(1,2,0) import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) #endif {- | Encapsulate a 'HVFSStat' result. This is required due to Haskell typing restrictions. You can get at it with: > case encap of > HVFSStatEncap x -> -- now use x -} 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. Here is an example from the HVFS source: > vGetModificationTime fs fp = > do s <- vGetFileStatus fs fp > return $ epochToClockTime (withStat s vModificationTime) See 'System.Time.Utils.epochToClockTime' for more information. -} withStat :: forall b. HVFSStatEncap -> (forall a. HVFSStat a => a -> b) -> b withStat s f = case s of HVFSStatEncap x -> f x {- | Similar to 'HVFSStatEncap', but for 'vOpen' result. -} data HVFSOpenEncap = forall a. HVIO a => HVFSOpenEncap a {- | Similar to 'withStat', but for the 'vOpen' result. -} withOpen :: forall b. HVFSOpenEncap -> (forall a. HVIO a => a -> b) -> b withOpen s f = case s of HVFSOpenEncap x -> f x {- | Evaluating types of files and information about them. This corresponds to the System.Posix.Types.FileStatus type, and indeed, that is one instance of this class. Inplementators must, at minimum, implement 'vIsDirectory' and 'vIsRegularFile'. Default implementations of everything else are provided, returning reasonable values. A default implementation of this is not currently present on Windows. -} class (Show a) => HVFSStat a where vDeviceID :: a -> DeviceID vFileID :: a -> FileID {- | Refers to file permissions, NOT the st_mode field from stat(2) -} vFileMode :: a -> FileMode vLinkCount :: a -> LinkCount vFileOwner :: a -> UserID vFileGroup :: a -> GroupID vSpecialDeviceID :: a -> DeviceID vFileSize :: a -> FileOffset vAccessTime :: a -> EpochTime vModificationTime :: a -> EpochTime vStatusChangeTime :: a -> EpochTime vIsBlockDevice :: a -> Bool vIsCharacterDevice :: a -> Bool vIsNamedPipe :: a -> Bool vIsRegularFile :: a -> Bool vIsDirectory :: a -> Bool vIsSymbolicLink :: a -> Bool vIsSocket :: a -> Bool vDeviceID _ = 0 vFileID _ = 0 vFileMode x = if vIsDirectory x then 0x755 else 0o0644 vLinkCount _ = 1 vFileOwner _ = 0 vFileGroup _ = 0 vSpecialDeviceID _ = 0 vFileSize _ = 0 vAccessTime _ = 0 vModificationTime _ = 0 vStatusChangeTime _ = 0 vIsBlockDevice _ = False vIsCharacterDevice _ = False vIsNamedPipe _ = False vIsSymbolicLink _ = False vIsSocket _ = False {- | The main HVFS class. Default implementations of these functions are provided: * 'vGetModificationTime' -- implemented in terms of 'vGetFileStatus' * 'vRaiseError' * 'vDoesFileExist' -- implemented in terms of 'vGetFileStatus' * 'vDoesDirectoryExist' -- implemented in terms of 'vGetFileStatus' * 'vDoesExist' -- implemented in terms of 'vGetSymbolicLinkStatus' * 'vGetSymbolicLinkStatus' -- set to call 'vGetFileStatus'. Default implementations of all other functions will generate an isIllegalOperation error, since they are assumed to be un-implemented. You should always provide at least a 'vGetFileStatus' call, and almost certainly several of the others. Most of these functions correspond to functions in System.Directory or System.Posix.Files. Please see detailed documentation on them there. -} class (Show a) => HVFS a where vGetCurrentDirectory :: a -> IO FilePath vSetCurrentDirectory :: a -> FilePath -> IO () vGetDirectoryContents :: a -> FilePath -> IO [FilePath] vDoesFileExist :: a -> FilePath -> IO Bool vDoesDirectoryExist :: a -> FilePath -> IO Bool {- | True if the file exists, regardless of what type it is. This is even True if the given path is a broken symlink. -} vDoesExist :: a -> FilePath -> IO Bool vCreateDirectory :: a -> FilePath -> IO () vRemoveDirectory :: a -> FilePath -> IO () vRenameDirectory :: a -> FilePath -> FilePath -> IO () vRemoveFile :: a -> FilePath -> IO () vRenameFile :: a -> FilePath -> FilePath -> IO () vGetFileStatus :: a -> FilePath -> IO HVFSStatEncap vGetSymbolicLinkStatus :: a -> FilePath -> IO HVFSStatEncap vGetModificationTime :: a -> FilePath -> IO ClockTime {- | Raise an error relating to actions on this class. -} vRaiseError :: a -> IOErrorType -> String -> Maybe FilePath -> IO c vCreateSymbolicLink :: a -> FilePath -> FilePath -> IO () vReadSymbolicLink :: a -> FilePath -> IO FilePath vCreateLink :: a -> FilePath -> FilePath -> IO () vGetModificationTime fs fp = do s <- vGetFileStatus fs fp return $ epochToClockTime (withStat s vModificationTime) vRaiseError _ et desc mfp = ioError $ mkIOError et desc Nothing mfp vGetCurrentDirectory fs = eh fs "vGetCurrentDirectory" vSetCurrentDirectory fs _ = eh fs "vSetCurrentDirectory" vGetDirectoryContents fs _ = eh fs "vGetDirectoryContents" vDoesFileExist fs fp = Control.Exception.catch (do s <- vGetFileStatus fs fp return $ withStat s vIsRegularFile ) (\(_ :: Control.Exception.IOException) -> return False) 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 return True ) (\(_ :: Control.Exception.IOException) -> return False) vCreateDirectory fs _ = eh fs "vCreateDirectory" vRemoveDirectory fs _ = eh fs "vRemoveDirectory" vRemoveFile fs _ = eh fs "vRemoveFile" vRenameFile fs _ _ = eh fs "vRenameFile" vRenameDirectory fs _ _ = eh fs "vRenameDirectory" vCreateSymbolicLink fs _ _ = eh fs "vCreateSymbolicLink" vReadSymbolicLink fs _ = eh fs "vReadSymbolicLink" vCreateLink fs _ _ = eh fs "vCreateLink" vGetSymbolicLinkStatus = vGetFileStatus -- | Error handler helper eh :: HVFS a => a -> String -> IO c 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. You need only implement 'vOpen'. -} class HVFS a => HVFSOpenable a where vOpen :: a -> FilePath -> IOMode -> IO HVFSOpenEncap vReadFile :: a -> FilePath -> IO String vWriteFile :: a -> FilePath -> String -> IO () vOpenBinaryFile :: a -> FilePath -> IOMode -> IO HVFSOpenEncap vReadFile h fp = do oe <- vOpen h fp ReadMode withOpen oe (\fh -> vGetContents fh) vWriteFile h fp s = do oe <- vOpen h fp WriteMode withOpen oe (\fh -> do vPutStr fh s vClose fh) -- | Open a file in binary mode. vOpenBinaryFile = vOpen instance Show FileStatus where show _ = "" ---------------------------------------------------------------------- -- Standard implementations ---------------------------------------------------------------------- instance HVFSStat FileStatus where vDeviceID = deviceID vFileID = fileID vFileMode = fileMode vLinkCount = linkCount vFileOwner = fileOwner vFileGroup = fileGroup vSpecialDeviceID = specialDeviceID vFileSize = fileSize vAccessTime = accessTime vModificationTime = modificationTime vStatusChangeTime = statusChangeTime vIsBlockDevice = isBlockDevice vIsCharacterDevice = isCharacterDevice vIsNamedPipe = isNamedPipe vIsRegularFile = isRegularFile vIsDirectory = isDirectory vIsSymbolicLink = isSymbolicLink vIsSocket = isSocket data SystemFS = SystemFS 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 vGetFileStatus _ fp = getFileStatus fp >>= return . HVFSStatEncap #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vGetSymbolicLinkStatus _ fp = getSymbolicLinkStatus fp >>= return . HVFSStatEncap #else -- No symlinks on Windows; just get the file status directly vGetSymbolicLinkStatus = vGetFileStatus #endif #if MIN_VERSION_directory(1,2,0) vGetModificationTime _ p = getModificationTime p >>= (\modUTCTime -> return $ TOD ((toEnum . fromEnum . utcTimeToPOSIXSeconds) modUTCTime) 0) #else vGetModificationTime _ = getModificationTime #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vCreateSymbolicLink _ = createSymbolicLink vReadSymbolicLink _ = readSymbolicLink vCreateLink _ = createLink #else vCreateSymbolicLink _ _ _ = fail "Symbolic link creation not supported by Windows" vReadSymbolicLink _ _ = fail "Symbolic link reading not supported by Widnows" vCreateLink _ _ _ = fail "Hard link creation not supported by Windows" #endif instance HVFSOpenable SystemFS where vOpen _ fp iomode = openFile fp iomode >>= return . HVFSOpenEncap vOpenBinaryFile _ fp iomode = openBinaryFile fp iomode >>= return . HVFSOpenEncap MissingH-1.2.0.0/src/System/IO/HVFS/0000755000175000017500000000000012027213047016747 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/IO/HVFS/InstanceHelpers.hs0000644000175000017500000002000712027213047022371 0ustar jgoerzenjgoerzen{- arch-tag: HVFS instance helpers Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.InstanceHelpers Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Utilities for creating instances of the items defined in "System.IO.HVFS". -} module System.IO.HVFS.InstanceHelpers(-- * HVFSStat objects SimpleStat(..), -- * HVFS objects & types -- ** MemoryVFS MemoryVFS, newMemoryVFS, newMemoryVFSRef, MemoryNode, MemoryEntry(..), -- * Utilities nice_slice, getFullPath, getFullSlice) where import Data.IORef (newIORef, readIORef, writeIORef, IORef()) import Data.List (genericLength) import System.IO -- (ReadMode) import System.IO.Error (doesNotExistErrorType, illegalOperationErrorType, permissionErrorType) import System.IO.HVFS import System.IO.HVIO (newStreamReader) import System.Path (absNormPath) import System.Path.NameManip (slice_path) {- | 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 fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory } deriving (Show, Eq) instance HVFSStat SimpleStat where vIsRegularFile x = isFile x vIsDirectory x = not (isFile x) vFileSize x = fileSize x ---------------------------------------------------------------------- -- In-Memory Tree Types ---------------------------------------------------------------------- {- | The basic node of a 'MemoryVFS'. The String corresponds to the filename, and the entry to the contents. -} type MemoryNode = (String, MemoryEntry) {- | The content of a file or directory in a 'MemoryVFS'. -} data MemoryEntry = MemoryDirectory [MemoryNode] | MemoryFile String deriving (Eq, Show) {- | An in-memory read\/write filesystem. Think of it as a dynamically resizable ramdisk written in Haskell. -} data MemoryVFS = MemoryVFS { content :: IORef [MemoryNode], cwd :: IORef FilePath } instance Show MemoryVFS where show _ = "" -- | Create a new 'MemoryVFS' object from an existing tree. -- An empty filesystem may be created by using @[]@ for the parameter. newMemoryVFS :: [MemoryNode] -> IO MemoryVFS newMemoryVFS s = do r <- newIORef s newMemoryVFSRef r -- | Create a new 'MemoryVFS' object using an IORef to an -- existing tree. newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS newMemoryVFSRef r = do c <- newIORef "/" return (MemoryVFS {content = r, cwd = c}) {- | Similar to 'System.Path.NameManip' but the first element won't be @\/@. >nice_slice "/" -> [] >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 {- | 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 Nothing -> vRaiseError fs doesNotExistErrorType ("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path)) Just newpath -> return newpath {- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'. -} getFullSlice :: HVFS a => a -> String -> IO [String] getFullSlice fs fp = do newpath <- getFullPath fs fp return (nice_slice newpath) -- | 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 = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 newh = if (h /= "/") && 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 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 -- | Find an element on the tree, normalizing the path first getMelem :: MemoryVFS -> String -> IO MemoryEntry getMelem x s = do base <- readIORef $ cwd x case absNormPath base s of Nothing -> vRaiseError x doesNotExistErrorType ("Trouble normalizing path " ++ s) (Just s) Just newpath -> findMelem x newpath instance HVFS MemoryVFS where vGetCurrentDirectory x = readIORef $ cwd x vSetCurrentDirectory x fp = do curpath <- vGetCurrentDirectory x -- Make sure new dir is valid newdir <- getMelem x fp case newdir of (MemoryFile _) -> vRaiseError x doesNotExistErrorType ("Attempt to cwd to non-directory " ++ fp) (Just fp) (MemoryDirectory _) -> case absNormPath curpath fp of Nothing -> -- should never happen due to above getMelem call vRaiseError x illegalOperationErrorType "Bad internal error" (Just fp) Just y -> writeIORef (cwd x) y vGetFileStatus x fp = do elem <- getMelem x fp case elem of (MemoryFile y) -> return $ HVFSStatEncap $ SimpleStat {isFile = True, fileSize = (genericLength y)} (MemoryDirectory _) -> return $ HVFSStatEncap $ SimpleStat {isFile = False, fileSize = 0} vGetDirectoryContents x fp = do elem <- getMelem x fp case elem of MemoryFile _ -> vRaiseError x doesNotExistErrorType "Can't list contents of a file" (Just fp) MemoryDirectory c -> return $ map fst c instance HVFSOpenable MemoryVFS where vOpen x fp (ReadMode) = do elem <- getMelem x fp case elem of MemoryDirectory _ -> vRaiseError x doesNotExistErrorType "Can't open a directory" (Just fp) MemoryFile y -> newStreamReader y >>= return . HVFSOpenEncap vOpen x fp _ = vRaiseError x permissionErrorType "Only ReadMode is supported with MemoryVFS files" (Just fp) MissingH-1.2.0.0/src/System/IO/HVFS/Utils.hs0000644000175000017500000001323412027213047020406 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- arch-tag: HVFS utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing filesystems. Written by John Goerzen, jgoerzen\@complete.org To operate on your system's main filesystem, just pass SystemFS as the first parameter to these functions. -} module System.IO.HVFS.Utils (recurseDir, recurseDirStat, recursiveRemove, lsl, SystemFS(..) ) where import System.IO.HVFS import System.Time.Utils import System.IO.PlafCompat import Text.Printf import System.Time import System.Locale import System.IO.Unsafe {- | 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. If the passed value is not a directory, the return value be only that value. The \".\" and \"..\" entries are removed from the data returned. -} recurseDir :: HVFS a => a -> FilePath -> IO [FilePath] recurseDir fs x = recurseDirStat fs x >>= return . map fst {- | Like 'recurseDir', but return the stat() (System.Posix.Files.FileStatus) information with them. This is an optimization if you will be statting files yourself later. The items are returned lazily. WARNING: do not change your current working directory until you have consumed all the items. Doing so could cause strange effects. Alternatively, you may wish to pass an absolute path to this function. -} recurseDirStat :: HVFS a => a -> FilePath -> IO [(FilePath, HVFSStatEncap)] recurseDirStat h fn = do fs <- vGetSymbolicLinkStatus h fn if withStat fs vIsDirectory then do dirc <- vGetDirectoryContents h fn let contents = map ((++) (fn ++ "/")) $ filter (\x -> x /= "." && x /= "..") dirc subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents return $ (concat subdirs) ++ [(fn, fs)] else return [(fn, fs)] {- | Removes a file or a directory. If a directory, also removes all its child files\/directories. -} recursiveRemove :: HVFS a => a -> FilePath -> IO () recursiveRemove h fn = recurseDirStat h fn >>= (mapM_ $ \(fn, fs) -> if withStat fs vIsDirectory then vRemoveDirectory h fn else vRemoveFile h fn ) {- | Provide a result similar to the command ls -l over a directory. Known bug: setuid bit semantics are inexact compared with standard ls. -} lsl :: HVFS a => a -> FilePath -> IO String lsl fs fp = let showmodes mode = let i m = (intersectFileModes mode m /= 0) in (if i ownerReadMode then 'r' else '-') : (if i ownerWriteMode then 'w' else '-') : (if i setUserIDMode then 's' else if i ownerExecuteMode then 'x' else '-') : (if i groupReadMode then 'r' else '-') : (if i groupWriteMode then 'w' else '-') : (if i setGroupIDMode then 's' else if i groupExecuteMode then 'x' else '-') : (if i otherReadMode then 'r' else '-') : (if i otherWriteMode then 'w' else '-') : (if i otherExecuteMode then 'x' else '-') : [] showentry origdir fh (state, fp) = case state of HVFSStatEncap se -> let typechar = if vIsDirectory se then 'd' else if vIsSymbolicLink se then 'l' else if vIsBlockDevice se then 'b' else if vIsCharacterDevice se then 'c' else if vIsSocket se then 's' else if vIsNamedPipe se then 's' else '-' clocktime = epochToClockTime (vModificationTime se) 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) return $ " -> " ++ sl return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s" typechar (showmodes (vFileMode se)) (toInteger $ vFileOwner se) (toInteger $ vFileGroup se) (toInteger $ vFileSize se) (datestr c) fp linkstr in do c <- vGetDirectoryContents fs fp pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp ++ "/" ++ x) return (ss, x) ) c linedata <- mapM (showentry fp fs) pairs return $ unlines $ ["total 1"] ++ linedata MissingH-1.2.0.0/src/System/IO/HVFS/Combinators.hs0000644000175000017500000001613112027213047021565 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- arch-tag: HVFS Combinators Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.Combinators Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Support for combining different HVFS modules together Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org -} module System.IO.HVFS.Combinators ( -- * Restrictions HVFSReadOnly(..), HVFSChroot, newHVFSChroot) where import System.IO import System.IO.Error import System.IO.HVFS import System.IO.HVFS.InstanceHelpers (getFullPath) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Files -- This actually needed? -Wall doesn't seem to think -- so, but I'm not sure... #endif import System.Path (secureAbsNormPath) import System.Path.NameManip (normalise_path) ---------------------------------------------------------------------- -- Providing read-only access ---------------------------------------------------------------------- {- | Restrict access to the underlying filesystem to be strictly read-only. Any write-type operations will cause an error. No constructor is required; just say @HVFSReadOnly fs@ to make a new read-only wrapper around the 'HVFS' instance @fs@. -} data HVFS a => HVFSReadOnly a = HVFSReadOnly a deriving (Eq, Show) withro :: HVFS a => (a -> b) -> HVFSReadOnly a -> b withro f (HVFSReadOnly x) = f x roerror :: (HVFS a) => HVFSReadOnly a -> IO c roerror h = let err x = vRaiseError x permissionErrorType "Read-only virtual filesystem" Nothing in withro err h instance HVFS a => HVFS (HVFSReadOnly a) where vGetCurrentDirectory = withro vGetCurrentDirectory vSetCurrentDirectory = withro vSetCurrentDirectory vGetDirectoryContents = withro vGetDirectoryContents vDoesFileExist = withro vDoesFileExist vDoesDirectoryExist = withro vDoesDirectoryExist vCreateDirectory h _ = roerror h vRemoveDirectory h _ = roerror h vRenameDirectory h _ _ = roerror h vRenameFile h _ _ = roerror h vGetFileStatus = withro vGetFileStatus vGetSymbolicLinkStatus = withro vGetSymbolicLinkStatus vGetModificationTime = withro vGetModificationTime vRaiseError = withro vRaiseError vCreateSymbolicLink h _ _ = roerror h vReadSymbolicLink = withro vReadSymbolicLink vCreateLink h _ _ = roerror h instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where vOpen fh fp mode = case mode of ReadMode -> withro (\h -> vOpen h fp mode) fh _ -> roerror fh ---------------------------------------------------------------------- -- Restricting to a subdirectory ---------------------------------------------------------------------- {- | Access a subdirectory of a real filesystem as if it was the root of that filesystem. -} data HVFS a => HVFSChroot a = HVFSChroot String a deriving (Eq, Show) {- | Create a new 'HVFSChroot' object. -} newHVFSChroot :: HVFS a => a -- ^ The object to pass requests on to -> FilePath -- ^ The path of the directory to make root -> IO (HVFSChroot a) -- ^ The resulting new object newHVFSChroot fh fp = do full <- getFullPath fh fp isdir <- vDoesDirectoryExist fh full if isdir then do let newobj = (HVFSChroot full fh) vSetCurrentDirectory newobj "/" return newobj else vRaiseError fh doesNotExistErrorType ("Attempt to instantiate HVFSChroot over non-directory " ++ full) (Just full) {- | Get the embedded object -} dch :: (HVFS t) => HVFSChroot t -> t dch (HVFSChroot _ a) = a {- | 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 case secureAbsNormPath fp full of Nothing -> vRaiseError h doesNotExistErrorType ("Trouble normalizing path in chroot") (Just (fp ++ "," ++ full)) Just x -> return x {- | Convert a full path to a local (chroot) path. -} fp2dch (HVFSChroot fp h) locfp = do newpath <- case secureAbsNormPath fp locfp of Nothing -> vRaiseError h doesNotExistErrorType ("Unable to securely normalize path") (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) dch2fph :: (HVFS t) => (t -> String -> IO t1) -> HVFSChroot t -> [Char] -> IO t1 dch2fph func fh@(HVFSChroot _ h) locfp = do newfp <- dch2fp fh locfp func h newfp instance HVFS a => HVFS (HVFSChroot a) where vGetCurrentDirectory x = do fp <- vGetCurrentDirectory (dch x) fp2dch x fp vSetCurrentDirectory = dch2fph vSetCurrentDirectory vGetDirectoryContents = dch2fph vGetDirectoryContents vDoesFileExist = dch2fph vDoesFileExist vDoesDirectoryExist = dch2fph vDoesDirectoryExist vCreateDirectory = dch2fph vCreateDirectory vRemoveDirectory = dch2fph vRemoveDirectory vRenameDirectory fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vRenameDirectory (dch fh) old' new' vRemoveFile = dch2fph vRemoveFile vRenameFile fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vRenameFile (dch fh) old' new' vGetFileStatus = dch2fph vGetFileStatus vGetSymbolicLinkStatus = dch2fph vGetSymbolicLinkStatus vGetModificationTime = dch2fph vGetModificationTime -- vRaiseError vCreateSymbolicLink fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vCreateSymbolicLink (dch fh) old' new' vReadSymbolicLink fh fp = do result <- dch2fph vReadSymbolicLink fh fp fp2dch fh result vCreateLink fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vCreateLink (dch fh) old' new' instance HVFSOpenable a => HVFSOpenable (HVFSChroot a) where vOpen fh fp mode = do newfile <- dch2fp fh fp vOpen (dch fh) newfile mode MissingH-1.2.0.0/src/System/IO/Binary.hs0000644000175000017500000002735012027213047017770 0ustar jgoerzenjgoerzen{- arch-tag: I/O utilities, binary tools Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.Binary Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable to platforms supporting binary I\/O This module provides various helpful utilities for dealing with binary input and output. You can use this module to deal with binary blocks of data as either Strings or lists of Word8. The BinaryConvertible class provides this abstraction. Wherever you see HVIO, you can transparently substite a regular Handle. This module can work with any HVIO object, however. See "System.IO.HVIO" for more details. 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" Written by John Goerzen, jgoerzen\@complete.org -} module System.IO.Binary( -- * Support for different types of blocks BinaryConvertible(..), -- * Entire File\/Handle Utilities -- ** Opened Handle Data Copying hBlockCopy, blockCopy, -- ** Disk File Data Copying copyFileBlocksToFile, -- * Binary Single-Block I\/O hPutBufStr, putBufStr, hGetBufStr, getBufStr, hFullGetBufStr, fullGetBufStr, -- * Binary Multi-Block I\/O hGetBlocks, getBlocks, hFullGetBlocks, fullGetBlocks, -- * Lazy Interaction readBinaryFile, writeBinaryFile, -- ** Binary Block-based hBlockInteract, blockInteract, hFullBlockInteract, fullBlockInteract ) where import Data.Word (Word8()) import Foreign.C.String (peekCStringLen, withCString) import Foreign.C.Types (CChar()) import Foreign.ForeignPtr import Foreign.Marshal.Array (peekArray, withArray) import Foreign.Ptr import System.IO import System.IO.HVFS import System.IO.HVIO import System.IO.Unsafe (unsafeInterleaveIO) {- | Provides support for handling binary blocks with convenient types. This module provides implementations for Strings and for [Word8] (lists of Word8s). -} class (Eq a, Show a) => BinaryConvertible a where toBuf :: [a] -> (Ptr CChar -> IO c) -> IO c fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [a] instance BinaryConvertible Char where toBuf = withCString fromBuf len func = do fbuf <- mallocForeignPtrArray (len + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- func ptr peekCStringLen (ptr, bytesread) instance BinaryConvertible Word8 where toBuf hslist func = withArray hslist (\ptr -> func (castPtr ptr)) fromBuf len func = do (fbuf::(ForeignPtr Word8)) <- mallocForeignPtrArray (len + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- func (castPtr ptr) peekArray bytesread ptr -- ************************************************** -- Binary Files -- ************************************************** {- | As a wrapper around the standard function 'System.IO.hPutBuf', this function takes a standard Haskell 'String' instead of the far less convenient @Ptr a@. The entire contents of the string will be written as a binary buffer using 'hPutBuf'. The length of the output will be the length of the passed String or list. If it helps, you can thing of this function as being of type @Handle -> String -> IO ()@ -} hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO () hPutBufStr f s = toBuf s (\cs -> vPutBuf f cs (length s)) -- | An alias for 'hPutBufStr' 'stdout' putBufStr :: (BinaryConvertible b) => [b] -> IO () putBufStr = hPutBufStr stdout {- | Acts a wrapper around the standard function 'System.IO.hGetBuf', this function returns a standard Haskell String (or [Word8]) instead of modifying a 'Ptr a' buffer. The length is the maximum length to read and the semantice are the same as with 'hGetBuf'; namely, the empty string is returned with EOF is reached, and any given read may read fewer bytes than the given length. (Actually, it's a wrapper around 'System.IO.HVIO.vGetBuf') -} hGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b] hGetBufStr f count = fromBuf count (\buf -> vGetBuf f buf count) -- | An alias for 'hGetBufStr' 'stdin' getBufStr :: (BinaryConvertible b) => Int -> IO [b] getBufStr = hGetBufStr stdin {- | Like 'hGetBufStr', but guarantees that it will only return fewer than the requested number of bytes when EOF is encountered. -} hFullGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b] hFullGetBufStr _ 0 = return [] hFullGetBufStr f count = do thisstr <- hGetBufStr f count if thisstr == [] then return [] else do remainder <- hFullGetBufStr f (count - (length thisstr)) return (thisstr ++ remainder) -- | An alias for 'hFullGetBufStr' 'stdin' fullGetBufStr :: BinaryConvertible b => Int -> IO [b] fullGetBufStr = hFullGetBufStr stdin {- | Writes the list of blocks to the given file handle -- a wrapper around 'hPutBufStr'. Think of this function as: >Handle -> [String] -> IO () (You can use it that way) -} hPutBlocks :: (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO () hPutBlocks _ [] = return () hPutBlocks h (x:xs) = do hPutBufStr h x hPutBlocks h xs {- | An alias for 'hPutBlocks' 'stdout' putBlocks :: (BinaryConvertible b) => [[b]] -> IO () putBlocks = hPutBlocks stdout -} {- | Returns a lazily-evaluated list of all blocks in the input file, as read by 'hGetBufStr'. There will be no 0-length block in this list. The list simply ends at EOF. -} hGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]] hGetBlocks = hGetBlocksUtil hGetBufStr -- | An alias for 'hGetBlocks' 'stdin' getBlocks :: BinaryConvertible b => Int -> IO [[b]] getBlocks = hGetBlocks stdin {- | Same as 'hGetBlocks', but using 'hFullGetBufStr' underneath. -} hFullGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]] hFullGetBlocks = hGetBlocksUtil hFullGetBufStr -- | An alias for 'hFullGetBlocks' 'stdin' fullGetBlocks :: BinaryConvertible b => Int -> IO [[b]] fullGetBlocks = hFullGetBlocks stdin hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]] hGetBlocksUtil readfunc h count = unsafeInterleaveIO $ do block <- readfunc h count if block == [] then return [] else do remainder <- hGetBlocksUtil readfunc h count return (block : remainder) {- | Binary block-based interaction. This is useful for scenarios that take binary blocks, manipulate them in some way, and then write them out. Take a look at 'hBlockCopy' for an example. The integer argument is the size of input binary blocks. This function uses 'hGetBlocks' internally. -} hBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hBlockInteract = hBlockInteractUtil hGetBlocks -- | An alias for 'hBlockInteract' over 'stdin' and 'stdout' blockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO () blockInteract x = hBlockInteract x stdin stdout {- | Same as 'hBlockInteract', but uses 'hFullGetBlocks' instead of 'hGetBlocks' internally. -} hFullBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hFullBlockInteract = hBlockInteractUtil hFullGetBlocks -- | An alias for 'hFullBlockInteract' over 'stdin' and 'stdout' fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO () fullBlockInteract x = hFullBlockInteract x stdin stdout hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => (a -> Int -> IO [[b]]) -> Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hBlockInteractUtil blockreader blocksize hin hout func = do blocks <- blockreader hin blocksize hPutBlocks hout (func blocks) {- | Copies everything from the input handle to the output handle using binary blocks of the given size. This was once the following beautiful implementation: > hBlockCopy bs hin hout = hBlockInteract bs hin hout id ('id' is the built-in Haskell function that just returns whatever is given to it) In more recent versions of MissingH, it uses a more optimized routine that avoids ever having to convert the binary buffer at all. -} hBlockCopy :: (HVIO a, HVIO b) => Int -> a -> b -> IO () hBlockCopy bs hin hout = do (fbuf::ForeignPtr CChar) <- mallocForeignPtrArray (bs + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- vGetBuf hin ptr bs if bytesread > 0 then do vPutBuf hout ptr bytesread handler ptr else return () {- | Copies from 'stdin' to 'stdout' using binary blocks of the given size. An alias for 'hBlockCopy' over 'stdin' and 'stdout' -} blockCopy :: Int -> IO () blockCopy bs = hBlockCopy bs stdin stdout {- | Copies one filename to another in binary mode. Please note that the Unix permission bits on the output file cannot be set due to a limitation of the Haskell 'System.IO.openBinaryFile' function. Therefore, you may need to adjust those bits after the copy yourself. This function is implemented using 'hBlockCopy' internally. -} copyFileBlocksToFile :: Int -> FilePath -> FilePath -> IO () copyFileBlocksToFile bs infn outfn = do hin <- openBinaryFile infn ReadMode hout <- openBinaryFile outfn WriteMode hBlockCopy bs hin hout hClose hin hClose hout return () {- | Like the built-in 'readFile', but opens the file in binary instead of text mode. -} readBinaryFile :: FilePath -> IO String readBinaryFile = vReadBinaryFile SystemFS {- | Same as 'readBinaryFile', but works with HVFS objects. -} vReadBinaryFile :: (HVFSOpenable a) => a -> FilePath -> IO String vReadBinaryFile fs fp = vOpenBinaryFile fs fp ReadMode >>= (\(HVFSOpenEncap h) -> vGetContents h) {- | Like the built-in 'writeFile', but opens the file in binary instead of text mode. -} writeBinaryFile :: FilePath -> String -> IO () writeBinaryFile = vWriteBinaryFile SystemFS {- | Like 'writeBinaryFile', but works on HVFS objects. -} vWriteBinaryFile :: (HVFSOpenable a) => a -> FilePath -> String -> IO () vWriteBinaryFile fs name str = do h <- vOpenBinaryFile fs name WriteMode case h of HVFSOpenEncap x -> do vPutStr x str vClose x MissingH-1.2.0.0/src/System/IO/Utils.hs0000644000175000017500000001650012027213047017637 0ustar jgoerzenjgoerzen{- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable -} module System.IO.Utils(-- * Entire File Handle Utilities -- ** Opened Handle Data Copying hCopy, hCopyProgress, hLineCopy, lineCopy, -- ** Disk File Data Copying copyFileLinesToFile, -- * Line Processing Utilities hPutStrLns, hGetLines, -- * Lazy Interaction -- ** Character-based hInteract, -- ** Line-based hLineInteract, lineInteract, -- ** Misc. Lazy lazyMapM, -- * Optimizations optimizeForBatch, optimizeForInteraction ) where import System.IO.Unsafe (unsafeInterleaveIO) import System.IO import Data.List (genericLength) import System.IO.HVIO {- | Given a list of strings, output a line containing each item, adding newlines as appropriate. The list is not expected to have newlines already. -} hPutStrLns :: HVIO a => a -> [String] -> IO () hPutStrLns h = mapM_ $ vPutStrLn h {- | Given a handle, returns a list of all the lines in that handle. Thanks to lazy evaluation, this list does not have to be read all at once. Combined with 'hPutStrLns', this can make a powerful way to develop filters. See the 'lineInteract' function for more on that concept. Example: > main = do > l <- hGetLines stdin > hPutStrLns stdout $ filter (startswith "1") l -} -- FIXME: does hGetContents h >>= return . lines not work? hGetLines :: HVIO a => a -> IO [String] hGetLines h = unsafeInterleaveIO (do ieof <- vIsEOF h if (ieof) then return [] else do line <- vGetLine h remainder <- hGetLines h return (line : remainder)) {- | This is similar to the built-in 'System.IO.interact', but works on any handle, not just stdin and stdout. In other words: > interact = hInteract stdin stdout -} hInteract :: (HVIO a, HVIO b) => a -> b -> (String -> String) -> IO () hInteract finput foutput func = do content <- vGetContents finput vPutStr foutput (func content) {- | Line-based interaction. This is similar to wrapping your interact functions with 'lines' and 'unlines'. This equality holds: > lineInteract = hLineInteract stdin stdout Here's an example: > main = lineInteract (filter (startswith "1")) This will act as a simple version of grep -- all lines that start with 1 will be displayed; all others will be ignored. -} lineInteract :: ([String] -> [String]) -> IO () lineInteract = hLineInteract stdin stdout {- | Line-based interaction over arbitrary handles. This is similar to wrapping hInteract with 'lines' and 'unlines'. One could view this function like this: > hLineInteract finput foutput func = > let newf = unlines . func . lines in > hInteract finput foutput newf Though the actual implementation is this for efficiency: > hLineInteract finput foutput func = > do > lines <- hGetLines finput > hPutStrLns foutput (func lines) -} hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO () hLineInteract finput foutput func = do lines <- hGetLines finput hPutStrLns foutput (func lines) {- | Copies from one handle to another in raw mode (using hGetContents). -} hCopy :: (HVIO a, HVIO b) => a -> b -> IO () hCopy hin hout = do c <- vGetContents hin vPutStr hout c {- | Copies from one handle to another in raw mode (using hGetContents). Takes a function to provide progress updates to the user. -} hCopyProgress :: (HVIO b, HVIO c, Integral a) => b -- ^ Input handle -> c -- ^ Output handle -> (Maybe a -> Integer -> Bool -> IO ()) -- ^ Progress function -- the bool is always False unless this is the final call -> Int -- Block size -> Maybe a -- Estimated file size (passed to func) -> IO Integer -- Number of bytes copied hCopyProgress hin hout func bsize estsize = let copyFunc :: String -> Integer -> IO Integer copyFunc [] count = return count copyFunc indata count = let block = take bsize indata remainder = drop bsize indata newcount = count + (genericLength block) in do vPutStr hout block func estsize count False copyFunc remainder newcount in do c <- vGetContents hin bytes <- copyFunc c 0 func estsize bytes True return bytes {- | Copies from one handle to another in text mode (with lines). Like 'hBlockCopy', this implementation is nice: > hLineCopy hin hout = hLineInteract hin hout id -} hLineCopy :: (HVIO a, HVIO b) => a -> b -> IO() hLineCopy hin hout = hLineInteract hin hout id {- | Copies from 'stdin' to 'stdout' using lines. An alias for 'hLineCopy' over 'stdin' and 'stdout'. -} lineCopy :: IO () lineCopy = hLineCopy stdin stdout {- | Copies one filename to another in text mode. Please note that the Unix permission bits are set at a default; you may need to adjust them after the copy yourself. This function is implemented using 'hLineCopy' internally. -} copyFileLinesToFile :: FilePath -> FilePath -> IO () copyFileLinesToFile infn outfn = do hin <- openFile infn ReadMode hout <- openFile outfn WriteMode hLineCopy hin hout hClose hin hClose hout return () {- | Sets stdin and stdout to be block-buffered. This can save a huge amount of system resources since far fewer syscalls are made, and can make programs run much faster. -} optimizeForBatch :: IO () optimizeForBatch = do hSetBuffering stdin (BlockBuffering (Just 4096)) hSetBuffering stdout (BlockBuffering (Just 4096)) {- | Sets stdin and stdout to be line-buffered. This saves resources on stdout, but not many on stdin, since it it still looking for newlines. -} optimizeForInteraction :: IO () optimizeForInteraction = do hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering {- | Applies a given function to every item in a list, and returns the new list. Unlike the system\'s mapM, items are evaluated lazily. -} lazyMapM :: (a -> IO b) -> [a] -> IO [b] lazyMapM _ [] = return [] lazyMapM conv (x:xs) = do this <- conv x next <- unsafeInterleaveIO $ lazyMapM conv xs return (this:next) MissingH-1.2.0.0/src/System/IO/StatCompat.hs0000644000175000017500000000426212027213047020620 0ustar jgoerzenjgoerzen{-# LANGUAGE CPP #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.StatCompat Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Provide a stat-like structure for use in MissingH. Especially useful with HVFS and on Windows. See also "System.IO.WindowsCompat". -} module System.IO.StatCompat where import System.Posix.Types import System.Posix.Consts #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Files(intersectFileModes) #endif import Data.Bits ((.&.)) #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) type LinkCount = Int type UserID = Int type GroupID = Int #endif data FileStatusCompat = FileStatusCompat {deviceID :: DeviceID, fileID :: FileID, fileMode :: FileMode, linkCount :: LinkCount, fileOwner :: UserID, fileGroup :: GroupID, specialDeviceID :: DeviceID, fileSize :: FileOffset, accessTime :: EpochTime, modificationTime :: EpochTime, statusChangeTime :: EpochTime } sc_helper :: FileMode -> FileStatusCompat -> Bool sc_helper comp stat = (fileMode stat `intersectFileModes` fileTypeModes) == comp isBlockDevice,isCharacterDevice,isNamedPipe,isRegularFile,isDirectory,isSymbolicLink,isSocket :: FileStatusCompat -> Bool isBlockDevice = sc_helper blockSpecialMode isCharacterDevice = sc_helper characterSpecialMode isNamedPipe = sc_helper namedPipeMode isRegularFile = sc_helper regularFileMode 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 MissingH-1.2.0.0/src/System/Debian/0000755000175000017500000000000012027213047017054 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/System/Debian/ControlParser.hs0000644000175000017500000000524312027213047022211 0ustar jgoerzenjgoerzen{- arch-tag: Parser for Debian control file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Debian.ControlParser Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with Debian files and programs. Written by John Goerzen, jgoerzen\@complete.org -} module System.Debian.ControlParser(control, depPart) where import Text.ParserCombinators.Parsec import Data.String.Utils (split) eol, extline :: GenParser Char st String eol = (try (string "\r\n")) <|> string "\n" "EOL" extline = try (do char ' ' content <- many (noneOf "\r\n") eol return content ) entry :: GenParser Char st (String, String) entry = do key <- many1 (noneOf ":\r\n") char ':' val <- many (noneOf "\r\n") eol exts <- many extline return (key, unlines ([val] ++ exts)) {- | Main parser for the control file -} control :: CharParser a [(String, String)] 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 return () blankLine = do many (oneOf " \t") eol return () headerHash = do string "Hash: " manyTill (noneOf "\r\n") eol return () header = (try headerPGP) <|> (try blankLine) <|> (try headerHash) {- | Dependency parser. Returns (package name, Maybe version, arch list) version is (operator, operand) -} depPart :: CharParser a (String, (Maybe (String, String)), [String]) depPart = do packagename <- many1 (noneOf " (") many (char ' ') version <- (do char '(' op <- many1 (oneOf "<>=") many (char ' ') vers <- many1 (noneOf ") ") many (char ' ') char ')' return $ Just (op, vers) ) <|> return Nothing many (char ' ') archs <- (do char '[' t <- many1 (noneOf "]") many (char ' ') char ']' return (split " " t) ) <|> return [] return (packagename, version, archs) MissingH-1.2.0.0/src/Data/0000755000175000017500000000000012027213047015257 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Compression/0000755000175000017500000000000012027213047017560 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Compression/Inflate.hs0000644000175000017500000002751412027213047021507 0ustar jgoerzenjgoerzen-- arch-tag: Inflate implementation for Haskell {- Inflate implementation for Haskell Copyright 2004 Ian Lynagh Licence: 3 clause BSD. \section{Inflate} This module provides a Haskell implementation of the inflate function, as described by RFC 1951. -} {- | Module : Data.Compression.Inflate Copyright : Copyright (C) 2004 Ian Lynagh License : 3-clause BSD Maintainer : Ian Lynagh, Maintainer : Stability : provisional Portability: portable Inflate algorithm implementation Copyright (C) 2004 Ian Lynagh -} module Data.Compression.Inflate (inflate_string, inflate_string_remainder, inflate, Output, Bit, bits_to_word32) where import Data.Array import Data.List import Data.Maybe import qualified Data.Char import Control.Monad import Data.Bits import Data.Word inflate_string :: String -> String inflate_string = fst . inflate_string_remainder -- map (Data.Char.chr . fromIntegral) $ fst $ inflate $ map Data.Char.ord s -- | Returns (Data, Remainder) inflate_string_remainder :: String -> (String, String) inflate_string_remainder s = let res = inflate $ map Data.Char.ord s convw32l l = map (Data.Char.chr . fromIntegral) l output = convw32l $ fst res b2w32 [] = [] b2w32 b = let (this, next) = splitAt 8 b in bits_to_word32 this : b2w32 next remainder = convw32l $ b2w32 $ snd res in (output, remainder) {- \section{Types} Type synonyms are your friend. -} type Output = [Word32] -- The final output type Code = Word32 -- A generic code type Dist = Code -- A distance code type LitLen = Code -- A literal/length code type Length = Word32 -- Number of bits needed to identify a code type Table = InfM Code -- A Huffman table type Tables = (Table, Table) -- lit/len and dist Huffman tables {- The \verb!Bit! datatype is used for the input. We can show values and convert from the input we are given and to \verb!Word32!s which we us to represent most values. -} newtype Bit = Bit Bool deriving Eq instance Show Bit where show = (\x -> [x]) . show_b showList bs = showString $ "'" ++ map show_b bs ++ "'" show_b :: Bit -> Char show_b (Bit True) = '1' show_b (Bit False) = '0' int_to_bits :: Int -> [Bit] int_to_bits = word8_to_bits . fromIntegral word8_to_bits :: Word8 -> [Bit] word8_to_bits n = map (\i -> Bit (testBit n i)) [0..7] bits_to_word32 :: [Bit] -> Word32 bits_to_word32 = foldr (\(Bit b) i -> 2 * i + (if b then 1 else 0)) 0 {- \section{Monad} 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 history :: Array Word32 Word32, -- last 32768 output words loc :: Word32 -- where in history we are } data InfM a = InfM (State -> (a, State)) instance Monad InfM where -- (>>=) :: InfM a -> (a -> InfM b) -> InfM b InfM v >>= f = InfM $ \s -> let (x, s') = v s InfM y = f x in y s' -- return :: a -> InfM a return x = InfM $ \s -> (x, s) set_bits :: [Bit] -> InfM () set_bits bs = InfM $ const ((), State bs 0 (array (0, 32767) []) 0) {- no_bits :: InfM Bool no_bits = InfM $ \s -> (null (bits s), s) -} align_8_bits :: InfM () align_8_bits = InfM $ \s -> ((), s { bits = genericDrop ((8 - offset s) `mod` 8) (bits s), offset = 0 }) get_bits :: Word32 -> InfM [Bit] get_bits n = InfM $ \s -> case need n (bits s) of (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!" need i (x:xs) = let (ys, zs) = need (i-1) xs in (x:ys, zs) extract_InfM :: InfM a -> (a, [Bit]) extract_InfM (InfM f) = let (x, s) = f undefined in (x, bits s) output_w32 :: Word32 -> InfM () output_w32 w = InfM $ \s -> let l = loc s in ((), s { history = history s // [(l, w)], loc = l + 1 }) repeat_w32s :: Word32 -> Word32 -> InfM [Word32] repeat_w32s len dist = InfM $ \s -> let l = loc s h = history s new = map (h!) $ genericTake dist ([(l - dist) `mod` 32768..32767] ++ [0..]) new_bit = genericTake len (cycle new) h' = h // zip (map (`mod` 32768) [l..]) new_bit in (new_bit, s { history = h', loc = (l + len) `mod` 32768 }) ----------------------------------- get_word32s :: Word32 -> Word32 -> InfM [Word32] get_word32s _ 0 = return [] get_word32s b n = do w <- get_w32 b ws <- get_word32s b (n-1) return (w:ws) get_w32 :: Word32 -> InfM Word32 get_w32 i = do bs <- get_bits i return (bits_to_word32 bs) get_bit :: InfM Bit get_bit = do [x] <- get_bits 1 return x {- \section{Inflate itself} The hardcore stuff! -} inflate :: [Int] -> (Output, [Bit]) inflate is = extract_InfM $ do set_bits $ concatMap int_to_bits is x <- inflate_blocks False align_8_bits return x -- Bool is true if we have seen the "last" block 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") inflate_tables :: InfM Tables inflate_tables = do hlit <- get_w32 5 hdist <- get_w32 5 hclen <- get_w32 4 llc_bs <- get_bits ((hclen + 4) * 3) let llc_bs' = zip (map bits_to_word32 $ triple llc_bs) [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15] tab = make_table llc_bs' lit_dist_lengths <- make_lit_dist_lengths tab (258 + hlit + hdist) (error "inflate_tables dummy") let (lit_lengths, dist_lengths) = genericSplitAt (257 + hlit) lit_dist_lengths lit_table = make_table (zip lit_lengths [0..]) dist_table = make_table (zip dist_lengths [0..]) return (lit_table, dist_table) triple :: [a] -> [[a]] triple (a:b:c:xs) = [a,b,c]:triple xs 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" make_lit_dist_lengths _ 0 _ = return [] make_lit_dist_lengths tab i last_thing = do c <- tab (ls, i', last_thing') <- meta_code i c last_thing ws <- make_lit_dist_lengths tab i' last_thing' return (ls ++ ws) meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32) meta_code c i _ | i < 16 = return ([i], c - 1, i) meta_code c 16 last_thing = do xs <- get_bits 2 let l = 3 + bits_to_word32 xs return (genericReplicate l last_thing, c - l, last_thing) meta_code c 17 _ = do xs <- get_bits 3 let l = 3 + bits_to_word32 xs return (genericReplicate l 0, c - l, 0) meta_code c 18 _ = do xs <- get_bits 7 let l = 11 + bits_to_word32 xs return (genericReplicate l 0, c - l, 0) meta_code _ i _ = error $ "meta_code: " ++ show i inflate_codes :: Bool -> Tables -> InfM Output inflate_codes seen_last tabs@(tab_litlen, tab_dist) = {- do done <- no_bits if done then return [] -- XXX Is this right? else -} do i <- tab_litlen; if i == 256 then inflate_blocks seen_last else do pref <- if i < 256 then do output_w32 i return [i] else case lookup i litlens of Nothing -> error "do_code_litlen" Just (base, num_bits) -> do extra <- get_w32 num_bits let l = base + extra dist <- dist_code tab_dist repeat_w32s l dist o <- inflate_codes seen_last tabs return (pref ++ o) litlens :: [(Code, (LitLen, Word32))] litlens = zip [257..285] $ mk_bases 3 litlen_counts ++ [(258, 0)] where litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5)] dist_code :: Table -> InfM Dist dist_code tab = do code <- tab case lookup code dists of Nothing -> error "dist_code" Just (base, num_bits) -> do extra <- get_w32 num_bits return (base + extra) dists :: [(Code, (Dist, Word32))] dists = zip [0..29] $ mk_bases 1 dist_counts where dist_counts = (4,0):map ((,) 2) [1..13] mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)] mk_bases base counts = snd $ mapAccumL next_base base incs where next_base current bs = (current + 2^bs, (current, bs)) incs = concat $ map (uncurry replicate) counts {- \section{Fixed tables} The fixed tables. Not much to say really. -} inflate_trees_fixed :: Tables inflate_trees_fixed = (make_table $ [(8, c) | c <- [0..143]] ++ [(9, c) | c <- [144..255]] ++ [(7, c) | c <- [256..279]] ++ [(8, c) | c <- [280..287]], make_table [(5, c) | c <- [0..29]]) {- \section{The Huffman Tree} As the name suggests, the obvious way to store Huffman trees is in a tree datastructure. Externally we want to view them as functions though, so we wrap the tree with \verb!get_code! which takes a list of bits and returns the corresponding code and the remaining bits. To make a tree from a list of length code pairs is a simple recursive process. -} data Tree = Branch Tree Tree | Leaf Word32 | Null 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" get_code :: Tree -> InfM Code get_code (Branch zero_tree one_tree) = do Bit b <- get_bit if b then get_code one_tree else get_code zero_tree get_code (Leaf w) = return w get_code Null = error "get_code Null" make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)]) make_tree _ [] = (Null, []) make_tree i lcs@((l, c):lcs') | i == l = (Leaf c, lcs') | i < l = let (zero_tree, lcs_z) = make_tree (i+1) lcs (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" MissingH-1.2.0.0/src/Data/Quantity.hs0000644000175000017500000002042612027213047017435 0ustar jgoerzenjgoerzen{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Quantity Copyright : Copyright (C) 2006-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Tools for rendering sizes Written by John Goerzen, jgoerzen\@complete.org -} module Data.Quantity ( renderNum, renderNums, parseNum, parseNumInt, quantifyNum, quantifyNums, SizeOpts(..), binaryOpts, siOpts ) where import Data.List import Text.Printf import Data.Char {- | 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 firstPower :: Int, -- ^ The first power for which suffixes are given suffixes :: String -- ^ The suffixes themselves } {- | Predefined definitions for byte measurement in groups of 1024, from 0 to 2**80 -} binaryOpts :: SizeOpts binaryOpts = SizeOpts {base = 2, firstPower = 0, suffixes = " KMGTPEZY", powerIncr = 10} {- | Predefined definitions for SI measurement, from 10**-24 to 10**24. -} siOpts :: SizeOpts siOpts = SizeOpts {base = 10, firstPower = -24, suffixes = "yzafpnum kMGTPEZY", powerIncr = 3} {- | Takes a number and returns a new (quantity, suffix) combination. The space character is used as the suffix for items around 0. -} quantifyNum :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> a -> (b, Char) quantifyNum opts n = (\(x, s) -> (head x, s)) $ quantifyNums opts [n] {- | Like 'quantifyNum', but takes a list of numbers. The first number in the list will be evaluated for the suffix. The same suffix and scale will be used for the remaining items in the list. Please see 'renderNums' for an example of how this works. It is invalid to use this function on an empty list. -} quantifyNums :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> [a] -> ([b], Char) quantifyNums _ [] = error "Attempt to use quantifyNums on an empty list" quantifyNums opts (headnum:xs) = (map (\n -> procnum n) (headnum:xs), suffix) where number = case fromRational . toRational $ headnum of 0 -> 1 x -> x 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) <= (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, -- that's fine; we'll just write it in terms of what we have. (usedexp, expidx) = case find finderfunc (reverse incrIdxList) of 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) / ((fromIntegral (base opts) ** (fromIntegral usedexp))) --(posres, possuf) = quantifyNum opts (headnum * (-1)) {- | Render a number into a string, based on the given quantities. This is useful for displaying quantities in terms of bytes or in SI units. Give this function the 'SizeOpts' for the desired output, and a precision (number of digits to the right of the decimal point), and you get a string output. Here are some examples: > Data.Quantity> renderNum binaryOpts 0 1048576 > "1M" > Data.Quantity> renderNum binaryOpts 2 10485760 > "10.00M" > Data.Quantity> renderNum binaryOpts 3 1048576 > "1.000M" > Data.Quantity> renderNum binaryOpts 3 1500000 > "1.431M" > Data.Quantity> renderNum binaryOpts 2 (1500 ** 3) > "3.14G" > Data.Quantity> renderNum siOpts 2 1024 > "1.02k" > Data.Quantity> renderNum siOpts 2 1048576 > "1.05M" > Data.Quantity> renderNum siOpts 2 0.001 > "1.00m" > Data.Quantity> renderNum siOpts 2 0.0001 > "100.00u" If you want more control over the output, see 'quantifyNum'. -} renderNum :: (Ord a, Real a) => SizeOpts -> Int -- ^ Precision of the result -> a -- ^ The number to examine -> String renderNum opts prec number = (printf ("%." ++ show prec ++ "g") num) ++ [suffix] where (num, suffix) = (quantifyNum opts number)::(Double, Char) {- | Like 'renderNum', but operates on a list of numbers. The first number in the list will be evaluated for the suffix. The same suffix and scale will be used for the remaining items in the list. See 'renderNum' for more examples. Also, unlike 'renderNum', the %f instead of %g printf format is used so that \"scientific\" notation is avoided in the output. Examples: > *Data.Quantity> renderNums binaryOpts 3 [1500000, 10240, 104857600] > ["1.431M","0.010M","100.000M"] > *Data.Quantity> renderNums binaryOpts 3 [1500, 10240, 104857600] > ["1.465K","10.000K","102400.000K"] -} renderNums :: (Ord a, Real a) => SizeOpts -> Int -- ^ Prevision of the result -> [a] -- ^ The numbers to examine -> [String] -- ^ Result renderNums opts prec numbers = map printit convnums where printit num = (printf ("%." ++ show prec ++ "f") num) ++ [suffix] (convnums, suffix) = (quantifyNums opts numbers)::([Double], Char) {- | Parses a String, possibly generated by 'renderNum'. Parses the suffix and applies it to the number, which is read via the Read class. Returns Left "error message" on error, or Right number on successful parse. If you want an Integral result, the convenience function 'parseNumInt' is for you. -} 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 -> Either String a parseNum opts insensitive inp = case reads inp of [] -> Left "Couldn't parse numeric component of input" [(num, "")] -> Right num -- No suffix; pass number unhindered [(num, [suffix])] -> case lookup (caseTransformer suffix) suffixMap of 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) (iterate (+ (powerIncr opts)) (firstPower opts)) caseTransformer x | insensitive = toLower x | otherwise = x multiplier :: (Read a, Fractional a) => Int -> a multiplier power = 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 result type. This function simply calls 'round' on the result of 'parseNum'. A 'Double' is used internally for the parsing of the numeric component. By using this function, a user can still say something like 1.5M and get an integral result. -} 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 Right n -> Right (round n)MissingH-1.2.0.0/src/Data/List/0000755000175000017500000000000012027213047016172 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/List/Utils.hs0000644000175000017500000003575012027213047017640 0ustar jgoerzenjgoerzen{- arch-tag: List utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.List.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with lists. Written by John Goerzen, jgoerzen\@complete.org -} module Data.List.Utils(-- * Merging merge, mergeBy, -- * Tests startswith, endswith, contains, hasAny, -- * Association List Utilities {- | These functions are designed to augment the association list functions in "Data.List" and provide an interface similar to "Data.FiniteMap" or "Data.Map" for association lists. -} addToAL, delFromAL, flipAL, keysAL, valuesAL, hasKeyAL, -- ** Association List Conversions strFromAL, strToAL, -- * Conversions split, join, replace, genericJoin, takeWhileList, dropWhileList, spanList, breakList, -- ** Advanced Conversions WholeFunc(..), wholeMap, fixedWidth, -- * Fixed-Width and State Monad Utilities grab, -- * Miscellaneous countElem, elemRIndex, alwaysElemRIndex, seqList, subIndex, uniq -- -- * 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) {- | Merge two sorted lists into a single, sorted whole. Example: > merge [1,3,5] [1,2,4,6] -> [1,1,2,3,4,5,6] QuickCheck test property: prop_merge xs ys = merge (sort xs) (sort ys) == sort (xs ++ ys) where types = xs :: [Int] -} merge :: (Ord a) => [a] -> [a] -> [a] merge = mergeBy (compare) {- | Merge two sorted lists using into a single, sorted whole, allowing the programmer to specify the comparison function. QuickCheck test property: prop_mergeBy xs ys = mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys) where types = xs :: [ (Int, Int) ] 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)) -- 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. | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally | 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".) Example: > startswith "He" "Hello" -> True -} startswith :: Eq a => [a] -> [a] -> Bool startswith = isPrefixOf {- | Returns true if the given list ends with the specified elements; false otherwise. (This is an alias for "Data.List.isSuffixOf".) Example: > endswith "lo" "Hello" -> True -} endswith :: Eq a => [a] -> [a] -> Bool endswith = isSuffixOf {- | Returns true if the given list contains any of the elements in the search list. -} 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 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. 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 then x : takeWhileList func xs else [] {- | 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) = 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. @spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ -} spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) spanList _ [] = ([],[]) spanList func list@(x:xs) = if func list then (x:ys,zs) else ([],list) where (ys,zs) = spanList func xs {- | 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]) breakList func = spanList (not . func) {- | Given a delimiter and a list (or string), split into components. Example: > split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""] > split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"] -} split :: Eq a => [a] -> [a] -> [[a]] split _ [] = [] split delim str = let (firstline, remainder) = breakList (startswith delim) str in firstline : case remainder of [] -> [] x -> if x == delim then [] : [] else split delim (drop (length delim) x) {- | Given a list and a replacement list, replaces each occurance of the search list with the replacement list in the operation list. Example: >replace "," "." "127,0,0,1" -> "127.0.0.1" This could logically be thought of as: >replace old new l = join new . split old $ l -} replace :: Eq a => [a] -> [a] -> [a] -> [a] 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. Example: > join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" -} join :: [a] -> [[a]] -> [a] join delim l = concat (intersperse delim l) {- | Like 'join', but works with a list of anything showable, converting it to a String. Examples: > genericJoin ", " [1, 2, 3, 4] -> "1, 2, 3, 4" > genericJoin "|" ["foo", "bar", "baz"] -> "\"foo\"|\"bar\"|\"baz\"" -} 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. 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 contains = isInfixOf -- above function submitted to GHC as Data.List.isInfixOf on 8/31/2006 {- | Adds the specified (key, value) pair to the given list, removing any existing pair with the same key already present. -} addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)] addToAL l key value = (key, value) : delFromAL l key {- | Removes all (key, value) pairs from the given list where the key matches the given one. -} delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)] delFromAL l key = filter (\a -> (fst a) /= key) l {- | Returns the keys that comprise the (key, value) pairs of the given AL. Same as: >map fst -} keysAL :: [(key, a)] -> [key] keysAL = map fst {- | Returns the values the comprise the (key, value) pairs of the given AL. Same as: >map snd -} valuesAL :: [(a, value)] -> [value] valuesAL = map snd {- | Indicates whether or not the given key is in the AL. -} hasKeyAL :: Eq a => a -> [(a, b)] -> Bool hasKeyAL key list = elem key (keysAL list) {- | Flips an association list. Converts (key1, val), (key2, val) pairs to (val, [key1, key2]). -} flipAL :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])] flipAL oldl = let worker :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])] -> [(val, [key])] worker [] accum = accum 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)) in worker oldl [] {- | Converts an association list to a string. The string will have one pair per line, with the key and value both represented as a Haskell string. This function is designed to work with [(String, String)] association lists, but may work with other types as well. -} strFromAL :: (Show a, Show b) => [(a, b)] -> String strFromAL inp = let worker (key, val) = show key ++ "," ++ show val in unlines . map worker $ inp {- | The inverse of 'strFromAL', this function reads a string and outputs the 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 = let worker line = case reads line of [(key, remainder)] -> case remainder of ',':valstr -> (key, read valstr) _ -> error "Data.List.Utils.strToAL: Parse error on value" _ -> error "Data.List.Utils.strToAL: Parse error on key" in map worker (lines inp) {- FIXME TODO: sub -} {- | Returns a count of the number of times the given element occured in the given list. -} countElem :: Eq a => a -> [a] -> Int countElem i = length . filter (i==) {- | Returns the rightmost index of the given element in the given list. -} elemRIndex :: Eq a => a -> [a] -> Maybe Int elemRIndex item l = case reverse $ elemIndices item l of [] -> Nothing (x:_) -> Just x {- | Like elemRIndex, but returns -1 if there is nothing found. -} alwaysElemRIndex :: Eq a => a -> [a] -> Int alwaysElemRIndex item list = case elemRIndex item list of Nothing -> -1 Just x -> x {- | Forces the evaluation of the entire list. -} seqList :: [a] -> [a] seqList [] = [] seqList list@(x:xs) = seq (seqList xs) list -------------------------------------------------- -- Advanced Conversions -------------------------------------------------- {- | The type used for functions for 'wholeMap'. See 'wholeMap' for details. -} newtype WholeFunc a b = WholeFunc ([a] -> (WholeFunc a b, [a], [b])) {- | This is an enhanced version of the concatMap or map functions in Data.List. Unlike those functions, this one: * Can consume a varying number of elements from the input list during each iteration * Can arbitrarily decide when to stop processing data * Can return a varying number of elements to insert into the output list * Can actually switch processing functions mid-stream * Is not even restricted to processing the input list intact The function used by wholeMap, of type 'WholeFunc', is repeatedly called with the input list. The function returns three things: the function to call for the next iteration (if any), what remains of the input list, and the list of output elements generated during this iteration. The return value of 'wholeMap' is the concatenation of the output element lists from all iterations. Processing stops when the remaining input list is empty. An example of a 'WholeFunc' is 'fixedWidth'. -} wholeMap :: WholeFunc a b -> [a] -> [b] wholeMap _ [] = [] -- Empty input, empty output. wholeMap (WholeFunc func) inplist = let (nextfunc, nextlist, output) = func inplist in output ++ wholeMap nextfunc nextlist {- | A parser designed to process fixed-width input fields. Use it with 'wholeMap'. The Int list passed to this function is the list of the field widths desired from the input. The result is a list of those widths, if possible. If any of the input remains after processing this list, it is added on as the final element in the result list. If the input is less than the sum of the requested widths, then the result list will be short the appropriate number of elements, and its final element may be shorter than requested. Examples: >wholeMap (fixedWidth [1, 2, 3]) "1234567890" > --> ["1","23","456","7890"] >wholeMap (fixedWidth (repeat 2)) "123456789" > --> ["12","34","56","78","9"] >wholeMap (fixedWidth []) "123456789" > --> ["123456789"] >wholeMap (fixedWidth [5, 3, 6, 1]) "Hello, This is a test." > --> ["Hello",", T","his is"," ","a test."] -} fixedWidth :: [Int] -> WholeFunc a [a] fixedWidth len = WholeFunc (fixedWidthFunc len) where -- Empty input: Empty output, stop fixedWidthFunc _ [] = ((fixedWidth []), [], []) -- Empty length: Stop here. fixedWidthFunc [] x = ((fixedWidth []), [], [x]) -- Stuff to process: Do it. fixedWidthFunc (len:lenxs) input = (fixedWidth lenxs, next, [this]) where (this, next) = splitAt len input {- | Helps you pick out fixed-width components from a list. Example: >conv :: String -> (String,String) >conv = runState $ > do f3 <- grab 3 > n2 <- grab 2 > return $ f3 ++ "," ++ n2 > >main = print $ conv "TestIng" Prints: >("Tes,tI","ng") -} grab :: Int -> State [a] [a] grab count = do g <- get (x, g') <- return $ splitAt count g put g' return x {- | Similar to Data.List.elemIndex. Instead of looking for one element in a list, this function looks for the first occurance of a sublist in the list, and returns the index of the first element of that occurance. If there is no such list, returns Nothing. If the list to look for is the empty list, will return Just 0 regardless of the content of the list to search. Examples: >subIndex "foo" "asdfoobar" -> Just 3 >subIndex "foo" [] -> Nothing >subIndex "" [] -> Just 0 >subIndex "" "asdf" -> Just 0 >subIndex "test" "asdftestbartest" -> Just 4 >subIndex [(1::Int), 2] [0, 5, 3, 2, 1, 2, 4] -> Just 4 -} subIndex :: Eq a => [a] -> [a] -> Maybe Int subIndex substr str = findIndex (isPrefixOf substr) (tails str) {- | Given a list, returns a new list with all duplicate elements removed. For example: >uniq "Mississippi" -> "Misp" You should not rely on this function necessarily preserving order, though the current implementation happens to. This function is not compatible with infinite lists. 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] MissingH-1.2.0.0/src/Data/MIME/0000755000175000017500000000000012027213047016006 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/MIME/Types.hs0000644000175000017500000004340412027213047017453 0ustar jgoerzenjgoerzen{- arch-tag: MIME Types main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.MIME.Types Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Utilities for guessing MIME types of files. Written by John Goerzen, jgoerzen\@complete.org -} module Data.MIME.Types (-- * Creating Lookup Objects defaultmtd, readMIMETypes, hReadMIMETypes, readSystemMIMETypes, -- * Basic Access MIMEResults, MIMETypeData(..), guessType, guessExtension, guessAllExtensions ) where import qualified Data.Map as Map import qualified Control.Exception (try, IOException) import Control.Monad import System.IO import System.IO.Error import System.IO.Utils import System.Path import Data.Map.Utils import Data.Char ---------------------------------------------------------------------- -- Basic type declarations ---------------------------------------------------------------------- data MIMETypeData = MIMETypeData { -- | A mapping used to expand common suffixes into equivolent, -- better-parsed versions. For instance, ".tgz" would expand -- into ".tar.gz". suffixMap :: Map.Map String String, -- | A mapping used to determine the encoding of a file. -- This is used, for instance, to map ".gz" to "gzip". encodingsMap :: Map.Map String String, -- | A mapping used to map extensions to MIME types. typesMap :: Map.Map String String, -- | A mapping used to augment the 'typesMap' when non-strict -- lookups are used. commonTypesMap :: Map.Map String String } {- | Return value from guessing a file's type. The first element of the tuple gives the MIME type. It is Nothing if no suitable type could be found. The second element gives the encoding. It is Nothing if there was no particular encoding for the file, or if no encoding could be found. -} type MIMEResults = (Maybe String, -- The MIME type Maybe String -- Encoding ) {- | Read the given mime.types file and add it to an existing object. Returns new object. -} readMIMETypes :: MIMETypeData -- ^ Data to work with -> Bool -- ^ Whether to work on strict data -> FilePath -- ^ File to read -> IO MIMETypeData -- ^ New object readMIMETypes mtd strict fn = do h <- openFile fn ReadMode hReadMIMETypes mtd strict h {- | Load a mime.types file from an already-open handle. -} hReadMIMETypes :: MIMETypeData -- ^ Data to work with -> 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 parseline obj line = let l1 = words line procwords [] = [] procwords (('#':_) :_) = [] procwords (x:xs) = x : procwords xs l2 = procwords l1 in if (length l2) >= 2 then let thetype = head l2 suffixlist = tail l2 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. -} guessType :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ File or URL name to consider -> MIMEResults -- ^ Result of guessing (see 'MIMEResults' for details on interpreting it) guessType mtd strict fn = let mapext (base, ex) = case Map.lookup ex (suffixMap mtd) of Nothing -> (base, ex) Just x -> mapext (splitExt (base ++ x)) checkencodings (base, ex) = case Map.lookup ex (encodingsMap mtd) of Nothing -> (base, ex, Nothing) Just x -> (fst (splitExt base), snd (splitExt base), Just x) (_, ext, enc) = checkencodings . mapext $ splitExt fn typemap = getStrict mtd strict in case Map.lookup ext typemap of Nothing -> (Map.lookup (map toLower ext) typemap, enc) Just x -> (Just x, enc) {- | Guess the extension of a file based on its MIME type. The return value includes the leading dot. Returns Nothing if no extension could be found. In the event that multiple possible extensions are available, one of them will be picked and returned. The logic to select one of these should be considered undefined. -} guessExtension :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ MIME type to consider -> Maybe String -- ^ Result of guessing, or Nothing if no match possible guessExtension mtd strict fn = case guessAllExtensions mtd strict fn of [] -> Nothing (x:_) -> Just x {- | Similar to 'guessExtension', but returns a list of all possible matching extensions, or the empty list if there are no matches. -} guessAllExtensions :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ MIME type to consider -> [String] -- ^ Result of guessing guessAllExtensions mtd strict fn = let mimetype = map toLower fn themap = getStrict mtd strict in flippedLookupM mimetype themap {- | Adds a new type to the data structures, replacing whatever data may exist about it already. That is, it overrides existing information about the given extension, but the same type may occur more than once. -} addType :: MIMETypeData -- ^ Source data -> Bool -- ^ Whether to add to strict data set -> String -- ^ MIME type to add -> String -- ^ Extension to add -> MIMETypeData -- ^ Result of addition addType mtd strict thetype theext = setStrict mtd strict (\m -> Map.insert theext thetype m) {- | Default MIME type data to use -} defaultmtd :: MIMETypeData defaultmtd = MIMETypeData {suffixMap = default_suffix_map, encodingsMap = default_encodings_map, typesMap = default_types_map, commonTypesMap = default_common_types} {- | Read the system's default mime.types files, and add the data contained therein to the passed object, then return the new one. -} readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData readSystemMIMETypes mtd = let tryread :: MIMETypeData -> String -> IO MIMETypeData tryread inputobj filename = do fn <- Control.Exception.try (openFile filename ReadMode) case fn of Left (_ :: Control.Exception.IOException) -> return inputobj Right h -> do x <- hReadMIMETypes inputobj True h hClose h return x in do foldM tryread mtd defaultfilelocations ---------------------------------------------------------------------- -- Internal utilities ---------------------------------------------------------------------- getStrict :: MIMETypeData -> Bool -> Map.Map String String getStrict mtd True = typesMap mtd getStrict mtd False = Map.union (typesMap mtd) (commonTypesMap mtd) setStrict :: MIMETypeData -> Bool -> (Map.Map String String -> Map.Map String String) -> MIMETypeData setStrict mtd True func = mtd{typesMap = func (typesMap mtd)} setStrict mtd False func = mtd{commonTypesMap = func (commonTypesMap mtd)} ---------------------------------------------------------------------- -- Default data structures ---------------------------------------------------------------------- defaultfilelocations :: [String] defaultfilelocations = [ "/etc/mime.types", "/usr/local/etc/httpd/conf/mime.types", "/usr/local/lib/netscape/mime.types", "/usr/local/etc/httpd/conf/mime.types", -- Apache 1.2 "/usr/local/etc/mime.types" -- Apache 1.3 ] default_encodings_map, default_suffix_map, default_types_map, default_common_types :: Map.Map String String default_encodings_map = Map.fromList [ (".Z", "compress"), (".gz", "gzip"), (".bz2", "bzip2") ] default_suffix_map = Map.fromList [ (".tgz", ".tar.gz"), (".tz", ".tar.gz"), (".taz", ".tar.gz") ] default_types_map = Map.fromList [ (".a", "application/octet-stream"), (".ai", "application/postscript"), (".aif", "audio/x-aiff"), (".aifc", "audio/x-aiff"), (".aiff", "audio/x-aiff"), (".au", "audio/basic"), (".avi", "video/x-msvideo"), (".bat", "text/plain"), (".bcpio", "application/x-bcpio"), (".bin", "application/octet-stream"), (".bmp", "image/x-ms-bmp"), (".c", "text/plain"), (".cdf", "application/x-netcdf"), (".cpio", "application/x-cpio"), (".csh", "application/x-csh"), (".css", "text/css"), (".dll", "application/octet-stream"), (".doc", "application/msword"), (".dot", "application/msword"), (".dvi", "application/x-dvi"), (".eml", "message/rfc822"), (".eps", "application/postscript"), (".etx", "text/x-setext"), (".exe", "application/octet-stream"), (".gif", "image/gif"), (".gtar", "application/x-gtar"), (".h", "text/plain"), (".hdf", "application/x-hdf"), (".htm", "text/html"), (".html", "text/html"), (".ief", "image/ief"), (".jpe", "image/jpeg"), (".jpeg", "image/jpeg"), (".jpg", "image/jpeg"), (".js", "application/x-javascript"), (".ksh", "text/plain"), (".latex", "application/x-latex"), (".m1v", "video/mpeg"), (".man", "application/x-troff-man"), (".me", "application/x-troff-me"), (".mht", "message/rfc822"), (".mhtml", "message/rfc822"), (".mif", "application/x-mif"), (".mov", "video/quicktime"), (".movie", "video/x-sgi-movie"), (".mp2", "audio/mpeg"), (".mp3", "audio/mpeg"), (".mpa", "video/mpeg"), (".mpe", "video/mpeg"), (".mpeg", "video/mpeg"), (".mpg", "video/mpeg"), (".ms", "application/x-troff-ms"), (".nc", "application/x-netcdf"), (".nws", "message/rfc822"), (".o", "application/octet-stream"), (".obj", "application/octet-stream"), (".oda", "application/oda"), (".p12", "application/x-pkcs12"), (".p7c", "application/pkcs7-mime"), (".pbm", "image/x-portable-bitmap"), (".pdf", "application/pdf"), (".pfx", "application/x-pkcs12"), (".pgm", "image/x-portable-graymap"), (".pl", "text/plain"), (".png", "image/png"), (".pnm", "image/x-portable-anymap"), (".pot", "application/vnd.ms-powerpoint"), (".ppa", "application/vnd.ms-powerpoint"), (".ppm", "image/x-portable-pixmap"), (".pps", "application/vnd.ms-powerpoint"), (".ppt", "application/vnd.ms-powerpoint"), (".ps", "application/postscript"), (".pwz", "application/vnd.ms-powerpoint"), (".py", "text/x-python"), (".pyc", "application/x-python-code"), (".pyo", "application/x-python-code"), (".qt", "video/quicktime"), (".ra", "audio/x-pn-realaudio"), (".ram", "application/x-pn-realaudio"), (".ras", "image/x-cmu-raster"), (".rdf", "application/xml"), (".rgb", "image/x-rgb"), (".roff", "application/x-troff"), (".rtx", "text/richtext"), (".sgm", "text/x-sgml"), (".sgml", "text/x-sgml"), (".sh", "application/x-sh"), (".shar", "application/x-shar"), (".snd", "audio/basic"), (".so", "application/octet-stream"), (".src", "application/x-wais-source"), (".sv4cpio", "application/x-sv4cpio"), (".sv4crc", "application/x-sv4crc"), (".swf", "application/x-shockwave-flash"), (".t", "application/x-troff"), (".tar", "application/x-tar"), (".tcl", "application/x-tcl"), (".tex", "application/x-tex"), (".texi", "application/x-texinfo"), (".texinfo", "application/x-texinfo"), (".tif", "image/tiff"), (".tiff", "image/tiff"), (".tr", "application/x-troff"), (".tsv", "text/tab-separated-values"), (".txt", "text/plain"), (".ustar", "application/x-ustar"), (".vcf", "text/x-vcard"), (".wav", "audio/x-wav"), (".wiz", "application/msword"), (".xbm", "image/x-xbitmap"), (".xlb", "application/vnd.ms-excel"), (".xls", "application/vnd.ms-excel"), (".xml", "text/xml"), (".xpm", "image/x-xpixmap"), (".xsl", "application/xml"), (".xwd", "image/x-xwindowdump"), (".zip", "application/zip") ] default_common_types = Map.fromList [ (".jpg", "image/jpg"), (".mid", "audio/midi"), (".midi", "audio/midi"), (".pct", "image/pict"), (".pic", "image/pict"), (".pict", "image/pict"), (".rtf", "application/rtf"), (".xul", "text/xul") ] MissingH-1.2.0.0/src/Data/String/0000755000175000017500000000000012027213047016525 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/String/Utils.hs0000644000175000017500000000633712027213047020172 0ustar jgoerzenjgoerzen{- arch-tag: String utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.String.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with strings. Written by John Goerzen, jgoerzen\@complete.org -} module Data.String.Utils (-- * Whitespace Removal strip, lstrip, rstrip, -- * Tests -- | Note: These functions are aliases for functions -- in "Data.List.Utils". startswith, endswith, -- * Conversions -- | Note: Some of these functions are aliases for functions -- in "Data.List.Utils". join, split, splitWs, replace, escapeRe, -- * Reading 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) wschars :: String wschars = " \t\r\n" {- | Removes any whitespace characters that are present at the start or end of a string. Does not alter the internal contents of a string. If no whitespace characters are present at the start or end of a string, returns the original string unmodified. Safe to use on any string. Note that this may differ from some other similar functions from other authors in that: 1. If multiple whitespace characters are present all in a row, they are all removed; 2. If no whitespace characters are present, nothing is done. -} strip :: String -> String strip = lstrip . rstrip -- | Same as 'strip', but applies only to the left side of the string. lstrip :: String -> String lstrip s = case s of [] -> [] (x:xs) -> if elem x wschars then lstrip xs else s -- | Same as 'strip', but applies only to the right side of the string. rstrip :: String -> String rstrip = reverse . lstrip . reverse {- | Splits a string around whitespace. Empty elements in the result list are automatically removed. -} splitWs :: String -> [String] splitWs = filter (\x -> x /= []) . splitRegex (mkRegex "[ \t\n\r\v\f]+") {- | Escape all characters in the input pattern that are not alphanumeric. Does not make special allowances for NULL, which isn't valid in a Haskell regular expression pattern. -} escapeRe :: String -> String escapeRe [] = [] escapeRe (x:xs) -- Chars that we never escape | x `elem` ['\'', '`'] = x : escapeRe xs -- General rules for chars we never escape | isDigit x || (isAscii x && isAlpha x) || x `elem` ['<', '>'] = x : escapeRe xs -- Escape everything else | otherwise = '\\' : x : escapeRe xs -- | Attempts to parse a value from the front of the string. maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads MissingH-1.2.0.0/src/Data/CSV.hs0000644000175000017500000000570212027213047016252 0ustar jgoerzenjgoerzen{- arch-tag: CSV and TSV utilities Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.CSV Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Haskell Parsec parsers for comma-separated value (CSV) files. Written by John Goerzen, jgoerzen\@complete.org -} module Data.CSV (csvFile, genCsvFile) where import Text.ParserCombinators.Parsec import Data.List (intersperse) eol :: forall st. GenParser Char st String eol = (try $ string "\n\r") <|> (try $ string "\r\n") <|> string "\n" <|> string "\r" "End of line" cell :: GenParser Char st String cell = quotedcell <|> many (noneOf ",\n\r") quotedchar :: GenParser Char st Char quotedchar = noneOf "\"" <|> (try $ do string "\"\"" return '"' ) quotedcell :: CharParser st String quotedcell = do char '"' content <- many quotedchar char '"' return content line :: GenParser Char st [String] line = sepBy cell (char ',') {- | Parse a Comma-Separated Value (CSV) file. The return value is a list of 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 from a CSV line that has no cells. Here are some examples: >Input (literal strings) Parses As (Haskell String syntax) >-------------------------------- --------------------------------- >1,2,3 [["1", "2", "3"]] > >l1 [["l1"], ["l2"]] >l2 > > (empty line) [[""]] > >NQ,"Quoted" [["NQ", "Quoted"]] > >NQ,"Embedded""Quote" [["NQ", "Embedded\"Quote"]] To parse a String, you might use: >import Text.ParserCombinators.Parsec >import Data.String.CSV >.... >parse csvFile "" mystring To parse a file, you might instead use: >do result <- parseFromFile csvFile "/path/to/file" Please note that the result of parsing will be of type (Either ParseError [[String]]). A Left result indicates an error. For more details, see the Parsec information. -} csvFile :: CharParser st [[String]] csvFile = endBy line eol {- | Generate CSV data for a file. The resulting string can be written out to disk directly. -} genCsvFile :: [[String]] -> String genCsvFile inp = unlines . map csvline $ inp where csvline :: [String] -> String csvline l = concat . intersperse "," . map csvcells $ l csvcells :: String -> String csvcells "" = "" csvcells c = '"' : convcell c ++ "\"" convcell :: String -> String convcell c = concatMap convchar c convchar '"' = "\"\"" convchar x = [x] MissingH-1.2.0.0/src/Data/Maybe/0000755000175000017500000000000012027213047016314 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Maybe/Utils.hs0000644000175000017500000000163012027213047017750 0ustar jgoerzenjgoerzen{- arch-tag: Maybe utilities Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Maybe.Utils Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Utilities for working with the Either data type -} module Data.Maybe.Utils ( forceMaybe, forceMaybeMsg ) where {- | Pulls a Just value out of a Maybe value. If the Maybe value is Nothing, raises an exception with error. -} forceMaybe :: Maybe a -> a forceMaybe = forceMaybeMsg "forceMaybe: Got Nothing" {- | Like 'forceMaybe', but lets you customize the error message raised if Nothing is supplied. -} forceMaybeMsg :: String -> Maybe a -> a forceMaybeMsg msg Nothing = error msg forceMaybeMsg _ (Just x) = x MissingH-1.2.0.0/src/Data/Progress/0000755000175000017500000000000012027213047017063 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Progress/Meter.hs0000644000175000017500000002142412027213047020476 0ustar jgoerzenjgoerzen{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Progress.Meter Copyright : Copyright (C) 2006-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Tool for maintaining a status bar, supporting multiple simultaneous tasks, as a layer atop "Data.Progress.Tracker". Written by John Goerzen, jgoerzen\@complete.org -} module Data.Progress.Meter (-- * Types ProgressMeter, -- * Creation and Configuration simpleNewMeter, newMeter, setComponents, addComponent, removeComponent, setWidth, -- * Rendering and Output renderMeter, displayMeter, clearMeter, writeMeterString, autoDisplayMeter, killAutoDisplayMeter ) where import Data.Progress.Tracker import Control.Concurrent import Control.Monad (when) import Data.String.Utils (join) import System.Time.Utils (renderSecs) import Data.Quantity (renderNums, binaryOpts) import System.IO import Control.Monad (filterM) {- | The main data type for the progress meter. -} data ProgressMeterR = ProgressMeterR {masterP :: Progress, -- ^ The master 'Progress' object for overall status components :: [Progress], -- ^ Individual component statuses width :: Int, -- ^ Width of the meter unit :: String, -- ^ Units of display renderer :: [Integer] -> [String], -- ^ Function to render numbers autoDisplayers :: [ThreadId] -- ^ Auto-updating display } type ProgressMeter = MVar ProgressMeterR {- | Set up a new status bar using defaults: * The given tracker * Width 80 * Data.Quantity.renderNums binaryOpts 1 * Unit inticator @"B"@ -} simpleNewMeter :: Progress -> IO ProgressMeter simpleNewMeter pt = newMeter pt "B" 80 (renderNums binaryOpts 1) {- | Set up a new status bar. -} newMeter :: Progress -- ^ The top-level 'Progress' -> String -- ^ Unit indicator string -> Int -- ^ Width of the terminal -- usually 80 -> ([Integer] -> [String])-- ^ A function to render sizes -> IO ProgressMeter newMeter tracker u w rfunc = newMVar $ ProgressMeterR {masterP = tracker, components = [], width = w, renderer = rfunc, autoDisplayers = [], unit = u} {- | Adjust the list of components of this 'ProgressMeter'. -} setComponents :: ProgressMeter -> [Progress] -> IO () setComponents meter componentlist = modifyMVar_ meter (\m -> return $ m {components = componentlist}) {- | Add a new component to the list of components. -} addComponent :: ProgressMeter -> Progress -> IO () addComponent meter component = modifyMVar_ meter (\m -> return $ m {components = component : components m}) {- | Remove a component by name. -} removeComponent :: ProgressMeter -> String -> IO () removeComponent meter componentname = modifyMVar_ meter $ \m -> do newc <- filterM (\x -> withStatus x (\y -> return $ trackerName y /= componentname)) (components m) return $ m {components = newc} {- | Adjusts the width of this 'ProgressMeter'. -} setWidth :: ProgressMeter -> Int -> IO () setWidth meter w = modifyMVar_ meter (\m -> return $ m {width = w}) {- | Like renderMeter, but prints it to the screen instead of returning it. This function will output CR, then the meter. Pass stdout as the handle for regular display to the screen. -} displayMeter :: Handle -> ProgressMeter -> IO () displayMeter h r = withMVar r $ \meter -> do s <- renderMeterR meter hPutStr h ("\r" ++ s) hFlush h -- By placing this whole thing under withMVar, we can effectively -- lock the IO and prevent IO from stomping on each other. {- | Clears the meter -- outputs CR, spaces equal to the width - 1, then another CR. Pass stdout as the handle for regular display to the screen. -} clearMeter :: Handle -> ProgressMeter -> IO () clearMeter h pm = withMVar pm $ \m -> do hPutStr h (clearmeterstr m) hFlush h {- | Clears the meter, writes the given string, then restores the meter. The string is assumed to contain a trailing newline. Pass stdout as the handle for regular display to the screen. -} writeMeterString :: Handle -> ProgressMeter -> String -> IO () writeMeterString h pm msg = withMVar pm $ \meter -> do s <- renderMeterR meter hPutStr h (clearmeterstr meter) hPutStr h msg hPutStr h s hFlush h clearmeterstr :: ProgressMeterR -> String clearmeterstr m = "\r" ++ replicate (width m - 1) ' ' ++ "\r" {- | Starts a thread that updates the meter every n seconds by calling the specified function. Note: @displayMeter stdout@ is an ideal function here. Save this threadID and use it later to call 'stopAutoDisplayMeter'. -} autoDisplayMeter :: ProgressMeter -- ^ The meter to display -> Int -- ^ Update interval in seconds -> (ProgressMeter -> IO ()) -- ^ Function to display it -> IO ThreadId -- ^ Resulting thread id autoDisplayMeter pm delay displayfunc = do thread <- forkIO workerthread modifyMVar_ pm (\p -> return $ p {autoDisplayers = thread : autoDisplayers p}) return thread where workerthread = do tid <- myThreadId -- Help fix a race condition so that the above -- modifyMVar can run before a check ever does yield loop tid loop tid = do displayfunc pm threadDelay (delay * 1000000) c <- doIContinue tid when c (loop tid) doIContinue tid = withMVar pm $ \p -> if tid `elem` autoDisplayers p then return True else return False {- | Stops the specified meter from displaying. You should probably call 'clearMeter' after a call to this. -} killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO () killAutoDisplayMeter pm t = modifyMVar_ pm (\p -> return $ p {autoDisplayers = filter (/= t) (autoDisplayers p)}) {- | Render the current status. -} renderMeter :: ProgressMeter -> IO String renderMeter r = withMVar r $ renderMeterR renderMeterR :: ProgressMeterR -> IO String renderMeterR meter = do overallpct <- renderpct $ masterP meter compnnts <- mapM (rendercomponent $ renderer meter) (components meter) let componentstr = case join " " compnnts of [] -> "" x -> x ++ " " rightpart <- renderoverall (renderer meter) (masterP meter) let leftpart = overallpct ++ " " ++ componentstr let padwidth = (width meter) - 1 - (length leftpart) - (length rightpart) if padwidth < 1 then return $ take (width meter - 1) $ leftpart ++ rightpart else return $ leftpart ++ replicate padwidth ' ' ++ rightpart where u = unit meter renderpct pt = withStatus pt renderpctpts renderpctpts pts = if (totalUnits pts == 0) then return "0%" else return $ show (((completedUnits pts) * 100) `div` (totalUnits pts)) ++ "%" rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String rendercomponent rfunc pt = withStatus pt $ \pts -> do pct <- renderpctpts pts let renders = rfunc [totalUnits pts, completedUnits pts] return $ "[" ++ trackerName pts ++ " " ++ (renders !! 1) ++ u ++ "/" ++ head renders ++ u ++ " " ++ pct ++ "]" renderoverall :: (ProgressStatuses a (IO [Char])) => ([Integer] -> [[Char]]) -> a -> IO [Char] renderoverall rfunc pt = withStatus pt $ \pts -> do etr <- getETR pts speed <- getSpeed pts return $ head (rfunc [floor (speed :: Double)]) ++ u ++ "/s " ++ renderSecs etr MissingH-1.2.0.0/src/Data/Progress/Tracker.hs0000644000175000017500000003737412027213047021030 0ustar jgoerzenjgoerzen{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Progress.Tracker Copyright : Copyright (C) 2006-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Tools for tracking the status of a long operation. Written by John Goerzen, jgoerzen\@complete.org See also "Data.Progress.Meter" -} module Data.Progress.Tracker ( -- * Introduction -- $introduction -- ** Examples -- $examples -- * Creation and Options newProgress, newProgress', addCallback, addParent, -- * Updating incrP, incrP', setP, setP', incrTotal, setTotal, finishP, -- * Reading and Processing getSpeed, withStatus, getETR, getETA, -- * Types ProgressStatus(..), Progress, ProgressTimeSource, ProgressCallback, ProgressStatuses, -- * Utilities defaultTimeSource ) where import Control.Concurrent.MVar import System.Time import System.Time.Utils import Data.Ratio {- $introduction ProgressTracker is a module for tracking the progress on long-running operations. It can be thought of as the back end engine behind a status bar. ProgressTracker can do things such as track how far along a task is, provide an estimated time of completion, estimated time remaining, current speed, etc. It is designed to be as generic as possible; it can even base its speed calculations on something other than the system clock. ProgressTracker also supports a notion of a parent tracker. This is used when a large task is composed of several individual tasks which may also be 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. 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 automatically. Finally, you can register callbacks. Callbacks are functions that are called whenever the status of a tracker changes. They'll be passed the old and new status and are intended to do things like update on-screen status displays. The cousin module 'Data.Progress.Meter' can be used to nicely render these trackers on a console. -} {- $examples Here is an example use: >do prog <- newProgress "mytracker" 1024 > incrP prog 10 > getETR prog >>= print -- prints number of seconds remaining > incrP prog 500 > finishP prog -} ---------------------------------------------------------------------- -- TYPES ---------------------------------------------------------------------- {- | A function that, when called, yields the current time. The default is 'defaultTimeSource'. -} type ProgressTimeSource = IO Integer {- | The type for a callback function for the progress tracker. When given at creation time to 'newProgress\'' or when added via 'addCallback', these functions get called every time the status of the tracker changes. This function is passed two 'ProgressStatus' records: the first reflects the status prior to the update, and the second reflects the status after the update. Please note that the owning 'Progress' object will be locked while the callback is running, so the callback will not be able to make changes to it. -} type ProgressCallback = ProgressStatus -> ProgressStatus -> IO () {- | The main progress status record. -} data ProgressStatus = ProgressStatus {completedUnits :: Integer, totalUnits :: Integer, startTime :: Integer, trackerName :: String, -- ^ An identifying string timeSource :: ProgressTimeSource } data ProgressRecord = ProgressRecord {parents :: [Progress], callbacks :: [ProgressCallback], status :: ProgressStatus} {- | The main Progress object. -} newtype Progress = Progress (MVar ProgressRecord) class ProgressStatuses a b where {- | 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 modifications while you are reading it), then pass the object to your function. If you happen to already have a 'ProgressStatus' object, withStatus will also accept it and simply pass it unmodified 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 ---------------------------------------------------------------------- -- Creation ---------------------------------------------------------------------- {- | Create a new 'Progress' object with the given name and number of total units initialized as given. The start time will be initialized with the current time at the present moment according to the system clock. The units completed will be set to 0, the time source will be set to the system clock, and the parents and callbacks will be empty. If you need more control, see 'newProgress\''. Example: > prog <- newProgress "mytracker" 1024 -} newProgress :: String -- ^ Name of this tracker -> Integer -- ^ Total units expected -> IO Progress newProgress name total = do t <- defaultTimeSource newProgress' (ProgressStatus {completedUnits = 0, totalUnits = total, startTime = t, trackerName = name, timeSource = defaultTimeSource}) [] {- | 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 the return value of 'defaultTimeSource' and also pass 'defaultTimeSource' as the timing source. -} newProgress' :: ProgressStatus -> [ProgressCallback] -> IO Progress newProgress' news newcb = do r <- newMVar $ ProgressRecord {parents = [], callbacks = newcb, status = news} return (Progress r) {- | 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 running, so the callback will not be able to make any modifications to it. -} addCallback :: Progress -> ProgressCallback -> IO () addCallback (Progress mpo) cb = modifyMVar_ mpo $ \po -> return $ po {callbacks = cb : callbacks po} {- | Adds a new parent to an existing 'Progress'. The parent will automatically have its completed and total counters incremented by the value of those counters in the existing 'Progress'. -} addParent :: Progress -- ^ The child object -> Progress -- ^ The parent to add to this child -> IO () addParent (Progress mcpo) ppo = modifyMVar_ mcpo $ \cpo -> do incrP' ppo (completedUnits . status $ cpo) incrTotal ppo (totalUnits . status $ cpo) return $ cpo {parents = ppo : parents cpo} {- | Call this when you are finished with the object. It is especially important to do this when parent objects are involved. This will simply set the totalUnits to the current completedUnits count, but will not call the callbacks. It will additionally propogate any adjustment in totalUnits to the parents, whose callbacks /will/ be 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 values on the parent would be off since it would be expecting more data than actually arrived. -} finishP :: Progress -> IO () finishP (Progress mp) = modifyMVar_ mp modfunc where modfunc :: ProgressRecord -> IO ProgressRecord modfunc oldpr = do let adjustment = (completedUnits . status $ oldpr) - (totalUnits . status $ oldpr) callParents oldpr (\x -> incrTotal x adjustment) return $ oldpr {status = (status oldpr) {totalUnits = completedUnits . status $ oldpr}} ---------------------------------------------------------------------- -- Updating ---------------------------------------------------------------------- {- | 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 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 = s {completedUnits = newcu s, totalUnits = if newcu s > totalUnits s then newcu s else totalUnits s} newcu s = completedUnits s + count {- | Like 'incrP', but never modify the total. -} incrP' :: Progress -> Integer -> IO () incrP' po count = modStatus po (\s -> s {completedUnits = completedUnits s + count}) {- | Set the completed unit count in the 'Progress' object to the specified value. Unlike 'incrP', this function sets the count to a specific value, rather than adding to the existing value. If this value exceeds the total, then the total will also be raised to match this value so that the completed count never exceeds teh total. -} setP :: Progress -> Integer -> IO () setP po count = modStatus po statusfunc where statusfunc s = s {completedUnits = count, totalUnits = if count > totalUnits s then count else totalUnits s} {- | Like 'setP', but never modify the total. -} setP' :: Progress -> Integer -> IO () 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 when the total number of units is not known in advance. -} incrTotal :: Progress -> Integer -> IO () incrTotal po count = modStatus po (\s -> s {totalUnits = totalUnits s + count}) {- | Set the total unit count in the 'Progress' object to the specified value. Like 'incrTotal', this would rarely be needed. -} setTotal :: Progress -> Integer -> IO () setTotal po count = modStatus po (\s -> s {totalUnits = count}) ---------------------------------------------------------------------- -- Reading and Processing ---------------------------------------------------------------------- {- | Returns the speed in units processed per time unit. (If you are using the default time source, this would be units processed per second). This obtains the current speed solely from analyzing the 'Progress' object. If no time has elapsed yet, returns 0. You can use this against either a 'Progress' object or a 'ProgressStatus' object. This is in the IO monad because the speed is based on the current time. Example: > getSpeed progressobj >>= print Don't let the type of this function confuse you. It is a fancy way of saying that it can take either a 'Progress' or a 'ProgressStatus' object, and returns 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 -> 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 0 whenever 'getSpeed' would return 0. See the comments under 'getSpeed' for information about this function's type and result. -} getETR :: (ProgressStatuses a (IO Integer), ProgressStatuses a (IO Rational)) => a -> IO Integer getETR po = do speed <- ((getSpeed po)::IO Rational) if speed == 0 then return 0 else -- FIXME: potential for a race condition here, but it should -- be negligible withStatus po $ \status -> do let remaining = totalUnits status - completedUnits status return $ round $ (toRational remaining) / speed {- | Returns the estimated system clock time of completion, in standard time units. Returns the current time whenever 'getETR' would return 0. See the comments under 'getSpeed' for information about this function's type and result. -} getETA :: (ProgressStatuses a (IO Integer), ProgressStatuses a (IO Rational)) => a -> IO Integer getETA po = do etr <- getETR po -- FIXME: similar race potential here withStatus po $ \status -> do timenow <- timeSource status return $ timenow + etr ---------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------- {- | The default time source for the system. This is defined as: >getClockTime >>= (return . clockTimeToEpoch) -} 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 = do let newpr = oldpr {status = func (status oldpr)} mapM_ (\x -> x (status oldpr) (status newpr)) (callbacks oldpr) -- Kick it up to the parents. case (completedUnits . status $ newpr) - (completedUnits . status $ oldpr) of 0 -> return () x -> callParents newpr (\y -> incrP' y x) case (totalUnits . status $ newpr) - (totalUnits . status $ oldpr) of 0 -> return () x -> callParents newpr (\y -> incrTotal y x) return newpr callParents :: ProgressRecord -> (Progress -> IO ()) -> IO () callParents pr func = mapM_ func (parents pr) MissingH-1.2.0.0/src/Data/Map/0000755000175000017500000000000012027213047015774 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Map/Utils.hs0000644000175000017500000000530612027213047017434 0ustar jgoerzenjgoerzen{- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Map.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with Data.Maps. Written by John Goerzen, jgoerzen\@complete.org -} module Data.Map.Utils (-- * Basic Utilities flipM, flippedLookupM, forceLookupM, -- * Conversions strToM, strFromM ) where 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 association lists. This implementation is simple: >strFromM = strFromAL . Data.Map.toList This function is designed to work with Map String String objects, but may also work with other objects with simple representations. -} strFromM :: (Show a, Show b, Ord a) => Data.Map.Map a b -> String strFromM = strFromAL . Data.Map.toList {- | Converts a String into a String, String Map. See 'Data.List.Utils.strToAL' for more on the similar function for association lists. This implementation is simple: >strToM = Data.Map.fromList . strToAL This function is designed to work with Map String String objects, but may work with other key\/value combinations if they have simple representations. -} strToM :: (Read a, Read b, Ord a) => String -> Data.Map.Map a b strToM = Data.Map.fromList . strToAL {- | Flips a Map. See 'Data.List.Utils.flipAL' for more on the similar function for lists. -} flipM :: (Ord key, Ord val) => Data.Map.Map key val -> Data.Map.Map val [key] flipM = Data.Map.fromList . flipAL . Data.Map.toList {- | Returns a list of all keys in the Map whose value matches the parameter. If the value does not occur in the Map, the empty list is returned. -} flippedLookupM :: (Ord val, Ord key) => val -> Data.Map.Map key val -> [key] flippedLookupM v fm = case Data.Map.lookup v (flipM fm) of Nothing -> [] 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. -} forceLookupM :: (Show key, Ord key) => String -> key -> Data.Map.Map key elt -> elt forceLookupM msg k fm = case Data.Map.lookup k fm of Just x -> x Nothing -> error $ msg ++ ": could not find key " ++ (show k) MissingH-1.2.0.0/src/Data/Hash/0000755000175000017500000000000012027213047016142 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Hash/MD5/0000755000175000017500000000000012027213047016527 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Hash/MD5/Zord64_HARD.lhs0000644000175000017500000000310012027213047021117 0ustar jgoerzenjgoerzen>-- #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 MissingH-1.2.0.0/src/Data/Hash/MD5.lhs0000644000175000017500000003215412027213047017244 0ustar jgoerzenjgoerzen>{- | > 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 MissingH-1.2.0.0/src/Data/Hash/CRC32/0000755000175000017500000000000012027213047016716 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Hash/CRC32/Posix.hs0000644000175000017500000001302012027213047020350 0ustar jgoerzenjgoerzen-- 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 ]) MissingH-1.2.0.0/src/Data/Hash/CRC32/GZip.hs0000644000175000017500000001044612027213047020130 0ustar jgoerzenjgoerzen{- arch-tag: GZIP CRC32 implementation in pure Haskell Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Hash.CRC32.GZip Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable CRC32 checksumming using the GZIP\/PKZIP algorithm as used in both ISO 3309 and section 8.1.1.6.2 of ITU-T V.42 and referenced in RFC1952. -} module Data.Hash.CRC32.GZip where import Data.Array import Data.Bits import Data.Word import Data.List import Data.Char update_crc :: Word32 -> Char -> Word32 update_crc crc ch = let c = crc `xor` 0xFFFFFFFF newval = (gzipcrctab ! fromIntegral ((c `xor` fromIntegral (ord ch)) .&. 0xff)) `xor` (c `shiftR` 8) in newval `xor` 0xFFFFFFFF update_crc_list :: Word32 -> [Char] -> Word32 update_crc_list start list = foldl update_crc start list calc_crc32 :: [Char] -> Word32 calc_crc32 s = update_crc_list 0 s gzipcrctab :: Array Int Word32 gzipcrctab = array (0,255) (zip [0..255] [ 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d ]) MissingH-1.2.0.0/src/Data/Bits/0000755000175000017500000000000012027213047016160 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Bits/Utils.hs0000644000175000017500000000346112027213047017620 0ustar jgoerzenjgoerzen{- arch-tag: Bit utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Bits.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable to platforms with rawSystem Bit-related utilities Written by John Goerzen, jgoerzen\@complete.org -} module Data.Bits.Utils(getBytes, fromBytes, c2w8, s2w8, w82c, w82s) where import Data.Bits import Data.Word {- | Returns a list representing the bytes that comprise a data type. Example: > 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) {- | The opposite of 'getBytes', this function builds a number based on its component bytes. Results are undefined if any components of the input list are > 0xff! -} fromBytes :: (Bits a, Num a) => [a] -> a fromBytes input = let dofb accum [] = accum dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs in dofb 0 input {- | Converts a Char to a Word8. -} c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum {- | Converts a String to a [Word8]. -} s2w8 :: String -> [Word8] s2w8 = map c2w8 {- | Converts a Word8 to a Char. -} w82c :: Word8 -> Char w82c = toEnum . fromIntegral {- | Converts a [Word8] to a String. -} w82s :: [Word8] -> String w82s = map w82c MissingH-1.2.0.0/src/Data/BinPacking.hs0000644000175000017500000001172012027213047017621 0ustar jgoerzenjgoerzen{- Copyright (c) 2008-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.BinPacking Copyright : Copyright (C) 2008-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Tools for packing into bins Written by John Goerzen, jgoerzen\@complete.org This module is designed to solve this type of problem: Given a bunch of objects of varying sizes, what is the best possible way to pack them into fixed-size bins? This can be used, for instance, by the datapacker program to pack files onto CDs or DVDs; by manufacturing environments to pack physical items into physicl bins; etc. A description of bin packing algorithms can be found at . -} module Data.BinPacking (BinPacker, BinPackerError(..), packByOrder, packLargeFirst ) where import Data.List import Control.Monad.Error {- | 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 = 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 deriving (Eq, Read) instance (Num size, Ord size, Show size, Show obj) => Show (BinPackerError size obj) where show (BPTooFewBins _) = "Too few bins" show (BPSizeTooLarge binsize (objsize, obj)) = "Size " ++ show objsize ++ " greater than bin size " ++ show binsize ++ " 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. > [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) => [size] -- The sizes of bins -> [(size, obj)] -- The sizes and objects -> Either (BinPackerError size obj) [[(size, obj)]] -- Either error or results {- | Pack objects into bins, preserving order. Objects will be taken from the input list one by one, and added to each bin until the bin is full. Work will then proceed on the next bin. No attempt is made to optimize allocations to bins. This is the simplest and most naive bin-packing algorithm, but may not make very good use of bin space. -} packByOrder :: BinPacker packByOrder _ [] = Right [] -- Ran out of sizes packByOrder [] remainder = Left (BPTooFewBins remainder) packByOrder (thisbinsize:otherbins) sizes = let fillBin _ [] = Right [] fillBin accumsize ((s, o):xs) | s > thisbinsize = Left $ BPSizeTooLarge thisbinsize (s, o) | s + accumsize > thisbinsize = Right [] | otherwise = do next <- fillBin (accumsize + s) xs return $ (s, o) : next in do thisset <- fillBin 0 sizes next <- packByOrder otherbins (drop (length thisset) sizes) return (thisset : next) {- | Pack objects into bins. For each bin, start with the largest objects, and keep packing the largest object from the remainder until no object can 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' :: BinPacker packLargeFirst' _ [] = Right [] -- Ran out of sizes packLargeFirst' [] remainder = Left (BPTooFewBins remainder) packLargeFirst' (thisbinsize:otherbins) sizes = let fillBin _ [] = Right [] fillBin accumsize sizelist = case break (\x -> (fst x) + accumsize <= thisbinsize) sizelist of (_, []) -> if accumsize == 0 then Left $ BPSizeTooLarge thisbinsize (head sizelist) else Right [] (nonmatches, ((s, o):matchxs)) -> do next <- fillBin (accumsize + s) (nonmatches ++ matchxs) return $ (s, o) : next in do thisset <- fillBin 0 sizes next <- packLargeFirst' otherbins (drop (length thisset) sizes) return (thisset : next) MissingH-1.2.0.0/src/Data/Tuple/0000755000175000017500000000000012027213047016350 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Tuple/Utils.hs0000644000175000017500000000157212027213047020011 0ustar jgoerzenjgoerzen{- arch-tag: Tuple utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Tuple.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with lists. Written by Neil Mitchell, -} module Data.Tuple.Utils( -- * Extraction fst3, snd3, thd3 ) where -- | Take the first item out of a 3 element tuple fst3 :: (a,b,c) -> a fst3 (a,b,c) = a -- | Take the second item out of a 3 element tuple snd3 :: (a,b,c) -> b snd3 (a,b,c) = b -- | Take the third item out of a 3 element tuple thd3 :: (a,b,c) -> c thd3 (a,b,c) = c MissingH-1.2.0.0/src/Data/Either/0000755000175000017500000000000012027213047016477 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Data/Either/Utils.hs0000644000175000017500000000457012027213047020141 0ustar jgoerzenjgoerzen{- arch-tag: Euither utilities Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Either.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable Utilities for working with the Either data type -} module Data.Either.Utils ( maybeToEither, forceEither, forceEitherMsg, eitherToMonadError, fromLeft, fromRight, fromEither ) where import Control.Monad.Error {- | Converts a Maybe value to an Either value, using the supplied parameter as the Left value if the Maybe is Nothing. This function can be interpreted as: @maybeToEither :: e -> Maybe a -> Either e a@ Its definition is given as it is so that it can be used in the Error and related monads. -} maybeToEither :: MonadError e m => 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 _ (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 (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 {- | 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 (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" -- | 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" -- | Take an Either, and return the value inside it fromEither :: Either a a -> a fromEither (Left a) = a fromEither (Right a) = a MissingH-1.2.0.0/src/Control/0000755000175000017500000000000012027213047016026 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Control/Concurrent/0000755000175000017500000000000012027213047020150 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Control/Concurrent/Thread/0000755000175000017500000000000012027213047021357 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/src/Control/Concurrent/Thread/Utils.hs0000644000175000017500000000201512027213047023011 0ustar jgoerzenjgoerzen{- arch-tag: Thread utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Control.Concurrent.Thread.Utils Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable This module provides various helpful utilities for dealing with threads. Written by John Goerzen, jgoerzen\@complete.org -} module Control.Concurrent.Thread.Utils(-- * I\/O utilities runInThread ) where import Control.Concurrent {- | 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. -} runInThread :: IO a -> (a -> IO b) -> IO ThreadId runInThread action callback = forkIO $ action >>= callback >> return () MissingH-1.2.0.0/Makefile0000644000175000017500000000275012027213047015263 0ustar jgoerzenjgoerzen# 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 MissingH-1.2.0.0/examples/0000755000175000017500000000000012027213047015435 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/examples/test3.hs0000644000175000017500000000304512027213047017035 0ustar jgoerzenjgoerzen-- example code 3 for socketserver import MissingH.Network.SocketServer import MissingH.IO import MissingH.Logging.Logger import Data.Char import System.IO import MissingH.Str import System.Time realhandler h = let loop = do e <- hIsEOF h if e then return () else do c <- hGetLine h case (rstrip c) of "QUIT" -> hPutStr h "Goodbye!\n" "COMMANDS" -> do hPutStrLn h "You can type TIME for the current time" loop "TIME" -> do ct <- getClockTime calt <- toCalendarTime ct hPutStrLn h $ calendarTimeToString calt loop x -> do hPutStrLn h (map toUpper x) loop in do hPutStrLn h "Welcome to the uppercase server. I'll echo" hPutStrLn h "everything back to you in uppercase. When done," hPutStrLn h "just type \"QUIT\" to exit." hPutStrLn h "You can also type \"COMMANDS\" for some fun stuff." hPutStrLn h "" loop hClose h handler = threadedHandler $ loggingHandler "main" INFO $ handleHandler $ realhandler main = do updateGlobalLogger "main" (setLevel DEBUG) serveTCPforever ((simpleInetOptions 12345) {reuse = True}) handler MissingH-1.2.0.0/examples/simplegrep.hs0000644000175000017500000000022712027213047020141 0ustar jgoerzenjgoerzenimport MissingH.List main = do c <- getContents putStr (unlines(filter (\line -> contains "Haskell" line) (lines c))) MissingH-1.2.0.0/examples/test2.hs0000644000175000017500000000171612027213047017037 0ustar jgoerzenjgoerzen-- example code 2 for socketserver import MissingH.Network.SocketServer import MissingH.IO import MissingH.Logging.Logger import Data.Char import System.IO import MissingH.Str lineInteraction :: [String] -> [String] lineInteraction inp = let realInteract :: [String] -> [String] realInteract [] = [] realInteract ("QUIT":_) = ["Goodbye!"] realInteract ("easeregg":_) = ["Yow!"] realInteract (x:xs) = map toUpper x : realInteract xs in ("Welcome to the uppercase server. I'll echo everything back to\n" ++ "you in uppercase. When done, just type \"QUIT\" to exit.\n") : realInteract (map rstrip inp) realhandler h = do hLineInteract h h lineInteraction hClose h handler = threadedHandler $ loggingHandler "main" INFO $ handleHandler $ realhandler main = do updateGlobalLogger "main" (setLevel DEBUG) serveTCPforever ((simpleInetOptions 12345) {reuse = True}) handler MissingH-1.2.0.0/wintest.bat0000644000175000017500000000036612027213047016011 0ustar jgoerzenjgoerzencd 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 MissingH-1.2.0.0/3rd-party-licenses/0000755000175000017500000000000012027213047017247 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/3rd-party-licenses/LGPL-2.10000644000175000017500000006370212027213047020236 0ustar jgoerzenjgoerzen GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! # arch-tag: LGPL 2.1 license text MissingH-1.2.0.0/3rd-party-licenses/BSD0000644000175000017500000000300312027213047017576 0ustar jgoerzenjgoerzenCopyright (c) The Regents of the University of California. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # arch-tag: 3-clause BSD license text MissingH-1.2.0.0/MissingH.cabal0000644000175000017500000000772212027213047016334 0ustar jgoerzenjgoerzenName: MissingH Version: 1.2.0.0 License: BSD3 Maintainer: John Goerzen Author: John Goerzen Copyright: Copyright (c) 2004-2011 John Goerzen 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 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.2.3 Flag splitBase description: Choose the new smaller, split-up base package. Flag buildtests description: Build the executable to run unit tests default: False 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 Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances, CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables 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 Executable runtests if flag(buildtests) Buildable: True Build-Depends: testpack, QuickCheck >= 1.0 && <2.0, HUnit else Buildable: False 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, WildMatchtest Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances, CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables MissingH-1.2.0.0/LICENSE0000644000175000017500000000754212027213047014634 0ustar jgoerzenjgoerzenCopyright (c) 2004 - 2011 John Goerzen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of John Goerzen nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ============================================================================ Special Notes for Included Code ============================================================================ If you split out the parts originally from other authors, and use them completely independently of the rest of the library, you may treat them under the licenses shown below. ---------------------------------------------------- Portions of System.Path come from Volker Wysk's HsShellScript library, version 2.1.0. That code is Copyright (c) 2004 Volker Wysk and was originally licensed under the GNU LGPL 2.1. Volker gave permission on Aug. 10, 2011, to John Goerzen to relicense it under the same 3-clause 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. Debian GNU/Linux users may find the 3-clause BSD license at /usr/share/common-licenses/BSD. Alternatively, you may find it at 3rd-party-licenses/BSD. Please note that the University of California has no claim on this code; simply substitute Ian Lynagh for the University wherever it may occur in that file. The code was obtained from http://urchin.earth.li/darcs/ian/inflate/Inflate.lhs ---------------------------------------------------- Data.Hash.MD5* is Copyright 2001 Ian Lynagh Licence: GPL or 3 clause BSD Debian GNU/Linux users may find the 3-clause BSD license at /usr/share/common-licenses/BSD. Alternatively, you may find it at 3rd-party-licenses/BSD. Please note that the University of California has no claim on this code; simply substitute Ian Lynagh for the University wherever it may occur in that file. 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. MissingH-1.2.0.0/TODO0000644000175000017500000000144212027213047014310 0ustar jgoerzenjgoerzenDocument 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. MissingH-1.2.0.0/pending/0000755000175000017500000000000012027213047015243 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/pending/Maildir.disabled0000644000175000017500000000423512027213047020321 0ustar jgoerzenjgoerzen{- 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) MissingH-1.2.0.0/pending/Tar.newhs0000644000175000017500000000346112027213047017043 0ustar jgoerzenjgoerzen{- 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 MissingH-1.2.0.0/pending/Gopher.hs0000644000175000017500000000640512027213047017030 0ustar jgoerzenjgoerzen{- 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 } MissingH-1.2.0.0/pending/Tar/0000755000175000017500000000000012027213047015771 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/pending/Tar/HeaderParser.newhs0000644000175000017500000000631412027213047021410 0ustar jgoerzenjgoerzen{- 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 . readoctMissingH-1.2.0.0/testsrc/0000755000175000017500000000000012027213047015306 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/testsrc/mime.types.test0000644000175000017500000000071712027213047020306 0ustar jgoerzenjgoerzen# arch-tag: test file for MIMETypes # Here are some comments # ## # and some fun blank lines # Some types with nothing application/activemessage application/applefile application/atomicmail # comment here # Some lines with real stuff application/andrew-inset ez # blah # Some lines with multiple things video/x-dv dif dv text/x-c++hdr h++ hpp hxx hh # foo MissingH-1.2.0.0/testsrc/gzfiles/0000755000175000017500000000000012027213047016751 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/testsrc/gzfiles/empty.gz0000644000175000017500000000003212027213047020444 0ustar jgoerzenjgoerzen‹™ ±AemptyMissingH-1.2.0.0/testsrc/gzfiles/t1bad.gz0000644000175000017500000000003212027213047020301 0ustar jgoerzenjgoerzen‹Öâ°A I-.Q0ø'˜MissingH-1.2.0.0/testsrc/gzfiles/t2.gz0000644000175000017500000000006712027213047017643 0ustar jgoerzenjgoerzen‹Öâ°A I-.Q0ø'™‹ãA±At2 I-.Q0£©.MissingH-1.2.0.0/testsrc/gzfiles/t1.gz0000644000175000017500000000003212027213047017632 0ustar jgoerzenjgoerzen‹Öâ°A I-.Q0ø'™MissingH-1.2.0.0/testsrc/gzfiles/zeros.gz0000644000175000017500000002374612027213047020471 0ustar jgoerzenjgoerzen‹×#±AzerosìÁ€þ¯î €ÛƒCAÿ_;Ãð Ì*Êž MissingH-1.2.0.0/testsrc/Str/0000755000175000017500000000000012027213047016056 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/testsrc/Str/CSVtest.hs0000644000175000017500000000201212027213047017740 0ustar jgoerzenjgoerzen{- arch-tag: CSV tests main file Copyright (C) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Str.CSVtest(tests) where import Test.HUnit import Data.CSV import Text.ParserCombinators.Parsec test_csv = let f inp exp = TestLabel inp $ TestCase $ exp @=? case parse csvFile "" inp of Right x -> Right x Left y -> Left (show y) in [ f "" (Right []), f "\n" (Right [[""]]), f "1,2,3\n" (Right [["1", "2", "3"]]), f "This is a,Test,Really\n" (Right [["This is a", "Test", "Really"]]), f "l1\nl2\n" (Right [["l1"], ["l2"]]), f "NQ,\"Quoted\"\n" (Right [["NQ", "Quoted"]]), f "1Q,\"\"\"\"\n" (Right [["1Q", "\""]]), f ",\"\"\n" (Right [["", ""]]), f "\"Embedded\"\"Quote\"\n" (Right [["Embedded\"Quote"]]) ] tests = TestList [TestLabel "csv" (TestList test_csv)] MissingH-1.2.0.0/testsrc/Maptest.hs0000644000175000017500000000211212027213047017253 0ustar jgoerzenjgoerzen{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Maptest(tests) where import Test.HUnit import Data.Map.Utils import Data.Map as M test_flipM = let f inp exp = TestCase $ (M.fromList exp) @=? flipM (M.fromList inp) in [ f ([]::[(Int,Int)]) ([]::[(Int,[Int])]) ,f [("a", "b")] [("b", ["a"])] ,f [("a", "b"), ("c", "b"), ("d", "e"), ("b", "b")] [("b", ["c", "b", "a"]), ("e", ["d"])] ] test_flippedLookupM = let f item inp exp = TestCase $ exp @=? flippedLookupM item (M.fromList inp) in [ f 'a' ([]::[(Char, Char)]) [] ,f 'a' [("Test1", 'a'), ("Test2", 'b')] ["Test1"] ,f 'a' [("Test1", 'b'), ("Test2", 'b')] [] ,f 'a' [("Test1", 'a'), ("Test2", 'a')] ["Test2", "Test1"] ] tests = TestList [TestLabel "flipM" (TestList test_flipM), TestLabel "flippedLookupM" (TestList test_flippedLookupM) ] MissingH-1.2.0.0/testsrc/Strtest.hs0000644000175000017500000000424012027213047017312 0ustar jgoerzenjgoerzen{- arch-tag: Str tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Strtest(tests) where import Test.HUnit import Data.String.Utils import Test.HUnit.Tools import Text.Regex import Data.Char test_lstrip = mapassertEqual "lstrip" lstrip [("", ""), ("a", "a"), (" a ", "a "), (" abas", "abas"), ("\n\t fdsa", "fdsa"), ("abc def", "abc def")] test_rstrip = mapassertEqual "rstrip" rstrip [("", ""), ("a", "a"), (" a ", " a"), ("abas ", "abas"), ("fdsa \n\t", "fdsa"), ("abc def", "abc def")] test_strip = mapassertEqual "strip" strip [("", ""), ("a", "a"), (" a ", "a"), ("abas ", "abas"), (" abas", "abas"), ("asdf\n\t ", "asdf"), ("\nbas", "bas"), ("abc def", "abc def")] test_splitWs = let f exp inp = TestCase $ exp @=? splitWs inp in [ f [] " ", f [] "", f ["asdf"] " asdf\n", f ["one", "two", "three"] " one\ntwo \tthree \n" ] test_escapeRe = map (\i -> TestLabel (show $ chr i) $ TestCase $ assertEqual [chr i] (Just []) (matchRegex (mkRegex $ escapeRe $ [chr i]) [chr i])) [1..255] ++ [TestCase $ assertEqual "big string" (Just ([], teststr, [], [])) (matchRegexAll (mkRegex $ escapeRe teststr) teststr) ] where teststr = map chr [1..255] tests = TestList [TestLabel "lstrip" (TestList test_lstrip), TestLabel "rstrip" $ TestList test_rstrip, TestLabel "strip" $ TestList test_strip, TestLabel "splitWs" $ TestList test_splitWs, TestLabel "escapeRe" $ TestList test_escapeRe ] MissingH-1.2.0.0/testsrc/MIMETypestest.hs0000644000175000017500000000536512027213047020327 0ustar jgoerzenjgoerzen{- arch-tag: MIMETypes tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module MIMETypestest(tests) where import Test.HUnit import Data.List import Data.MIME.Types test_readMIMETypes = let omtd = readMIMETypes defaultmtd True "testsrc/mime.types.test" f = \strict inp exp -> TestCase $ do mtd <- omtd exp @=? guessType mtd strict inp fe = \strict inp exp -> TestCase $ do mtd <- omtd (sort exp) @=? sort (guessAllExtensions mtd strict inp) in [ f True "foo.bar.baz" (Nothing, Nothing) ,f True "" (Nothing, Nothing) ,f True "foo.ez" (Just "application/andrew-inset", Nothing) ,fe True "application/andrew-inset" [".ez"] ,f True "foo.dv" (Just "video/x-dv", Nothing) ,fe True "video/x-dv" [".dif", ".dv"] ,f True "test.h++" (Just "text/x-c++hdr", Nothing) ,fe True "text/x-c++hdr" [".h++", ".hpp", ".hxx", ".hh"] ,f True "foo.tgz" (Just "application/x-tar", Just "gzip") ] test_guessAllExtensions = let f strict inp exp = TestCase $ (sort exp) @=? sort (guessAllExtensions defaultmtd strict inp) in [ f True "" [] ,f True "foo" [] ,f True "application/octet-stream" [".obj", ".so", ".bin", ".a", ".dll", ".exe", ".o"] ,f True "text/plain" [".pl", ".ksh", ".bat", ".c", ".h", ".txt"] ,f True "application/rtf" [] ,f False "application/rtf" [".rtf"] ] test_guessType = let f strict inp exp = TestCase $ exp @=? guessType defaultmtd strict inp in [ f True "" (Nothing, Nothing) ,f True "foo" (Nothing, Nothing) ,f True "foo.txt" (Just "text/plain", Nothing) ,f True "foo.txt.gz" (Just "text/plain", Just "gzip") ,f True "foo.txt.blah" (Nothing, Nothing) ,f True "foo.tar" (Just "application/x-tar", Nothing) ,f True "foo.tar.gz" (Just "application/x-tar", Just "gzip") ,f True "foo.tgz" (Just "application/x-tar", Just "gzip") ,f True "http://foo/test.dir/blah.rtf" (Nothing, Nothing) ,f False "http://foo/test.dir/blah.rtf" (Just "application/rtf", Nothing) ,f True "foo.pict" (Nothing, Nothing) ,f False "foo.pict" (Just "image/pict", Nothing) ] tests = TestList [TestLabel "guessType" (TestList test_guessType), TestLabel "guessAllExtensions" (TestList test_guessAllExtensions), TestLabel "readMIMETypes" (TestList test_readMIMETypes) ] MissingH-1.2.0.0/testsrc/GZiptest.hs0000644000175000017500000000552012027213047017415 0ustar jgoerzenjgoerzen{- arch-tag: Tests for GZip module Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module GZiptest(tests) where import Test.HUnit import System.FileArchive.GZip import System.FilePath import Data.Compression.Inflate import System.IO.Binary import System.IO import Data.Either.Utils import Data.List mf fn exp conf = TestLabel fn $ TestCase $ do c <- readBinaryFile $ joinPath ["testsrc", "gzfiles", fn] assertEqual "" exp (conf c) {- import System.FileArchive.GZip import System.IO import Data.Either.Utils main = do c <- hGetContents stdin let x = snd . forceEither . read_header $ c putStr x test_bunches = let f fn exp conv = mf fn exp (conv . snd . forceEither . read_header) f2 c = let fn = "t/z" ++ (show c) ++ ".gz" in f fn c (length . inflate_string) in map f2 [0..1000] -} test_inflate = let f fn exp conv = mf fn exp (conv . snd . forceEither . read_header) in [ f "t1.gz" "Test 1" inflate_string ,f "t1.gz" 6 (length . inflate_string) ,f "t1.gz" ("Test 1", "\x19\xf8\x27\x99\x06\x00\x00\x00") inflate_string_remainder ,f "empty.gz" "" inflate_string --,f "zeros.gz" 10485760 (length . inflate_string) -- BAD BAD ,f "zeros.gz" (replicate (10 * 1048576) '\0') inflate_string -- This line tests Igloo's code: --,f "zeros.gz" True (\x -> (replicate 10485760 '\0') == inflate_string x) ] test_header = let f fn exp = mf fn exp (fst . forceEither . read_header) in [ f "t1.gz" Header {method = 8, flags = 0, extra = Nothing, filename = Nothing, comment = Nothing, mtime = 1102111446, xfl = 2, os = 3} ,f "empty.gz" Header {method = 8, flags = 8, extra = Nothing, filename = Just "empty", comment = Nothing, mtime = 1102127257, xfl = 0, os = 3} ] test_gunzip = let f fn exp = mf fn exp decompress in [ f "t1.gz" ("Test 1", Nothing) ,f "t1bad.gz" ("Test 1", Just CRCError) ,f "t2.gz" ("Test 1Test 2", Nothing) -- The following tests my code {- ,mf "zeros.gz" True (\x -> case decompress x of (y, _) -> y == replicate 10485760 '\0' ) -} ] tests = TestList [TestLabel "inflate" (TestList test_inflate), TestLabel "header" (TestList test_header), -- TestLabel "bunches" (TestList test_bunches), TestLabel "gunzip" (TestList test_gunzip) ] MissingH-1.2.0.0/testsrc/Eithertest.hs0000644000175000017500000000250012027213047017757 0ustar jgoerzenjgoerzen{- arch-tag: Data.Either.Utils tests Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Eithertest(tests) where import Test.HUnit import Data.Either.Utils import Test.HUnit.Tools import Control.Exception instance Eq ErrorCall where (ErrorCall x) == (ErrorCall y) = x == y test_maybeToEither = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp inp in [ f "Nothing" (maybeToEither "error" (Nothing::Maybe String)) (Left "error"), 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))) (Right (5::Int)) ] test_forceEither = 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")) ] tests = TestList [TestLabel "test_maybeToEither" (TestList test_maybeToEither), TestLabel "test_forceEither" (TestList test_forceEither) ] MissingH-1.2.0.0/testsrc/HVFStest.hs0000644000175000017500000001035112027213047017310 0ustar jgoerzenjgoerzen{- arch-tag: HVFS tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module HVFStest(tests) where import Test.HUnit import System.IO.HVIO import System.IO.HVFS import System.IO.HVFS.InstanceHelpers import System.IO.HVFS.Combinators import Test.HUnit.Tools import System.IO import System.IO.Error import Control.Exception ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x testTree = [("test.txt", MemoryFile "line1\nline2\n"), ("file2.txt", MemoryFile "line3\nline4\n"), ("emptydir", MemoryDirectory []), ("dir1", MemoryDirectory [("file3.txt", MemoryFile "line5\n"), ("test.txt", MemoryFile "subdir test"), ("dir2", MemoryDirectory []) ] ) ] test_nice_slice = let f exp fp = TestLabel fp $ TestCase $ exp @=? nice_slice fp in [ f [] "/" ,f ["foo", "bar"] "/foo/bar" --,f [] "." ] 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 in [ f "line1\nline2\n" "test.txt", f "line1\nline2\n" "/test.txt", f "line5\n" "dir1/file3.txt", f "subdir test" "/dir1/test.txt" ] test_chroot = let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree vSetCurrentDirectory x "/emptydir" y <- newHVFSChroot x "/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") ,f "dot" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x ".") ,f "cwd tests" $ (\x -> do a <- vGetDirectoryContents x "/" ["file3.txt", "test.txt", "dir2"] @=? a vSetCurrentDirectory x "/dir2" cwd <- vGetCurrentDirectory x "/dir2" @=? cwd y <- vGetDirectoryContents x "." [] @=? y vSetCurrentDirectory x ".." "/" `ioeq` vGetCurrentDirectory x --vSetCurrentDirectory x ".." --"/" `ioeq` vGetCurrentDirectory x ) --,f "test.txt" (\x -> "subdir test" `ioeq` -- (vOpen x "/test.txt" ReadMode >>= vGetContents)) ] test_structure = let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree testfunc x in [ f "root" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] `ioeq` vGetDirectoryContents x "/") ,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" vGetDirectoryContents x ".") ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x "/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 -> do vSetCurrentDirectory x "dir1" [] `ioeq` vGetDirectoryContents x "dir2" ) ] tests = TestList [TestLabel "nice_slice" (TestList test_nice_slice) ,TestLabel "structure" (TestList test_structure) ,TestLabel "content" (TestList test_content) ,TestLabel "chroot" (TestList test_chroot) ] MissingH-1.2.0.0/testsrc/Bitstest.hs0000644000175000017500000000214012027213047017440 0ustar jgoerzenjgoerzen{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Bitstest(tests) where import Test.HUnit import Data.Bits.Utils import Data.Word test_fromBytes = let f :: [Word32] -> Word32 -> Test f inp exp = TestCase $ exp @=? fromBytes inp in [ f [] 0 ,f [0] 0 ,f [1] 1 ,f [0xff, 0] 0xff00 ,f [0x0, 0xff] 0xff ,f [0x12, 0x34, 0x56, 0x78] 0x12345678 ,f [0xff, 0xff, 0xff, 0xff] 0xffffffff ,f [0xff, 0, 0, 0] 0xff000000 ] test_getBytes = let f :: Word32 -> [Word32] -> Test f inp exp = TestCase $ exp @=? getBytes inp in [ f 0 [0, 0, 0, 0] ,f 0x1200 [0, 0, 0x12, 0] ,f 0x0012 [0, 0, 0, 0x12] ,f 0xffffffff [0xff, 0xff, 0xff, 0xff] ,f 0x12345678 [0x12, 0x34, 0x56, 0x78] ,f 0xf0000000 [0xf0, 0, 0, 0] ] tests = TestList [TestLabel "getBytes" (TestList test_getBytes), TestLabel "fromBytes" (TestList test_fromBytes) ] MissingH-1.2.0.0/testsrc/WildMatchtest.hs0000644000175000017500000000174412027213047020424 0ustar jgoerzenjgoerzen{- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module WildMatchtest(tests) where import Test.HUnit import System.Path.WildMatch import Test.HUnit.Tools test_wildCheckCase = let f patt name = TestCase $ assertBool (patt ++ "," ++ name ++ " was false") (wildCheckCase patt name) f0 patt name = TestCase $ assertBool (patt ++ "," ++ name ++ " was true") (not $ wildCheckCase patt name) in [f "asdf" "asdf", f "?*?" "abc", f "???*" "asd", f "*???" "asd", f "???" "asd", f "*" "asd", f "ab[cd]" "abc", f "ab[!de]" "abc", f0 "ab[de]" "abc", f0 "??" "a", f0 "a" "b", f "[\\]" "\\", f "[!\\]" "a", f0 "[!\\]" "\\", f0 "*.deb" "thedebianthing", f0 "a/*.foo" "testtmp/a/D"] tests = TestList [TestLabel "wildCheckCase" (TestList test_wildCheckCase)] MissingH-1.2.0.0/testsrc/Timetest.hs0000644000175000017500000000272012027213047017441 0ustar jgoerzenjgoerzen{- arch-tag: Time tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Timetest(tests) where import Test.HUnit import System.Time.Utils import System.Time base =CalendarTime {ctYear = 2005, ctMonth = January, ctDay = 21, ctHour = 1, ctMin = 1, ctSec = 20, ctPicosec = 0, ctWDay = Sunday, ctYDay = 0, ctTZName = "", ctTZ = 0, ctIsDST = False} test_ctu2e = let f base exp = TestLabel (show base) $ TestCase $ exp @=? timegm base in [ 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 ] test_ct2e = let f base exp = TestLabel (show base) $ TestCase $ do r <- timelocal base exp @=? r in [ f (base {ctYear = 2005, ctMonth = January, ctDay = 20, ctHour = 19, ctMin = 1, ctSec = 20}) 1106269280 ,f (base {ctYear = 2004, ctMonth = July, ctDay = 1, ctHour = 12, ctMin = 0, ctSec = 0}) 1088701200 ] tests = TestList [TestLabel "ctu2e" (TestList test_ctu2e)] MissingH-1.2.0.0/testsrc/Pathtest.hs0000644000175000017500000000427712027213047017450 0ustar jgoerzenjgoerzen{- arch-tag: Path tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Pathtest(tests) where import Test.HUnit import System.Path test_absNormPath = let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p f2 = f "/usr/1/2" in [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." (Just "/usr") ,f "/usr/1/2" "/foo/bar" (Just "/foo/bar") ,f2 "jack/./.." (Just "/usr/1/2") ,f2 "jack///../foo" (Just "/usr/1/2/foo") ,f2 "../bar" (Just "/usr/1/bar") ,f2 "../" (Just "/usr/1") ,f2 "../.." (Just "/usr") ,f2 "../../" (Just "/usr") ,f2 "../../.." (Just "/") ,f2 "../../../" (Just "/") ,f2 "../../../.." Nothing ] test_secureAbsNormPath = let f base p exp = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p f2 = f "/usr/1/2" in [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." Nothing ,f "/usr/1/2" "/foo/bar" Nothing ,f "/usr/1/2" "/usr/1/2" (Just "/usr/1/2") ,f "/usr/1/2" "/usr/1/2/foo/bar" (Just "/usr/1/2/foo/bar") ,f2 "jack/./.." (Just "/usr/1/2") ,f2 "jack///../foo" (Just "/usr/1/2/foo") ,f2 "../bar" Nothing ,f2 "../" Nothing ,f2 "../.." Nothing ,f2 "../../" Nothing ,f2 "../../.." Nothing ,f2 "../../../" Nothing ,f2 "../../../.." Nothing ] test_splitExt = let f inp exp = TestCase $ exp @=? splitExt inp in [ f "" ("", "") ,f "/usr/local" ("/usr/local", "") ,f "../foo.txt" ("../foo", ".txt") ,f "../bar.txt.gz" ("../bar.txt", ".gz") ,f "foo.txt/bar" ("foo.txt/bar", "") ,f "foo.txt/bar.bz" ("foo.txt/bar", ".bz") ] tests = TestList [TestLabel "splitExt" (TestList test_splitExt) ,TestLabel "absNormPath" (TestList test_absNormPath) ,TestLabel "secureAbsNormPath" (TestList test_secureAbsNormPath) ] MissingH-1.2.0.0/testsrc/HVIOtest.hs0000644000175000017500000000641312027213047017313 0ustar jgoerzenjgoerzen{- arch-tag: HVIO tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module HVIOtest(tests) where import Test.HUnit import System.IO.HVIO import Test.HUnit.Tools import System.IO import System.IO.Error import Control.Exception ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x test_MemoryBuffer = let f inp testfunc = TestLabel inp $ TestCase $ do x <- newMemoryBuffer inp mbDefaultCloseFunc testfunc x in [ f "" (\x -> do True `ioeq` vIsOpen x assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vPutStrLn x "Line1" vPutStrLn x "Line2" vRewind x "Line1" `ioeq` vGetLine x "Line2" `ioeq` vGetLine x 12 `ioeq` vTell x vSeek x AbsoluteSeek 1 "ine1" `ioeq` vGetLine x vSeek x RelativeSeek (-3) "e1" `ioeq` vGetLine x vSeek x SeekFromEnd (-3) "e2" `ioeq` vGetLine x vSeek x AbsoluteSeek 1 vPutStr x "IN" vRewind x "LINe1" `ioeq` vGetLine x "Line2" `ioeq` vGetLine x vSeek x SeekFromEnd 0 vPutChar x 'c' assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) vRewind x "LINe1\nLine2\nc" `ioeq` vGetContents x ) ] test_StreamReader = let f inp testfunc = TestLabel inp $ TestCase $ do x <- newStreamReader inp testfunc x in [ f "" (\x -> do True `ioeq` vIsEOF x True `ioeq` vIsOpen x assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vClose x False `ioeq` vIsOpen x ) ,f "abcd" (\x -> do False `ioeq` vIsEOF x True `ioeq` vIsOpen x 'a' `ioeq` vGetChar x "bcd" `ioeq` vGetContents x vClose x ) ,f "line1\nline2\n\n\nline5\nlastline" (\x -> do False `ioeq` vIsEOF x "line1" `ioeq` vGetLine x "line2" `ioeq` vGetLine x "" `ioeq` vGetLine x "" `ioeq` vGetLine x "line5" `ioeq` vGetLine x "lastline" `ioeq` vGetLine x assertRaises "eof error" (mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) ) ] tests = TestList [TestLabel "streamReader" (TestList test_StreamReader), TestLabel "MemoryBuffer" (TestList test_MemoryBuffer) ] MissingH-1.2.0.0/testsrc/ProgressTrackertest.hs0000644000175000017500000001031612027213047021663 0ustar jgoerzenjgoerzen{- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module ProgressTrackertest(tests) where import Data.Progress.Tracker import Test.HUnit import Control.Concurrent.MVar setup = do timem <- newMVar 0 let timesource = readMVar timem po <- newProgress' (ProgressStatus 0 100 0 "" timesource) [] return (po, timem) settime timem newval = swapMVar timem newval >> return () test_incrP = do (po, timem) <- setup incrP po 5 withStatus po $ \s -> do assertEqual "completedUnits" 5 (completedUnits s) assertEqual "totalUnits" 100 (totalUnits s) incrP po 95 withStatus po $ \s -> do assertEqual "completedUnits" 100 (completedUnits s) assertEqual "totalUnits" 100 (totalUnits s) incrP po 5 withStatus po $ \s -> do assertEqual "completedUnits" 105 (completedUnits s) assertEqual "totalUnits" 105 (totalUnits s) incrP' po 5 withStatus po $ \s -> do assertEqual "completedUnits" 110 (completedUnits s) assertEqual "totalUnits" 105 (totalUnits s) incrTotal po 10 withStatus po $ \s -> do 110 @=? completedUnits s 115 @=? totalUnits s test_setP = do (po, timem) <- setup setP po 5 withStatus po $ \s -> do 5 @=? completedUnits s 100 @=? totalUnits s setP po 100 withStatus po $ \s -> do 100 @=? completedUnits s 100 @=? totalUnits s setP po 105 withStatus po $ \s -> do 105 @=? completedUnits s 105 @=? totalUnits s setP' po 110 withStatus po $ \s -> do 110 @=? completedUnits s 105 @=? totalUnits s setTotal po 115 withStatus po $ \s -> do 110 @=? completedUnits s 115 @=? totalUnits s test_speed = do (po, timem) <- setup getSpeed po >>= assertEqual "initial speed" 0 getETR po >>= assertEqual "initial ETR" 0 getETA po >>= assertEqual "initial ETA" 0 incrP po 10 getSpeed po >>= assertEqual "speed after incr" 0 getETR po >>= assertEqual "ETR after incr" 0 getETA po >>= assertEqual "ETA after incr" 0 settime timem 5 getSpeed po >>= assertEqual "first speed" 2.0 getETR po >>= assertEqual "first ETR" 45 getETA po >>= assertEqual "first ETA" 50 incrP po 90 getSpeed po >>= assertEqual "speed 2" 20.0 getETR po >>= assertEqual "etr 2" 0 getETA po >>= assertEqual "eta 2" 5 settime timem 400 setP po 90 getSpeed po >>= assertEqual "speed 3" 0.225 getETR po >>= assertEqual "etr 2" 44 getETA po >>= assertEqual "eta 2" 444 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 readMVar mcounter >>= assertEqual "cb1" 1 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) 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)] MissingH-1.2.0.0/testsrc/runtests.hs0000644000175000017500000000034412027213047017532 0ustar jgoerzenjgoerzen{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Main where import Test.HUnit import Tests main = runTestTT tests MissingH-1.2.0.0/testsrc/CRC32POSIXtest.hs0000644000175000017500000000123412027213047020141 0ustar jgoerzenjgoerzen{- 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) ] MissingH-1.2.0.0/testsrc/IOtest.hs0000644000175000017500000000035712027213047017056 0ustar jgoerzenjgoerzen{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module IOtest() where import Test.HUnit import System.IO import Test.HUnit.Tools MissingH-1.2.0.0/testsrc/Globtest.hs0000644000175000017500000000706012027213047017430 0ustar jgoerzenjgoerzen{- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Globtest(tests) where import Test.HUnit import System.Path.Glob import System.Path import Test.HUnit.Tools import System.IO.HVFS import System.Directory(createDirectory) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Directory hiding (createDirectory) import System.Posix.Files #endif import Control.Exception import Data.List bp = "testtmp" touch x = writeFile x "" globtest thetest = bracket_ (setupfs) (recursiveRemove SystemFS bp) thetest where setupfs = do mapM_ (\x -> createDirectory x) [bp, bp ++ "/a", bp ++ "/aab", bp ++ "/aaa", bp ++ "/ZZZ", bp ++ "/a/bcd", bp ++ "/a/bcd/efg"] mapM_ touch [bp ++ "/a/D", bp ++ "/aab/F", bp ++ "/aaa/zzzF", bp ++ "/a/bcd/EF", bp ++ "/a/bcd/efg/ha", bp ++ "/a/foo", bp ++ "/a/afoo", bp ++ "/a/a-foo", bp ++ "/a/a.foo"] #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) 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 test_literal = map f [glob (preppath "a") >>= eq "" [preppath "a"] ,glob (preppath "a/D") >>= eq "" [preppath "a/D"] ,glob (preppath "aab") >>= eq "" [preppath "aab"] ,glob (preppath "nonexistant") >>= eq "empty" [] ] test_one_dir = map f [glob (preppath "a*") >>= eq "a*" (map preppath ["a", "aab", "aaa"]), glob (preppath "*a") >>= eq "*a" (map preppath ["a", "aaa"]), glob (preppath "aa?") >>= eq "aa?" (map preppath ["aaa", "aab"]), glob (preppath "aa[ab]") >>= eq "aa[ab]" (map preppath ["aaa", "aab"]), glob (preppath "*q") >>= eq "*q" [] ] test_nested_dir = map f [glob (preppath "a/bcd/E*") >>= eq "a/bcd/E*" [preppath "a/bcd/EF"], glob (preppath "a/bcd/*g") >>= eq "a/bcd/*g" [preppath "a/bcd/efg"], glob (preppath "a/*.foo") >>= eq "a/*.foo" [preppath "a/a.foo"] ] test_dirnames = map f [glob (preppath "*/D") >>= eq "*/D" [preppath "a/D"], glob (preppath "*/*a") >>= eq "*/*a" [], glob (preppath "a/*/*/*a") >>= eq "a/*/*/*a" [preppath "a/bcd/efg/ha"], glob (preppath "?a?/*F") >>= eq "?a?/*F" (map preppath ["aaa/zzzF", "aab/F"]) ] test_brokensymlinks = #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) map f [glob (preppath "sym*") >>= eq "sym*" (map preppath ["sym1", "sym2"]), glob (preppath "sym1") >>= eq "sym1" [preppath "sym1"], glob (preppath "sym2") >>= eq "sym2" [preppath "sym2"] ] #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)] MissingH-1.2.0.0/testsrc/CRC32GZIPtest.hs0000644000175000017500000000130412027213047020006 0ustar jgoerzenjgoerzen{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module CRC32GZIPtest(tests) where import Test.HUnit import Data.Hash.CRC32.GZip test_crcgzip = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp (calc_crc32 inp) in [f "Simple" "Test 1" 0x9927f819 ,f "Empty" "" 0x0 --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 "crcgzip" (TestList test_crcgzip) ] MissingH-1.2.0.0/testsrc/Tests.hs0000644000175000017500000000331012027213047016741 0ustar jgoerzenjgoerzen{- arch-tag: Tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Tests(tests) where import Test.HUnit import qualified MIMETypestest import qualified Listtest import qualified Maptest import qualified Pathtest import qualified Strtest import qualified IOtest import qualified Bitstest import qualified Eithertest import qualified CRC32POSIXtest import qualified CRC32GZIPtest import qualified GZiptest import qualified HVIOtest import qualified HVFStest import qualified Timetest import qualified Str.CSVtest import qualified WildMatchtest import qualified Globtest import qualified ProgressTrackertest test1 = TestCase ("x" @=? "x") tests = TestList [TestLabel "test1" test1, TestLabel "List" Listtest.tests, TestLabel "Str" Strtest.tests, TestLabel "CSV" Str.CSVtest.tests, TestLabel "Time" Timetest.tests, TestLabel "Map" Maptest.tests, TestLabel "ProgressTracker" ProgressTrackertest.tests, TestLabel "Path" Pathtest.tests, TestLabel "WildMatch" WildMatchtest.tests, TestLabel "HVIO" HVIOtest.tests, TestLabel "HVFS" HVFStest.tests, TestLabel "Glob" Globtest.tests, TestLabel "MIMETypes" MIMETypestest.tests, TestLabel "Bitstest" Bitstest.tests, TestLabel "Eithertest" Eithertest.tests, TestLabel "CRC32POSIXtest" CRC32POSIXtest.tests, TestLabel "CRC32GZIPtest" CRC32GZIPtest.tests, TestLabel "GZiptest" GZiptest.tests] MissingH-1.2.0.0/testsrc/Listtest.hs0000644000175000017500000002015712027213047017462 0ustar jgoerzenjgoerzen{- arch-tag: List tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} 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 test_delFromAL = let f :: [(String, Int)] -> [(String, Int)] -> Test f inp exp = TestCase $ exp @=? (delFromAL inp "testkey") in [ f [] [] ,f [("one", 1)] [("one", 1)] ,f [("1", 1), ("2", 2), ("testkey", 3)] [("1", 1), ("2", 2)] ,f [("testkey", 1)] [] ,f [("testkey", 1), ("testkey", 2)] [] ,f [("testkey", 1), ("2", 2), ("3", 3)] [("2", 2), ("3", 3)] ,f [("testkey", 1), ("2", 2), ("testkey", 3), ("4", 4)] [("2", 2), ("4", 4)] ] test_addToAL = let f :: [(String, Int)] -> [(String, Int)] -> Test f inp exp = TestCase $ exp @=? (addToAL inp "testkey" 101) in [ f [] [("testkey", 101)] ,f [("testkey", 5)] [("testkey", 101)] ,f [("testkey", 5), ("testkey", 6)] [("testkey", 101)] ] test_split = let f delim inp exp = TestCase $ exp @=? split delim inp in [ f "," "foo,bar,,baz," ["foo", "bar", "", "baz", ""] ,f "ba" ",foo,bar,,baz," [",foo,","r,,","z,"] ,f "," "" [] ,f "," "," ["", ""] ] test_join = let f :: (Eq a, Show a) => [a] -> [[a]] -> [a] -> Test f delim inp exp = TestCase $ exp @=? join delim inp in [ f "|" ["foo", "bar", "baz"] "foo|bar|baz" ,f "|" [] "" ,f "|" ["foo"] "foo" -- f 5 [[1, 2], [3, 4]] [1, 2, 5, 3, 4] ] test_replace = let f old new inp exp = TestCase $ exp @=? replace old new inp in [ f "" "" "" "" ,f "foo" "bar" "" "" ,f "foo" "bar" "foo" "bar" ,f "foo" "bar" "footestfoothisisabarfoo" "bartestbarthisisabarbar" ,f "," ", " "1,2,3,4" "1, 2, 3, 4" ,f "," "." "1,2,3,4" "1.2.3.4" ] test_genericJoin = let f delim inp exp = TestCase $ exp @=? genericJoin delim inp in [ f ", " [1, 2, 3, 4] "1, 2, 3, 4" ,f ", " ([] :: [Int]) "" ,f "|" ["foo", "bar", "baz"] "\"foo\"|\"bar\"|\"baz\"" ,f ", " [5] "5" ] test_flipAL = let f inp exp = TestCase $ exp @=? flipAL inp in [ f ([]::[(Int,Int)]) ([]::[(Int,[Int])]) ,f [("a", "b")] [("b", ["a"])] ,f [("a", "b"), ("c", "b"), ("d", "e"), ("b", "b")] [("b", ["b", "c", "a"]), ("e", ["d"])] ] test_uniq = let f inp exp = TestCase $ exp @=? uniq inp in [f ([]::[Int]) [], f "asdf" "asdf", f "aabbcc" "abc", f "abcabc" "abc", f "aaaaaa" "a", f "aaaaaab" "ab", f "111111111111111" "1", f "baaaaaaaaa" "ba", f "baaaaaaaaab" "ba", f "aaacccdbbbefff" "acdbef", f "foo" "fo", f "15553344409" "153409", f "Mississippi" "Misp"] test_trunc = let f len inp exp = TestCase $ exp @=? take len inp in [ f 2 "Hello" "He" ,f 1 "Hello" "H" ,f 0 "Hello" "" ,f 2 "H" "H" ,f 2 "" "" ,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 [ f "t1" "Haskell" "I really like Haskell." True ,f "t2" "" "Foo" True ,f "t3" "" "" True ,f "t4" "Hello" "" False ,f "t5" "Haskell" "Haskell" True ,f "t6" "Haskell" "1Haskell" True ,f "t7" "Haskell" "Haskell1" True ,f "t8" "Haskell" "Ocaml" False ,f "t9" "Haskell" "OCamlasfasfasdfasfd" False ,f "t10" "a" "Hello" False ,f "t11" "e" "Hello" True ] test_elemRIndex = let f item inp exp = TestCase $ exp @=? elemRIndex item inp in [ f "foo" [] Nothing ,f "foo" ["bar", "baz"] Nothing ,f "foo" ["foo"] (Just 0) ,f "foo" ["foo", "bar"] (Just 0) ,f "foo" ["bar", "foo"] (Just 1) ,f "foo" ["foo", "bar", "foo", "bar", "foo"] (Just 4) ,f 'f' ['f', 'b', 'f', 'f', 'b'] (Just 3) ,f 'f' ['b', 'b', 'f'] (Just 2) ] test_alwaysElemRIndex = let f item inp exp = TestCase $ exp @=? alwaysElemRIndex item inp in [ f "foo" [] (-1) ,f 'f' ['b', 'q'] (-1) ,f 'f' ['f', 'b', 'f', 'f', 'b'] 3 ] test_subIndex = let f item inp exp = TestCase $ exp @=? subIndex item inp in [f "foo" "asdfoobar" (Just 3) ,f "foo" [] (Nothing) ,f "" [] (Just 0) ,f "" "asdf" (Just 0) ,f "test" "asdftestbartest" (Just 4) ,f [(1::Int), 2] [0, 5, 3, 2, 1, 2, 4] (Just 4) ] test_fixedWidth = let f inplen inplist exp = TestLabel ((show inplen) ++ ", " ++ (show inplist)) $ TestCase $ wholeMap (fixedWidth inplen) inplist @=? exp in [ f [] ([]::[Int]) ([]::[[Int]]) ,f [1] [5] [[5]] ,f [1] [3, 4, 5, 6] [[3], [4, 5, 6]] ,f [1] ([]::[Int]) ([]::[[Int]]) ,f [2] [3] [[3]] ,f [2] [3, 4, 5, 6] [[3, 4], [5, 6]] ,f [2] [3, 4, 5] [[3, 4], [5]] ,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." ["Hello",", T","his is"," ","a test."] ] test_strToAL = let f inp exp = TestLabel (show inp) $ TestCase $ do let r = strFromAL inp exp @=? r inp @=? strToAL r in [ f ([]::[(String, String)]) "" ,f [("foo", "bar")] "\"foo\",\"bar\"\n" ,f [("foo", "bar"), ("baz", "quux")] "\"foo\",\"bar\"\n\"baz\",\"quux\"\n" ,f [(1::Int, 2::Int), (3, 4)] "1,2\n3,4\n" ,f [(1::Int, "one"), (2, "two")] "1,\"one\"\n2,\"two\"\n" ,f [("one", 1::Double), ("n\nl", 2::Double)] "\"one\",1.0\n\"n\\nl\",2.0\n" ] test_spanList = let f func inp exp = TestLabel (show inp) $ TestCase $ exp @=? spanList func inp in [f (contains "foo") "Testfoobar" ("Testf", "oobar"), f (\_ -> True) "Testasdf" ("Testasdf", ""), f (\_ -> False) "Testasdf" ("", "Testasdf"), f (contains "foo") "" ("", ""), f (contains "foo") "foo" ("f", "oo")] 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 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, TestLabel "delFromAL" (TestList test_delFromAL), TestLabel "uniq" (TestList test_uniq), TestLabel "addToAL" (TestList test_addToAL), TestLabel "split" (TestList test_split), TestLabel "join" (TestList test_join), TestLabel "genericJoin" (TestList test_genericJoin), TestLabel "trunc" (TestList test_trunc), TestLabel "flipAL" (TestList test_flipAL), TestLabel "elemRIndex" (TestList test_elemRIndex), TestLabel "alwaysElemRIndex" (TestList test_alwaysElemRIndex), TestLabel "replace" (TestList test_replace), TestLabel "contains" (TestList test_contains), TestLabel "strFromAL & strToAL" (TestList test_strToAL), TestLabel "fixedWidth" (TestList test_fixedWidth), TestLabel "subIndex" (TestList test_subIndex), TestLabel "spanList" (TestList test_spanList)] MissingH-1.2.0.0/Setup.hs0000644000175000017500000000010712027213047015251 0ustar jgoerzenjgoerzen#!/usr/bin/env runhugs import Distribution.Simple main = defaultMain MissingH-1.2.0.0/winbuild.bat0000644000175000017500000000011212027213047016116 0ustar jgoerzenjgoerzenghc -package Cabal Setup.hs -o setup.exe setup configure setup build MissingH-1.2.0.0/announcements/0000755000175000017500000000000012027213047016474 5ustar jgoerzenjgoerzenMissingH-1.2.0.0/announcements/0.8.0.txt0000644000175000017500000000370412027213047017704 0ustar jgoerzenjgoerzenMissingH 0.8.0 -- the "Festive Lambda" release New feature summary: * Virtualized I/O system Use familiar functions to work on not just Handles but all sorts of other types, including in-memory buffers. (HVIO module) * Virtualized filesystem Extends the virtual I/O concept to the filesystem, supporting entire virtual filesystems, and operations such as renames, stat(), etc. on them. (HVFS module) * Network server infrastructure Makes it easy to write a network server in Haskell. Functional interface permits easy adding of things such as multithreading, logging, etc. Functions to do these things are provided. Patterned loosely after Python's SocketServer system. (SocketServer module) * Full, pure-Haskell FTP server Provides a full FTP server over a real or virtual (HVFS) filesystem. It's a SocketServer server, so you get multithreading for free. Supports passive eand port modes. See below for an example: * Many path/file manipulation functions imported from Volker's HsShellScript. * Existing MissingH.IO functions updated to be HVIO compatible. MissingH 0.8.0 is available from: gopher://gopher.quux.org/1/devel/missingh or http://gopher.quux.org:70/devel/missingh ------------------------------------------------------------ Here is an example of a fully self-contained FTP server that serves up the local filesystem in read-only mode: import MissingH.Network.FTP.Server import MissingH.Network.SocketServer import MissingH.Logging.Logger import MissingH.IO.HVFS import MissingH.IO.HVFS.Combinators main = do updateGlobalLogger "" (setLevel DEBUG) updateGlobalLogger "MissingH.Network.FTP.Server" (setLevel DEBUG) let opts = (simpleTCPOptions 12345) {reuse = True} serveTCPforever opts $ threadedHandler $ loggingHandler "" INFO $ handleHandler $ anonFtpHandler (HVFSReadOnly SystemFS) # arch-tag: 0.8.0 announcement MissingH-1.2.0.0/announcements/0.10.0.txt0000644000175000017500000000454612027213047017762 0ustar jgoerzenjgoerzenMissingH 0.10.0 New feature summary: * Compatibility with Hugs 2005xx and GHC 6.4. Compatibility with GHC 6.2 has been retained. Compatibility with Hugs 2003xx is mostly retained but not completely possible. * Tighter integration with Cabal. * Better installation instructions. * New parser for debian/control files and similar Debian commands (does not require Debian to build/run) * New parser for CSV files * New utility for Maybe type * New binary I/O utilities (readBinaryFile, writeBinaryFile) * Powerful new list mainpulation functions: wholeMap, fixedWidth * New function: epochToClockTime ------------------------- What is MissingH? ------------------------- It's a collection of Haskell-related utilities. It is an extension of my earlier work developing MissingLib for OCaml. You can download MissingH from http://quux.org/devel/missingh. There is a mirror, with a few days' lag, at http://ftp.debian.org/debian/pool/main/m/missingh. ------------------------- Major Features ------------------------- * Powerful Logging Framework for Haskell This framework provides a system of hierarchical loggers and modular handlers permitting fine-grained logging with a great deal of control and yet a simple and fast interface. It's based on log4j for Java and logging for Python. Also included is a native-Haskell Syslog client. * Versatile modules to simplify everyday tasks: + FTP client library + E-mail client library + MIME types library to determine MIME types from files or URLs + Configuration file parser/generator * IO utilities make it easier to work with line-based text files and binary files * IO object virtualization so you can use one set of code to work on files of many different types * Filesystem virtualization so you can access variuos items with the same ease as your system's filesystem * Network utilities to streamline connections * List utilities including association list tools, list splitting, truncation, and delimiter joining * String utilities including removal of leading or trailing whitespace, joining, splitting, and truncation * Other utilities for threads, parers, filenames, etc. * Printf utilities for formatting strings * GZip decompression * Hundreds of unit tests to verify proper functionality * DBM module abstraction # arch-tag: 0.10.0 announcement MissingH-1.2.0.0/announcements/0.9.0.txt0000644000175000017500000000544012027213047017704 0ustar jgoerzenjgoerzenMissingH 0.9.0 New feature summary: * Perl-like regular expression operators (MissingH.Regex.Pesco) This module builds atop the standard POSIX Text.Regex module, extending it to be far more convenient with easier maching, grouping, and substitution operations. (Integrated from Pesco) * strToAL, strFomAL (MissingH.List) Converts any [(String, String)] and many other association lists to a simple string representation that can be stored on-disk or sent across the network. Also, re-generates the original list upon parsing the string representation. Used internally by MissingH.AnyDBM.StringDBM. * Persistent or non-persistent DBM storage class MissingH.AnyDBM is an abstraction for various mapping systems. MissingH itself provides an implementation using a non-persistent HashTable or FiniteMap, as well as a persistent StringDBM. Bindings to dbm, gdbm, dbhash, etc. are in the works and will be simple members of this typeclass. * Major cleaning up of the build system. Description of MissingH from README: ------------------------- What is MissingH? ------------------------- It's a collection of Haskell-related utilities. It is an extension of my earlier work developing MissingLib for OCaml. You can download MissingH from http://quux.org/devel/missingh. There is a mirror, with a few days' lag, at http://ftp.debian.org/debian/pool/main/m/missingh. ------------------------- Major Features ------------------------- * Powerful Logging Framework for Haskell This framework provides a system of hierarchical loggers and modular handlers permitting fine-grained logging with a great deal of control and yet a simple and fast interface. It's based on log4j for Java and logging for Python. Also included is a native-Haskell Syslog client. * Versatile modules to simplify everyday tasks: + FTP client library + E-mail client library + MIME types library to determine MIME types from files or URLs + Configuration file parser/generator * IO utilities make it easier to work with line-based text files and binary files * IO object virtualization so you can use one set of code to work on files of many different types * Filesystem virtualization so you can access variuos items with the same ease as your system's filesystem * Network utilities to streamline connections * List utilities including association list tools, list splitting, truncation, and delimiter joining * String utilities including removal of leading or trailing whitespace, joining, splitting, and truncation * Other utilities for threads, parers, filenames, etc. * Printf utilities for formatting strings * GZip decompression * Hundreds of unit tests to verify proper functionality * DBM module abstraction # arch-tag: 0.9.0 announcement