diff --git a/Data/Enumerator.hs b/Data/Enumerator.hs new file mode 100644 --- /dev/null +++ b/Data/Enumerator.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE Rank2Types #-} + +module Data.Enumerator + ( -- Enumerators + bytesEnum, + chunkEnum, + partialSocketEnum, + socketEnum, + + -- Combining enumerators + compose + ) where + +import Control.Monad (liftM) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C (unpack) +import Data.Word (Word8) +import Network.Socket (Socket) +import Network.Socket.ByteString (recv) +import Numeric (readHex) + +type IterateeM a m = a -> S.ByteString -> m (Either a a) +type EnumeratorM m = forall a. IterateeM a m -> a -> m a + +-- ----------------------------------------------------------- +-- Enumerators + +-- | Enumerates a 'ByteString'. +bytesEnum :: Monad m => S.ByteString -> EnumeratorM m +bytesEnum bs f seed = do + seed' <- f seed bs + case seed' of + Left seed'' -> return seed'' + Right seed'' -> return seed'' + + +nl :: Word8 +nl = 10 + +-- | Enumerates chunks of data encoded using HTTP chunked encoding. +chunkEnum :: Monad m => EnumeratorM m -> EnumeratorM m +chunkEnum enum f initSeed = fst `liftM` enum go (initSeed, Left S.empty) + where + go (seed, Left acc) bs = + case S.elemIndex nl bs of + Just ix -> let (line, rest) = S.splitAt (ix + 1) bs + hdr = S.append acc line + chunkLen = pHeader hdr + in case chunkLen of + Just n -> go (seed, Right n) rest + Nothing -> error $ "malformed header" ++ show hdr + Nothing -> return $ Right (seed, Left (S.append acc bs)) + go (seed, Right n) bs = + let len = S.length bs + in if len < n + then do + seed' <- f seed bs + case seed' of + Right seed'' -> return $ Right (seed'', Right $! n - len) + Left seed'' -> return $ Left (seed'', Right $! n - len) + else let (bs', rest) = S.splitAt n bs + in do + seed' <- f seed bs' + case seed' of + Right seed'' -> go (seed'', Left S.empty) rest + Left seed'' -> return $ Left (seed'', Left rest) + +-- TODO: Ignore header. +pHeader :: S.ByteString -> Maybe Int +pHeader bs = + case readHex $ C.unpack hdr of + [(n, "")] -> Just n + _ -> Nothing + where + hdr = S.take (S.length bs - 2) bs + +-- | Maximum number of bytes sent or received in every socket +-- operation. +blockSize :: Int +blockSize = 4 * 1024 + +-- | @partialSocketEnum sock numBytes@ enumerates @numBytes@ bytes +-- received through the given socket. Does not close the socket. +partialSocketEnum :: Socket -> Int -> EnumeratorM IO +partialSocketEnum sock numBytes f initSeed = go initSeed numBytes + where + go seed 0 = return seed + go seed n = do + bs <- recv sock blockSize + if S.null bs + then return seed + else do + seed' <- f seed bs + case seed' of + Right seed'' -> go seed'' $! n - S.length bs + Left seed'' -> return seed'' + +-- | Enumerates data received through the given socket. Does not +-- close the socket. +socketEnum :: Socket -> EnumeratorM IO +socketEnum sock f initSeed = go initSeed + where + go seed = do + bs <- recv sock blockSize + if S.null bs + then return seed + else do + seed' <- f seed bs + case seed' of + Right seed'' -> go seed'' + Left seed'' -> return seed'' + +-- ----------------------------------------------------------- +-- Combining enumerators + +-- Make two enumerators behave like one. +compose :: Monad m => EnumeratorM m -> EnumeratorM m -> EnumeratorM m +compose enum1 enum2 f initSeed = enum1 f1 (Right initSeed) >>= k + where + f1 (Right seed) bs = do + r <- f seed bs + case r of + x@(Right _) -> return $ Right x + x -> return $ Left x + f1 x _ = return $ Left x -- Cannot happen. + k (Left seed) = return seed + k (Right seed) = enum2 f seed diff --git a/Hyena/Config.hs b/Hyena/Config.hs new file mode 100644 --- /dev/null +++ b/Hyena/Config.hs @@ -0,0 +1,212 @@ +------------------------------------------------------------------------ +-- | +-- Module : Hyena.Config +-- Copyright : (c) Johan Tibell 2008 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module specifies the server configuration. +-- +------------------------------------------------------------------------ + +module Hyena.Config + ( Config(..), + configFromFlags, + defaultConfig + ) where + +import Control.Monad (when) +import Data.Monoid (Monoid(..)) +import System.Console.GetOpt +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.FilePath ((), dropFileName) +import System.IO (BufferMode(..), Handle, IOMode(..), hSetBuffering, openFile, + stderr) + +-- --------------------------------------------------------------------- +-- Config type + +-- | The server configuration. +data Config = Config + { address :: String + -- ^ Address (hostname or IP) to bind to when listening for + -- connections. + , daemonize :: Bool + -- ^ Run in the background. + , debug :: Bool + -- ^ Print lots of debug information. + , logHandle :: Handle + -- ^ Where to dump log messages in daemon mode. + , port :: Int + -- ^ Port to bind to when listening for connections. + } deriving Show + +-- | Converts a set of flags into a server configuration. +flagsToConfig :: Flags -> IO Config +flagsToConfig flags = do + when (flag flagDaemonize) $ + createDirectoryIfMissing True $ dropFileName (flag flagLogFile) + logHandle' <- if flag flagDaemonize + then openFile (flag flagLogFile) AppendMode + else return stderr + hSetBuffering logHandle' LineBuffering + return Config + { address = flag flagAddress + , daemonize = flag flagDaemonize + , debug = flag flagDebug + , logHandle = logHandle' + , port = flag flagPort + } + where flag field = fromFlag $ field flags + +-- | Reads the server options from the command line. Settings from +-- 'defaultConfig' is used for unspecified options. Creates missing +-- directories as needed for the log file referred to by the @--log@ +-- flag when in 'daemonize'd mode. +configFromFlags :: IO Config +configFromFlags = do + argv <- getArgs + cwd <- getCurrentDirectory + progName <- getProgName + case parseArgs argv progName of + Left err -> putStr err >> exitFailure + Right flags -> flagsToConfig $ defaultFlags cwd `mappend` flags + +-- | A set of default options most users should use. Creates missing +-- directories as needed for the default log file when in 'daemonize'd +-- mode. +defaultConfig :: IO Config +defaultConfig = do + cwd <- getCurrentDirectory + flagsToConfig $ defaultFlags cwd + +-- --------------------------------------------------------------------- +-- Flag type + +data Flag a = Flag a | NoFlag deriving Show + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Monoid (Flag a) where + mempty = NoFlag + _ `mappend` f@(Flag _) = f + f `mappend` NoFlag = f + +fromFlag :: Flag a -> a +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag" + +-- --------------------------------------------------------------------- +-- Config flags + +data Flags = Flags + { flagAddress :: Flag String + , flagDaemonize :: Flag Bool + , flagDebug :: Flag Bool + , flagLogFile :: Flag FilePath + , flagPort :: Flag Int + } deriving Show + +defaultFlags :: FilePath -> Flags +defaultFlags cwd = + -- NOTE: If we add a flag to change the working directory it has + -- to be taken into account here. + Flags { flagAddress = Flag "0.0.0.0" + , flagDaemonize = Flag False + , flagDebug = Flag False + , flagLogFile = Flag $ cwd "log/hyena.log" + , flagPort = Flag 3000 + } + +emptyFlags :: Flags +emptyFlags = mempty + +instance Monoid Flags where + mempty = Flags + { flagAddress = mempty + , flagDaemonize = mempty + , flagDebug = mempty + , flagLogFile = mempty + , flagPort = mempty + } + mappend a b = Flags + { flagAddress = combine flagAddress + , flagDaemonize = combine flagDaemonize + , flagDebug = combine flagDebug + , flagLogFile = combine flagLogFile + , flagPort = combine flagPort + } + where combine field = field a `mappend` field b + +-- --------------------------------------------------------------------- +-- Args parsing + +-- | Converts a 'String' containing a port number to an integer and +-- fails with an 'error' if the 'String' contained non-digit +-- characters. +flagToPort :: String -> Int +flagToPort str = + case reads str of + [(i, "")] -> i + _ -> error $ "--port: invalid port `" ++ str ++ "'" + +-- | The command line options. +options :: [OptDescr (Flags -> Flags)] +options = + [Option "a" ["address"] + (reqArgFlag "ADDRESS" flagAddress + (\v flags -> flags {flagAddress = v})) + "bind to ADDRESS (hostname or IP) on localhost" + ,Option "d" ["daemonize"] + (trueArg flagDaemonize (\v flags -> flags {flagDaemonize = v})) + "run in the background" + ,Option "B" ["debug"] + (trueArg flagDebug (\v flags -> flags {flagDebug = v})) + "print lots of debug information" + ,Option "l" ["log"] + (reqArgFlag "FILE" flagLogFile + (\v flags -> flags {flagLogFile = v})) + "dump log messages to FILE when daemonized" + ,Option "p" ["port"] + (reqArg "PORT" (Flag . flagToPort) + flagPort (\v flags -> flags {flagPort = v})) + "bind to PORT on localhost" + ] + +-- | Parses the given command line arguments. Returns either the +-- parsed flags or a 'String' explaining the error on failure. +parseArgs :: [String] -> String -> Either String Flags +parseArgs argv progName = + case getOpt Permute options argv of + (flags, _, []) -> Right $ foldl (flip id) emptyFlags flags + (_, _, errs) -> Left $ concat errs ++ usageInfo header options + where header = "Usage: " ++ progName ++ " [OPTION]..." + +-- --------------------------------------------------------------------- +-- GetOpt helpers + +reqArg :: (Monoid a) => + String -> (String -> a) -> (t -> a) -> (a -> t -> t1) + -> ArgDescr (t -> t1) +reqArg name mkFlag get set = + ReqArg (\v flags -> set (get flags `mappend` mkFlag v) flags) name + +noArg :: (Monoid a) => a -> (t -> a) -> (a -> t -> t1) -> ArgDescr (t -> t1) +noArg flag get set = + NoArg (\flags -> set (get flags `mappend` flag) flags) + +trueArg :: (t -> Flag Bool) -> (Flag Bool -> t -> t1) + -> ArgDescr (t -> t1) +trueArg = noArg (Flag True) + +reqArgFlag :: String -> (t -> Flag String) -> (Flag String -> t -> t1) + -> ArgDescr (t -> t1) +reqArgFlag name = reqArg name Flag + diff --git a/Hyena/Http.hs b/Hyena/Http.hs new file mode 100644 --- /dev/null +++ b/Hyena/Http.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE Rank2Types #-} + +-- See: http://www.w3.org/Protocols/rfc2616/rfc2616.html + +------------------------------------------------------------------------ +-- | +-- Module : Hyena.Http +-- Copyright : (c) Johan Tibell 2008 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Receiving and sending HTTP requests and responses. +-- +------------------------------------------------------------------------ + +module Hyena.Http + ( -- * The request and response data types + Request(..), + Response(..), + + -- * Sending and receiving + sendResponse, + isValidStatusCode, + receiveRequest, + + -- * Common responses + errorResponse, + + -- * Parsing + parseRequest + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C (map, pack, unpack) +import Data.Char (chr, digitToInt, isAlpha, isDigit, isSpace, ord, toLower) +import Data.Either (either) +import Control.Arrow +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Word (Word8) +import Network.Socket (Socket) +import Network.Socket.ByteString (recv, send) +import Network.Wai (Enumerator, Headers, Method(..)) + +import Data.Enumerator +import Hyena.Parser + +-- --------------------------------------------------------------------- +-- Request and response data types + +-- | An HTTP request. +data Request = Request + { method :: Method + , requestUri :: S.ByteString + , httpVersion :: (Int, Int) + , requestHeaders :: [(S.ByteString, S.ByteString)] + , requestBody :: Enumerator + } + +-- | An internal representation of the request header part of an HTTP +-- request. +data IRequest = IRequest + { iMethod :: Method + , iRequestUri :: S.ByteString + , iHttpVersion :: (Int, Int) + , iRequestHeaders :: [(S.ByteString, S.ByteString)] + } deriving Show + +-- | An HTTP response. +data Response = Response + { statusCode :: Int + , reasonPhrase :: S.ByteString + , responseHeaders :: [(S.ByteString, S.ByteString)] + , responseBody :: Enumerator + } + +-- --------------------------------------------------------------------- +-- Sending and receiving + +-- | Maximum number of bytes sent or received in every socket operation. +blockSize :: Int +blockSize = 4 * 1024 + +-- | Send response over socket. +sendResponse :: Socket -> Response -> IO () +sendResponse sock resp = do + -- TODO: Check if all data was sent. + send sock $ S.concat [C.pack "HTTP/1.1 " + ,(C.pack $ show (statusCode resp) ++ " " + ++(C.unpack $ reasonPhrase resp)) + ,C.pack "\r\n"] + sendHeaders sock (responseHeaders resp) + send sock $ C.pack "\r\n" + responseBody resp (sendMessageBody sock) () + -- TODO: Flush the socket. + +-- TODO: Check if all bytes were sent, otherwise retry. + +-- | Iteratee used for sending message body over socket. +sendMessageBody :: Socket -> () -> S.ByteString -> IO (Either () ()) +sendMessageBody sock _ bs = send sock bs >> return (Right ()) + +-- | Send headers over socket. +sendHeaders :: Socket -> Headers -> IO () +sendHeaders sock headers = do + send sock $ S.concat $ map go headers + return () + where go (k, v) = S.concat [k, C.pack ": " + ,v, C.pack "\r\n"] + +-- | Receive request from socket. If the request is malformed +-- 'Nothing' is returned. +receiveRequest :: Socket -> IO (Maybe Request) +receiveRequest sock = do + x <- parseIRequest sock + case x of + Nothing -> return Nothing + Just (req, bs) -> + let len = contentLength req + rest = bytesEnum bs + enum = case len of + Just n -> partialSocketEnum sock (n - S.length bs) + Nothing -> chunkEnum $ socketEnum sock + in return $ Just + Request + { method = iMethod req + , requestUri = iRequestUri req + , httpVersion = iHttpVersion req + , requestHeaders = iRequestHeaders req + , requestBody = compose rest enum + } + +-- | The length of the request's message body, if present. +contentLength :: IRequest -> Maybe Int +contentLength req + | iMethod req `elem` [Options, Get, Head] = Just 0 + | otherwise = do v <- getHeader "Content-Length" req + toInt $ C.unpack v + where + toInt str = case reads str of + [(i, "")] -> Just i + _ -> Nothing + +-- | Get header if present. +getHeader :: String -> IRequest -> Maybe S.ByteString +getHeader hdr req = lookup (C.map toLower $ C.pack hdr) headers + where + mapFst = map . first + headers = mapFst (C.map toLower) (iRequestHeaders req) + +-- --------------------------------------------------------------------- +-- Common responses + +-- | An error response with an empty message body. Closes the +-- connection. +errorResponse :: Int -> Response +errorResponse status = + Response + { statusCode = status + , reasonPhrase = fromJust $ M.lookup status reasonPhrases + , responseHeaders = [(C.pack "Connection", C.pack "close")] + , responseBody = emptyMessageBody + } + +-- --------------------------------------------------------------------- +-- Parsing requests + +c2w :: Char -> Word8 +c2w = fromIntegral . ord + +-- | Parsers for different tokens in an HTTP request. +sp, digit, letter, nonSpace, notEOL :: Parser Word8 +sp = byte $ c2w ' ' +digit = satisfies (isDigit . chr . fromIntegral) +letter = satisfies (isAlpha . chr . fromIntegral) +nonSpace = satisfies (not . isSpace . chr . fromIntegral) +notEOL = noneOf $ map c2w "\r\n" + +-- | Parser for request \"\r\n\" sequence. +crlf :: Parser S.ByteString +crlf = bytes $ C.pack "\r\n" + +-- | Parser that recognize if the current byte is an element of the +-- given sequence of bytes. +oneOf, noneOf :: [Word8] -> Parser Word8 +oneOf bs = satisfies (`elem` bs) +noneOf bs = satisfies (`notElem` bs) + +-- | Parser for zero or more spaces. +spaces :: Parser [Word8] +spaces = many sp + +-- | Parses the header part (i.e. everything expect for the request +-- body) of an HTTP request. Returns any bytes read that were not +-- used when parsing. Returns @Nothing@ on failure and @Just +-- (request, remaining)@ on success. +parseIRequest :: Socket -> IO (Maybe (IRequest, S.ByteString)) +parseIRequest sock = do + initial <- recv sock blockSize + go $ runParser pIRequest initial + where + go (Finished req bs) = return $ Just (req, bs) + go (Failed _) = return Nothing + -- TODO: Detect end of input. + go (Partial k) = recv sock blockSize >>= go . k . Just + +-- | Parser for the internal request data type. +pIRequest :: Parser IRequest +pIRequest = IRequest + <$> pMethod <* sp + <*> pUri <* sp + <*> pVersion <* crlf + <*> pHeaders <* crlf + +-- | Parser for the request method. +pMethod :: Parser Method +pMethod = (Options <$ bytes (C.pack "OPTIONS")) + <|> (Get <$ bytes (C.pack "GET")) + <|> (Head <$ bytes (C.pack "HEAD")) + <|> byte (c2w 'P') *> ((Post <$ bytes (C.pack "OST")) <|> + (Put <$ bytes (C.pack "UT"))) + <|> (Delete <$ bytes (C.pack "DELETE")) + <|> (Trace <$ bytes (C.pack "TRACE")) + <|> (Connect <$ bytes (C.pack "CONNECT")) + +-- | Parser for the request URI. +pUri :: Parser S.ByteString +pUri = fmap S.pack $ many nonSpace + +-- | Parser for the request's HTTP protocol version. +pVersion :: Parser (Int, Int) +pVersion = bytes (C.pack "HTTP/") *> + liftA2 (,) (digit' <* byte (c2w '.')) digit' + where + digit' = fmap (digitToInt . chr . fromIntegral) digit + +-- | Parser for request headers. +pHeaders :: Parser [(S.ByteString, S.ByteString)] +pHeaders = many header + where + header = liftA2 (,) fieldName (byte (c2w ':') *> spaces *> contents) + fieldName = liftA2 S.cons letter fieldChars + contents = liftA2 S.append (fmap S.pack $ some notEOL <* crlf) + (continuation <|> pure S.empty) + continuation = liftA2 S.cons (c2w ' ' <$ + some (oneOf (map c2w " \t"))) contents + +-- It's important that all these three definitions are kept on the top +-- level to have RULES fire correctly. + +-- | Parser for zero or more bytes in a header field. +fieldChars :: Parser S.ByteString +fieldChars = fmap S.pack $ many fieldChar + +-- fieldChar = letter <|> digit <|> oneOf (map c2w "-_") + +-- | Parser for one header field byte. +fieldChar :: Parser Word8 +fieldChar = satisfies isFieldChar + where + isFieldChar b = (isDigit $ chr $ fromIntegral b) || + (isAlpha $ chr $ fromIntegral b) || + (b `elem` map c2w "-_") + +-- --------------------------------------------------------------------- +-- Helpers + +-- | An empty 'Enumerator' that just returns the passed in seed. +emptyMessageBody :: Enumerator +emptyMessageBody _ = return + +-- | Test if the given HTTP status code is valid. +isValidStatusCode :: Int -> Bool +isValidStatusCode code = M.member code reasonPhrases + +-- | Mapping from status code to reason phrases. +reasonPhrases :: M.Map Int S.ByteString +reasonPhrases = M.fromList . map (second C.pack) $ + [(100, "Continue") + ,(101, "Switching Protocols") + ,(200, "OK") + ,(201, "Created") + ,(202, "Accepted") + ,(203, "Non-Authoritative Information") + ,(204, "No Content") + ,(205, "Reset Content") + ,(206, "Partial Content") + ,(300, "Multiple Choices") + ,(301, "Moved Permanently") + ,(302, "Found") + ,(303, "See Other") + ,(304, "Not Modified") + ,(305, "Use Proxy") + ,(307, "Temporary Redirect") + ,(400, "Bad Request") + ,(401, "Unauthorized") + ,(402, "Payment Required") + ,(403, "Forbidden") + ,(404, "Not Found") + ,(405, "Method Not Allowed") + ,(406, "Not Acceptable") + ,(407, "Proxy Authentication Required") + ,(408, "Request Time-out") + ,(409, "Conflict") + ,(410, "Gone") + ,(411, "Length Required") + ,(412, "Precondition Failed") + ,(413, "Request Entity Too Large") + ,(414, "Request-URI Too Large") + ,(415, "Unsupported Media Type") + ,(416, "Requested range not satisfiable") + ,(417, "Expectation Failed") + ,(500, "Internal Server Error") + ,(501, "Not Implemented") + ,(502, "Bad Gateway") + ,(503, "Service Unavailable") + ,(504, "Gateway Time-out") + ,(505, "HTTP Version not supported")] + +-- TODO: Return remaining bytes if Content-Length present. + +-- | Parse a request from a sequence of bytes. +parseRequest :: S.ByteString -> IO (Maybe (Request, S.ByteString)) +parseRequest input = + go $ runParser pIRequest input + where + go (Failed _) = return Nothing + go (Partial k) = go (k Nothing) + go (Finished req bs) = + let req' = Request + { method = iMethod req + , requestUri = iRequestUri req + , httpVersion = iHttpVersion req + , requestHeaders = iRequestHeaders req + , requestBody = \f z -> either id id `fmap` f z bs + } + in return $ Just (req', S.empty) diff --git a/Hyena/Logging.hs b/Hyena/Logging.hs new file mode 100644 --- /dev/null +++ b/Hyena/Logging.hs @@ -0,0 +1,145 @@ +module Hyena.Logging + ( -- * The Logger and LogRequest types + AccessLogger, + LogRequest(..), + ErrorLogger, + + -- * Logging + startAccessLogger, + stopAccessLogger, + logAccess, + startErrorLogger, + stopErrorLogger, + logError, + ) where + +import qualified Data.ByteString.Char8 as C +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Network.Socket (HostAddress, inet_ntoa) +import Network.Wai (Method(..)) +import Prelude hiding (log) +import System.IO (Handle, hFlush, hPutStr, hPutStrLn) +import Text.Printf (printf) + +import Hyena.Http (Request(..), Response(..)) + +-- --------------------------------------------------------------------- +-- The Logger and LogRequest types + +-- | A queue of messages waiting to be logged. +data Logger a = Logger + { channel :: Chan (Maybe a) + , finished :: MVar () + -- ^ The logger puts a value here once it has terminated. + } + +-- | A description of a processed request. +data LogRequest = LogRequest + { hostAddress :: HostAddress + , request :: Request + , response :: Response + } + +-- | A logger for client requests. +newtype AccessLogger = AccessLogger (Logger LogRequest) + +-- | A logger for error messages. +newtype ErrorLogger = ErrorLogger (Logger String) + +-- --------------------------------------------------------------------- +-- Logging + +-- | Start a new logger in a separate thread that runs until +-- 'stopLogger' is called. Returns a 'Logger' that can be used to log +-- messages. +startLogger :: (Handle -> a -> IO ()) -> Handle -> IO (Logger a) +startLogger writer logHandle = do + chan <- newChan + finished' <- newEmptyMVar + forkIO $ logMessages chan finished' + return Logger { channel = chan + , finished = finished' + } + where + logMessages chan finished' = do + msg <- readChan chan + case msg of + Just msg' -> writer logHandle msg' >> + logMessages chan finished' + Nothing -> putMVar finished' () + +-- | Stop the access after all currently enqueued log requests have +-- been processed. Waits until the logger has finished. +stopLogger :: Logger a -> IO () +stopLogger logger = do + writeChan (channel logger) Nothing + takeMVar (finished logger) + +-- | Start a new logger that logs client requests. +startAccessLogger :: Handle -> IO AccessLogger +startAccessLogger = fmap AccessLogger . startLogger writeAccess + +-- | Stop a client request logger. +stopAccessLogger :: AccessLogger -> IO () +stopAccessLogger (AccessLogger logger) = stopLogger logger + +-- | Start a new logger that logs error messages. +startErrorLogger :: Handle -> IO ErrorLogger +startErrorLogger = fmap ErrorLogger . startLogger writeError + +-- | Stop error message logger. +stopErrorLogger :: ErrorLogger -> IO () +stopErrorLogger (ErrorLogger logger) = stopLogger logger + +-- | Log an error. +logError :: ErrorLogger -> String -> IO () +logError (ErrorLogger logger) = writeChan (channel logger) . Just + +-- | Write error message to the given 'Handle'. +writeError :: Handle -> String -> IO () +writeError handle msg = hPutStr handle msg >> hFlush handle + +-- | Log a client request. +logAccess :: AccessLogger -> Request -> Response -> HostAddress -> IO () +logAccess (AccessLogger logger) req resp haddr = + writeChan (channel logger) $ Just + LogRequest + { hostAddress = haddr + , request = req + , response = resp + } + +-- | Write client request log message to the given 'Handle'. +writeAccess :: Handle -> LogRequest -> IO () +writeAccess h logReq = do + host <- inet_ntoa (hostAddress logReq) + let requestLine = printf "\"%s %s HTTP/%s\"" method' uri version + response' = show (statusCode $ response logReq) ++ " " ++ show length' + hPutStrLn h $ host ++ " " ++ requestLine ++ " " ++ response' + where + (major, minor) = httpVersion $ request logReq + version = show major ++ "." ++ show minor + method' = prettyPrint $ method $ request logReq + uri = C.unpack $ requestUri $ request logReq + respHeaders = responseHeaders $ response logReq + -- TODO: Calculate the size in case Content-Length is missing. + length' :: Int + length' = maybe 0 (read . C.unpack) + (lookup (C.pack "Content-Length") respHeaders) + +class PrettyPrint a where + prettyPrint :: a -> String + +-- | Converts from a 'Method' enumeration to the corresponding HTTP +-- string. +instance PrettyPrint Method where + prettyPrint Options = "OPTIONS" + prettyPrint Get = "GET" + prettyPrint Head = "HEAD" + prettyPrint Post = "POST" + prettyPrint Put = "PUT" + prettyPrint Delete = "DELETE" + prettyPrint Trace = "TRACE" + prettyPrint Connect = "CONNECT" diff --git a/Hyena/Parser.hs b/Hyena/Parser.hs new file mode 100644 --- /dev/null +++ b/Hyena/Parser.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE Rank2Types #-} + +------------------------------------------------------------------------ +-- | +-- Module : Hyena.Parser +-- Copyright : (c) Johan Tibell 2008 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- A resumable LL(1) parser combinator library for 'ByteString's. +-- +------------------------------------------------------------------------ + +module Hyena.Parser + ( + -- * The Parser type + Parser, + Result(..), + runParser, + + -- * Primitive parsers + satisfies, + byte, + bytes, + + module Control.Applicative + ) where + +import Control.Applicative +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import Data.Int (Int64) +import Data.Word (Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peekByteOff) +import Prelude hiding (fail, rem, succ) +import Text.Show.Functions () + +-- --------------------------------------------------------------------- +-- The Parser type + +-- | The parse state. +data S r = S + {-# UNPACK #-} !S.ByteString + {-# UNPACK #-} !Int64 + {-# UNPACK #-} !Bool + {-# UNPACK #-} !(S r -> Result r) + deriving Show + +-- | Set the failure continuation. +setFail :: S r -> (S r -> Result r) -> S r +setFail (S bs pos eof _) = S bs pos eof +{-# INLINE setFail #-} + +-- | A parse either succeeds, fails or returns a suspension with which +-- the parsing can be resumed. +data Result a = Finished a S.ByteString + -- ^ Parsing succeeded and produced a value of type + -- @a@. The returned 'S.ByteString' is the remaining + -- unconsumed input. + | Failed Int64 + -- ^ Parsing failed at the given position. Either + -- because the parser didn't match the input or because + -- an unexpected end of input was reached during + -- parsing. + | Partial (Maybe S.ByteString -> Result a) + -- ^ The parsing needs more input to continue. Pass in + -- @Just input@ to continue parsing and @Nothing@ to + -- signal end of input. If @Nothing@ is passed the + -- 'Result' is either 'Finished' or 'Failed'. + deriving Show + +-- | A parser takes a parse state, a success continuation and returns +-- a 'Result'. +newtype Parser a = Parser + { unParser :: forall r. S r -> (a -> S r -> Result r) -> Result r } + +-- --------------------------------------------------------------------- +-- Instances + +instance Functor Parser where + fmap f p = Parser $ \s succ -> unParser p s (succ . f) + {-# INLINE fmap #-} + +instance Applicative Parser where + pure a = Parser $ \s succ -> succ a s + {-# INLINE pure #-} + + p <*> p' = Parser $ \s succ -> + let succ' f s' = unParser p' s' (succ . f) + in unParser p s succ' + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = Parser $ \s@(S _ _ _ fail) _ -> fail s + {-# INLINE empty #-} + + p <|> p' = Parser $ \s@(S _ _ _ fail) succ -> + let fail' s' = unParser p' (setFail s' fail) succ + in unParser p (setFail s fail') succ + {-# INLINE (<|>) #-} + +-- --------------------------------------------------------------------- +-- Running a parser + +initState :: S.ByteString -> S r +initState bs = S bs 0 False failed +{-# INLINE initState #-} + +-- | This is the final continuation that turns a successful parse into +-- a 'Result'. +finished :: a -> S r -> Result a +finished v (S bs _ _ _) = Finished v bs + +-- | This is the final continuation that turns an unsuccessful parse +-- into a 'Result'. +failed :: S r -> Result a +failed (S _ pos _ _) = Failed pos + +-- | TODO: Write documentation. +runParser :: Parser a -> S.ByteString -> Result a +runParser p bs = unParser p (initState bs) finished + +-- --------------------------------------------------------------------- +-- Primitive parsers + +-- | The parser @satisfies p@ succeeds for any byte for which the +-- supplied function @p@ returns 'True'. Returns the byte that is +-- actually parsed. +satisfies :: (Word8 -> Bool) -> Parser Word8 +satisfies p = + Parser $ \s@(S bs pos eof fail) succ -> + case S.uncons bs of + Just (b, bs') -> if p b + then succ b (S bs' (pos + 1) eof failed) + else fail s + Nothing -> if eof + then fail s + else Partial $ \x -> + case x of + Just bs' -> retry (S bs' pos eof fail) + Nothing -> fail (S bs pos True fail) + where retry s' = unParser (satisfies p) s' succ + +-- | @byte b@ parses a single byte @b@. Returns the parsed byte +-- (i.e. @b@). +byte :: Word8 -> Parser Word8 +byte b = satisfies (== b) + +-- TODO: Check when we can let go of the failure continuation. + +-- | @bytes bs@ parses a sequence of bytes @bs@. Returns the parsed +-- bytes (i.e. @bs@). +bytes :: S.ByteString -> Parser S.ByteString +bytes bs = + Parser $ \(S bs' pos eof fail) succ -> + let go rem inp + | len == remLen = + succ bs (S (S.drop len inp) newPos eof failed) + | len < remLen && inpLen >= remLen = + fail (S (S.drop len inp) newPos eof fail) + | otherwise = + Partial $ \x -> + case x of + Just bs'' -> go (S.drop len rem) bs'' + Nothing -> fail (S S.empty newPos True fail) + where + len = commonPrefixLen rem inp + remLen = S.length rem + newPos = pos + fromIntegral len + inpLen = S.length inp + in go bs bs' + +-- --------------------------------------------------------------------- +-- Internal utilities + +-- | /O(n)/ @commonPrefixLen xs ys@ returns the length of the longest +-- common prefix of @xs@ and @ys@. +commonPrefixLen :: S.ByteString -> S.ByteString -> Int +commonPrefixLen (S.PS fp1 off1 len1) (S.PS fp2 off2 len2) = + S.inlinePerformIO $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + lcp (p1 `plusPtr` off1) (p2 `plusPtr` off2) 0 len1 len2 + +lcp :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Int-> IO Int +lcp p1 p2 n len1 len2 + | n == len1 = return len1 + | n == len2 = return len2 + | otherwise = do + a <- peekByteOff p1 n :: IO Word8 + b <- peekByteOff p2 n + if a == b then lcp p1 p2 (n + 1) len1 len2 else return n diff --git a/Hyena/Server.hs b/Hyena/Server.hs new file mode 100644 --- /dev/null +++ b/Hyena/Server.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables, RankNTypes #-} + +------------------------------------------------------------------------ +-- | +-- Module : Hyena.Server +-- Copyright : (c) Johan Tibell 2008 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : experimental +-- Portability : not portable, uses cunning newtype deriving +-- +-- Core module of the server. Receives HTTP requests, runs the +-- application and sends responses. +-- +------------------------------------------------------------------------ + +module Hyena.Server + ( serve, + serveWithConfig + ) where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Exception.Extensible +import Control.Monad (unless, when) +import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, ask, asks, + liftIO, runReaderT) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C (elemIndex, pack) +import Network.BSD (getProtocolNumber) +import Network.Socket (Family(..), HostAddress, SockAddr(..), Socket, + SocketOption(..), SocketType(..), accept, bindSocket, + listen, inet_addr, maxListenQueue, sClose, + setSocketOption, socket, withSocketsDo) +import Network.Wai +import Prelude hiding (catch, log) +import System.Exit (exitFailure, ExitCode(..)) +import System.IO (Handle, stderr, hPutStrLn) +#ifndef mingw32_HOST_OS +import System.Posix.Signals (Handler(..), installHandler, sigPIPE) +#endif + +import Hyena.Config +import Hyena.Http +import Hyena.Logging + +-- TODO: Header names are not case sensitive and header values may or +-- may not be. + +-- TODO: How do we handle the fact that an error can be detected in +-- the middle of receiving data using chunked encoding, e.g. the +-- number indicating the chunk size contains non-hex characters. + +-- --------------------------------------------------------------------- +-- The Server type + +newtype Server a = Server (ReaderT ServerConfig IO a) + deriving (Monad, MonadIO, MonadReader ServerConfig) + +-- | The server configuration. Includes the user supplied +-- configuration and the loggers used by the server. +data ServerConfig = ServerConfig + { config :: Config -- ^ The initial user configuration. + , accessLogger :: AccessLogger -- ^ Access logger. + , errorLogger :: ErrorLogger -- ^ Error logger. + } + +-- | Run the server action. +runServer :: ServerConfig -> Server a -> IO a +runServer conf (Server a) = runReaderT a conf + +-- | Run action in the server monad, and in case of exception, and +-- catch it and run the error case. +catchServer ::Server a -> (forall e. (Exception e) => e ->Server a) -> Server a +catchServer m k = do + conf <- ask + io $ runServer conf m `catches` handlers conf + where handlers c + = [ Handler $ \(e::ExitCode) ->throw e + , Handler $ \(e::SomeException) ->runServer c $ k e ] + +-- | Run the first action and then the second action. The second +-- action is run even if the first action threw and exception. +finallyServer :: Server a -> Server b -> Server a +finallyServer m k = do + conf <- ask + io $ runServer conf m `finally` runServer conf k + +-- | Fork a new thread. +forkServer :: Server () -> Server ThreadId +forkServer m = do + conf <- ask + io $ forkIO $ runServer conf m + +-- --------------------------------------------------------------------- +-- Running applications + +-- | Forward requests to the given 'Application' forever. Read server +-- configuration from command line flags. +serve :: Application -> IO () +serve application = do + conf <- configFromFlags + serveWithConfig conf application + +-- TODO: Fork a new daemonized thread/process if daemonized mode is +-- requested. This is currently not possible because of limitations +-- in the GHC RTS. + +-- | Forward requests to the given 'Application' forever. Use +-- supplied server configuration. +serveWithConfig :: Config -> Application -> IO () +serveWithConfig conf application = do +#ifndef mingw32_HOST_OS + installHandler sigPIPE Ignore Nothing +#endif + when (daemonize conf) $ do + hPutStrLn stderr "Daemonized mode not supported at the moment." + hPutStrLn stderr $ "If you need this feature please say so in " ++ + "GHC ticket #1185." + exitFailure + bracketLoggers (logHandle conf) $ \accessLog errorLog -> + let serverConf = ServerConfig + { config = conf + , accessLogger = accessLog + , errorLogger = errorLog + } + in runServer serverConf $ serve' application + +-- --------------------------------------------------------------------- +-- Networking + +-- | Start loggers, run an action using those loggers and when +-- finished, stop the loggers. +bracketLoggers :: Handle -> (AccessLogger -> ErrorLogger -> IO ()) -> IO () +bracketLoggers h = + bracket (do accessLog <- startAccessLogger h + errorLog <- startErrorLogger stderr + return (accessLog, errorLog)) + (\(accessLog, errorLog) -> do + stopErrorLogger errorLog + stopAccessLogger accessLog) + . uncurry + +-- | Open the server socket and start accepting connections. +serve' :: Application -> Server () +serve' application = do + conf <- ask + port' <- asks (fromIntegral . port . config) + address' <- asks (address . config) + io $ withSocketsDo $ + do proto <- getProtocolNumber "tcp" + addr <- inet_addr address' + bracket (socket AF_INET Stream proto) + sClose + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port' addr) + listen sock maxListenQueue + runServer conf $ acceptConnections application sock) + +-- | Accept connections, and fork off a new thread to handle each one. +acceptConnections :: Application -> Socket -> Server () +acceptConnections application serverSock = do + (sock, SockAddrInet _ haddr) <- io $ accept serverSock + forkServer ((talk sock haddr application `finallyServer` + (io $ sClose sock)) + `catchServer` + (\e -> do logger <- asks errorLogger + io $ logError logger $ show e)) + acceptConnections application serverSock + +-- | Read the client input, parse the request, run the application, +-- and send a response. +talk :: Socket -> HostAddress -> Application -> Server () +talk sock haddr application = do + req <- io $ receiveRequest sock + case req of + Nothing -> io $ sendResponse sock $ errorResponse 400 + Just req' -> + -- TODO: Validate the request: + -- * If HTTP 1.1 Host MUST be present. + do errorLogger' <- asks errorLogger + let environ = requestToEnvironment (logError errorLogger') req' + resp <- run environ application + accessLogger' <- asks accessLogger + io $ logAccess accessLogger' req' resp haddr + io $ sendResponse sock resp + unless (closeConnection req' resp) $ + talk sock haddr application + +-- | Run the application and send a response. +run :: Environment -> Application -> Server Response +run environ application = io $ do + -- TODO: Check the validity of the returned status code and headers + -- and log an error and send a 500 if either is invalid. + (status, reason, headers', output) <- application environ + return Response + { statusCode = status + , reasonPhrase = reason + , responseHeaders = headers' + , responseBody = output + } + +-- | Check if the connection should be closed after processing this +-- request. +closeConnection :: Request -> Response -> Bool +closeConnection req resp = + let reqHdr = lookup hdrName (requestHeaders req) + respHdr = lookup hdrName (responseHeaders resp) + closeSet = + case (reqHdr, respHdr) of + (Just v, _) | v == closeVal -> True + (_, Just v) | v == closeVal -> True + _ -> False + keepAliveSet = + case reqHdr of + Just v | v == keepAliveVal -> True + _ -> False + in closeSet || (httpVersion req < (1,1) && not keepAliveSet) + where + hdrName = C.pack "Connection" + closeVal = C.pack "close" + keepAliveVal = C.pack "keep-alive" + +-- --------------------------------------------------------------------- +-- General utilities + +-- | Lift an IO action into the 'Server' monad. +io :: MonadIO m => IO a -> m a +io = liftIO + +-- | Convert an HTTP 'Request' to an 'Environment'. +requestToEnvironment :: (String -> IO ()) -> Request -> Environment +requestToEnvironment err req = + Environment + { requestMethod = method req + , scriptName = S.empty + , pathInfo = path + , queryString = query + , requestProtocol = httpVersion req + , headers = requestHeaders req + , input = requestBody req + , errors = err + } + where + (path, query) = splitRequestUri $ requestUri req + splitRequestUri uri = + let index = C.elemIndex '?' uri + in case index of + Nothing -> (uri, Nothing) + Just i -> (S.take i uri, Just $ S.drop (i + 1) uri) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Johan Tibell 2007 + +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 Johan Tibell nor the names of other + 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 +OWNER 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. + diff --git a/Network/Wai.hs b/Network/Wai.hs new file mode 100644 --- /dev/null +++ b/Network/Wai.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE Rank2Types, ImpredicativeTypes #-} + +------------------------------------------------------------------------ +-- | +-- Module : Network.Wai +-- Copyright : (c) Johan Tibell 2008 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : experimental +-- Portability : not portable, uses 2-rank types +-- +-- Defines the interface implemented by all web applications. +-- +-- Example application: +-- +-- > module Main where +-- > +-- > import qualified Data.ByteString as S +-- > import qualified Data.ByteString.Char8 as C (pack, unpack) +-- > import Network.Wai (Application(..), Enumerator(..)) +-- > import System.Directory (getCurrentDirectory) +-- > import System.FilePath ((), makeRelative) +-- > import System.IO +-- > +-- > sendFile :: FilePath -> IO Enumerator +-- > sendFile fname = do +-- > cwd <- getCurrentDirectory +-- > h <- openBinaryFile (cwd makeRelative "/" fname) ReadMode +-- > let yieldBlock f z = do +-- > block <- S.hGetNonBlocking h 1024 +-- > if S.null block then hClose h >> return z +-- > else do +-- > z' <- f z block +-- > case z' of +-- > Left z'' -> hClose h >> return z'' +-- > Right z'' -> yieldBlock f z'' +-- > return yieldBlock +-- > +-- > fileServer :: Application +-- > fileServer environ = do +-- > -- Here you should add security checks, etc. +-- > let contentType = (C.pack "Content-Type", +-- > C.pack "application/octet-stream") +-- > enumerator <- sendFile $ C.unpack $ pathInfo environ +-- > return (200, pack "OK", [contentType], enumerator) +-- +------------------------------------------------------------------------ + +module Network.Wai + ( -- * The Application type + Application, + Enumerator, + Environment(..), + Headers, + Method(..) + ) where + +import qualified Data.ByteString as S + +-- | The HTTP request headers. +type Headers = [(S.ByteString, S.ByteString)] + +-- | The HTTP request method. +data Method = Options | Get | Head | Post | Put | Delete | Trace | Connect + deriving (Eq, Show) + +-- | An environment providing information regarding the request. +data Environment = Environment + { requestMethod :: Method + -- ^ The HTTP request method, such as \"GET\" or \"POST\". + , scriptName :: S.ByteString + -- ^ The initial portion of the request URL's \"path\" that + -- corresponds to the application, so that the application knows + -- its virtual \"location\". This may be an empty string, if the + -- application corresponds to the \"root\" of the server. + , pathInfo :: S.ByteString + -- ^ The remainder of the request URL's \"path\", designating the + -- virtual \"location\" of the request's target within the + -- application. This may be an empty string, if the request URL + -- targets the application root and does not have a trailing + -- slash. + , queryString :: Maybe (S.ByteString) + -- ^ The portion of the request URL that follows the @\"?\"@, if + -- any. May be empty or absent. + , requestProtocol :: (Int, Int) + -- ^ The version of the protocol the client used to send the + -- request. Typically this will be @(1, 0)@ or @(1, 1)@ and may + -- be used by the application to determine how to treat any HTTP + -- request headers. + , headers :: Headers + -- ^ The client-supplied HTTP request headers. + , input :: Enumerator + -- ^ An 'Enumerator' from which the HTTP body can be read. + , errors :: String -> IO () + -- ^ A function with which error output can be written, for the + -- purpose of recording program or other errors in a standardized + -- and possibly centralized location. This function will not add + -- a trailing newline to the string. + } + +-- | A left-fold enumerator. +type Enumerator = forall a. (a -> S.ByteString -> IO (Either a a)) -> a -> IO a + +-- | An application takes an environment and returns a HTTP status +-- code, a sequence of headers and an 'Enumerator' containing the +-- response body. +type Application = Environment -> IO (Int, S.ByteString, Headers, Enumerator) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/hyena.cabal b/hyena.cabal new file mode 100644 --- /dev/null +++ b/hyena.cabal @@ -0,0 +1,44 @@ +name: hyena +version: 0.1 +synopsis: Simple web application server +description: + A simple web application server using iteratees. +license: BSD3 +license-file: LICENSE +author: Johan Tibell +maintainer: Johan Tibell +build-type: Simple +cabal-version: >= 1.6 +homepage: http://github.com/tibbe/hyena +category: Network + +library + exposed-modules: + Hyena.Config + Hyena.Server + Network.Wai + other-modules: + Data.Enumerator + Hyena.Http + Hyena.Logging + Hyena.Parser + + build-depends: + base == 4.*, + bytestring, + containers, + directory, + extensible-exceptions, + filepath, + mtl >= 1 && < 1.2, + network >= 2.1 && < 2.3, + network-bytestring >= 0.1.1.2 && < 0.2 + + if !os(windows) + build-depends: + unix + + extensions: Rank2Types + ghc-options: -funbox-strict-fields -Wall + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs