diff --git a/happstack-server.cabal b/happstack-server.cabal
--- a/happstack-server.cabal
+++ b/happstack-server.cabal
@@ -1,5 +1,5 @@
 Name:                happstack-server
-Version:             6.4.6
+Version:             6.5.1
 Synopsis:            Web related tools and services.
 Description:         Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course <http://happstack.com/docs/crashcourse/index.html>
 License:             BSD3
@@ -27,6 +27,11 @@
     Description: Build the testsuite, and include the tests in the library
     Default: False
 
+Flag disable-https
+     Description: Compile server with out https:// support
+     Default: False
+     Manual: True
+
 Library
 
   Exposed-modules:
@@ -44,6 +49,8 @@
                        Happstack.Server.Internal.LowLevel
                        Happstack.Server.Internal.MessageWrap
 --                       Happstack.Server.Internal.NoPush
+                       Happstack.Server.Internal.TLS
+                       Happstack.Server.Internal.TimeoutIO
                        Happstack.Server.Internal.TimeoutManager
                        Happstack.Server.Internal.TimeoutSocket
                        Happstack.Server.Internal.Monads
@@ -56,8 +63,6 @@
                        Happstack.Server.SimpleHTTP
                        Happstack.Server.Types
                        Happstack.Server.Validation
-                       Happstack.Server.XSLT
-
   if flag(tests)
     Exposed-modules:   
                        Happstack.Server.Tests
@@ -86,10 +91,9 @@
                        extensible-exceptions,
                        filepath,
                        hslogger >= 1.0.2,
-                       happstack-data >= 6.0 && < 6.1,
                        html,
                        monad-control >= 0.3 && < 0.4,
-                       mtl >= 1.1 && < 2.1,
+                       mtl >= 2 && < 2.1,
                        old-locale,
                        old-time,
                        parsec < 4,
@@ -103,12 +107,19 @@
                        utf8-string >= 0.3.4 && < 0.4,
                        xhtml,
                        zlib
+  if !flag(disable-https)
+    Exposed-modules:
+                       Happstack.Server.Internal.TimeoutSocketTLS
+    Build-Depends:
+                       HsOpenSSL == 0.10.*
+    Extra-Libraries:   crypto++ ssl
+  else
+    CPP-Options:       -DDISABLE_HTTPS
+
   if flag(network_2_2_3)
     Build-Depends:     network >= 2.2.3
   else
     Build-Depends:     network < 2.2.3, network-bytestring
-
-
 
   hs-source-dirs:      src
   if flag(tests)
diff --git a/src/Happstack/Server/Auth.hs b/src/Happstack/Server/Auth.hs
--- a/src/Happstack/Server/Auth.hs
+++ b/src/Happstack/Server/Auth.hs
@@ -5,10 +5,8 @@
 import Control.Monad                             (MonadPlus(mzero, mplus))
 import Data.ByteString.Base64                    as Base64
 import qualified Data.ByteString.Char8           as B
-import Data.Char                                 (chr)
 import qualified Data.Map                        as M
-import Happstack.Server.Monads                   (Happstack, FilterMonad, ServerMonad, WebMonad, escape, getHeaderM, setHeaderM)
-import Happstack.Server.Types                    (Response)
+import Happstack.Server.Monads                   (Happstack, escape, getHeaderM, setHeaderM)
 import Happstack.Server.Response                 (unauthorized, toResponse)
 
 -- | A simple HTTP basic authentication guard.
diff --git a/src/Happstack/Server/Cookie.hs b/src/Happstack/Server/Cookie.hs
--- a/src/Happstack/Server/Cookie.hs
+++ b/src/Happstack/Server/Cookie.hs
@@ -11,9 +11,6 @@
     where
 
 import Control.Monad.Trans              (MonadIO(..))
-import Data.Data                        (Data)
-import Data.Typeable                    (Typeable)
-import Data.Time.Clock                  (UTCTime)
 import Happstack.Server.Internal.Monads (FilterMonad, composeFilter)
 import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader)
 import Happstack.Server.Types           (Response, addHeader)
@@ -47,4 +44,4 @@
 -- >      ok $ "The cookie has been expired."
 
 expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () 
-expireCookie cookieName = addCookie Expired (mkCookie cookieName "")
+expireCookie name = addCookie Expired (mkCookie name "")
diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs
--- a/src/Happstack/Server/FileServe/BuildingBlocks.hs
+++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs
@@ -51,46 +51,30 @@
      isDot
     ) where
 
-import Control.Exception.Extensible (IOException, SomeException, Exception(fromException), bracket, handleJust)
-import Control.Monad (MonadPlus(mzero), msum)
-import Control.Monad.Trans (MonadIO(liftIO))
+import Control.Exception.Extensible (IOException, bracket, catch)
+import Control.Monad                (MonadPlus(mzero), msum)
+import Control.Monad.Trans          (MonadIO(liftIO))
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.ByteString.Char8 as S
-import Data.Data  (Data, Typeable)
-import Data.Maybe (fromMaybe, maybe)
-import           Data.Map (Map)
-import qualified Data.Map as Map
-import Happstack.Server.Monads     (Happstack, ServerMonad(askRq), FilterMonad, WebMonad, require)
-import Happstack.Server.Response   (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)
-import Happstack.Server.Types      (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)
-import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)
-import System.FilePath ((</>), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, splitDirectories, takeExtension, isValid)
-import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile)
-import System.Locale (defaultTimeLocale, rfc822DateFormat)
-import System.Log.Logger (Priority(DEBUG), logM)
-import System.Time (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime)
-
+import Data.Data                    (Data, Typeable)
+import Data.List                    (sort)
+import Data.Maybe                   (fromMaybe)
+import           Data.Map           (Map)
+import qualified Data.Map           as Map
+import Happstack.Server.Monads      (ServerMonad(askRq), FilterMonad, WebMonad)
+import Happstack.Server.Response    (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)
+import Happstack.Server.Types       (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader)
+import Prelude                      hiding (catch)
+import System.Directory             (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime)
+import System.FilePath              ((</>), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid)
+import System.IO                    (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile)
+import System.Locale                (defaultTimeLocale)
+import System.Log.Logger            (Priority(DEBUG), logM)
+import System.Time                  (CalendarTime, formatCalendarTime, toCalendarTime, toUTCTime)
 import           Text.Blaze                  ((!))
 import qualified Text.Blaze.Html5            as H
 import qualified Text.Blaze.Html5.Attributes as A
 
--- FIXME: why are these functions here ?
-
-ioErrors :: SomeException -> Maybe IOException
-ioErrors = fromException
-
-errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response
-errorwrapper binarylocation loglocation
-    = require getErrorLog $ \errorLog ->
-      return $ toResponse errorLog
-    where getErrorLog
-                = handleJust ioErrors (const (return Nothing)) $
-                do bintime <- getModificationTime binarylocation
-                   logtime <- getModificationTime loglocation
-                   if (logtime > bintime)
-                     then fmap Just $ readFile loglocation
-                     else return Nothing
-
 -- * Mime-Type / Content-Type
 
 -- |a 'Map' from file extensions to content-types
@@ -498,9 +482,9 @@
              -> [String]
              -> FilePath
              -> m Response
-browseIndex renderFn serveFn mimeFn ixFiles localPath =
+browseIndex renderFn _serveFn _mimeFn _ixFiles localPath =
     do c       <- liftIO $ getDirectoryContents localPath
-       listing <- renderFn localPath $ filter (/= ".") c
+       listing <- renderFn localPath $ filter (/= ".") (sort c)
        ok $ toResponse $ listing
 
 data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum)
@@ -516,9 +500,9 @@
     do fps' <- liftIO $ mapM (getMetaData localPath) fps
        return $ H.html $ do 
          H.head $ do
-           H.title $ H.string "Directory Listing"
-           H.meta  ! A.httpEquiv (H.stringValue "Content-Type") ! A.content (H.stringValue "text/html;charset=utf-8")
-           H.style $ H.string $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
+           H.title $ H.toHtml "Directory Listing"
+           H.meta  ! A.httpEquiv (H.toValue "Content-Type") ! A.content (H.toValue "text/html;charset=utf-8")
+           H.style $ H.toHtml $ unlines [ "table { margin: 0 auto; width: 760px; border-collapse: collapse; font-family: 'sans-serif'; }"
                                         , "table, th, td { border: 1px solid #353948; }" 
                                         , "td.size { text-align: right; font-size: 0.7em; width: 50px }"
                                         , "td.date { text-align: right; font-size: 0.7em; width: 130px }"
@@ -532,19 +516,8 @@
                                         , "img { width: 20px }"
                                         , "a { text-decoration: none }"
                                         ]
-{-
-           H.style $ H.string $ unlines [ "table { border-collapse: collapse; font-family: 'sans-serif'; }"
-                                        , "table, th, td { border: 1px solid #98BF21; }" 
-                                        , "td.size { text-align: right; }"
-                                        , "td.date { text-align: right; }"
-                                        , "td { padding-right: 1em; padding-left: 1em; }"
-                                        , "tr { background-color: white; }"
-                                        , "tr.alt { background-color: #EAF2D3 }"
-                                        , "th { background-color: #A7C942; color: white; font-size: 1.125em; }"
-                                        ]
--}
          H.body $ do
-           H.h1 $ H.string "Directory Listing"
+           H.h1 $ H.toHtml "Directory Listing"
            renderDirectoryContentsTable fps'
 
 -- | a function to generate an HTML table showing the contents of a directory on the disk
@@ -558,23 +531,23 @@
 renderDirectoryContentsTable :: [(FilePath, Maybe CalendarTime, Maybe Integer, EntryKind)] -- ^ list of files+meta data, see 'getMetaData'
                              -> H.Html
 renderDirectoryContentsTable fps =
-           H.table $ do H.thead $ do H.th $ H.string ""
-                                     H.th $ H.string "Name"
-                                     H.th $ H.string "Last modified"
-                                     H.th $ H.string "Size"
+           H.table $ do H.thead $ do H.th $ H.toHtml ""
+                                     H.th $ H.toHtml "Name"
+                                     H.th $ H.toHtml "Last modified"
+                                     H.th $ H.toHtml "Size"
                         H.tbody $ mapM_ mkRow (zip fps $ cycle [False, True])
     where
       mkRow :: ((FilePath, Maybe CalendarTime, Maybe Integer, EntryKind), Bool) -> H.Html
       mkRow ((fp, modTime, count, kind), alt) = 
-          (if alt then (! A.class_ (H.stringValue "alt")) else id) $
+          (if alt then (! A.class_ (H.toValue "alt")) else id) $
           H.tr $ do
                    H.td (mkKind kind)
-                   H.td (H.a ! A.href (H.stringValue fp)  $ H.string fp)
-                   H.td ! A.class_ (H.stringValue "date") $ (H.string $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)
-                   (maybe id (\c -> (! A.title (H.stringValue (show c)))) count)  (H.td ! A.class_ (H.stringValue "size") $ (H.string $ maybe "-" prettyShow count)) 
+                   H.td (H.a ! A.href (H.toValue fp)  $ H.toHtml fp)
+                   H.td ! A.class_ (H.toValue "date") $ (H.toHtml $ maybe "-" (formatCalendarTime defaultTimeLocale "%d-%b-%Y %X %Z") modTime)
+                   (maybe id (\c -> (! A.title (H.toValue (show c)))) count)  (H.td ! A.class_ (H.toValue "size") $ (H.toHtml $ maybe "-" prettyShow count)) 
       mkKind :: EntryKind -> H.Html
       mkKind File        = return ()
-      mkKind Directory   = H.string "➦"
+      mkKind Directory   = H.toHtml "➦"
       mkKind UnknownKind = return ()
       prettyShow x
         | x > 1024 = prettyShowK $ x `div` 1024
@@ -598,12 +571,12 @@
 getMetaData localPath fp =
      do let localFp = localPath </> fp
         modTime <- (fmap Just . toCalendarTime =<< getModificationTime localFp) `catch` 
-                   (const $ return Nothing)
+                   (\(_ :: IOException) -> return Nothing)
         count <- do de <- doesDirectoryExist localFp
                     if de
                       then do return Nothing
                       else do bracket (openBinaryFile localFp ReadMode) hClose (fmap Just . hFileSize) 
-                                          `catch` (\(e :: IOException) -> return Nothing)
+                                          `catch` (\(_e :: IOException) -> return Nothing)
         kind <- do fe <- doesFileExist localFp
                    if fe
                       then return File
diff --git a/src/Happstack/Server/HTTPClient/HTTP.hs b/src/Happstack/Server/HTTPClient/HTTP.hs
--- a/src/Happstack/Server/HTTPClient/HTTP.hs
+++ b/src/Happstack/Server/HTTPClient/HTTP.hs
@@ -141,7 +141,7 @@
 -- Util
 import Data.Bits ((.&.))
 import Data.Char
-import Data.List (partition,elemIndex,intersperse)
+import Data.List (foldl', elemIndex, intersperse, partition)
 import Control.Monad (when,forM)
 import Numeric (readHex)
 import Text.ParserCombinators.ReadP
@@ -1011,7 +1011,7 @@
 urlEncodeVars :: [(String,String)] -> String
 urlEncodeVars ((n,v):t) =
     let (same,diff) = partition ((==n) . fst) t
-    in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
+    in urlEncode n ++ '=' : foldl' (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
        ++ urlEncodeRest diff
        where urlEncodeRest [] = []
              urlEncodeRest diff = '&' : urlEncodeVars diff
diff --git a/src/Happstack/Server/HTTPClient/Stream.hs b/src/Happstack/Server/HTTPClient/Stream.hs
--- a/src/Happstack/Server/HTTPClient/Stream.hs
+++ b/src/Happstack/Server/HTTPClient/Stream.hs
@@ -30,14 +30,12 @@
 
 ) where
 
+import Control.Monad   (liftM)
 import Control.Exception.Extensible as Exception
-import System.IO.Error
-
--- Networking
-import Network.Socket
-
-import Control.Monad (liftM)
-import System.IO
+import Network.Socket  (ShutdownCmd(..), Socket, SocketOption(SoError), getSocketOption, recv, send, sClose, shutdown)
+import Prelude         hiding (catch)
+import System.IO       (Handle, IOMode(..), hClose, hFlush, hPutStrLn, openFile)
+import System.IO.Error (isEOFError)
 
 data ConnError = ErrorReset 
                | ErrorClosed
@@ -126,13 +124,15 @@
 
 myrecv :: Socket -> Int -> IO String
 myrecv sock len =
-    let handler e = if isEOFError e then return [] else ioError e
-        in System.IO.Error.catch (recv sock len) handler
+    recv sock len `catch` 
+             (\e ->
+                  if isEOFError e 
+                  then return []
+                  else ioError e)
 
 -- | Allows stream logging.
 -- Refer to 'debugStream' below.
 data Debug x = Dbg Handle x
-
 
 instance (Stream x) => Stream (Debug x) where
     readBlock (Dbg h c) n =
diff --git a/src/Happstack/Server/Internal/Compression.hs b/src/Happstack/Server/Internal/Compression.hs
--- a/src/Happstack/Server/Internal/Compression.hs
+++ b/src/Happstack/Server/Internal/Compression.hs
@@ -36,7 +36,7 @@
 
     installHandler accept = do
       let eEncoding = bestEncoding allEncodings $ BS.unpack accept
-      (coding,identityAllowed,action) <- case eEncoding of
+      (coding, identityAllowed, action) <- case eEncoding of
           Left _ -> do
             setResponseCode 406
             finishWith $ toResponse ""
@@ -46,6 +46,7 @@
                                      , fromMaybe (fail badEncoding)
                                           (lookup a allEncodingHandlers)
                                      )
+          Right [] -> fail badEncoding
       action coding identityAllowed
       return coding
 
diff --git a/src/Happstack/Server/Internal/Cookie.hs b/src/Happstack/Server/Internal/Cookie.hs
--- a/src/Happstack/Server/Internal/Cookie.hs
+++ b/src/Happstack/Server/Internal/Cookie.hs
@@ -16,7 +16,6 @@
     )
     where
 
-import Control.Applicative   ((<$>))
 import qualified Data.ByteString.Char8 as C
 import Data.Char             (chr, toLower)
 import Data.Data             (Data, Typeable)
diff --git a/src/Happstack/Server/Internal/Handler.hs b/src/Happstack/Server/Internal/Handler.hs
--- a/src/Happstack/Server/Internal/Handler.hs
+++ b/src/Happstack/Server/Internal/Handler.hs
@@ -28,33 +28,30 @@
 import Happstack.Server.Internal.Multipart
 import Happstack.Server.Internal.RFC822Headers
 import Happstack.Server.Internal.MessageWrap
--- import Happstack.Server.Internal.NoPush
 import Happstack.Server.SURI(SURI(..),path,query)
 import Happstack.Server.SURI.ParseURI
+import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
 import qualified Happstack.Server.Internal.TimeoutManager as TM
-import Happstack.Server.Internal.TimeoutSocket (sGetContents, sPutTickle, sendFileTickle)
-import Network.Socket (Socket)
-import Network.Socket.ByteString (sendAll)
 import Numeric
 import System.Directory (removeFile)
 import System.IO
 import System.IO.Error (isDoesNotExistError)
 
-request :: TM.Handle -> Conf -> Socket -> Host -> (Request -> IO Response) -> IO ()
-request thandle conf sock host handler = rloop thandle conf sock host handler =<< sGetContents thandle sock
+request :: TimeoutIO -> Conf -> Host -> (Request -> IO Response) -> IO ()
+request timeoutIO conf host handler =
+    rloop timeoutIO conf host handler =<< toGetContents timeoutIO
 
 required :: String -> Maybe a -> Either String a
 required err Nothing  = Left err
 required _   (Just a) = Right a
 
-rloop :: TM.Handle
+rloop :: TimeoutIO
          -> Conf
-         -> Socket
          -> Host
          -> (Request -> IO Response)
          -> L.ByteString
          -> IO ()
-rloop thandle conf sock host handler inputStr
+rloop timeoutIO conf host handler inputStr
     | L.null inputStr = return ()
     | otherwise
     = join $
@@ -65,22 +62,22 @@
                       let (m,u,v) = requestLine rql
                       headers' <- parseHeaders "host" (L.unpack headerStr)
                       let headers = mkHeaders headers'
-                      let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)
+                      let contentLen = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)
                       (body, nextRequest) <- case () of
-                          () | contentLength < 0               -> fail "negative content-length"
+                          () | contentLen < 0               -> fail "negative content-length"
                              | isJust $ getHeaderBS transferEncodingC headers ->
                                  return $ consumeChunks restStr
-                             | otherwise                       -> return (L.splitAt (fromIntegral contentLength) restStr)
+                             | otherwise                       -> return (L.splitAt (fromIntegral contentLen) restStr)
                       let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle
-                      return (m, u, cookies, v, headers, body, host, nextRequest)
+                      return (m, u, cookies, v, headers, body, nextRequest)
 
          case parseRequest of
            Left err -> error $ "failed to parse HTTP request: " ++ err
-           Right (m, u, cookies, v, headers, body, host, nextRequest)
+           Right (m, u, cookies, v, headers, body, nextRequest)
                -> return $
                   do bodyRef        <- newMVar (Body body)
                      bodyInputRef   <- newEmptyMVar
-                     let req = Request m (pathEls (path u)) (path u) (query u)
+                     let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u)
                                   (queryInput u) bodyInputRef cookies v headers bodyRef host
 
                      let ioseq act = act >>= \x -> x `seq` return x
@@ -101,10 +98,10 @@
                               logger host' user time requestLn responseCode size referer userAgent
 
                      -- withNoPush sock $ putAugmentedResult thandle sock req res
-                     putAugmentedResult thandle sock req res
+                     putAugmentedResult timeoutIO req res
                      -- clean up tmp files
                      cleanupTempFiles req
-                     when (continueHTTP req res) $ rloop thandle conf sock host handler nextRequest
+                     when (continueHTTP req res) $ rloop timeoutIO conf host handler nextRequest
 
 -- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup
 cleanupTempFiles :: Request -> IO ()
@@ -207,22 +204,22 @@
 staticHeaders :: Headers
 staticHeaders =
     foldr (uncurry setHeaderBS) (mkHeaders [])
-    [ (serverC, happsC) ]
+    [ (serverC, happstackC) ]
 
 -- FIXME: we should not be controlling the response headers in mysterious ways in this low level code
 -- headers should be set by application code and the core http engine should be very lean.
-putAugmentedResult :: TM.Handle -> Socket -> Request -> Response -> IO ()
-putAugmentedResult thandle outp req res = do
+putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
+putAugmentedResult timeoutIO req res = do
     case res of
         -- standard bytestring response
         Response {} -> do
-            let chunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req
-            sendTop (if chunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) chunked
+            let isChunked = rsfLength (rsFlags res) == TransferEncodingChunked && isHTTP1_1 req
+            sendTop (if isChunked then Nothing else (Just (fromIntegral (L.length (rsBody res))))) isChunked
             when (rqMethod req /= HEAD)
-                     (let body = if chunked
+                     (let body = if isChunked
                                  then chunk (rsBody res)
                                  else rsBody res
-                      in sPutTickle thandle outp body)
+                      in toPutLazy timeoutIO body)
         -- zero-copy sendfile response
         -- the handle *should* be closed by the garbage collector
 
@@ -231,25 +228,25 @@
                 off = sfOffset res
                 count = sfCount res
             sendTop (Just count) False
-            TM.tickle thandle
-            sendFileTickle thandle outp infp off count
+            TM.tickle (toHandle timeoutIO)
+            toSendFile timeoutIO infp off count
 
     where ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs
-          sendTop cl chunked = do
-              allHeaders <- augmentHeaders req res cl chunked
-              sendAll outp $ B.concat $ concat
+          sendTop cl isChunked = do
+              allHeaders <- augmentHeaders req res cl isChunked
+              toPut timeoutIO $ B.concat $ concat
                  [ (pversion $ rqVersion req)          -- Print HTTP version
                  , [responseMessage $ rsCode res]      -- Print responseCode
                  , concatMap ph (M.elems allHeaders)   -- Print all headers
                  , [crlfC]
                  ]
-              TM.tickle thandle
+              TM.tickle (toHandle timeoutIO)
           chunk :: L.ByteString -> L.ByteString
           chunk Empty        = LC.pack "0\r\n\r\n"
           chunk (Chunk c cs) = Chunk (B.pack $ showHex (B.length c) "\r\n") (Chunk c (Chunk (B.pack "\r\n") (chunk cs)))
 
 augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
-augmentHeaders req res mcl chunked = do
+augmentHeaders req res mcl isChunked = do
     -- TODO: Hoist static headers to the toplevel.
     raw <- getApproximateTime
     let stdHeaders = staticHeaders `M.union`
@@ -264,7 +261,7 @@
                                             | otherwise -> []
                               TransferEncodingChunked
                                   -- we check 'chunked' because we might not use this mode if the client is http 1.0
-                                  | chunked   -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])]
+                                  | isChunked -> [(transferEncodingC, HeaderPair transferEncodingC [chunkedC])]
                                   | otherwise -> []
 
                      )
@@ -307,7 +304,7 @@
 http11 :: B.ByteString
 http11 = P.pack "HTTP/1.1"
 
--- Constants
+-- * ByteString Constants
 
 connectionC :: B.ByteString
 connectionC      = P.pack "Connection"
@@ -321,8 +318,8 @@
 crlfC            = P.pack "\r\n"
 fsepC :: B.ByteString
 fsepC            = P.pack ": "
-contentTypeC :: B.ByteString
-contentTypeC     = P.pack "Content-Type"
+-- contentTypeC :: B.ByteString
+-- contentTypeC     = P.pack "Content-Type"
 contentLengthC :: B.ByteString
 contentLengthC   = P.pack "Content-Length"
 contentlengthC :: B.ByteString
@@ -333,10 +330,10 @@
 dateCLower       = P.map toLower dateC
 serverC :: B.ByteString
 serverC          = P.pack "Server"
-happsC :: B.ByteString
-happsC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version
-textHtmlC :: B.ByteString
-textHtmlC        = P.pack "text/html; charset=utf-8"
+happstackC :: B.ByteString
+happstackC           = P.pack $ "Happstack/" ++ DV.showVersion Paths.version
+-- textHtmlC :: B.ByteString
+-- textHtmlC        = P.pack "text/html; charset=utf-8"
 transferEncodingC :: B.ByteString
 transferEncodingC = P.pack "Transfer-Encoding"
 chunkedC :: B.ByteString
diff --git a/src/Happstack/Server/Internal/Listen.hs b/src/Happstack/Server/Internal/Listen.hs
--- a/src/Happstack/Server/Internal/Listen.hs
+++ b/src/Happstack/Server/Internal/Listen.hs
@@ -4,10 +4,19 @@
 import Happstack.Server.Internal.Types          (Conf(..), Request, Response)
 import Happstack.Server.Internal.Handler        (request)
 import Happstack.Server.Internal.Socket         (acceptLite)
+import Happstack.Server.Internal.TimeoutIO      (TimeoutIO(toHandle, toShutdown))
 import Happstack.Server.Internal.TimeoutManager (cancel, initialize, register)
+import Happstack.Server.Internal.TimeoutSocket  as TS
+#ifdef DISABLE_HTTPS
+import Happstack.Server.Internal.TLS            (HTTPS)
+#else
+import Happstack.Server.Internal.TimeoutSocketTLS  as TSS
+import Happstack.Server.Internal.TLS            (HTTPS, TLSConf(..), acceptTLS, httpsOnSocket)
+#endif
 import Control.Exception.Extensible             as E
 import Control.Concurrent                       (forkIO, killThread, myThreadId)
 import Control.Monad                            (forever, when)
+import Data.Maybe                               (fromJust)
 import Network.BSD                              (getProtocolNumber)
 import Network                                  (sClose, Socket)
 import Network.Socket as Socket (SocketOption(KeepAlive), setSocketOption, 
@@ -16,6 +25,10 @@
                                  iNADDR_ANY, maxListenQueue, SocketType(..), 
                                  bindSocket)
 import qualified Network.Socket                 as Socket (listen, inet_addr)
+#ifndef DISABLE_HTTPS
+import qualified OpenSSL                        as SSL
+import qualified OpenSSL.Session                as SSL
+#endif
 import System.IO.Error                          (isFullError)
 {-
 #ifndef mingw32_HOST_OS
@@ -70,11 +83,22 @@
     let port' = port conf
     socketm <- listenOn port'
     setSocketOption socketm KeepAlive 1
-    listen' socketm conf hand
+    mHTTPS <- case tls conf of
+                Nothing ->  return Nothing
+                (Just tlsConf) ->
+#ifdef DISABLE_HTTPS
+                    do return Nothing
+#else
+                    do SSL.withOpenSSL $ return ()
+                       tlsSocket <- listenOn (tlsPort tlsConf)
+                       https <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) tlsSocket
+                       return (Just https)
+#endif
+    listen' socketm mHTTPS conf hand
 
 -- | Use a previously bind port and listen
-listen' :: Socket -> Conf -> (Request -> IO Response) -> IO ()
-listen' s conf hand = do
+listen' :: Socket -> Maybe HTTPS -> Conf -> (Request -> IO Response) -> IO ()
+listen' s mhttps conf hand = do
 {-
 #ifndef mingw32_HOST_OS
 -}
@@ -83,21 +107,54 @@
 #endif
 -}
   let port' = port conf
-  log' NOTICE ("Listening on port " ++ show port')
   tm <- initialize ((timeout conf) * (10^(6 :: Int)))
+  -- https:// loop
+  httpsTid <- forkIO $
+    case mhttps of
+      Nothing -> return ()
+#ifdef DISABLE_HTTPS
+      (Just _) -> 
+          do log' ERROR ("Ignoring https:// configuration because happstack-server was compiled with disable_https")
+#else
+      (Just https) -> 
+          do let ehs (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTPS request failed with: " ++ show x)
+                 work (ssl, hn, p) = 
+                     do tid <- myThreadId
+                        thandle <- register tm (killThread tid)
+                        let timeoutIO = TSS.timeoutSocketIO thandle ssl
+                        request timeoutIO conf (hn,fromIntegral p) hand `E.catch` ehs
+                        -- remove thread from timeout table
+                        cancel (toHandle timeoutIO)
+                        toShutdown timeoutIO
+                 loop = forever ((do w <- acceptTLS https
+                                     forkIO $ work w
+                                     return ())
+                                   `E.catch` sslException)
+                 sslException :: SSL.SomeSSLException -> IO ()
+                 sslException e = log' ERROR ("SSL exception in https accept thread: " ++ show e)
+                 pe e = log' ERROR ("ERROR in https accept thread: " ++ show e)
+                 infi = loop `catchSome` pe >> infi
+             log' NOTICE ("Listening for https:// on port " ++ show (tlsPort $ fromJust (tls conf)))
+             infi `finally` (sClose s)
+#endif
+  -- http:// loop
+  log' NOTICE ("Listening for http:// on port " ++ show port')
   let eh (x::SomeException) = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTP request failed with: " ++ show x)
       work (sock, hn, p) = 
           do tid <- myThreadId
              thandle <- register tm (killThread tid)
-             request thandle conf sock (hn,fromIntegral p) hand `E.catch` eh
+             let timeoutIO = TS.timeoutSocketIO thandle sock
+             request timeoutIO conf (hn,fromIntegral p) hand `E.catch` eh
              -- remove thread from timeout table
              cancel thandle
              sClose sock
       loop = forever $ do w <- acceptLite s
                           forkIO $ work w
-      pe e = log' ERROR ("ERROR in accept thread: " ++ show e)
+      pe e = log' ERROR ("ERROR in http accept thread: " ++ show e)
       infi = loop `catchSome` pe >> infi
-  infi `finally` (sClose s) --  >> killThread ttid)
+
+  infi `finally` (sClose s >> killThread httpsTid)
+
 {--
 #ifndef mingw32_HOST_OS
 -}
diff --git a/src/Happstack/Server/Internal/MessageWrap.hs b/src/Happstack/Server/Internal/MessageWrap.hs
--- a/src/Happstack/Server/Internal/MessageWrap.hs
+++ b/src/Happstack/Server/Internal/MessageWrap.hs
@@ -9,7 +9,6 @@
 import Control.Monad.Trans (MonadIO(liftIO))
 import qualified Data.ByteString.Char8 as P
 import qualified Data.ByteString.Lazy.Char8 as L
-import Data.Maybe
 import Data.Int (Int64)
 import Happstack.Server.Internal.Types as H
 import Happstack.Server.Internal.Multipart
@@ -52,24 +51,23 @@
       isDecodable :: Maybe ContentType -> Bool
       isDecodable Nothing                                                      = True -- assume it is application/x-www-form-urlencoded
       isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True
-      isDecodable (Just (ContentType "multipart" "form-data" ps))              = True
+      isDecodable (Just (ContentType "multipart" "form-data" _ps))             = True
       isDecodable (Just _)                                                     = False
 
 bodyInput bodyPolicy req =
   liftIO $
-    do let getBS (Body bs) = bs
-           ctype = parseContentType . P.unpack =<< getHeader "content-type" req
+    do let ctype = parseContentType . P.unpack =<< getHeader "content-type" req
        mbi <- tryTakeMVar (rqInputsBody req)
        case mbi of
          (Just bi) ->
              do putMVar (rqInputsBody req) bi
                 return (bi, Nothing)
          Nothing ->
-             do rqBody <- takeRequestBody req
-                case rqBody of
+             do rqbody <- takeRequestBody req
+                case rqbody of
                   Nothing          -> return ([], Just $ "bodyInput: Request body was already consumed.")
                   (Just (Body bs)) -> 
-                      do r@(inputs, err) <- decodeBody bodyPolicy ctype bs
+                      do r@(inputs, _err) <- decodeBody bodyPolicy ctype bs
                          putMVar (rqInputsBody req) inputs
                          return r
 
@@ -107,9 +105,9 @@
                 -> [(String,String)] -- ^ Content-type parameters
                 -> L.ByteString      -- ^ Request body
                 -> IO ([(String,Input)], Maybe String) -- ^ Input variables and values.
-multipartDecode inputWorker ps inp =
+multipartDecode worker ps inp =
     case lookup "boundary" ps of
-         Just b  -> multipartBody inputWorker (L.pack b) inp
+         Just b  -> multipartBody worker (L.pack b) inp
          Nothing -> return ([], Just $ "boundary not found in parameters: " ++ show ps)
 
 -- | Get the path components from a String.
diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs
--- a/src/Happstack/Server/Internal/Monads.hs
+++ b/src/Happstack/Server/Internal/Monads.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, UndecidableInstances  #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances  #-}
 {-| This module defines the Monad stack used by Happstack. You mostly don't want to be looking in here. Look in "Happstack.Server.Monads" instead.
 -}
 module Happstack.Server.Internal.Monads where
@@ -8,6 +8,17 @@
 import Control.Monad                             ( MonadPlus(mzero, mplus), ap, liftM, msum
                                                  )
 import Control.Monad.Base                        ( MonadBase, liftBase )
+import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT
+                                                 , Error, MonadError, throwError
+                                                 , catchError, mapErrorT
+                                                 )
+import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT
+                                                 , MonadReader, ask, local, mapReaderT
+                                                 )
+import Control.Monad.RWS                         ( RWST, mapRWST
+                                                 )
+
+import Control.Monad.State                       (MonadState, StateT, get, put, mapStateT)
 import Control.Monad.Trans                       ( MonadTrans, lift
                                                  , MonadIO, liftIO
                                                  )
@@ -15,19 +26,12 @@
                                                  , MonadBaseControl(..)
                                                  , ComposeSt, defaultLiftBaseWith, defaultRestoreM
                                                  )
-import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT
-                                                 , MonadReader, ask, local
-                                                 )
 import Control.Monad.Writer                      ( WriterT(WriterT), runWriterT
                                                  , MonadWriter, tell, pass
-                                                 , listens
+                                                 , listens, mapWriterT
                                                  )
 import qualified Control.Monad.Writer            as Writer (listen) -- So that we can disambiguate 'Listen.listen'
-import Control.Monad.State                       (MonadState, get, put)
-import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT
-                                                 , Error, MonadError, throwError
-                                                 , catchError, mapErrorT
-                                                 )
+
 import Control.Monad.Trans.Maybe                 (MaybeT(MaybeT), runMaybeT)
 import qualified Data.ByteString.Lazy.UTF8       as LU (fromString)
 import Data.Char                                 (ord)
@@ -554,3 +558,71 @@
       encodeEntity c
           | ord c > 127 = "&#" ++ show (ord c) ++ ";"
           | otherwise = [c]
+
+------------------------------------------------------------------------------
+-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, 
+-- WriterT, and RWST
+------------------------------------------------------------------------------
+
+-- ReaderT
+
+instance (ServerMonad m) => ServerMonad (ReaderT r m) where
+    askRq         = lift askRq
+    localRq f     = mapReaderT (localRq f)
+
+instance (FilterMonad res m) => FilterMonad res (ReaderT r m) where
+    setFilter f   = lift $ setFilter f
+    composeFilter = lift . composeFilter
+    getFilter     = mapReaderT getFilter
+
+instance (WebMonad a m) => WebMonad a (ReaderT r m) where
+    finishWith    = lift . finishWith
+
+-- StateT
+
+instance (ServerMonad m) => ServerMonad (StateT s m) where
+    askRq         = lift askRq
+    localRq f     = mapStateT (localRq f)
+
+instance (FilterMonad res m) => FilterMonad res (StateT s m) where
+    setFilter f   = lift $ setFilter f
+    composeFilter = lift . composeFilter
+    getFilter   m = mapStateT (\m' -> 
+                                   do ((b,s), f) <- getFilter m'
+                                      return ((b, f), s)) m
+
+instance (WebMonad a m) => WebMonad a (StateT s m) where
+    finishWith    = lift . finishWith
+
+
+-- WriterT
+
+instance (ServerMonad m, Monoid w) => ServerMonad (WriterT w m) where
+    askRq         = lift askRq
+    localRq f     = mapWriterT (localRq f)
+
+instance (FilterMonad res m, Monoid w) => FilterMonad res (WriterT w m) where
+    setFilter f   = lift $ setFilter f
+    composeFilter = lift . composeFilter
+    getFilter   m = mapWriterT (\m' -> 
+                                   do ((b,w), f) <- getFilter m'
+                                      return ((b, f), w)) m
+
+instance (WebMonad a m, Monoid w) => WebMonad a (WriterT w m) where
+    finishWith    = lift . finishWith
+
+-- RWST
+
+instance (ServerMonad m, Monoid w) => ServerMonad (RWST r w s m) where
+    askRq         = lift askRq
+    localRq f     = mapRWST (localRq f)
+
+instance (FilterMonad res m, Monoid w) => FilterMonad res (RWST r w s m) where
+    setFilter f   = lift $ setFilter f
+    composeFilter = lift . composeFilter
+    getFilter   m = mapRWST (\m' -> 
+                                   do ((b,s,w), f) <- getFilter m'
+                                      return ((b, f), s, w)) m
+
+instance (WebMonad a m, Monoid w) => WebMonad a (RWST r w s m) where
+    finishWith     = lift . finishWith
diff --git a/src/Happstack/Server/Internal/Multipart.hs b/src/Happstack/Server/Internal/Multipart.hs
--- a/src/Happstack/Server/Internal/Multipart.hs
+++ b/src/Happstack/Server/Internal/Multipart.hs
@@ -1,27 +1,25 @@
 module Happstack.Server.Internal.Multipart where
 
-import           Control.Monad (MonadPlus(mplus), foldM)
-import qualified Data.ByteString.Lazy.Char8    as L
-import qualified Data.ByteString.Internal      as B
-import           Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))
-import           Data.ByteString.Lazy.Internal as L
-import qualified Data.ByteString.Lazy.UTF8     as LU
-import qualified Data.ByteString.Char8         as S
-import           Data.List (intercalate)
-import           Data.Maybe (fromMaybe)
-import           Data.Int (Int64)
-import           Text.ParserCombinators.Parsec (ParseError, parse)
+import           Control.Monad                   (MonadPlus(mplus))
+import qualified Data.ByteString.Lazy.Char8      as L
+import           Data.ByteString.Lazy.Internal   (ByteString(Chunk, Empty))
+import qualified Data.ByteString.Lazy.UTF8       as LU
+import qualified Data.ByteString.Char8           as S
+import           Data.Maybe                      (fromMaybe)
+import           Data.Int                        (Int64)
+import           Text.ParserCombinators.Parsec   (parse)
 import           Happstack.Server.Internal.Types (Input(..))
-import           Happstack.Server.Internal.RFC822Headers ( ContentType(..), ContentDisposition(..), Header
-                                                         , getContentDisposition, getContentType, pHeaders)
-import           System.IO (Handle, hClose, openBinaryTempFile)
+import           Happstack.Server.Internal.RFC822Headers 
+                                                  ( ContentType(..), ContentDisposition(..), Header
+                                                  , getContentDisposition, getContentType, pHeaders)
+import           System.IO                        (Handle, hClose, openBinaryTempFile)
 
 -- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character.
 --
 -- TODO: this function has not been profiled.
 spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)
 spanS f cs0 = spanS' 0 cs0
-  where spanS' n Empty = (Empty, Empty)
+  where spanS' _ Empty = (Empty, Empty)
         spanS' n bs@(Chunk c cs)
             | n >= S.length c = 
                 let (x, y) = spanS' 0 cs
@@ -32,7 +30,7 @@
 
 takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
 takeWhileS f cs0 = takeWhile' 0 cs0
-  where takeWhile' n Empty = Empty
+  where takeWhile' _ Empty = Empty
         takeWhile' n bs@(Chunk c cs)
             | n >= S.length c = Chunk c (takeWhile' 0 cs)
             | not (f (Chunk (S.drop n c) cs)) = (Chunk (S.take n c) Empty)
@@ -74,6 +72,7 @@
 		-> L.ByteString 	-- ^ content to save
 		-> IO (Bool, Int64 , FilePath)	-- ^ truncated?, saved bytes, saved filename
 
+defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath)
 defaultFileSaver tmpDir diskQuota filename b =
     do (fn, h) <- openBinaryTempFile tmpDir filename
        (trunc, len) <- hPutLimit diskQuota h b
@@ -123,8 +122,8 @@
 {-# INLINE hPutLimit #-}
 
 hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)
-hPutLimit' _maxCount h count Empty = return (False, count)
-hPutLimit'  maxCount h count (Chunk c cs)
+hPutLimit' _maxCount _h count Empty = return (False, count)
+hPutLimit'  maxCount h  count (Chunk c cs)
     | (count + fromIntegral (S.length c)) > maxCount =
         do S.hPut h (S.take (fromIntegral (maxCount - count)) c)
            return (True, maxCount)
@@ -146,6 +145,7 @@
                   cont (BodyWork ctype ps b)
 
               cd -> return $ Failed Nothing ("Expected content-disposition: form-data but got " ++ show cd)
+         (BodyResult {}) -> return $ Failed Nothing "bodyPartToInput: Got unexpected BodyResult."
 
 bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)
 bodyPartsToInputs _ [] = 
@@ -184,8 +184,8 @@
 parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
 parseMultipartBody boundary s =
     case dropPreamble boundary s of
-      (partData, Just e)  -> ([], Just e)
-      (partData, Nothing) -> splitParts boundary partData
+      (_partData, Just e)  -> ([], Just e)
+      (partData,  Nothing) -> splitParts boundary partData
 
 dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String)
 dropPreamble b s | isBoundary b s = (dropLine s, Nothing)
diff --git a/src/Happstack/Server/Internal/Socket.hs b/src/Happstack/Server/Internal/Socket.hs
--- a/src/Happstack/Server/Internal/Socket.hs
+++ b/src/Happstack/Server/Internal/Socket.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
-module Happstack.Server.Internal.Socket(acceptLite) where
+module Happstack.Server.Internal.Socket
+    ( acceptLite
+    , sockAddrToHostName
+    ) where
 
 import Data.List (intersperse)
 import Data.Word (Word32)
@@ -15,10 +18,8 @@
   , SockAddr(..)
   , HostName
   , accept
-  , socketToHandle
   )
 import Numeric (showHex)
-import System.IO
 
 type HostAddress = Word32
 type HostAddress6 = (Word32, Word32, Word32, Word32)
@@ -50,8 +51,12 @@
 acceptLite sock = do
   (sock', addr) <- S.accept sock
   (N.PortNumber p) <- N.socketPort sock'
-  
-  let peer = $(if supportsIPv6
+  let peer = sockAddrToHostName addr
+  return (sock', peer, p)
+
+sockAddrToHostName ::  S.SockAddr -> S.HostName
+sockAddrToHostName addr =
+    $(if supportsIPv6
                  then
                  return $ CaseE (VarE (mkName "addr")) 
                             [Match 
@@ -73,6 +78,3 @@
                       (S.SockAddrInet _ ha)      -> showHostAddress ha
                       _                          -> error "Unsupported socket"
                  |])
-                     
-  return (sock', peer, p)
-
diff --git a/src/Happstack/Server/Internal/TLS.hs b/src/Happstack/Server/Internal/TLS.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/Internal/TLS.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE CPP #-}
+{- | core functions and types for HTTPS support
+-}
+module Happstack.Server.Internal.TLS where
+
+#ifdef DISABLE_HTTPS
+import Network.Socket (Socket)
+#else
+import Control.Monad  (when)
+import Happstack.Server.Internal.Socket (acceptLite)
+import Network.Socket (HostName, PortNumber, Socket)
+import OpenSSL.Session (SSL, SSLContext)
+import qualified OpenSSL.Session as SSL
+#endif
+
+-- | configuration for using https://
+data TLSConf = TLSConf {
+      tlsPort :: Int        -- port (usually 443)
+    , tlsCert :: FilePath   -- path to SSL certificate
+    , tlsKey  :: FilePath   -- path to SSL private key
+    }
+
+#ifdef DISABLE_HTTPS
+data HTTPS = HTTPS
+httpsOnSocket :: FilePath  -- ^ path to ssl certificate
+              -> FilePath  -- ^ path to ssl private key
+              -> Socket    -- ^ listening socket (on which listen() has been called, but not accept())
+              -> IO HTTPS
+httpsOnSocket = error "happstack-server was compiled with disable_https."
+#else
+-- | record that holds the 'Socket' and 'SSLContext' needed to start
+-- the https:// event loop. Used with 'simpleHTTPWithSocket''
+--
+-- see also: 'httpOnSocket'
+data HTTPS = HTTPS
+    { httpsSocket :: Socket
+    , sslContext :: SSLContext
+    }
+
+-- | generate the 'HTTPS' record needed to start the https:// event loop
+--
+httpsOnSocket :: FilePath  -- ^ path to ssl certificate
+              -> FilePath  -- ^ path to ssl private key
+              -> Socket    -- ^ listening socket (on which listen() has been called, but not accept())
+              -> IO HTTPS
+httpsOnSocket cert key socket =
+    do ctx <- SSL.context
+       SSL.contextSetPrivateKeyFile  ctx key
+       SSL.contextSetCertificateFile ctx cert
+       SSL.contextSetDefaultCiphers  ctx
+
+       b <- SSL.contextCheckPrivateKey ctx
+       when (not b) $ error $ "OpenTLS certificate and key do not match."
+
+       return (HTTPS socket ctx)
+
+acceptTLS :: HTTPS -> IO (SSL, HostName, PortNumber)
+acceptTLS (HTTPS sck' ctx) =
+    do -- do normal accept
+      (sck, peer, port) <- acceptLite sck'
+
+      --  then TLS accept
+      ssl <- SSL.connection ctx sck
+      SSL.accept ssl
+
+      return (ssl, peer, port)
+#endif
diff --git a/src/Happstack/Server/Internal/TimeoutIO.hs b/src/Happstack/Server/Internal/TimeoutIO.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/Internal/TimeoutIO.hs
@@ -0,0 +1,22 @@
+module Happstack.Server.Internal.TimeoutIO 
+    ( TimeoutIO(..)
+    ) where
+
+import qualified Data.ByteString.Char8          as B
+import qualified Data.ByteString.Lazy.Char8     as L
+import Happstack.Server.Internal.TimeoutManager (Handle)
+import Network.Socket.SendFile                  (ByteCount, Offset)
+
+
+-- |TimeoutIO is a record which abstracts out all the network IO
+-- functions needed by the request handling loop. This allows use to
+-- use the same event loop for handle both http:// and https://.
+data TimeoutIO = TimeoutIO
+    { toHandle      :: Handle
+    , toPutLazy     :: L.ByteString -> IO ()
+    , toPut         :: B.ByteString -> IO ()
+    , toGetContents :: IO L.ByteString
+    , toSendFile    :: FilePath -> Offset -> ByteCount -> IO ()
+    , toShutdown    :: IO ()
+    , toSecure      :: Bool
+    }
diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs
--- a/src/Happstack/Server/Internal/TimeoutSocket.hs
+++ b/src/Happstack/Server/Internal/TimeoutSocket.hs
@@ -4,31 +4,34 @@
 -}
 module Happstack.Server.Internal.TimeoutSocket where
 
-import           Control.Concurrent            (ThreadId, forkIO, killThread, threadDelay, threadWaitWrite)
-import           Control.Exception             (SomeException, catch, throw)
+import           Control.Concurrent            (threadWaitWrite)
+import           Control.Exception             (catch, throw)
 import           Control.Monad                 (liftM, when)
 import qualified Data.ByteString.Char8         as B
 import qualified Data.ByteString.Lazy.Char8    as L
 import qualified Data.ByteString.Lazy.Internal as L
 import qualified Data.ByteString               as S
-import qualified Network.Socket.ByteString as N
-import           Data.Word
-import           Data.IORef
-import           Data.List (foldl')
-import           Data.Time.Clock.POSIX(POSIXTime, getPOSIXTime)
-import           Happstack.Server.Internal.Clock (getApproximatePOSIXTime)
+import           Network.Socket                (sClose)
+import qualified Network.Socket.ByteString     as N
 import qualified Happstack.Server.Internal.TimeoutManager as TM
+import           Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
 import           Network.Socket (Socket, ShutdownCmd(..), shutdown)
 import           Network.Socket.SendFile (Iter(..), ByteCount, Offset, sendFileIterWith')
 import           Network.Socket.ByteString (sendAll)
 import           Prelude hiding (catch)
-import           System.IO (Handle, hClose, hIsEOF, hWaitForInput)
 import           System.IO.Error (isDoesNotExistError)
 import           System.IO.Unsafe (unsafeInterleaveIO)
 
-sPutTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()
-sPutTickle thandle sock cs =
+sPutLazyTickle :: TM.Handle -> Socket -> L.ByteString -> IO ()
+sPutLazyTickle thandle sock cs =
     do L.foldrChunks (\c rest -> sendAll sock c >> TM.tickle thandle >> rest) (return ()) cs
+{-# INLINE sPutLazyTickle #-}
+
+sPutTickle :: TM.Handle -> Socket -> B.ByteString -> IO ()
+sPutTickle thandle sock cs =
+    do sendAll sock cs
+       TM.tickle thandle
+       return ()
 {-# INLINE sPutTickle #-}
 
 sGetContents :: TM.Handle 
@@ -64,3 +67,14 @@
                       iterTickle' cont
                (Sent _ cont) ->
                    do iterTickle' cont
+
+timeoutSocketIO :: TM.Handle -> Socket -> TimeoutIO
+timeoutSocketIO handle socket =
+    TimeoutIO { toHandle      = handle
+              , toShutdown    = sClose socket 
+              , toPutLazy     = sPutLazyTickle handle socket
+              , toPut         = sPutTickle     handle socket
+              , toGetContents = sGetContents   handle socket
+              , toSendFile    = sendFileTickle handle socket
+              , toSecure      = False
+              }
diff --git a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+{- | 
+-- borrowed from snap-server. Check there periodically for updates.
+-}
+module Happstack.Server.Internal.TimeoutSocketTLS where
+
+import           Control.Monad                 (liftM)
+import qualified Data.ByteString.Char8         as B
+import qualified Data.ByteString.Lazy.Char8    as L
+import qualified Data.ByteString.Lazy.Internal as L
+import qualified Data.ByteString               as S
+import qualified Happstack.Server.Internal.TimeoutManager as TM
+import           Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
+import           Network.Socket.SendFile (ByteCount, Offset)
+import           OpenSSL.Session               (SSL)
+import qualified OpenSSL.Session               as SSL
+import           Prelude hiding (catch)
+import           System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile)
+import           System.IO.Unsafe (unsafeInterleaveIO)
+
+sPutLazyTickle :: TM.Handle -> SSL -> L.ByteString -> IO ()
+sPutLazyTickle thandle ssl cs =
+    do L.foldrChunks (\c rest -> SSL.write ssl c >> TM.tickle thandle >> rest) (return ()) cs
+{-# INLINE sPutLazyTickle #-}
+
+sPutTickle :: TM.Handle -> SSL -> B.ByteString -> IO ()
+sPutTickle thandle ssl cs =
+    do SSL.write ssl cs
+       TM.tickle thandle
+{-# INLINE sPutTickle #-}
+
+sGetContents :: TM.Handle 
+             -> SSL              -- ^ Connected socket
+             -> IO L.ByteString  -- ^ Data received
+sGetContents handle ssl = loop where
+  loop = unsafeInterleaveIO $ do
+    s <- SSL.read ssl 65536
+    TM.tickle handle
+    if S.null s
+      then do -- SSL.shutdown ssl SSL.Unidirectional `catch` (\e -> when (not $ isDoesNotExistError e) (throw e))
+              return L.Empty
+      else L.Chunk s `liftM` loop
+
+timeoutSocketIO :: TM.Handle -> SSL -> TimeoutIO
+timeoutSocketIO handle ssl =
+    TimeoutIO { toHandle      = handle
+              , toShutdown    = SSL.shutdown ssl SSL.Bidirectional
+              , toPutLazy     = sPutLazyTickle handle ssl
+              , toPut         = sPutTickle     handle ssl
+              , toGetContents = sGetContents   handle ssl
+              , toSendFile    = sendFileTickle handle ssl
+              , toSecure      = True
+              }
+
+sendFileTickle :: TM.Handle -> SSL -> FilePath -> Offset -> ByteCount -> IO ()
+sendFileTickle thandle ssl fp offset count =
+    do withBinaryFile fp ReadMode $ \h -> do
+         hSeek h AbsoluteSeek offset
+         c <- L.hGetContents h
+         sPutLazyTickle thandle ssl (L.take (fromIntegral count) c)
diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs
--- a/src/Happstack/Server/Internal/Types.hs
+++ b/src/Happstack/Server/Internal/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-}
 
 module Happstack.Server.Internal.Types
     (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),
@@ -9,7 +9,7 @@
      setHeader, setHeaderBS, setHeaderUnsafe,
      addHeader, addHeaderBS, addHeaderUnsafe,
      setRsCode, -- setCookie, setCookies,
-     Conf(..), nullConf, result, resultBS,
+     Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS,
      redirect, -- redirect_, redirect', redirect'_,
      isHTTP1_0, isHTTP1_1,
      RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
@@ -24,14 +24,13 @@
 import Control.Concurrent.MVar
 import qualified Data.Map as M
 import Data.Data (Data)
-import Data.IORef (IORef, atomicModifyIORef, readIORef)
 import Data.Time.Format (FormatTime(..))
 import Data.Typeable(Typeable)
 import qualified Data.ByteString.Char8 as P
 import Data.ByteString.Char8 (ByteString,pack)
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.ByteString.Lazy.UTF8  as LU (fromString)
-import Data.Int   (Int, Int8, Int16, Int32, Int64)
+import Data.Int   (Int8, Int16, Int32, Int64)
 import Data.Maybe
 import Data.List
 import Data.Word  (Word, Word8, Word16, Word32, Word64)
@@ -40,6 +39,7 @@
 import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )
 import Happstack.Server.Internal.Cookie
 import Happstack.Server.Internal.LogFormat (formatRequestCombined)
+import Happstack.Server.Internal.TLS
 import Numeric (readDec, readSigned)
 import System.Log.Logger (Priority(..), logM)
 import Text.Show.Functions ()
@@ -53,37 +53,57 @@
 
 -- | 'True' if 'Request' is HTTP version @1.1@
 isHTTP1_1 :: Request -> Bool
-isHTTP1_1 rq = case rqVersion rq of HttpVersion 1 1 -> True; _ -> False
+isHTTP1_1 rq =
+    case rqVersion rq of
+      HttpVersion 1 1 -> True
+      _               -> False
 
 -- | 'True' if 'Request' is HTTP version @1.0@
 isHTTP1_0 :: Request -> Bool
-isHTTP1_0 rq = case rqVersion rq of HttpVersion 1 0 -> True; _ -> False
+isHTTP1_0 rq =
+    case rqVersion rq of
+      HttpVersion 1 0 -> True
+      _               -> False
 
 -- | Should the connection be used for further messages after this.
 -- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose
 continueHTTP :: Request -> Response -> Bool
---continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)
-continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq   && rsfLength (rsFlags res) == ContentLength) ||
-                      (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength)
+continueHTTP rq res =
+    (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq   && rsfLength (rsFlags res) == ContentLength) ||
+    (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength)
 
 -- | HTTP configuration
-data Conf = Conf { port       :: Int -- ^ Port for the server to listen on.
-                 , validator  :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly
-                 , logAccess  :: forall t. FormatTime t => Maybe (String -> String -> t -> String -> Int -> Integer -> String -> String -> IO ()) -- ^ function to log access requests (see also: 'logMAccess')
-                 , timeout    :: Int -- ^ number of seconds to wait before killing an inactive thread
-                 } 
+data Conf = Conf
+    { port       :: Int -- ^ Port for the server to listen on.
+    , tls        :: Maybe TLSConf
+    , validator  :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly
+    , logAccess  :: forall t. FormatTime t => Maybe (String -> String -> t -> String -> Int -> Integer -> String -> String -> IO ()) -- ^ function to log access requests (see also: 'logMAccess')
+    , timeout    :: Int -- ^ number of seconds to wait before killing an inactive thread
+    }
 
 -- | Default configuration contains no validator and the port is set to 8000
 nullConf :: Conf
-nullConf = Conf { port      = 8000
-                , validator = Nothing
-                , logAccess = Just logMAccess
-                , timeout   = 30
-                }
+nullConf =
+    Conf { port      = 8000
+         , tls       = Nothing
+         , validator = Nothing
+         , logAccess = Just logMAccess
+         , timeout   = 30
+         }
 
 -- | log access requests using hslogger and apache-style log formatting
 --
 -- see also: 'Conf'
+logMAccess :: forall t. FormatTime t =>
+              String  -- ^ host
+           -> String  -- ^ user
+           -> t       -- ^ time
+           -> String  -- ^ requestLine
+           -> Int     -- ^ responseCode
+           -> Integer -- ^ size
+           -> String  -- ^ referer
+           -> String  -- ^ userAgent
+           -> IO ()
 logMAccess host user time requestLine responseCode size referer userAgent =
     logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent
 
@@ -92,15 +112,14 @@
                deriving(Show,Read,Eq,Ord,Typeable,Data)
 
 -- | an HTTP header
-data HeaderPair 
-    = HeaderPair { hName :: ByteString     -- ^ header name
-                 , hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)
-                 } 
-      deriving (Read,Show)
--- | Combined headers.
+data HeaderPair = HeaderPair
+    { hName :: ByteString     -- ^ header name
+    , hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)
+    }
+    deriving (Read,Show)
 
 -- | a Map of HTTP headers
--- 
+--
 -- the Map key is the header converted to lowercase
 type Headers = M.Map ByteString HeaderPair -- ^ lowercased name -> (realname, value)
 
@@ -109,14 +128,14 @@
 -- encoding is used.
 --
 -- see also: 'nullRsFlags', 'notContentLength', and 'chunked'
-data Length 
+data Length
     = ContentLength             -- ^ automatically add a @Content-Length@ header to the 'Response'
     | TransferEncodingChunked   -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding
     | NoContentLength           -- ^ do not set @Content-Length@ or @chunked@ output encoding.
       deriving (Eq, Ord, Read, Show, Enum)
 
 -- | Result flags
-data RsFlags = RsFlags 
+data RsFlags = RsFlags
     { rsfLength :: Length
     } deriving (Show,Read,Typeable)
 
@@ -136,7 +155,6 @@
 contentLength :: Response -> Response
 contentLength res   = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = ContentLength }
 
-
 -- | a value extract from the @QUERY_STRING@ or 'Request' body
 --
 -- If the input value was a file, then it will be saved to a temporary file on disk and 'inputValue' will contain @Left pathToTempFile@.
@@ -144,27 +162,28 @@
     { inputValue       :: Either FilePath L.ByteString
     , inputFilename    :: Maybe FilePath
     , inputContentType :: ContentType
-    } deriving (Show,Read,Typeable)
+    } deriving (Show, Read, Typeable)
 
 -- | hostname & port
 type Host = (String, Int) -- ^ (hostname, port)
 
 -- | an HTTP Response
-data Response  = Response  { rsCode      :: Int,
-                             rsHeaders   :: Headers,
-                             rsFlags     :: RsFlags,
-                             rsBody      :: L.ByteString,
-                             rsValidator :: Maybe (Response -> IO Response)
-                           }
-               | SendFile  { rsCode      :: Int,
-                             rsHeaders   :: Headers,
-                             rsFlags     :: RsFlags,
-                             rsValidator :: Maybe (Response -> IO Response),
-                             sfFilePath  :: FilePath,  -- ^ file handle to send from
-                             sfOffset    :: Integer,   -- ^ offset to start at
-                             sfCount     :: Integer    -- ^ number of bytes to send
-                           }
-               deriving (Typeable)
+data Response
+    = Response  { rsCode      :: Int
+                , rsHeaders   :: Headers
+                , rsFlags     :: RsFlags
+                , rsBody      :: L.ByteString
+                , rsValidator :: Maybe (Response -> IO Response)
+                }
+    | SendFile  { rsCode      :: Int
+                , rsHeaders   :: Headers
+                , rsFlags     :: RsFlags
+                , rsValidator :: Maybe (Response -> IO Response)
+                , sfFilePath  :: FilePath  -- ^ file handle to send from
+                , sfOffset    :: Integer   -- ^ offset to start at
+                , sfCount     :: Integer    -- ^ number of bytes to send
+                }
+      deriving (Typeable)
 
 instance Show Response where
     showsPrec _ res@Response{}  =
@@ -186,27 +205,30 @@
 
 -- what should the status code be ?
 instance Error Response where
-  strMsg str = 
-      setHeader "Content-Type" "text/plain; charset=UTF-8" $ 
+  strMsg str =
+      setHeader "Content-Type" "text/plain; charset=UTF-8" $
        result 500 str
 
 -- | an HTTP request
-data Request = Request { rqMethod      :: Method,
-                         rqPaths       :: [String],
-                         rqUri         :: String,
-                         rqQuery       :: String,
-                         rqInputsQuery :: [(String,Input)],
-                         rqInputsBody  :: MVar [(String,Input)],
-                         rqCookies     :: [(String,Cookie)],
-                         rqVersion     :: HttpVersion,
-                         rqHeaders     :: Headers,
-                         rqBody        :: MVar RqBody,
-                         rqPeer        :: Host
-                       } deriving(Typeable)
+data Request = Request
+    { rqSecure        :: Bool                  -- ^ request uses https://
+      , rqMethod      :: Method                -- ^ request method
+      , rqPaths       :: [String]              -- ^ the uri, split on /, and then decoded
+      , rqUri         :: String                -- ^ the raw rqUri
+      , rqQuery       :: String                -- ^ the QUERY_STRING
+      , rqInputsQuery :: [(String,Input)]      -- ^ the QUERY_STRING decoded as key/value pairs
+      , rqInputsBody  :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate)
+      , rqCookies     :: [(String,Cookie)]     -- ^ cookies
+      , rqVersion     :: HttpVersion           -- ^ HTTP version
+      , rqHeaders     :: Headers               -- ^ the HTTP request headers
+      , rqBody        :: MVar RqBody           -- ^ the raw, undecoded request body
+      , rqPeer        :: Host                  -- ^ (hostname, port) of the client making the request
+    } deriving (Typeable)
 
 instance Show Request where
     showsPrec _ rq =
         showString   "================== Request =================" .
+        showString "\nrqSecure      = " . shows      (rqMethod rq) .
         showString "\nrqMethod      = " . shows      (rqMethod rq) .
         showString "\nrqPaths       = " . shows      (rqPaths rq) .
         showString "\nrqUri         = " . showString (rqUri rq) .
@@ -224,9 +246,7 @@
 -- IMPORTANT: You can really only call this function once. Subsequent
 -- calls will return 'Nothing'.
 takeRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody)
-takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq) 
--- takeRequestBody rq = return (rqBody rq)
-
+takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq)
 
 -- | read the request body inputs
 --
@@ -240,37 +260,34 @@
                    return (Just bi)
          Nothing -> return Nothing
 
-{-
-takeRequestBody rq = 
-    do body <- atomicModifyIORef (rqBody rq) (\bdy -> (Nothing, bdy))
-       newBD <- readIORef (rqBody rq)
-       print newBD
-       newBD `seq` return body
--}
 -- | Converts a Request into a String representing the corresponding URL
 rqURL :: Request -> String
 rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)
 
 -- | a class for working with types that contain HTTP headers
-class HasHeaders a where 
+class HasHeaders a where
     updateHeaders :: (Headers->Headers) -> a -> a -- ^ modify the headers
-    headers       :: a -> Headers -- ^ extract the headers
+    headers       :: a -> Headers                 -- ^ extract the headers
 
-instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}
-                                   headers = rsHeaders
-instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} 
-                                  headers = rqHeaders
+instance HasHeaders Response where
+    updateHeaders f rs = rs {rsHeaders=f $ rsHeaders rs }
+    headers            = rsHeaders
 
-instance HasHeaders Headers where updateHeaders f = f
-                                  headers = id
+instance HasHeaders Request where
+    updateHeaders f rq = rq {rqHeaders = f $ rqHeaders rq }
+    headers            = rqHeaders
 
+instance HasHeaders Headers where
+    updateHeaders f = f
+    headers         = id
+
 -- | The body of an HTTP 'Request'
 newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable)
 
 -- | Sets the Response status code to the provided Int and lifts the computation
 -- into a Monad.
 setRsCode :: (Monad m) => Int -> Response -> m Response
-setRsCode code rs = return rs {rsCode = code}
+setRsCode code rs = return rs { rsCode = code }
 
 -- | Takes a list of (key,val) pairs and converts it into Headers.  The
 -- keys will be converted to lowercase
@@ -342,7 +359,7 @@
 
 -- | Sets the key to the HeaderPair.  This is the only way to associate a key
 -- with multiple values via the setHeader* functions.  Does not force the key
--- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. 
+-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.
 setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
 setHeaderUnsafe key val = updateHeaders (M.insert key val)
 
@@ -351,7 +368,7 @@
 --------------------------------------------------------------
 
 -- | Add a key/value pair to the header.  If the key already has a value
--- associated with it, then the value will be appended.  
+-- associated with it, then the value will be appended.
 -- Forces the key to be lowercase.
 addHeader :: HasHeaders r => String -> String -> r -> r
 addHeader key val = addHeaderBS (pack key) (pack val)
@@ -361,18 +378,18 @@
 addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])
 
 -- | Add a key/value pair to the header using the underlying HeaderPair data
--- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. 
+-- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.
 addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
 addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)
     where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)
 
 -- | Creates a Response with the given Int as the status code and the provided
--- String as the body of the Response 
+-- String as the body of the Response
 result :: Int -> String -> Response
 result code = resultBS code . LU.fromString
 
 -- | Acts as 'result' but works with ByteStrings directly.
--- 
+--
 -- By default, Transfer-Encoding: chunked will be used
 resultBS :: Int -> L.ByteString -> Response
 resultBS code s = Response code M.empty nullRsFlags s Nothing
@@ -404,21 +421,21 @@
   case readDec s of
     [(n,[])] -> n
     _    -> error "readDec' failed."
-    
+
 -- | Read in any monad.
 readM :: (Monad m, Read t) => String -> m t
 readM s = case reads s of
             [(v,"")] -> return v
             _        -> fail "readM: parse error"
-            
+
 -- |convert a 'ReadS a' result to 'Maybe a'
 fromReadS :: [(a, String)] -> Maybe a
 fromReadS [(n,[])] = Just n
 fromReadS _        = Nothing
-    
+
 -- | This class is used by 'path' to parse a path component into a
 -- value.
--- 
+--
 -- The instances for number types ('Int', 'Float', etc) use 'readM' to
 -- parse the path component.
 --
@@ -448,7 +465,7 @@
 instance FromReqURI Word64  where fromReqURI = fromReadS . readDec
 instance FromReqURI Float   where fromReqURI = readM
 instance FromReqURI Double  where fromReqURI = readM
-instance FromReqURI Bool    where 
+instance FromReqURI Bool    where
   fromReqURI s =
     let s' = map toLower s in
     case s' of
diff --git a/src/Happstack/Server/Monads.hs b/src/Happstack/Server/Monads.hs
--- a/src/Happstack/Server/Monads.hs
+++ b/src/Happstack/Server/Monads.hs
@@ -14,7 +14,7 @@
       ServerPartT
     , ServerPart
       -- * Happstack class
-    , Happstack(..)
+    , Happstack
       -- * ServerMonad
     , ServerMonad(..)
     , mapServerPartT
@@ -39,7 +39,12 @@
 import Control.Applicative               (Alternative, Applicative)         
 import Control.Monad                     (MonadPlus(mzero))
 import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift))
+import Control.Monad.Reader              (ReaderT)
+import Control.Monad.Writer              (WriterT)
+import Control.Monad.State               (StateT)
+import Control.Monad.RWS                 (RWST)
 import qualified Data.ByteString.Char8   as B
+import Data.Monoid                       (Monoid)
 import Happstack.Server.Internal.Monads
 import Happstack.Server.Types            (Response, addHeader, getHeader, setHeader)
 import Happstack.Server.RqData           (HasRqData)
@@ -49,8 +54,12 @@
       , MonadIO m, MonadPlus m, HasRqData m, Monad m, Functor m
       , Applicative m, Alternative m) => Happstack m
 
-
-instance (Functor m, Monad m, MonadPlus m, MonadIO m) => Happstack (ServerPartT m)
+instance (Functor m, Monad m, MonadPlus m
+         , MonadIO m)            => Happstack (ServerPartT m)
+instance (Happstack m)           => Happstack (StateT      s m)
+instance (Happstack m)           => Happstack (ReaderT r     m)
+instance (Happstack m, Monoid w) => Happstack (WriterT   w   m)
+instance (Happstack m, Monoid w) => Happstack (RWST    r w s m)
 
 -- | Get a header out of the request.
 getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)
diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs
--- a/src/Happstack/Server/Response.hs
+++ b/src/Happstack/Server/Response.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-}
 -- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: <http://happstack.com/docs/crashcourse/HelloWorld.html#response_code>
 module Happstack.Server.Response 
     ( -- * Converting values to a 'Response'
diff --git a/src/Happstack/Server/Routing.hs b/src/Happstack/Server/Routing.hs
--- a/src/Happstack/Server/Routing.hs
+++ b/src/Happstack/Server/Routing.hs
@@ -1,8 +1,11 @@
 {-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-}
 -- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: <http://happstack.com/docs/crashcourse/RouteFilters.html>
 module Happstack.Server.Routing 
-    ( -- * Route by request method
-      methodM
+    ( -- * Route by scheme
+      http
+    , https
+      -- * Route by request method
+    , methodM
     , methodOnly
     , methodSP
     , method
@@ -22,10 +25,9 @@
     , guardRq
     ) where
 
-import           Control.Monad                    (MonadPlus(mzero,mplus), unless)
+import           Control.Monad                    (MonadPlus(mzero), unless)
 import qualified Data.ByteString.Char8            as B
-import           Happstack.Server.Monads          (ServerPartT, ServerMonad(..))
-import           Happstack.Server.Internal.Monads (WebT, anyRequest)
+import           Happstack.Server.Monads          (ServerMonad(..))
 import           Happstack.Server.Types           (Request(..), Method(..), FromReqURI(..), getHeader, rqURL)
 import           System.FilePath                  (makeRelative, splitDirectories)
 
@@ -52,6 +54,31 @@
     rq <- askRq
     unless (f rq) mzero
 
+
+-- | guard which checks that an insecure connection was made via http://
+--
+-- Example:
+--
+-- > handler :: ServerPart Response
+-- > handler =
+-- >     do https
+-- >        ...
+http :: (ServerMonad m, MonadPlus m) => m ()
+http = guardRq (not . rqSecure)
+
+
+-- | guard which checks that a secure connection was made via https://
+--
+-- Example:
+--
+-- > handler :: ServerPart Response
+-- > handler =
+-- >     do https
+-- >        ...
+https :: (ServerMonad m, MonadPlus m) => m ()
+https = guardRq rqSecure
+
+
 -- | Guard against the method only (as opposed to 'methodM').
 --
 -- Example:
@@ -63,7 +90,6 @@
 method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
 method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)
 
-
 -- | Guard against the method. This function also guards against
 -- *any remaining path segments*. See 'method' for the version
 -- that guards only by method.
@@ -106,6 +132,10 @@
 -- 
 -- NOTE: This style of combinator is going to be deprecated in the
 -- future. It is better to just use 'method'.
+--
+-- > handler :: ServerPart Response
+-- > handler = method [GET, HEAD] >> nullDir >> subHandler
+{-# DEPRECATED methodSP "use method instead." #-}
 methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b
 methodSP m handle = methodM m >> handle
 
diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs
--- a/src/Happstack/Server/RqData.hs
+++ b/src/Happstack/Server/RqData.hs
@@ -30,6 +30,7 @@
     -- body for matches keys. 
     , body
     , queryString
+    , bytestring
     -- * Validation and Parsing
     , checkRq
     , checkRqM        
@@ -57,10 +58,13 @@
 
 import Control.Applicative 			(Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>))
 import Control.Concurrent.MVar                  (newMVar)
-import Control.Monad 				(MonadPlus(mzero), liftM)
+import Control.Monad 				(MonadPlus(mzero))
 import Control.Monad.Reader 			(ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)
+import Control.Monad.State 			(StateT, mapStateT)
+import Control.Monad.Writer 			(WriterT, mapWriterT)
+import Control.Monad.RWS  			(RWST, mapRWST)
 import Control.Monad.Error 			(Error(noMsg, strMsg))
-import Control.Monad.Trans                      (MonadIO(..))
+import Control.Monad.Trans                      (MonadIO(..), lift)
 import qualified Data.ByteString.Char8          as P
 import qualified Data.ByteString.Lazy.Char8     as L
 import qualified Data.ByteString.Lazy.UTF8      as LU
@@ -76,7 +80,7 @@
 import Happstack.Server.Internal.RFC822Headers  (parseContentType)
 import Happstack.Server.Types                   (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody)
 import Happstack.Server.Internal.MessageWrap    (BodyPolicy(..), bodyInput, defaultBodyPolicy)
-import Happstack.Server.Response                (internalServerError, requestEntityTooLarge, toResponse)
+import Happstack.Server.Response                (requestEntityTooLarge, toResponse)
 
 newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a }
     deriving (Functor, Monad, MonadPlus)
@@ -113,12 +117,14 @@
     noMsg = Errors []
     strMsg str = Errors [str]
 
-mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)
-mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)
-
+{- commented out to avoid 'Defined but not used' warning. 
 readerError :: (Monoid e, Error e) => e -> ReaderError r e b
 readerError e = mapReaderErrorT ((Left e) `apEither`) (return ())
 
+mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)
+mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)
+-}
+
 runReaderError :: ReaderError r e a -> r -> Either e a
 runReaderError = runReaderT . unReaderError
 
@@ -157,10 +163,10 @@
           isDecodable :: Maybe ContentType -> Bool
           isDecodable Nothing                                                      = True -- assume it is application/x-www-form-urlencoded
           isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True
-          isDecodable (Just (ContentType "multipart" "form-data" ps))              = True
+          isDecodable (Just (ContentType "multipart" "form-data" _ps))             = True
           isDecodable (Just _)                                                     = False
 
-    rqDataError e = mzero
+    rqDataError _e = mzero
     localRqEnv f m =
         do rq <- askRq
            b  <- liftIO $ readInputsBody rq
@@ -172,6 +178,30 @@
                         }
            localRq (const rq') m
 
+------------------------------------------------------------------------------
+-- HasRqData instances for ReaderT, StateT, WriterT, and RWST
+------------------------------------------------------------------------------
+
+instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where
+    askRqEnv      = lift askRqEnv
+    localRqEnv f  = mapReaderT (localRqEnv f)
+    rqDataError e = lift (rqDataError e)
+
+instance (Monad m, HasRqData m) => HasRqData (StateT s m) where
+    askRqEnv      = lift askRqEnv
+    localRqEnv f  = mapStateT (localRqEnv f)
+    rqDataError e = lift (rqDataError e)
+
+instance (Monad m, HasRqData m, Monoid w) => HasRqData (WriterT w m) where
+    askRqEnv      = lift askRqEnv
+    localRqEnv f  = mapWriterT (localRqEnv f)
+    rqDataError e = lift (rqDataError e)
+
+instance (Monad m, HasRqData m, Monoid w) => HasRqData (RWST r w s m) where
+    askRqEnv      = lift askRqEnv
+    localRqEnv f  = mapRWST (localRqEnv f)
+    rqDataError e = lift (rqDataError e)
+
 -- | apply 'RqData a' to a 'RqEnv'
 --
 -- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn'
@@ -248,9 +278,9 @@
 -- | like 'checkRq' but the check function can be monadic
 checkRqM :: (Monad m, HasRqData m) => m a -> (a -> m (Either String b)) -> m b
 checkRqM rq f =
-    do a <- rq
-       b <- f a
-       case b of
+    do a  <- rq
+       eb <- f a
+       case eb of
          (Left e)  -> rqDataError (strMsg e)
          (Right b) -> return b
 
@@ -286,7 +316,7 @@
 fromMaybeBody funName fieldName mBody =
     case mBody of
       Nothing -> error $ funName ++ " " ++ fieldName ++ " failed because the request body has not been decoded yet. Try using 'decodeBody' to decode the body. Or the 'queryString' filter to ignore the body."
-      (Just body) -> body
+      (Just bdy) -> bdy
 
 -- | Gets the first matching named input parameter
 -- 
@@ -296,8 +326,8 @@
 lookInput :: (Monad m, HasRqData m) => String -> m Input
 lookInput name
     = do (query, mBody, _cookies) <- askRqEnv
-         let body = fromMaybeBody "lookInput" name mBody
-         case lookup name (query ++ body) of
+         let bdy = fromMaybeBody "lookInput" name mBody
+         case lookup name (query ++ bdy) of
            Just i  -> return $ i
            Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name)
 
@@ -309,8 +339,8 @@
 lookInputs :: (Monad m, HasRqData m) => String -> m [Input]
 lookInputs name
     = do (query, mBody, _cookies) <- askRqEnv
-         let body = fromMaybeBody "lookInputs" name mBody
-         return $ lookups name (query ++ body)
+         let bdy = fromMaybeBody "lookInputs" name mBody
+         return $ lookups name (query ++ bdy)
 
 -- | Gets the first matching named input parameter as a lazy 'ByteString'
 --
@@ -321,7 +351,7 @@
 lookBS n = 
     do i <- fmap inputValue (lookInput n)
        case i of
-         (Left fp)  -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.")
+         (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.")
          (Right bs) -> return bs
 
 -- | Gets all matches for the named input parameter as lazy 'ByteString's
@@ -334,7 +364,7 @@
     do is <- fmap (map inputValue) (lookInputs n)
        case partitionEithers is of
          ([], bs) -> return bs
-         (fp, _)  -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.")
+         (_fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.")
 
 -- | Gets the first matching named input parameter as a 'String'
 --
@@ -458,8 +488,8 @@
 lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)]
 lookPairs = 
     do (query, mBody, _cookies) <- askRqEnv
-       let body = fromMaybeBody "lookPairs" "" mBody
-       return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ body)
+       let bdy = fromMaybeBody "lookPairs" "" mBody
+       return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ bdy)
 
 -- | gets all the input parameters
 --
@@ -470,8 +500,8 @@
 lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)]
 lookPairsBS = 
     do (query, mBody, _cookies) <- askRqEnv
-       let body = fromMaybeBody "lookPairsBS" "" mBody
-       return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ body)
+       let bdy = fromMaybeBody "lookPairsBS" "" mBody
+       return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy)
 
 -- | The POST\/PUT body of a Request is not received or decoded unless
 -- this function is invoked. 
@@ -587,7 +617,7 @@
 body :: (HasRqData m) => m a -> m a
 body rqData = localRqEnv f rqData
     where
-      f (_query, body, _cookies) = ([], body, [])
+      f (_query, bdy, _cookies) = ([], bdy, [])
 
 -- | limit the scope to the QUERY_STRING
 --
@@ -600,14 +630,11 @@
     where
       f (query, _body, _cookies) = (query, Just [], [])
 
-right :: (MonadPlus m) => Either a b -> m b
-right (Right a) = return a
-right (Left e) = mzero
-
+-- | limit the scope to 'Input's  which produce a 'ByteString' (aka, not a file)
 bytestring :: (HasRqData m) => m a -> m a
 bytestring rqData = localRqEnv f rqData
     where
-      f (query, body, cookies) = (filter bsf query, filter bsf <$> body, cookies)
+      f (query, bdy, cookies) = (filter bsf query, filter bsf <$> bdy, cookies)
       bsf (_, i) =
           case inputValue i of
             (Left  _fp) -> False
diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs
--- a/src/Happstack/Server/SURI.hs
+++ b/src/Happstack/Server/SURI.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-}
 -- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'. 
 module Happstack.Server.SURI where
 
diff --git a/src/Happstack/Server/SimpleHTTP.hs b/src/Happstack/Server/SimpleHTTP.hs
--- a/src/Happstack/Server/SimpleHTTP.hs
+++ b/src/Happstack/Server/SimpleHTTP.hs
@@ -1,4 +1,4 @@
-
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE OverlappingInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -41,6 +41,7 @@
     , simpleHTTP''
     , simpleHTTPWithSocket
     , simpleHTTPWithSocket'
+    , httpsOnSocket
     , bindPort
     , bindIPv4
     , parseConfig
@@ -85,9 +86,9 @@
 
 import Data.Maybe                                (fromMaybe)
 import qualified Data.Version                    as DV
-import Happstack.Server.Internal.Monads          (FilterFun, WebT(..), UnWebT, unFilterFun, mapServerPartT, runServerPartT, ununWebT)
+import Happstack.Server.Internal.Monads          (FilterFun, WebT(..), unFilterFun, runServerPartT, ununWebT)
 import qualified Happstack.Server.Internal.Listen as Listen (listen, listen',listenOn, listenOnIPv4) -- So that we can disambiguate 'Writer.listen'
-import Happstack.Server.Types                    (Conf(port, validator), Request, Response(rsBody, rsCode), nullConf, readDec', setHeader)
+import Happstack.Server.Internal.TLS             (httpsOnSocket)
 import Network                                   (Socket)
 import qualified Paths_happstack_server          as Cabal
 import System.Console.GetOpt                     ( OptDescr(Option)
@@ -157,20 +158,20 @@
 -- >     -- do other stuff as root here
 -- >     getUserEntryForName "www" >>= setUserID . userID
 -- >     -- finally start handling incoming requests
--- >     tid <- forkIO $ simpleHTTPWithSocket socket conf impl
+-- >     tid <- forkIO $ simpleHTTPWithSocket socket Nothing conf impl
 --
 -- Note: It's important to use the same conf (or at least the same
 -- port) for 'bindPort' and 'simpleHTTPWithSocket'.
 --
 -- see also: 'bindPort', 'bindIPv4'
-simpleHTTPWithSocket :: (ToMessage a) => Socket -> Conf -> ServerPartT IO a -> IO ()
+simpleHTTPWithSocket :: (ToMessage a) => Socket -> Maybe HTTPS -> Conf -> ServerPartT IO a -> IO ()
 simpleHTTPWithSocket = simpleHTTPWithSocket' id
 
 -- | Like 'simpleHTTP'' with a socket.
 simpleHTTPWithSocket' :: (ToMessage b, Monad m, Functor m) => (UnWebT m a -> UnWebT IO b)
-                      -> Socket -> Conf -> ServerPartT m a -> IO ()
-simpleHTTPWithSocket' toIO socket conf hs =
-    Listen.listen' socket conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
+                      -> Socket -> Maybe HTTPS -> Conf -> ServerPartT m a -> IO ()
+simpleHTTPWithSocket' toIO socket mHttps conf hs =
+    Listen.listen' socket mHttps conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
 
 -- | Bind port and return the socket for use with 'simpleHTTPWithSocket'. This
 -- function always binds to IPv4 ports until Network module is fixed
diff --git a/src/Happstack/Server/Types.hs b/src/Happstack/Server/Types.hs
--- a/src/Happstack/Server/Types.hs
+++ b/src/Happstack/Server/Types.hs
@@ -7,7 +7,7 @@
      setHeader, setHeaderBS, setHeaderUnsafe,
      addHeader, addHeaderBS, addHeaderUnsafe,
      setRsCode, -- setCookie, setCookies,
-     Conf(..), nullConf, result, resultBS,
+     Conf(..), nullConf, TLSConf(..), HTTPS(..), result, resultBS,
      redirect, -- redirect_, redirect', redirect'_,
      isHTTP1_0, isHTTP1_1,
      RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
diff --git a/src/Happstack/Server/XSLT.hs b/src/Happstack/Server/XSLT.hs
deleted file mode 100644
--- a/src/Happstack/Server/XSLT.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,
-             DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,
-    ScopedTypeVariables #-}
--- | Functions to allow you to use XSLT to transform your output. To use this, you would generally design your happstack application to output XML. The xslt filter will then run an external tool which performs the tranforms. The transformed result will then be sent to the http client as the Response.
---
--- NOTE: This module is currently looking for a maintainer. If you want to improve XSLT support in Happstack, please volunteer!
-module Happstack.Server.XSLT
-    (xsltFile, xsltString, {- xsltElem, -} xsltFPS, xsltFPSIO, XSLPath,
-     xslt, doXslt, xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd
-    ) where
-
-
-import System.Log.Logger
-
-import Control.Concurrent              (forkIO)
-import Control.Concurrent.MVar         (newEmptyMVar, putMVar, takeMVar)
-import Control.Monad
-import Control.Monad.Trans
-import qualified Data.ByteString.Char8           as B
-import Happstack.Server.SimpleHTTP
-
-import Happstack.Server.Types
--- import Happstack.Server.MinHaXML
-import Control.Exception.Extensible(bracket,try,SomeException)
-import qualified Data.ByteString.Char8 as P
-import qualified Data.ByteString.Lazy.Char8 as L
-import System.Directory(removeFile)
-import System.Environment(getEnv)
-import System.Exit (ExitCode(..))
-import System.IO
-import System.IO.Unsafe(unsafePerformIO)
-import System.Process (runInteractiveProcess, waitForProcess)
--- import Text.XML.HaXml.Verbatim(verbatim)
-import Happstack.Data hiding (Element)
-
-logMX :: Priority -> String -> IO ()
-logMX = logM "Happstack.Server.XSLT"
-
-type XSLPath = FilePath
-
-$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]
-   [d|
-       data XSLTCmd = XSLTProc | Saxon 
-    |]
-   )
-
-xsltCmd :: XSLTCmd
-           -> XSLPath
-           -> FilePath
-           -> FilePath
-           -> (FilePath, [String])
-xsltCmd XSLTProc = xsltproc'
-xsltCmd Saxon = saxon'
-{-
--- | Uses 'xsltString' to transform the given XML 'Element' into a
--- a 'String'.    
-xsltElem :: XSLPath -> Element -> String
-xsltElem xsl = xsltString xsl . verbatim
--}
-
-procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString
-procLBSIO xsltp' xsl inp = 
-    withTempFile "happs-src.xml" $ \sfp sh -> do
-    withTempFile "happs-dst.xml" $ \dfp dh -> do
-    let xsltp = xsltCmd xsltp'
-    L.hPut sh inp
-    hClose sh
-    hClose dh
-    xsltFileEx xsltp xsl sfp dfp
-    s <- L.readFile dfp
-    logMX DEBUG (">>> XSLT: result: "++ show s)
-    return s
-
-
-procFPSIO :: XSLTCommand
-             -> XSLPath
-             -> [P.ByteString]
-             -> IO [P.ByteString]
-procFPSIO xsltp xsl inp = 
-    withTempFile "happs-src.xml" $ \sfp sh -> do
-    withTempFile "happs-dst.xml" $ \dfp dh -> do
-    mapM_ (P.hPut sh) inp
-    hClose sh
-    hClose dh
-    xsltFileEx xsltp xsl sfp dfp
-    s <- P.readFile dfp
-    logMX DEBUG (">>> XSLT: result: "++ show s)
-    return [s]
-
--- | Performs an XSL transformation with lists of ByteStrings instead of
--- a String.
-xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]
-xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl
-
--- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level
--- ByteString operations.
-xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]
-xsltFPSIO xsl inp = 
-    withTempFile "happs-src.xml" $ \sfp sh -> do
-    withTempFile "happs-dst.xml" $ \dfp dh -> do
-    mapM_ (P.hPut sh) inp
-    hClose sh
-    hClose dh
-    xsltFile xsl sfp dfp
-    s <- P.readFile dfp
-    logMX DEBUG (">>> XSLT: result: "++ show s)
-    return [s]
-
--- | Uses the provided xsl file to transform the given string.
--- This function creates temporary files during its execution, but
--- guarantees their cleanup.
-xsltString :: XSLPath -> String -> String
-xsltString xsl inp = unsafePerformIO $
-    withTempFile "happs-src.xml" $ \sfp sh -> do
-    withTempFile "happs-dst.xml" $ \dfp dh -> do
-    hPutStr sh inp
-    hClose sh
-    hClose dh
-    xsltFile xsl sfp dfp
-    s <- readFileStrict dfp
-    logMX DEBUG (">>> XSLT: result: "++ show s)
-    return s
-
--- | Note that the xsl file must have .xsl suffix.
-xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()
-xsltFile = xsltFileEx xsltproc'
-
--- | Use @xsltproc@ to transform XML.
-xsltproc :: XSLTCmd
-xsltproc = XSLTProc
-xsltproc' :: XSLTCommand
-xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])
-
-
--- | Use @saxon@ to transform XML.
-saxon :: XSLTCmd
-saxon = Saxon
-saxon' :: XSLTCommand
-saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",
-                     ["com.icl.saxon.StyleSheet"
-                     ,"-o",dst,src,xsl])
-                        
-type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])
-xsltFileEx   :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()
-xsltFileEx xsltp xsl src dst = do
-    let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])
-    logMX DEBUG msg
-    uncurry runCommand $ xsltp dst xsl src
-    logMX DEBUG (">>> XSLT: xsltproc done")
-
--- Utilities
-
-withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a
-withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)
-
-readFileStrict :: FilePath -> IO String
-readFileStrict fp = do
-    let fseqM [] = return [] 
-        fseqM xs = last xs `seq` return xs
-    fseqM =<< readFile fp
-
-{-# NOINLINE tempDir #-}
-tempDir :: FilePath
-tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err
-    where err = return "/tmp"
-
-tryAny :: [IO a] -> IO a -> IO a
-tryAny [] c     = c
-tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x
-
--- | Use @cmd@ to transform XML against @xslPath@.  This function only
--- acts if the content-type is @application\/xml@.
-xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>
-        XSLTCmd  -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.
-     -> XSLPath      -- ^ Path to xslt stylesheet.
-     -> m r -- ^ Affected 'ServerPart's.
-     -> m Response
-xslt cmd xslPath parts = do
-    res <- parts
-    if toContentType res == B.pack "application/xml"
-        then doXslt cmd xslPath (toResponse res)
-        else return (toResponse res)
-
-doXslt :: (MonadIO m) =>
-          XSLTCmd -> XSLPath -> Response -> m Response
-doXslt cmd xslPath res =
-    do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res
-       return $ setHeader "Content-Type" "text/html" $
-              setHeader "Content-Length" (show $ L.length new) $
-              res { rsBody = new }
-              
--- | Run an external command. Upon failure print status
---   to stderr.
-runCommand :: String -> [String] -> IO ()
-runCommand cmd args = do 
-    (_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing
-    let pGetContents h = do mv <- newEmptyMVar
-                            let put [] = putMVar mv []
-                                put xs = last xs `seq` putMVar mv xs
-                            forkIO (hGetContents h >>= put)
-                            takeMVar mv
-    os <- pGetContents outP
-    es <- pGetContents errP
-    ec <- waitForProcess pid
-    case ec of
-      ExitSuccess   -> return ()
-      ExitFailure e ->
-          do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")")
-             hPutStrLn stderr os
-             hPutStrLn stderr es
-             hPutStrLn stderr "Raising error..."
-             fail "Running external command failed"
-
-