packages feed

happstack-server (empty) → 0.1

raw patch · 31 files changed

+4885/−0 lines, 31 filesdep +HUnitdep +HaXmldep +basesetup-changed

Dependencies added: HUnit, HaXml, base, bytestring, containers, directory, extensible-exceptions, happstack-data, happstack-ixset, happstack-state, happstack-util, hslogger, html, mtl, network, old-locale, old-time, parsec, process, syb, template-haskell, unix, xhtml

Files

+ COPYING view
@@ -0,0 +1,29 @@+Copyright (c) 2006, HAppS.org+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of the HAppS.org; nor the names of its contributors+may be used to endorse or promote products derived from this software+without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ happstack-server.cabal view
@@ -0,0 +1,90 @@+Name:                happstack-server+Version:             0.1+Synopsis:            Web related tools and services.+Description:         Web framework+License:             BSD3+License-file:        COPYING+Author:              Happstack team, HAppS LLC+Maintainer:          Happstack team <happs@googlegroups.com>+homepage:            http://happstack.com+Category:            Web, Distributed Computing+Build-Type:          Simple+Cabal-Version:       >= 1.2.3++Flag base4+    Description: Choose the even newer, even smaller, split-up base package.++Flag tests+    Description: Build the testsuite, and include the tests in the library+    Default: True++Library++  Exposed-modules:+                       HAppS.Server,+                       HAppS.Server.Cookie,+                       HAppS.Server.HTTP.Client,+                       HAppS.Server.HTTP.Types,+                       HAppS.Server.HTTP.LowLevel,+                       HAppS.Server.HTTP.FileServe,+                       HAppS.Server.SimpleHTTP,+                       HAppS.Server.JSON,+                       HAppS.Server.MessageWrap,+                       HAppS.Server.MinHaXML,+                       HAppS.Server.SURI,+                       HAppS.Server.XSLT,+                       HAppS.Server.Cron,+                       HAppS.Server.StdConfig,+                       HAppS.Store.Util+  if flag(tests)+    Exposed-modules:   +                       HAppS.Server.Tests+  Other-modules:       +                       HAppS.Server.S3,+                       HAppS.Server.HTTPClient.HTTP,+                       HAppS.Server.HTTPClient.Stream,+                       HAppS.Server.HTTPClient.TCP,+                       HAppS.Server.HTTP.Clock,+                       HAppS.Server.HTTP.Handler,+                       HAppS.Server.HTTP.LazyLiner,+                       HAppS.Server.HTTP.Listen,+                       HAppS.Server.HTTP.Multipart,+                       HAppS.Server.HTTP.RFC822Headers,+                       HAppS.Server.SURI.ParseURI++  Build-Depends:       base, HaXml >= 1.13 && < 1.14, parsec<3, mtl, network,+                       hslogger >= 1.0.2, happstack-data, happstack-util,+                       happstack-state, happstack-ixset, template-haskell, xhtml, html,+                       bytestring, containers, old-time, old-locale, directory, +                       process, extensible-exceptions+  hs-source-dirs:      src+  if flag(tests)+    hs-source-dirs:    tests++  if !os(windows)+     Build-Depends:    unix+     cpp-options:      -DUNIX+  if flag(base4)+    Build-Depends:     base >= 4 && < 5, syb++  if flag(tests)+    Build-Depends:     HUnit++  -- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains+  Extensions:          TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses,+                       TypeFamilies, FlexibleContexts, OverlappingInstances,+                       FlexibleInstances, UndecidableInstances, ScopedTypeVariables,+                       TypeSynonymInstances, PatternGuards, PatternSignatures,+                       CPP, ForeignFunctionInterface+  ghc-options:         -Wall+  GHC-Prof-Options:    -auto-all++Executable happstack-server-tests+  Main-Is: Test.hs+  GHC-Options: -threaded+  Build-depends: HUnit+  hs-source-dirs: tests, src+  if flag(tests)+    Buildable: True+  else+    Buildable: False
+ src/HAppS/Server.hs view
@@ -0,0 +1,21 @@+module HAppS.Server +(+ module HAppS.State.Control+,module HAppS.Server.XSLT+,module HAppS.Server.SimpleHTTP+,module HAppS.Server.HTTP.Client+,module HAppS.Server.MessageWrap+,module HAppS.Server.HTTP.FileServe+,module HAppS.Server.StdConfig+,module HAppS.Store.Util++)+where+import HAppS.Server.HTTP.Client+import HAppS.Server.StdConfig+import HAppS.State.Control+import HAppS.Server.XSLT+import HAppS.Server.SimpleHTTP+import HAppS.Server.MessageWrap+import HAppS.Server.HTTP.FileServe+import HAppS.Store.Util
+ src/HAppS/Server/Cookie.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- http://tools.ietf.org/html/rfc2109+module HAppS.Server.Cookie+    ( Cookie(..), mkCookie, mkCookieHeader+    , getCookies, getCookie )+    where++import qualified Data.ByteString.Char8 as C+import Data.Char+import Data.List+import Data.Generics+import HAppS.Util.Common (Seconds)+import Text.ParserCombinators.ReadP++data Cookie = Cookie+    { cookieVersion :: String+    , cookiePath    :: String+    , cookieDomain  :: String+    , cookieName    :: String+    , cookieValue   :: String+    } deriving(Show,Eq,Read,Typeable,Data)++mkCookie :: String -> String -> Cookie+mkCookie key val = Cookie "1" "/" "" key val++-- | Set a Cookie in the Result.+-- The values are escaped as per RFC 2109, but some browsers may+-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.+mkCookieHeader :: Seconds -> Cookie -> String+mkCookieHeader sec cookie =+    let l = [("Domain=",s cookieDomain)+            ,("Max-Age=",if sec < 0 then "" else show sec)+            ,("Path=", cookiePath cookie)+            ,("Version=", s cookieVersion)]+        s f | f cookie == "" = ""+        s f   = '\"' : concatMap e (f cookie) ++ "\""+        e c | fctl c || c == '"' = ['\\',c]+            | otherwise          = [c]+    in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])+++{- Cookie syntax:+   av-pairs        =       av-pair *(";" av-pair)+   av-pair         =       attr ["=" value]        ; optional value+   attr            =       token+   value           =       word+   word            =       token | quoted-string+-}++gmany :: ReadP a -> ReadP [a]+gmany  p = gmany1 p <++ return []+gmany1 :: ReadP a -> ReadP [a]+gmany1 p = do x  <- p+              xs <- gmany1 p <++ return []+              return (x:xs)+gskipMany1 :: ReadP a -> ReadP ()+gskipMany1 p = p >> (gskipMany p <++ return ())+gskipMany :: ReadP a -> ReadP ()+gskipMany  p = gskipMany1 p <++ return ()++fctl :: Char -> Bool+fctl         = \ch -> ch == chr 127 || ch <= chr 31+fseparator :: Char -> Bool+fseparator   = \ch -> ch `elem` "()<>@,;:\\\"[]?={} \t" -- ignore '/' here+fchar :: Char -> Bool+fchar        = \ch -> ch <= chr 127+ftoken :: Char -> Bool+ftoken       = \ch -> fchar ch && not (fctl ch || fseparator ch)+lws :: ReadP ()+lws          = ((char '\r' >> char '\n') <++ return ' ') >> gskipMany (satisfy (\ch -> ch == ' ' || ch == '\t'))+token :: ReadP [Char]+token        = gmany $ satisfy ftoken+quotedString :: ReadP [Char]+quotedString = do char '"'  -- " stupid emacs syntax highlighting+                  x <- many ((char '\\' >> satisfy fchar) <++ (satisfy $ \ch -> ch /= '"' && fchar ch && (ch == ' ' || ch == '\t' || not (fctl ch))))+                  char '"' -- " stupid emacs syntax highlighting+                  return x+word :: ReadP [Char]+word = quotedString <++ token++avPair :: ReadP (String, [Char])+avPair = do+  k <- token+  lws >> char '=' >> lws+  v <- word+  return (low k,v)++sep :: ReadP ()+sep = lws >> satisfy (\ch -> ch == ',' || ch == ';') >> lws++cookies :: ReadP [Cookie]+cookies = do+  let kpw n = do lws+                 (k,v) <- avPair+                 if k == n then return v else fail "Invalid key"+  ver <- ((kpw "$version" <~ sep) <++ return "")+  let ci = do (k,v) <- avPair+              p <- (sep >> kpw "$path")   <++ return ""+              d <- (sep >> kpw "$domain") <++ return ""+              return $ Cookie ver p d k v+  x  <- lws >> ci+  xs <- gmany (sep >> ci) <~ lws+  return (x:xs)++(<~) :: Monad m => m a -> m b -> m a+(<~) a b = do x <- a; b; return x++parse :: Monad m => String -> m [Cookie]+parse i = case readP_to_S cookies i of+            [(res,"")] -> return res+            xs         -> fail ("Invalid cookie syntax!: at position "++show (length i - length xs)++" input "++show i)++-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from+-- the most specific to the least specific. Multiple cookies with the same+-- name are allowed to exist.+getCookies :: Monad m => C.ByteString -> m [Cookie]+getCookies header | C.null header = return []+                  | otherwise     = parse (C.unpack header)+++-- | Get the most specific cookie with the given name. Fails if there is no such+-- cookie or if the browser did not escape cookies in a proper fashion.+-- Browser support for escaping cookies properly is very diverse.+getCookie :: Monad m => String -> C.ByteString -> m Cookie+getCookie s h = do cs <- getCookies h+                   case filter ((==) (low s) . cookieName) cs of+                     [r] -> return r+                     _   -> fail ("getCookie: " ++ show s)++low :: String -> String+low = map toLower
+ src/HAppS/Server/Cron.hs view
@@ -0,0 +1,12 @@+module HAppS.Server.Cron (cron) where++import Control.Concurrent (threadDelay)++type Seconds = Int++cron :: Seconds -> IO () -> IO a+cron seconds action+    = loop+    where loop = do threadDelay (10^(6 :: Int) * seconds)+                    action+                    loop
+ src/HAppS/Server/HTTP/Client.hs view
@@ -0,0 +1,50 @@+module HAppS.Server.HTTP.Client where+++import HAppS.Server.HTTP.Handler+import HAppS.Server.HTTP.Types+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L ++import System.IO+import qualified Data.ByteString.Char8 as B +import Network++getResponse :: Request -> IO (Either String Response)+getResponse rq = withSocketsDo $ do+  let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq +      portInt = if null p then 80 else read $ tail p+      portId = PortNumber $ toEnum $ portInt+  h <- connectTo hostName portId +  hSetBuffering h NoBuffering++  putRequest h rq+  hFlush h++  inputStr <- L.hGetContents h+  return $ parseResponse inputStr++unproxify :: Request -> Request+unproxify rq = rq {rqPaths = tail $ rqPaths rq,+                   rqHeaders = +                       forwardedFor $ forwardedHost $ +                       setHeader "host" (head $ rqPaths rq) $+                   rqHeaders rq}+  where+  appendInfo hdr val x = setHeader hdr (csv val $+                                        maybe "" B.unpack $+                                        getHeader hdr rq) x+  forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq)+  forwardedHost = appendInfo "X-Forwarded-Host" +                  (B.unpack $ fromJust $ getHeader "host" rq)+  csv v "" = v+  csv v x = x++", " ++ v++unrproxify :: String -> [(String, String)] -> Request -> Request+unrproxify defaultHost list rq = unproxify rq {rqPaths = host: rqPaths rq}+  where+  host::String+  host = maybe defaultHost (f .B.unpack) $+         getHeader "host" rq+  f = maybe defaultHost id . flip lookup list+
+ src/HAppS/Server/HTTP/Clock.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-cse #-}+module HAppS.Server.HTTP.Clock(getApproximateTime) where++import Control.Concurrent+import Data.IORef+import System.IO.Unsafe+import System.Time+import System.Locale++import qualified Data.ByteString.Char8 as B++mkTime :: IO B.ByteString+mkTime = do now <- getClockTime+            return $ B.pack (formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" (toUTCTime now))+++{-# NOINLINE clock #-}+clock :: IORef B.ByteString+clock = unsafePerformIO $ do+  ref <- newIORef =<< mkTime+  forkIO $ updater ref+  return ref++updater :: IORef B.ByteString -> IO ()+updater ref = do threadDelay (10^(6 :: Int) * 1) -- Every second+                 writeIORef ref =<< mkTime+                 updater ref++getApproximateTime :: IO B.ByteString+getApproximateTime = readIORef clock
+ src/HAppS/Server/HTTP/FileServe.hs view
@@ -0,0 +1,215 @@+module HAppS.Server.HTTP.FileServe+    (+     MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper+    ) where++import Control.Exception.Extensible++import Control.Monad.Reader+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Data.Int+import HAppS.Server.SimpleHTTP hiding (path)+import System.Directory+import System.IO+import System.Locale(defaultTimeLocale)+import System.Log.Logger+import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Map as Map+import qualified HAppS.Server.SimpleHTTP as SH++ioErrors :: SomeException -> Maybe IOException+ioErrors = fromException++errorwrapper :: MonadIO m => String -> String -> ServerPartT m Response+errorwrapper binarylocation loglocation+    = require getErrorLog $ \errorLog ->+      --[method () $ SH.ok errorLog]+      [anyRequest $ liftIO $ return $ toResponse errorLog]+    where getErrorLog+              = liftIO $+                handleJust ioErrors (const (return Nothing)) $+                do bintime <- getModificationTime binarylocation+                   logtime <- getModificationTime loglocation+                   if (logtime > bintime)+                     then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./"+                     else return Nothing++type MimeMap = Map.Map String String++doIndex :: (MonadIO m) =>+           [String] -> Map.Map String String -> Request -> String -> WebT m Response+doIndex [] _mime _rq _fp = do setResponseCode 403+                              return $ toResponse "Directory index forbidden"+doIndex (index:rest) mime rq fp =+    do+    let path = fp++'/':index+    --print path+    fe <- liftIO $ doesFileExist path+    if fe then retFile path else doIndex rest mime rq fp+    where retFile = returnFile mime rq+defaultIxFiles :: [String]+defaultIxFiles= ["index.html","index.xml","index.gif"]++fileServe :: MonadIO m => [FilePath] -> FilePath -> ServerPartT m Response+fileServe ixFiles localpath  = +    withRequest (fileServe' localpath (doIndex (ixFiles++defaultIxFiles)) mimeTypes)++-- | Serve files with a mime type map under a directory.+--   Uses the function to transform URIs to FilePaths.+fileServe' :: (MonadIO m) =>+              String+              -> (Map.Map String String -> Request -> String -> WebT m Response)+              -> Map.Map String String+              -> Request+              -> WebT m Response+fileServe' localpath fdir mime rq = do+    let fp2 = takeWhile (/=',') fp+        fp = filepath+        safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)+        filepath = intercalate "/"  (localpath:safepath)+        fp' = if null safepath then "" else last safepath+    if "TESTH" `isPrefixOf` fp'+        then renderResponse mime rq $ fakeFile $ (read $ drop 5 $ fp' :: Integer)+        else do+    fe <- liftIO $ doesFileExist fp+    fe2 <- liftIO $ doesFileExist fp2+    de <- liftIO $ doesDirectoryExist fp+    -- error $ "show ilepath: " ++show (fp,de)+    let status | de   = "DIR"+               | fe   = "file"+               | fe2  = "group"+               | True = "NOT FOUND"+    liftIO $ logM "HAppS.Server.HTTP.FileServe" INFO ("fileServe: "++show fp++" \t"++status)+    if de then fdir mime rq fp else do+    getFile mime fp >>= flip either (renderResponse mime rq) +                (const $ returnGroup localpath mime rq safepath)++returnFile :: (MonadIO m) =>+              Map.Map String String -> Request -> String -> WebT m Response+returnFile mime rq fp =  +    getFile mime fp >>=  either fileNotFound (renderResponse mime rq)++-- if fp has , separated then return concatenation with content-type of last+-- and last modified of latest+tr :: (Eq a) => a -> a -> [a] -> [a]+tr a b list = map (\x->if x==a then b else x) list+ltrim :: String -> String+ltrim = dropWhile (flip elem " \t\r")   ++returnGroup :: (MonadIO m) =>+               String -> Map.Map String String -> Request -> [String] -> WebT m Response+returnGroup localPath mime rq fp = do+  let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp+      fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0++  -- if (head $ head fps0)=="TEST" then   renderResponse mime rq fakeFile else do++  mbFiles <-  mapM (getFile mime) $ fps+  let notFounds = [x | Left x <- mbFiles]+      files = [x | Right x <- mbFiles]+  if not $ null notFounds +    then fileNotFound $ drop (length localPath) $ head notFounds else do+  let totSize = sum $ map (snd . fst) files+      maxTime = maximum $ map (fst . fst) files :: ClockTime++  renderResponse mime rq ((maxTime,totSize),(fst $ snd $ head files,+                                             L.concat $ map (snd . snd) files))++++fileNotFound :: (Monad m) => String -> WebT m Response+fileNotFound fp = do setResponseCode 404 +                     return $ toResponse $ "File not found "++ fp+--fakeLen = 71* 1024+fakeFile :: (Integral a) =>+            a -> ((ClockTime, Int64), (String, L.ByteString))+fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))+    where+      body = L.pack $ (("//"++(show len)++" ") ++ ) $ (take len $ repeat '0') ++ "\n"+      len = fromIntegral fakeLen++getFile :: (MonadIO m) =>+           Map.Map String String+           -> String+           -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))+getFile mime fp = do+  let ct = Map.findWithDefault "text/plain" (getExt fp) mime+  fe <- liftIO $ doesFileExist fp+  if not fe then return $ Left fp else do+  +  time <- liftIO  $ getModificationTime fp+  h <- liftIO $ openBinaryFile fp ReadMode+  size <- liftIO $ hFileSize h+  lbs <- liftIO $ L.hGetContents h+  return $ Right ((time,size),(ct,lbs))++++renderResponse :: (Monad m,+                   Show t1) =>+                  t+                  -> Request+                  -> ((ClockTime, t1), (String, L.ByteString))+                  -> WebT m Response+renderResponse _ rq ((modtime,size),(ct,body)) = do++  let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)+      repr = formatCalendarTime defaultTimeLocale +             "%a, %d %b %Y %X GMT" (toUTCTime modtime)+  -- "Mon, 07 Jan 2008 19:51:02 GMT"+  -- when (isJust $ getHeader "if-modified-since"  rq) $ error $ show $ getHeader "if-modified-since" rq+  if notmodified then do setResponseCode 304 ; return $ toResponse "" else do+  --  modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr))+  modifyResponse (setHeader "Last-modified" repr)+  -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid+  modifyResponse (setHeader "Content-Length" (show size))+  modifyResponse (setHeader "Content-Type" ct)  +  return $ resultBS 200 body++              +++getExt :: String -> String+getExt fPath = reverse $ takeWhile (/='.') $ reverse fPath++-- | Ready collection of common mime types.+mimeTypes :: MimeMap+mimeTypes = Map.fromList+	    [("xml","application/xml")+	    ,("xsl","application/xml")+	    ,("js","text/javascript")+	    ,("html","text/html")+	    ,("css","text/css")+	    ,("gif","image/gif")+	    ,("jpg","image/jpeg")+	    ,("png","image/png")+	    ,("txt","text/plain")+	    ,("doc","application/msword")+	    ,("exe","application/octet-stream")+	    ,("pdf","application/pdf")+	    ,("zip","application/zip")+	    ,("gz","application/x-gzip")+	    ,("ps","application/postscript")+	    ,("rtf","application/rtf")+	    ,("wav","application/x-wav")+	    ,("hs","text/plain")]++++blockDotFiles :: (Request -> IO Response) -> Request -> IO Response+blockDotFiles fn rq+    | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."+    | otherwise = fn rq++isDot :: String -> Bool+isDot = isD . reverse+    where+    isD ('.':'/':_) = True+    isD ['.']       = True+    --isD ('/':_)     = False+    isD (_:cs)      = isD cs+    isD []          = False
+ src/HAppS/Server/HTTP/Handler.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}++module HAppS.Server.HTTP.Handler(request-- version,required+  ,parseResponse,putRequest+-- ,unchunkBody,val,testChunk,pack+) where+--    ,fsepC,crlfC,pversion+import Control.Exception.Extensible as E+import Control.Monad+import Data.List(elemIndex)+import Data.Char(toLower)+import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )+import Prelude hiding (last)+import qualified Data.List as List+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Map as M+import System.IO+import Numeric+import Data.Int (Int64)+import HAppS.Server.Cookie+import HAppS.Server.HTTP.Clock+import HAppS.Server.HTTP.LazyLiner+import HAppS.Server.HTTP.Types+import HAppS.Server.HTTP.Multipart+import HAppS.Server.HTTP.RFC822Headers+import HAppS.Server.MessageWrap+import HAppS.Server.SURI(SURI(..),path,query)+import HAppS.Server.SURI.ParseURI+import HAppS.Util.TimeOut+++request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()+request conf h host handler = rloop conf h host handler =<< L.hGetContents h++required :: String -> Maybe a -> Either String a+required err Nothing  = Left err+required _   (Just a) = Right a++transferEncodingC :: [Char]+transferEncodingC = "transfer-encoding"+rloop :: t+         -> Handle+         -> Host+         -> (Request -> IO Response)+         -> L.ByteString+         -> IO ()+rloop conf h host handler inputStr+    | L.null inputStr = return ()+    | otherwise+    = join $ withTimeOut (30 * second) $+      do let parseRequest+                 = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr+                      (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr+                      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)+                      (body, nextRequest) <- case () of+                          () | contentLength < 0               -> fail "negative content-length"+                             | isJust $ getHeader transferEncodingC headers ->+                                 return $ consumeChunks restStr+                             | otherwise                       -> return (L.splitAt (fromIntegral contentLength) restStr)+                      let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle+                          rqTmp = Request m (pathEls (path u)) (path u) (query u) +                                  [] cookies v headers (Body body) host+                          rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp}+                      return (rq, nextRequest)+         case parseRequest of+           Left err -> error $ "failed to parse HTTP request: " ++ err+           Right (req, rest)+               -> return $+                  do let ioseq act = act >>= \x -> x `seq` return x+                     res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e+                     putAugmentedResult h req res+                     when (continueHTTP req res) $ rloop conf h host handler rest++parseResponse :: L.ByteString -> Either String Response+parseResponse inputStr =+    do (topStr,restStr) <- required "failed to separate response" $ +                           splitAtEmptyLine inputStr+       (rsl,headerStr) <- required "failed to separate headers/body" $+                          splitAtCRLF topStr+       let (_,code) = responseLine rsl+       headers' <- parseHeaders "host" (L.unpack headerStr)+       let headers = mkHeaders headers'+       let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)+       (body,_) <-+           maybe (if (isNothing $ getHeader "transfer-encoding" headers) +                       then  return (restStr,L.pack "") +                       else  return $ consumeChunks restStr)+                 (\cl->return (L.splitAt (fromIntegral cl) restStr))+                 mbCL+       return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True,rsValidator=Nothing}++-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html+-- note this does NOT handle extenions+consumeChunks::L.ByteString->(L.ByteString,L.ByteString)+consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)++consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)+consumeChunksImpl str+    | L.null str = ([],L.empty,str)+    | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str+                          (tr',rest'') = getTrailer rest' +                      in ([(0,last)],tr',rest'')+    | otherwise = ((chunkLen,part):crest,tr,rest2)+    where+      line1 = head $ lazylines str +      lenLine1 = (L.length line1) + 1 -- endchar+      chunkLen = (fst $ head $ readHex $ L.unpack line1)+      len = chunkLen + lenLine1 + 2+      (part,rest) = L.splitAt len str+      (crest,tr,rest2) = consumeChunksImpl rest+      getTrailer s = L.splitAt index s+          where index | crlfLC `L.isPrefixOf` s = 2+                      | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s+                                        Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))+                                    in fromIntegral $ i+4++crlfLC :: L.ByteString+crlfLC = L.pack "\r\n"++-- Properly lazy version of 'lines' for lazy bytestrings+lazylines           :: L.ByteString -> [L.ByteString]+lazylines s+    | L.null s  = []+    | otherwise =+        let (l,s') = L.break ((==) '\n') s+        in l : if L.null s' then []+                            else lazylines (L.tail s')++requestLine :: L.ByteString -> (Method, SURI, Version)+requestLine l = case P.words ((P.concat . L.toChunks) l) of+                  [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)+                  [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9)+                  x -> error $ "requestLine cannot handle input:  " ++ (show x)++responseLine :: L.ByteString -> (B.ByteString, Int)+responseLine l = case B.words ((B.concat . L.toChunks) l) of +                   (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))+                   x -> error $ "responseLine cannot handle input: " ++ (show x)+++method :: B.ByteString -> Method+method r = fj $ lookup r mtable+    where fj (Just x) = x+          fj Nothing  = error "invalid request method"+          mtable = [(P.pack "GET",     GET),+                    (P.pack "HEAD",    HEAD),+                    (P.pack "POST",    POST),+                    (P.pack "PUT",     PUT),+                    (P.pack "DELETE",  DELETE),+                    (P.pack "TRACE",   TRACE),+                    (P.pack "OPTIONS", OPTIONS),+                    (P.pack "CONNECT", CONNECT)]++-- Result side++staticHeaders :: Headers+staticHeaders =+    foldr (uncurry setHeaderBS) (mkHeaders [])+    [ (serverC, happsC), (contentTypeC, textHtmlC) ]++putAugmentedResult :: Handle -> Request -> Response -> IO ()+putAugmentedResult h req res = do+  let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs+  raw <- getApproximateTime+  let cl = L.length $ rsBody res+  let put x = P.hPut h x+  -- TODO: Hoist static headers to the toplevel.+  let stdHeaders = staticHeaders `M.union`+                   M.fromList ( [ (dateCLower,       HeaderPair dateC [raw])+                                , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])+                                ] ++ if rsfContentLength (rsFlags res)+                                     then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]+                                     else [] )+      allHeaders = rsHeaders res `M.union` stdHeaders  -- 'union' prefers 'headers res' when duplicate keys are encountered.++  mapM_ put $ concat+    [ (pversion $ rqVersion req)          -- Print HTTP version+    , [responseMessage $ rsCode res]      -- Print responseCode+    , concatMap ph (M.elems allHeaders)   -- Print all headers+    , [crlfC]+    ]+  when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res+  hFlush h+++putRequest :: Handle -> Request -> IO ()+putRequest h rq = do +    let put x = B.hPut h x+        ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs+        sp = [B.pack " "]+    mapM_ put $ concat+      [[B.pack $ show $ rqMethod rq],sp+      ,[B.pack $ rqURL rq],sp+      ,(pversion $ rqVersion rq), [crlfC]+      ,concatMap ph (M.elems $ rqHeaders rq)+      ,[crlfC]+      ]+    let Body body = rqBody rq+    L.hPut h  body+    hFlush h++++-- Version++pversion :: Version -> [B.ByteString]+pversion (Version 1 1) = [http11]+pversion (Version 1 0) = [http10]+pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]++version :: B.ByteString -> Version+version x | x == http09 = Version 0 9+          | x == http10 = Version 1 0+          | x == http11 = Version 1 1+          | otherwise   = error "Invalid HTTP version"++http09 :: B.ByteString+http09 = P.pack "HTTP/0.9"+http10 :: B.ByteString+http10 = P.pack "HTTP/1.0"+http11 :: B.ByteString+http11 = P.pack "HTTP/1.1"++-- Constants++connectionC :: B.ByteString+connectionC      = P.pack "Connection"+connectionCLower :: B.ByteString+connectionCLower = P.map toLower connectionC+closeC :: B.ByteString+closeC           = P.pack "close"+keepAliveC :: B.ByteString+keepAliveC       = P.pack "Keep-Alive"+crlfC :: B.ByteString+crlfC            = P.pack "\r\n"+fsepC :: B.ByteString+fsepC            = P.pack ": "+contentTypeC :: B.ByteString+contentTypeC     = P.pack "Content-Type"+contentLengthC :: B.ByteString+contentLengthC   = P.pack "Content-Length"+contentlengthC :: B.ByteString+contentlengthC   = P.pack "content-length"+dateC :: B.ByteString+dateC            = P.pack "Date"+dateCLower :: B.ByteString+dateCLower       = P.map toLower dateC+serverC :: B.ByteString+serverC          = P.pack "Server"+happsC :: B.ByteString+happsC           = P.pack "HAppS/0.9.2"+textHtmlC :: B.ByteString+textHtmlC        = P.pack "text/html; charset=utf-8"++-- Response code names++responseMessage :: (Num t) => t -> B.ByteString+responseMessage 100 = P.pack " 100 Continue\r\n"+responseMessage 101 = P.pack " 101 Switching Protocols\r\n"+responseMessage 200 = P.pack " 200 OK\r\n"+responseMessage 201 = P.pack " 201 Created\r\n"+responseMessage 202 = P.pack " 202 Accepted\r\n"+responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"+responseMessage 204 = P.pack " 204 No Content\r\n"+responseMessage 205 = P.pack " 205 Reset Content\r\n"+responseMessage 206 = P.pack " 206 Partial Content\r\n"+responseMessage 300 = P.pack " 300 Multiple Choices\r\n"+responseMessage 301 = P.pack " 301 Moved Permanently\r\n"+responseMessage 302 = P.pack " 302 Found\r\n"+responseMessage 303 = P.pack " 303 See Other\r\n"+responseMessage 304 = P.pack " 304 Not Modified\r\n"+responseMessage 305 = P.pack " 305 Use Proxy\r\n"+responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"+responseMessage 400 = P.pack " 400 Bad Request\r\n"+responseMessage 401 = P.pack " 401 Unauthorized\r\n"+responseMessage 402 = P.pack " 402 Payment Required\r\n"+responseMessage 403 = P.pack " 403 Forbidden\r\n"+responseMessage 404 = P.pack " 404 Not Found\r\n"+responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"+responseMessage 406 = P.pack " 406 Not Acceptable\r\n"+responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"+responseMessage 408 = P.pack " 408 Request Time-out\r\n"+responseMessage 409 = P.pack " 409 Conflict\r\n"+responseMessage 410 = P.pack " 410 Gone\r\n"+responseMessage 411 = P.pack " 411 Length Required\r\n"+responseMessage 412 = P.pack " 412 Precondition Failed\r\n"+responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"+responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"+responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"+responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"+responseMessage 417 = P.pack " 417 Expectation Failed\r\n"+responseMessage 500 = P.pack " 500 Internal Server Error\r\n"+responseMessage 501 = P.pack " 501 Not Implemented\r\n"+responseMessage 502 = P.pack " 502 Bad Gateway\r\n"+responseMessage 503 = P.pack " 503 Service Unavailable\r\n"+responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"+responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"+responseMessage x   = P.pack (show x ++ "\r\n")+
+ src/HAppS/Server/HTTP/LazyLiner.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module HAppS.Server.HTTP.LazyLiner+    (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks+    ) where++import Control.Concurrent.MVar+import System.IO+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L++newtype Lazy = Lazy (MVar L.ByteString)++newLinerHandle :: Handle -> IO Lazy+newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)++headerLines :: Lazy -> IO [P.ByteString]+headerLines (Lazy mv) = modifyMVar mv $ \l -> do+  let loop acc r0 = let (h,r) = L.break ((==) ch) r0+                        ph    = toStrict h+                        phl   = P.length ph+                        ph2   = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph+                        ch    = '\x0A'+                        r'    = if L.null r then r else L.tail r+                    in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'+  return $ loop [] l++getBytesStrict :: Lazy -> Int -> IO P.ByteString+getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do+  let (h,p) = L.splitAt (fromIntegral len) l+  return (p, toStrict h)++getBytes :: Lazy -> Int -> IO L.ByteString+getBytes (Lazy mv) len = modifyMVar mv $ \l -> do+  let (h,p) = L.splitAt (fromIntegral len) l+  return (p, h)++getRest :: Lazy -> IO L.ByteString+getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)++toStrict :: L.ByteString -> P.ByteString+toStrict = P.concat . L.toChunks
+ src/HAppS/Server/HTTP/Listen.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}+module HAppS.Server.HTTP.Listen(listen) where++import System.Log.Logger++import HAppS.Server.HTTP.Types+import HAppS.Server.HTTP.Handler++import Control.Exception.Extensible as E+import Control.Concurrent+import Network+import Network.Socket as Socket hiding (listen)+import System.IO++{-+#ifndef mingw32_HOST_OS+-}+import System.Posix.Signals+{-+#endif+-}++-- alternative implementation of accept to work around EAI_AGAIN errors+acceptLite :: Socket -> IO (Handle, HostName, Socket.PortNumber)+acceptLite sock = do+  (sock', addr) <- Socket.accept sock+  (Just peer, _) <- getNameInfo [NI_NUMERICHOST] True False addr+  h <- socketToHandle sock' ReadWriteMode+  (PortNumber p) <- Network.socketPort sock'+  return (h, peer, p)++++listen :: Conf -> (Request -> IO Response) -> IO ()+listen conf hand = do+{-+#ifndef mingw32_HOST_OS+-}+  installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+  s <- listenOn $ PortNumber $ toEnum $ port conf+  let work (h,hn,p) = do -- hSetBuffering h NoBuffering+                         let eh (x::SomeException) = logM "HAppS.Server.HTTP.Listen" ERROR ("HTTP request failed with: "++show x)+                         request conf h (hn,fromIntegral p) hand `E.catch` eh+                         hClose h+  let loop = do acceptLite s >>= forkIO . work+                loop+  let pe e = logM "HAppS.Server.HTTP.Listen" ERROR ("ERROR in accept thread: "+++                                                    show e)+  let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi+  infi `finally` sClose s+{--+#ifndef mingw32_HOST_OS+-}+  installHandler openEndedPipe Ignore Nothing+  return ()+{-+#endif+-}+  where  -- why are these handlers needed?++    catchSome op h = op `E.catches` [+            Handler $ \(e :: ArithException) -> h (toException e),+            Handler $ \(e :: ArrayException) -> h (toException e)+          ]
+ src/HAppS/Server/HTTP/LowLevel.hs view
@@ -0,0 +1,28 @@+module HAppS.Server.HTTP.LowLevel+    (-- * HTTP Implementation+     -- $impl++     -- * Problems+     -- $problems++     -- * API+     module HAppS.Server.HTTP.Handler,+     module HAppS.Server.HTTP.Listen,+     module HAppS.Server.HTTP.Types+    ) where++import HAppS.Server.HTTP.Handler+import HAppS.Server.HTTP.Listen+import HAppS.Server.HTTP.Types++-- $impl+-- The HAppS HTTP implementation supports HTTP 1.0 and 1.1.+-- Multiple request on a connection including pipelining is supported.++-- $problems+-- Currently if a client sends an invalid HTTP request the whole+-- connection is aborted and no further processing is done.+--+-- When the connection times out HAppS closes it. In future it could+-- send a 408 response but this may be problematic if the sending+-- of a response caused the problem.
+ src/HAppS/Server/HTTP/Multipart.hs view
@@ -0,0 +1,216 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module      :  HAppS.Server.HTTP.Multipart+-- Copyright   :  (c) Peter Thiemann 2001,2002+--                (c) Bjorn Bringert 2005-2006+--                (c) Lemmih 2007+-- License     :  BSD-style+--+-- Maintainer  :  lemmih@vo.com+-- Stability   :  experimental+-- Portability :  xbnon-portable+--+-- Parsing of the multipart format from RFC2046.+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTP.Multipart+    (+     -- * Multi-part messages+     MultiPart(..), BodyPart(..), Header+    , parseMultipartBody, hGetMultipartBody+     -- * Headers+    , ContentType(..), ContentTransferEncoding(..)+    , ContentDisposition(..)+    , parseContentType+    , parseContentTransferEncoding+    , parseContentDisposition+    , getContentType+    , getContentTransferEncoding+    , getContentDisposition++    , splitAtEmptyLine+    , splitAtCRLF+    ) where++import Control.Monad+import Data.Int (Int64)+import Data.Maybe+import System.IO (Handle)++import HAppS.Server.HTTP.RFC822Headers++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++--+-- * Multi-part stuff.+--++data MultiPart = MultiPart [BodyPart]+               deriving (Show, Read, Eq, Ord)++data BodyPart = BodyPart [Header] ByteString+                deriving (Show, Read, Eq, Ord)++-- | Read a multi-part message from a 'ByteString'.+parseMultipartBody :: String -- ^ Boundary+                   -> ByteString -> Maybe MultiPart+parseMultipartBody b s = +    do+    ps <- splitParts (BS.pack b) s+    liftM MultiPart $ mapM parseBodyPart ps++-- | Read a multi-part message from a 'Handle'.+--   Fails on parse errors.+hGetMultipartBody :: String -- ^ Boundary+                  -> Handle+                  -> IO MultiPart+hGetMultipartBody b h = +    do+    s <- BS.hGetContents h+    case parseMultipartBody b s of+        Nothing -> fail "Error parsing multi-part message"+        Just m  -> return m++++parseBodyPart :: ByteString -> Maybe BodyPart+parseBodyPart s =+    do+    (hdr,bdy) <- splitAtEmptyLine s+    hs <- parseM pHeaders "<input>" (BS.unpack hdr)+    return $ BodyPart hs bdy++--+-- * Splitting into multipart parts.+--++-- | Split a multipart message into the multipart parts.+splitParts :: ByteString -- ^ The boundary, without the initial dashes+           -> ByteString +           -> Maybe [ByteString]+splitParts b s = dropPreamble b s >>= spl+  where+  spl x = case splitAtBoundary b x of+            Nothing -> Nothing+            Just (s1,d,s2) | isClose b d -> Just [s1]+                           | otherwise -> spl s2 >>= Just . (s1:)++-- | Drop everything up to and including the first line starting +--   with the boundary. Returns 'Nothing' if there is no +--   line starting with a boundary.+dropPreamble :: ByteString -- ^ The boundary, without the initial dashes+             -> ByteString +             -> Maybe ByteString+dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)+                 | otherwise = dropLine s >>= dropPreamble b++-- | Split a string at the first boundary line.+splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes+                -> ByteString -- ^ String to split.+                -> Maybe (ByteString,ByteString,ByteString)+                   -- ^ The part before the boundary, the boundary line,+                   --   and the part after the boundary line. The CRLF+                   --   before and the CRLF (if any) after the boundary line+                   --   are not included in any of the strings returned.+                   --   Returns 'Nothing' if there is no boundary.+splitAtBoundary b s = spl 0+  where+  spl i = case findCRLF (BS.drop i s) of+              Nothing -> Nothing+              Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)+                         | otherwise -> spl (i+j+l)+                  where +                  s1 = BS.take (i+j) s+                  s2 = BS.drop (i+j+l) s+                  (d,s3) = splitAtCRLF_ s2++-- | Check whether a string starts with two dashes followed by+--   the given boundary string.+isBoundary :: ByteString -- ^ The boundary, without the initial dashes+           -> ByteString+           -> Bool+isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s++-- | Check whether a string for which 'isBoundary' returns true+--   has two dashes after the boudary string.+isClose :: ByteString -- ^ The boundary, without the initial dashes+        -> ByteString +        -> Bool+isClose b s = startsWithDashes (BS.drop (2+BS.length b) s)++-- | Checks whether a string starts with two dashes.+startsWithDashes :: ByteString -> Bool+startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s+++--+-- * RFC 2046 CRLF+--++-- | Drop everything up to and including the first CRLF.+dropLine :: ByteString -> Maybe ByteString+dropLine s = fmap snd (splitAtCRLF s)++-- | Split a string at the first empty line. The CRLF (if any) before the+--   empty line is included in the first result. The CRLF after the+--   empty line is not included in the result.+--   'Nothing' is returned if there is no empty line.+splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)+splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)+                   | otherwise = spl 0+  where+  spl i = case findCRLF (BS.drop i s) of+              Nothing -> Nothing+              Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)+                         | otherwise -> spl (i+j+l)+                where (s1,s2) = BS.splitAt (i+j+l) s++-- | Split a string at the first CRLF. The CRLF is not included+--   in any of the returned strings.+splitAtCRLF :: ByteString -- ^ String to split.+            -> Maybe (ByteString,ByteString)+            -- ^  Returns 'Nothing' if there is no CRLF.+splitAtCRLF s = case findCRLF s of+                  Nothing -> Nothing+                  Just (i,l) -> Just (s1, BS.drop l s2)+                      where (s1,s2) = BS.splitAt i s++-- | Like 'splitAtCRLF', but if no CRLF is found, the first+--   result is the argument string, and the second result is empty.+splitAtCRLF_ :: ByteString -> (ByteString,ByteString)+splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)++-- | Get the index and length of the first CRLF, if any.+findCRLF :: ByteString -- ^ String to split.+         -> Maybe (Int64,Int64)+findCRLF s = +    case findCRorLF s of+              Nothing -> Nothing+              Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)+              Just j -> case (BS.index s j, BS.index s (j+1)) of+                           ('\n','\r') -> Just (j,2)+                           ('\r','\n') -> Just (j,2)+                           _           -> Just (j,1)++findCRorLF :: ByteString -> Maybe Int64+findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s++startsWithCRLF :: ByteString -> Bool+startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')+  where c = BS.index s 0++-- | Drop an initial CRLF, if any. If the string is empty, +--   nothing is done. If the string does not start with CRLF,+--   the first character is dropped.+dropCRLF :: ByteString -> ByteString+dropCRLF s | BS.null s = BS.empty+           | BS.null (BS.drop 1 s) = BS.empty+           | c0 == '\n' && c1 == '\r' = BS.drop 2 s+           | c0 == '\r' && c1 == '\n' = BS.drop 2 s+           | otherwise = BS.drop 1 s+  where c0 = BS.index s 0+        c1 = BS.index s 1
+ src/HAppS/Server/HTTP/RFC822Headers.hs view
@@ -0,0 +1,266 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module      :  Network.CGI.RFC822Headers+-- Copyright   :  (c) Peter Thiemann 2001,2002+--                (c) Bjorn Bringert 2005-2006+--                (c) Lemmih 2007+-- License     :  BSD-style+--+-- Maintainer  :  lemmih@vo.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Parsing of RFC822-style headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTP.RFC822Headers+    ( -- * Headers+      Header, +      pHeader,+      pHeaders,+      parseHeaders,++      -- * Content-type+      ContentType(..), +      getContentType,+      parseContentType,+      showContentType,++      -- * Content-transfer-encoding+      ContentTransferEncoding(..),+      getContentTransferEncoding,+      parseContentTransferEncoding,++      -- * Content-disposition+      ContentDisposition(..),+      getContentDisposition,                           +      parseContentDisposition,+                              +      -- * Utilities+      parseM+      ) where++import Data.Char+import Data.List+import Text.ParserCombinators.Parsec++type Header = (String, String)++pHeaders :: Parser [Header]+pHeaders = many pHeader++parseHeaders :: Monad m => SourceName -> String -> m [Header]+parseHeaders s inp = parseM pHeaders s inp++pHeader :: Parser Header+pHeader = +    do name <- many1 headerNameChar+       char ':'+       many ws1+       line <- lineString+       crLf+       extraLines <- many extraFieldLine+       return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = +    do sp <- ws1+       line <- lineString+       crLf+       return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+    where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+          esc '\\' = "\\\\"+          esc '"'  = "\\\""+          esc c | c `elem` ['\\','"'] = '\\':[c]+                | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+  do lexeme $ char ';'+     p_name <- lexeme $ p_token+     lexeme $ char '='+     -- Workaround for seemingly standardized web browser bug+     -- where nothing is escaped in the filename parameter+     -- of the content-disposition header in multipart/form-data+     let litStr = if p_name == "filename" +                   then buggyLiteralString+                   else literalString+     p_value <- litStr <|> p_token+     return (map toLower p_name, p_value)+++-- +-- * Content type+--++-- | A MIME media type value.+--   The 'Show' instance is derived automatically.+--   Use 'showContentType' to obtain the standard+--   string representation.+--   See <http://www.ietf.org/rfc/rfc2046.txt> for more+--   information about MIME media types.+data ContentType = +	ContentType {+                     -- | The top-level media type, the general type+                     --   of the data. Common examples are+                     --   \"text\", \"image\", \"audio\", \"video\",+                     --   \"multipart\", and \"application\".+                     ctType :: String,+                     -- | The media subtype, the specific data format.+                     --   Examples include \"plain\", \"html\",+                     --   \"jpeg\", \"form-data\", etc.+                     ctSubtype :: String,+                     -- | Media type parameters. On common example is+                     --   the charset parameter for the \"text\" +                     --   top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+                     ctParameters :: [(String, String)]+                    }+    deriving (Show, Read, Eq, Ord)++-- | Produce the standard string representation of a content-type,+--   e.g. \"text\/html; charset=ISO-8859-1\".+showContentType :: ContentType -> String+showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps++pContentType :: Parser ContentType+pContentType = +  do many ws1+     c_type <- p_token+     lexeme $ char '/'+     c_subtype <- lexeme $ p_token+     c_parameters <- many p_parameter+     return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+--   If the input cannot be parsed, this function calls+--   'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: Monad m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+	ContentTransferEncoding String+    deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+  do many ws1+     c_cte <- p_token+     return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding+parseContentTransferEncoding = +    parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs = +    lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+	ContentDisposition String [(String, String)]+    deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+  do many ws1+     c_cd <- p_token+     c_parameters <- many p_parameter+     return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: Monad m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: Monad m => [Header] -> m ContentDisposition+getContentDisposition hs = +    lookupM "content-disposition" hs  >>= parseContentDisposition++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+  case parse p n inp of+    Left e -> fail (show e)+    Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+		   str <- many (noneOf "\"\\" <|> quoted_pair)+		   char '\"'+		   return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = +    do char '\"'+       str <- manyTill anyChar (try lastQuote)+       return str+  where lastQuote = do char '\"' +                       notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++especials, tokenchar :: [Char]+especials = "()<>@,;:\\\"/[]?.="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+		 p_text
+ src/HAppS/Server/HTTP/Types.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}++module HAppS.Server.HTTP.Types+    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),+     rqURL, mkHeaders,+     getHeader, getHeaderBS, getHeaderUnsafe,+     hasHeader, hasHeaderBS, hasHeaderUnsafe,+     setHeader, setHeaderBS, setHeaderUnsafe,+     addHeader, addHeaderBS, addHeaderUnsafe,+     setRsCode, -- setCookie, setCookies,+     Conf(..), nullConf, result, resultBS,+     redirect, -- redirect_, redirect', redirect'_,+     RsFlags(..), nullRsFlags, noContentLength,+     Version(..), Method(..), Headers, continueHTTP,+     Host, ContentType(..)+    ) where+++import qualified Data.Map as M+import Data.Typeable(Typeable)+import Data.Maybe+import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString,pack)+import qualified Data.ByteString.Lazy.Char8 as L+import HAppS.Server.SURI+import Data.Char (toLower)++import HAppS.Server.HTTP.Multipart ( ContentType(..) )+import HAppS.Server.Cookie+import Data.List+import Text.Show.Functions ()++-- | HTTP version+data Version = Version Int Int+             deriving(Show,Read,Eq)++isHTTP1_1 :: Request -> Bool+isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False+isHTTP1_0 :: Request -> Bool+isHTTP1_0 rq = case rqVersion rq of Version 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) ||+                      (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && rsfContentLength (rsFlags res)++-- | HTTP configuration+data Conf = Conf { port      :: Int -- ^ Port for the server to listen on.+                 , validator  :: Maybe (Response -> IO Response)+                 } +nullConf :: Conf+nullConf = Conf { port      = 8000+                , validator  = Nothing+                }++++-- | HTTP request method+data Method  = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT+               deriving(Show,Read,Eq)++data HeaderPair = HeaderPair { hName :: ByteString, hValue :: [ByteString] } deriving (Read,Show)+-- | Combined headers.+type Headers = M.Map ByteString HeaderPair -- lowercased name -> (realname, value)++++-- | Result flags+data RsFlags = RsFlags +    { rsfContentLength :: Bool -- ^ whether a content-length header will be added to the result.+    } deriving(Show,Read,Typeable)+nullRsFlags :: RsFlags+nullRsFlags = RsFlags { rsfContentLength = True }+-- | Don't display a Content-Lenght field for the 'Result'.+noContentLength :: Response -> Response+noContentLength res = res { rsFlags = upd } where upd = (rsFlags res) { rsfContentLength = False }++data Input = Input+    { inputValue :: L.ByteString+    , inputFilename :: Maybe String+    , inputContentType :: ContentType+    } deriving (Show,Read,Typeable)++type Host = (String,Int)++data Response  = Response  { rsCode    :: Int,+                             rsHeaders :: Headers,+                             rsFlags   :: RsFlags,+                             rsBody    :: L.ByteString,+                             rsValidator:: Maybe (Response -> IO Response)+                           } deriving (Show,Typeable) ++data Request = Request { rqMethod  :: Method,+                         rqPaths   :: [String],+			 rqUri	   :: String,+                         rqQuery   :: String,+                         rqInputs  :: [(String,Input)],+                         rqCookies :: [(String,Cookie)],+                         rqVersion :: Version,+                         rqHeaders :: Headers,+                         rqBody    :: RqBody,+                         rqPeer    :: Host+                       } deriving(Show,Read,Typeable)++++rqURL :: Request -> String+rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)++class HasHeaders a where +    updateHeaders::(Headers->Headers)->a->a+    headers::a->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 Headers where updateHeaders f hs = f hs+                                  headers = id++newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable)+++setRsCode :: (Monad m) => Int -> Response -> m Response+setRsCode code rs = return rs {rsCode = code}++mkHeaders :: [(String,String)] -> Headers+mkHeaders hdrs+    = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]+    where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)++--------------------------------------------------------------+-- Retrieving header information+--------------------------------------------------------------++-- | Lookup header value. Key is case-insensitive.+getHeader :: HasHeaders r => String -> r -> Maybe ByteString+getHeader key = getHeaderBS (pack key)++-- | Lookup header value. Key is a case-insensitive bytestring.+getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderBS key = getHeaderUnsafe (P.map toLower key)++-- | Lookup header value with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)++-- | Lookup header with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair+getHeaderUnsafe' key r = M.lookup key (headers r)++--------------------------------------------------------------+-- Querying header status+--------------------------------------------------------------+++hasHeader :: HasHeaders r => String -> r -> Bool+hasHeader key r = isJust (getHeader key r)++hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool+hasHeaderBS key r = isJust (getHeaderBS key r)++hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool+hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)++checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)++checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderUnsafe key val r+    = case getHeaderUnsafe key r of+        Just val' | P.map toLower val' == val -> True+        _ -> False+++--------------------------------------------------------------+-- Setting header status+--------------------------------------------------------------++setHeader :: HasHeaders r => String -> String -> r -> r+setHeader key val = setHeaderBS (pack key) (pack val)++setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+setHeaderUnsafe key val = updateHeaders (M.insert key val)++--------------------------------------------------------------+-- Adding headers+--------------------------------------------------------------++addHeader :: HasHeaders r => String -> String -> r -> r+addHeader key val = addHeaderBS (pack key) (pack val)++addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++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)+++result :: Int -> String -> Response+result code s = resultBS code (L.pack s)++resultBS :: Int -> L.ByteString -> Response+resultBS code s = Response code M.empty nullRsFlags s Nothing++redirect :: (ToSURI s) => Int -> s -> Response -> Response+redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}++++-- constants here+locationC :: ByteString+locationC   = P.pack "Location"+closeC :: ByteString+closeC      = P.pack "close"+connectionC :: ByteString+connectionC = P.pack "Connection"+keepaliveC :: ByteString+keepaliveC  = P.pack "Keep-Alive"+
+ src/HAppS/Server/HTTPClient/HTTP.hs view
@@ -0,0 +1,1045 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  HAppS.Server.HTTPClient.HTTP+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005+-- License     :  BSD+-- +-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- An easy HTTP interface enjoy.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      - Created functions receiveHTTP and responseHTTP to allow server side interactions+--        (although 100-continue is unsupported and I haven't checked for standard compliancy).+--      - Pulled the transfer functions from sendHTTP to global scope to allow access by+--        above functions.+--+-- * Changes by Graham Klyne:+--      - export httpVersion+--      - use new URI module (similar to old, but uses revised URI datatype)+--+-- * Changes by Bjorn Bringert:+--+--      - handle URIs with a port number+--      - added debugging toggle+--      - disabled 100-continue transfers to get HTTP\/1.0 compatibility+--      - change 'ioError' to 'throw'+--      - Added simpleHTTP_, which takes a stream argument.+--+-- * Changes from 0.1+--      - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.+--      - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.+--      - reworking of the use of Stream, including alterations to make 'sendHTTP' generic+--        and the addition of a debugging stream.+--      - simplified error handling.+-- +-- * TODO+--     - request pipelining+--     - https upgrade (includes full TLS, i.e. SSL, implementation)+--         - use of Stream classes will pay off+--         - consider C implementation of encryption\/decryption+--     - comm timeouts+--     - MIME & entity stuff (happening in separate module)+--     - support \"*\" uri-request-string for OPTIONS request method+-- +-- +-- * Header notes:+--+--     [@Host@]+--                  Required by HTTP\/1.1, if not supplied as part+--                  of a request a default Host value is extracted+--                  from the request-uri.+-- +--     [@Connection@] +--                  If this header is present in any request or+--                  response, and it's value is "close", then+--                  the current request\/response is the last +--                  to be allowed on that connection.+-- +--     [@Expect@]+--                  Should a request contain a body, an Expect+--                  header will be added to the request.  The added+--                  header has the value \"100-continue\".  After+--                  a 417 \"Expectation Failed\" response the request+--                  is attempted again without this added Expect+--                  header.+--                  +--     [@TransferEncoding,ContentLength,...@]+--                  if request is inconsistent with any of these+--                  header values then you may not receive any response+--                  or will generate an error response (probably 4xx).+--+--+-- * Response code notes+-- Some response codes induce special behaviour:+--+--   [@1xx@]   \"100 Continue\" will cause any unsent request body to be sent.+--             \"101 Upgrade\" will be returned.+--             Other 1xx responses are ignored.+-- +--   [@417@]   The reason for this code is \"Expectation failed\", indicating+--             that the server did not like the Expect \"100-continue\" header+--             added to a request.  Receipt of 417 will induce another+--             request attempt (without Expect header), unless no Expect header+--             had been added (in which case 417 response is returned).+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.HTTP (+    module HAppS.Server.HTTPClient.Stream,+    module HAppS.Server.HTTPClient.TCP,++    -- ** Constants+    httpVersion,+    +    -- ** HTTP +    Request(..),+    Response(..),+    RequestMethod(..),+    simpleHTTP, simpleHTTP_,+    sendHTTP,+    sendHTTPPipelined,+    receiveHTTP,+    respondHTTP,++    -- ** Header Functions+    HasHeaders,+    Header(..),+    HeaderName(..),+    insertHeader,+    insertHeaderIfMissing,+    insertHeaders,+    retrieveHeaders,+    replaceHeader,+    findHeader,++    -- ** URL Encoding+    urlEncode,+    urlDecode,+    urlEncodeVars,++    -- ** URI authority parsing+    URIAuthority(..),+    parseURIAuthority+) where++++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Control.Exception.Extensible as Exception++-- Networking+import Network.URI+import HAppS.Server.HTTPClient.Stream+import HAppS.Server.HTTPClient.TCP+++-- Util+import Data.Bits ((.&.))+import Data.Char+import Data.List (partition,elemIndex,intersperse)+import Data.Maybe+import Control.Monad (when,guard)+import Numeric (readHex)+import Text.ParserCombinators.ReadP+import Text.Read.Lex +import System.IO++++-- Turn on to enable HTTP traffic logging+debug :: Bool+debug = True -- False++-- File that HTTP traffic logs go to+httpLogFile :: String+httpLogFile = "http-debug.log"++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- remove leading and trailing whitespace.+trim :: String -> String+trim = let dropspace = dropWhile isSpace in+       reverse . dropspace . reverse . dropspace+++-- Split a list into two parts, the delimiter occurs+-- at the head of the second list.  Nothing is returned+-- when no occurance of the delimiter is found.+split :: Eq a => a -> [a] -> Maybe ([a],[a])+split delim list = case delim `elemIndex` list of+    Nothing -> Nothing+    Just x  -> Just $ splitAt x list+    +++crlf :: String+crlf = "\r\n"+sp :: String+sp   = " "++-----------------------------------------------------------------+------------------ URI Authority parsing ------------------------+-----------------------------------------------------------------++data URIAuthority = URIAuthority { user :: Maybe String, +				   password :: Maybe String,+				   host :: String,+				   port :: Maybe Int+				 } deriving (Eq,Show)++-- | Parse the authority part of a URL.+--+-- > RFC 1732, section 3.1:+-- >+-- >       //<user>:<password>@<host>:<port>/<url-path>+-- >  Some or all of the parts "<user>:<password>@", ":<password>",+-- >  ":<port>", and "/<url-path>" may be excluded.+parseURIAuthority :: String -> Maybe URIAuthority+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuthority+pURIAuthority = do+		(u,pw) <- (pUserInfo `before` char '@') +			  <++ return (Nothing, Nothing)+		h <- munch (/=':')+		p <- orNothing (char ':' >> readDecP)+		look >>= guard . null +		return URIAuthority{ user=u, password=pw, host=h, port=p }++pUserInfo :: ReadP (Maybe String, Maybe String)+pUserInfo = do+	    u <- orNothing (munch (`notElem` ":@"))+	    p <- orNothing (char ':' >> munch (/='@'))+	    return (u,p)++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++orNothing :: ReadP a -> ReadP (Maybe a)+orNothing p = fmap Just p <++ return Nothing++-----------------------------------------------------------------+------------------ Header Data ----------------------------------+-----------------------------------------------------------------+++-- | The Header data type pairs header names & values.+data Header = Header HeaderName String+++instance Show Header where+    show (Header key value) = show key ++ ": " ++ value ++ crlf+++-- | HTTP Header Name type:+--  Why include this at all?  I have some reasons+--   1) prevent spelling errors of header names,+--   2) remind everyone of what headers are available,+--   3) might speed up searches for specific headers.+--+--  Arguments against:+--   1) makes customising header names laborious+--   2) increases code volume.+--+data HeaderName = +                 -- Generic Headers --+                  HdrCacheControl+                | HdrConnection+                | HdrDate+                | HdrPragma+                | HdrTransferEncoding        +                | HdrUpgrade                +                | HdrVia++                -- Request Headers --+                | HdrAccept+                | HdrAcceptCharset+                | HdrAcceptEncoding+                | HdrAcceptLanguage+                | HdrAuthorization+                | HdrCookie+                | HdrExpect+                | HdrFrom+                | HdrHost+                | HdrIfModifiedSince+                | HdrIfMatch+                | HdrIfNoneMatch+                | HdrIfRange+                | HdrIfUnmodifiedSince+                | HdrMaxForwards+                | HdrProxyAuthorization+                | HdrRange+                | HdrReferer+                | HdrUserAgent++                -- Response Headers+                | HdrAge+                | HdrLocation+                | HdrProxyAuthenticate+                | HdrPublic+                | HdrRetryAfter+                | HdrServer+                | HdrSetCookie+                | HdrVary+                | HdrWarning+                | HdrWWWAuthenticate++                -- Entity Headers+                | HdrAllow+                | HdrContentBase+                | HdrContentEncoding+                | HdrContentLanguage+                | HdrContentLength+                | HdrContentLocation+                | HdrContentMD5+                | HdrContentRange+                | HdrContentType+                | HdrETag+                | HdrExpires+                | HdrLastModified++                -- Mime entity headers (for sub-parts)+                | HdrContentTransferEncoding++                -- | Allows for unrecognised or experimental headers.+                | HdrCustom String -- not in header map below.+    deriving(Eq)+++-- Translation between header names and values,+-- good candidate for improvement.+headerMap :: [ (String,HeaderName) ]+headerMap + = [  ("Cache-Control"        ,HdrCacheControl      )+	, ("Connection"           ,HdrConnection        )+	, ("Date"                 ,HdrDate              )    +	, ("Pragma"               ,HdrPragma            )+	, ("Transfer-Encoding"    ,HdrTransferEncoding  )        +	, ("Upgrade"              ,HdrUpgrade           )                +	, ("Via"                  ,HdrVia               )+	, ("Accept"               ,HdrAccept            )+	, ("Accept-Charset"       ,HdrAcceptCharset     )+	, ("Accept-Encoding"      ,HdrAcceptEncoding    )+	, ("Accept-Language"      ,HdrAcceptLanguage    )+	, ("Authorization"        ,HdrAuthorization     )+	, ("From"                 ,HdrFrom              )+	, ("Host"                 ,HdrHost              )+	, ("If-Modified-Since"    ,HdrIfModifiedSince   )+	, ("If-Match"             ,HdrIfMatch           )+	, ("If-None-Match"        ,HdrIfNoneMatch       )+	, ("If-Range"             ,HdrIfRange           ) +	, ("If-Unmodified-Since"  ,HdrIfUnmodifiedSince )+	, ("Max-Forwards"         ,HdrMaxForwards       )+	, ("Proxy-Authorization"  ,HdrProxyAuthorization)+	, ("Range"                ,HdrRange             )   +	, ("Referer"              ,HdrReferer           )+	, ("User-Agent"           ,HdrUserAgent         )+	, ("Age"                  ,HdrAge               )+	, ("Location"             ,HdrLocation          )+	, ("Proxy-Authenticate"   ,HdrProxyAuthenticate )+	, ("Public"               ,HdrPublic            )+	, ("Retry-After"          ,HdrRetryAfter        )+	, ("Server"               ,HdrServer            )+	, ("Vary"                 ,HdrVary              )+	, ("Warning"              ,HdrWarning           )+	, ("WWW-Authenticate"     ,HdrWWWAuthenticate   )+	, ("Allow"                ,HdrAllow             )+	, ("Content-Base"         ,HdrContentBase       )+	, ("Content-Encoding"     ,HdrContentEncoding   )+	, ("Content-Language"     ,HdrContentLanguage   )+	, ("Content-Length"       ,HdrContentLength     )+	, ("Content-Location"     ,HdrContentLocation   )+	, ("Content-MD5"          ,HdrContentMD5        )+	, ("Content-Range"        ,HdrContentRange      )+	, ("Content-Type"         ,HdrContentType       )+	, ("ETag"                 ,HdrETag              )+	, ("Expires"              ,HdrExpires           )+	, ("Last-Modified"        ,HdrLastModified      )+   	, ("Set-Cookie"           ,HdrSetCookie         )+	, ("Cookie"               ,HdrCookie            )+    , ("Expect"               ,HdrExpect            ) ]+++instance Show HeaderName where+    show (HdrCustom s) = s+    show x = case filter ((==x).snd) headerMap of+                [] -> error "headerMap incomplete"+                (h:_) -> fst h++++++-- | This class allows us to write generic header manipulation functions+-- for both 'Request' and 'Response' data types.+class HasHeaders x where+    getHeaders :: x -> [Header]+    setHeaders :: x -> [Header] -> x++++-- Header manipulation functions+insertHeader, replaceHeader, insertHeaderIfMissing+    :: HasHeaders a => HeaderName -> String -> a -> a+++-- | Inserts a header with the given name and value.+-- Allows duplicate header names.+insertHeader name value x = setHeaders x newHeaders+    where+        newHeaders = (Header name value) : getHeaders x+++-- | Adds the new header only if no previous header shares+-- the same name.+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+    where+        newHeaders list@(h@(Header n _): rest)+            | n == name  = list+            | otherwise  = h : newHeaders rest+        newHeaders [] = [Header name value]++            ++-- | Removes old headers with duplicate name.+replaceHeader name value x = setHeaders x newHeaders+    where+        newHeaders = Header name value : [ h | h@(Header n _) <- getHeaders x, name /= n ]+          ++-- | Inserts multiple headers.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)+++-- | Gets a list of headers with a particular 'HeaderName'.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+    where+        matchname (Header n _)  |  n == name  =  True+        matchname _ = False+++-- | Lookup presence of specific HeaderName in a list of Headers+-- Returns the value from the first matching header.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t)  |  v == n   =  Just s+                               | otherwise =  lookupHeader v t+lookupHeader _ _  =  Nothing++++-----------------------------------------------------------------+------------------ HTTP Messages --------------------------------+-----------------------------------------------------------------+++-- Protocol version+httpVersion :: String+httpVersion = "HTTP/1.1"+++-- | The HTTP request method, to be used in the 'Request' object.+-- We are missing a few of the stranger methods, but these are+-- not really necessary until we add full TLS.+data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE | DELETE+    deriving(Show,Eq)++rqMethodMap :: [(String, RequestMethod)]+rqMethodMap = [("HEAD",    HEAD),+	       ("PUT",     PUT),+	       ("GET",     GET),+	       ("POST",    POST),+	       ("OPTIONS", OPTIONS),+	       ("TRACE",   TRACE),+               ("DELETE",  DELETE)]++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request =+     Request { rqURI       :: URI   -- ^ might need changing in future+                                    --  1) to support '*' uri in OPTIONS request+                                    --  2) transparent support for both relative+                                    --     & absolute uris, although this should+                                    --     already work (leave scheme & host parts empty).+             , rqMethod    :: RequestMethod             +             , rqHeaders   :: [Header]+             , rqBody      :: String+             }+++++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show Request where+    show (Request u m h _) =+        show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf+        ++ foldr (++) [] (map show h) ++ crlf+        where+            alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' +                        then u { uriPath = '/' : uriPath u } +                        else u+++instance HasHeaders Request where+    getHeaders = rqHeaders+    setHeaders rq hdrs = rq { rqHeaders=hdrs }+++++++type ResponseCode  = (Int,Int,Int)+type ResponseData  = (ResponseCode,String,[Header])+type RequestData   = (RequestMethod,URI,[Header])++-- | An HTTP Response.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output, additionally the output will+-- show an HTTP version of 1.1 instead of the actual version returned+-- by a server.+data Response =+    Response { rspCode     :: ResponseCode+             , rspReason   :: String+             , rspHeaders  :: [Header]+             , rspBody     :: String+             }+                   +++-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1+instance Show Response where+    show (Response (a,b,c) reason headers _) =+        httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf+        ++ foldr (++) [] (map show headers) ++ crlf++++instance HasHeaders Response where+    getHeaders = rspHeaders+    setHeaders rsp hdrs = rsp { rspHeaders=hdrs }++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++parseHeader :: String -> Result Header+parseHeader str =+    case split ':' str of+        Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)+        Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+    where+        fn k = case map snd $ filter (match k . fst) headerMap of+                 [] -> (HdrCustom k)+                 (h:_) -> h++        match :: String -> String -> Bool+        match s1 s2 = map toLower s1 == map toLower s2+    ++parseHeaders :: [String] -> Result [Header]+parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""+    where+        -- Joins consecutive lines where the second line+        -- begins with ' ' or '\t'.+        joinExtended old (h : t)+            | not (null h) && (head h == ' ' || head h == '\t')+                = joinExtended (old ++ ' ' : tail h) t+            | otherwise = old : joinExtended h t+        joinExtended old [] = [old]++        clean [] = []+        clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+                    | otherwise = h : clean t++        -- tollerant of errors?  should parse+        -- errors here be reported or ignored?+        -- currently ignored.+        catRslts :: [a] -> [Result a] -> Result [a]+        catRslts list (h:t) = +            case h of+                Left _ -> catRslts list t+                Right v -> catRslts (v:list) t+        catRslts list [] = Right $ reverse list            +        ++-- Parsing a request+parseRequestHead :: [String] -> Result RequestData+parseRequestHead [] = Left ErrorClosed+parseRequestHead (com:hdrs) =+    requestCommand com `bindE` \(_version,rqm,uri) ->+    parseHeaders hdrs `bindE` \hdrs' ->+    Right (rqm,uri,hdrs')+    where+        requestCommand line+	    =  case words line of+                _yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of+					  (Just u, Just r) -> Right (version,r,u)+					  _                -> Left (ErrorParse $ "Request command line parse failure: " ++ line)+		_no -> if null line+			       then Left ErrorClosed+			       else Left (ErrorParse $ "Request command line parse failure: " ++ line)  ++-- Parsing a response+parseResponseHead :: [String] -> Result ResponseData+parseResponseHead [] = Left ErrorClosed+parseResponseHead (sts:hdrs) = +    responseStatus sts `bindE` \(_version,code,reason) ->+    parseHeaders hdrs `bindE` \hdrs' ->+    Right (code,reason,hdrs')+    where++        responseStatus line+            =  case words line of+                _yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)+                _no -> if null line +                    then Left ErrorClosed  -- an assumption+                    else Left (ErrorParse $ "Response status line parse failure: " ++ line)+++        match [a,b,c] = (digitToInt a,+                         digitToInt b,+                         digitToInt c)+        match _ = (-1,-1,-1)  -- will create appropriate behaviour+++        ++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data Behaviour = Continue+               | Retry+               | Done+               | ExpectEntity+               | DieHorribly String++++++matchResponse :: RequestMethod -> ResponseCode -> Behaviour+matchResponse rqst rsp =+    case rsp of+        (1,0,0) -> Continue+        (1,0,1) -> Done        -- upgrade to TLS+        (1,_,_) -> Continue    -- default+        (2,0,4) -> Done+        (2,0,5) -> Done+        (2,_,_) -> ans+        (3,0,4) -> Done+        (3,0,5) -> Done+        (3,_,_) -> ans+        (4,1,7) -> Retry       -- Expectation failed+        (4,_,_) -> ans+        (5,_,_) -> ans+        (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")+    where+        ans | rqst == HEAD = Done+            | otherwise    = ExpectEntity+        ++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+--  Host        Altered only if no Host header is supplied, HTTP\/1.1+--              requires a Host header.+--  Connection  Where no allowance is made for persistant connections+--              the Connection header will be set to "close"+simpleHTTP :: Request -> IO (Result Response)+simpleHTTP r = +    do +       auth <- getAuth r+       c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+       simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ s r =+    do +       auth <- getAuth r+       let r' = fixReq auth r +       rsp <- if debug then do+	        s' <- debugStream httpLogFile s+	        sendHTTP s' r'+	       else+	        sendHTTP s r'+       -- already done by sendHTTP because of "Connection: close" header+       --; close s +       return rsp+       where+  {- RFC 2616, section 5.1.2:+     "The most common form of Request-URI is that used to identify a+      resource on an origin server or gateway. In this case the absolute+      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as+      the Request-URI, and the network location of the URI (authority) MUST+      be transmitted in a Host header field." -}+  -- we assume that this is the case, so we take the host name from+  -- the Host header if there is one, otherwise from the request-URI.+  -- Then we make the request-URI an abs_path and make sure that there+  -- is a Host header.+             fixReq :: URIAuthority -> Request -> Request+	     fixReq URIAuthority{host=h} req = +		 insertHeaderIfMissing HdrConnection "close" $+		 insertHeaderIfMissing HdrHost h $+		 req { rqURI = (rqURI req){ uriScheme = "", +					uriAuthority = Nothing } }	       ++getAuth :: Monad m => Request -> m URIAuthority+getAuth r = case parseURIAuthority auth of+			 Just x -> return x +			 Nothing -> fail $ "Error parsing URI authority '"+				           ++ auth ++ "'"+		 where auth = case findHeader HdrHost r of+			      Just h -> h+			      Nothing -> authority (rqURI r)++sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP conn rq+    = do rst <- sendHTTPPipelined conn [rq]+         case rst of+           ([response],_) -> return (Right response)+           (_,Just err)   -> return (Left err)+           (_,_) -> error "Case not supported in sendHTTP"++sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError)+sendHTTPPipelined conn rqs = +    do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs))+                      (\(e::SomeException) -> do { close conn; throw e })+       ; let fn list = when (or $ map findConnClose list)+                            (close conn)+       ; fn (map rqHeaders rqs ++ map rspHeaders ok)+       ; return (ok,rsp)+       }+    where       +-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+        main :: [Request] -> IO ([Response], Maybe ConnError)+        main rqsts =+            do +	       --let str = if null (rqBody rqst)+               --              then show rqst+               --              else show (insertHeader HdrExpect "100-continue" rqst)+	       -- write body immediately, don't wait for 100 CONTINUE+               writeBlock conn $ concat $ intersperse "\r\n" [ show rqst ++ rqBody rqst | rqst <- rqsts ]+               rets <- flip mapM rqsts $ \rqst ->+                       do rsp <- getResponseHead+                          switchResponse True True rsp rqst+               return (sequenceResponses rets)++        sequenceResponses :: [Result Response] -> ([Response], Maybe ConnError)+        sequenceResponses = worker []+            where worker acc [] = (reverse acc, Nothing)+                  worker acc (Right x:xs) = worker (x:acc) xs+                  worker acc (Left x:_) = (reverse acc,Just x)++        -- reads and parses headers+        getResponseHead :: IO (Result ResponseData)+        getResponseHead =+            do { lor <- readTillEmpty1 conn+               ; return $ lor `bindE` parseResponseHead+               }++        -- Hmmm, this could go bad if we keep getting "100 Continue"+        -- responses...  Except this should never happen according+        -- to the RFC.+        switchResponse :: Bool {- allow retry? -}+                       -> Bool {- is body sent? -}+                       -> Result ResponseData+                       -> Request+                       -> IO (Result Response)+            +        switchResponse _ _ (Left e) _ = return (Left e)+                -- retry on connreset?+                -- if we attempt to use the same socket then there is an excellent+                -- chance that the socket is not in a completely closed state.++        switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+            case matchResponse (rqMethod rqst) cd of+                Continue+                    | not bdy_sent -> {- Time to send the body -}+                        do { val <- writeBlock conn (rqBody rqst)+                           ; case val of+                                Left e -> return (Left e)+                                Right _ ->+                                    do { rsp <- getResponseHead+                                       ; switchResponse allow_retry True rsp rqst+                                       }+                           }+                    | otherwise -> {- keep waiting -}+                        do { rsp <- getResponseHead+                           ; switchResponse allow_retry bdy_sent rsp rqst                           +                           }++                Retry -> {- Request with "Expect" header failed.+                                Trouble is the request contains Expects+                                other than "100-Continue" -}+                    do { writeBlock conn (show rqst ++ rqBody rqst)+                       ; rsp <- getResponseHead+                       ; switchResponse False bdy_sent rsp rqst+                       }   +                     +                Done ->+                    return (Right $ Response cd rn hdrs "")++                DieHorribly str ->+                    return $ Left $ ErrorParse ("Invalid response: " ++ str)++                ExpectEntity ->+                    let tc = lookupHeader HdrTransferEncoding hdrs+                        cl = lookupHeader HdrContentLength hdrs+                    in+                    do { rslt <- case tc of+                          Nothing -> +                              case cl of+                                  Just x  -> linearTransfer conn (read x :: Int)+                                  Nothing -> hopefulTransfer conn ""+                          Just x  -> +                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer conn+                                  _         -> uglyDeathTransfer conn+                       ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) +                       }++        +        -- Adds a Host header if one is NOT ALREADY PRESENT+        fixHostHeader :: Request -> Request+        fixHostHeader rq =+            let uri = rqURI rq+                h = authority uri+            in insertHeaderIfMissing HdrHost h rq+                                     +        -- Looks for a "Connection" header with the value "close".+        -- Returns True when this is found.+        findConnClose :: [Header] -> Bool+        findConnClose hdrs =+            case lookupHeader HdrConnection hdrs of+                Nothing -> False+                Just x  -> map toLower (trim x) == "close"++-- | Receive and parse a HTTP request from the given Stream. Should be used +--   for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP conn = do rq <- getRequestHead+		      processRequest rq	    +    where+        -- reads and parses headers+        getRequestHead :: IO (Result RequestData)+        getRequestHead =+            do { lor <- readTillEmpty1 conn+               ; return $ lor `bindE` parseRequestHead+               }+	+        processRequest (Left e) = return $ Left e+	processRequest (Right (rm,uri,hdrs)) = +	    do -- FIXME : Also handle 100-continue.+               let tc = lookupHeader HdrTransferEncoding hdrs+                   cl = lookupHeader HdrContentLength hdrs+	       rslt <- case tc of+                          Nothing ->+                              case cl of+                                  Just x  -> linearTransfer conn (read x :: Int)+                                  Nothing -> return (Right ([], "")) -- hopefulTransfer ""+                          Just x  ->+                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer conn+                                  _         -> uglyDeathTransfer conn+               +               return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+++-- | Very simple function, send a HTTP response over the given stream. This +--   could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+                          -- write body immediately, don't wait for 100 CONTINUE+                          writeBlock conn (rspBody rsp)+			  return ()++-- The following functions were in the where clause of sendHTTP, they have+-- been moved to global scope so other functions can access them.		       ++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))+linearTransfer conn n+    = do info <- readBlock conn n+         return $ info `bindE` \str -> Right ([],str)++-- | Used when nothing about data is known,+--   Unfortunately waiting for a socket closure+--   causes bad behaviour.  Here we just+--   take data once and give up the rest.+hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))+hopefulTransfer conn str+    = readLine conn >>= +      either (\v -> return $ Left v)+             (\more -> if null more +                         then return (Right ([],str)) +                         else hopefulTransfer conn (str++more))+-- | A necessary feature of HTTP\/1.1+--   Also the only transfer variety likely to+--   return any footers.+chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))+chunkedTransfer conn+    =  chunkedTransferC conn 0 >>= \v ->+       return $ v `bindE` \(ftrs,c,info) ->+                let myftrs = Header HdrContentLength (show c) : ftrs              +                in Right (myftrs,info)++chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))+chunkedTransferC conn n+    =  readLine conn >>= \v -> case v of+                  Left e -> return (Left e)+                  Right line ->+                      let size = ( if null line || (head line) == '0'+                                     then 0+                                     else case readHex line of+                                        (n',_):_ -> n'+                                        _       -> 0+                                     )+                      in if size == 0+                           then do { rs <- readTillEmpty2 conn []+                                   ; return $+                                        rs `bindE` \strs ->+                                        parseHeaders strs `bindE` \ftrs ->+                                        Right (ftrs,n,"")+                                   }+                           else do { some <- readBlock conn size+                                   ; readLine conn+                                   ; more <- chunkedTransferC conn (n+size)+                                   ; return $ +                                        some `bindE` \cdata ->+                                        more `bindE` \(ftrs,m,mdata) -> +                                        Right (ftrs,m,cdata++mdata) +                                   }                   ++-- | Maybe in the future we will have a sensible thing+--   to do here, at that time we might want to change+--   the name.+uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))+uglyDeathTransfer _+    = return $ Left $ ErrorParse "Unknown Transfer-Encoding"++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Stream s => s -> IO (Result [String])+readTillEmpty1 conn =+    do { line <- readLine conn+       ; case line of+           Left e -> return $ Left e+           Right s ->+               if s == crlf+                 then readTillEmpty1 conn+                 else readTillEmpty2 conn [s]+       }++-- | Read lines until an empty line (CRLF),+--   also accepts a connection close as end of+--   input, which is not an HTTP\/1.1 compliant+--   thing to do - so probably indicates an+--   error condition.+readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])+readTillEmpty2 conn list =+    do { line <- readLine conn+       ; case line of+           Left e -> return $ Left e+           Right s ->+               if s == crlf || null s+                 then return (Right $ reverse (s:list))+                 else readTillEmpty2 conn (s:list)+       }++        +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+    I had a quick look around but couldn't find any RFC about+    the encoding of data on the query string.  I did find an+    IETF memo, however, so this is how I justify the urlEncode+    and urlDecode methods.++    Doc name: draft-tiwari-appl-wxxx-forms-01.txt  (look on www.ietf.org)++    Reserved chars:  ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+    Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+    URI delims: "<" | ">" | "#" | "%" | <">+    Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+                     <US-ASCII coded character 20 hexadecimal>+    Also unallowed:  any non-us-ascii character++    Escape method: char -> '%' a b  where a, b :: Hex digits+-}++urlEncode, urlDecode :: String -> String++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+                         : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []++urlEncode (h:t) =+    let str = if reserved_ (ord h) then escape h else [h]+    in str ++ urlEncode t+    where+        reserved_ x+            | x >= ord 'a' && x <= ord 'z' = False+            | x >= ord 'A' && x <= ord 'Z' = False+            | x >= ord '0' && x <= ord '9' = False+            | x <= 0x20 || x >= 0x7F = True+            | otherwise = x `elem` map ord [';','/','?',':','@','&'+                                           ,'=','+',',','$','{','}'+                                           ,'|','\\','^','[',']','`'+                                           ,'<','>','#','%','"']+        -- wouldn't it be nice if the compiler+        -- optimised the above for us?++        escape x = +            let y = ord x +            in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []+            +++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+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)+       ++ urlEncodeRest diff+       where urlEncodeRest [] = []+             urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []
+ src/HAppS/Server/HTTPClient/Stream.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  HAppS.Server.HTTPClient.Stream+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- License     :  BSD+--+-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- An library for creating abstract streams. Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      +-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.Stream (+    -- ** Streams+    Debug,+    Stream(..),+    debugStream,+    +    -- ** Errors+    ConnError(..),+    Result,+    handleSocketError,+    bindE,+    myrecv++) where++import Control.Exception.Extensible as Exception+import System.IO.Error++-- Networking+import Network.Socket++import Control.Monad (liftM)+import System.IO++data ConnError = ErrorReset +               | ErrorClosed+               | ErrorParse String+               | ErrorMisc String+    deriving(Show,Eq)++-- error propagating:+-- we could've used a monad, but that would lead us+-- into using the "-fglasgow-exts" compile flag.+bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b+bindE (Left e)  _ = Left e+bindE (Right v) f = f v++-- | This is the type returned by many exported network functions.+type Result a = Either ConnError   {- error  -}+                       a           {- result -}++-----------------------------------------------------------------+------------------ Gentle Art of Socket Sucking -----------------+-----------------------------------------------------------------++-- | Streams should make layering of TLS protocol easier in future,+-- they allow reading/writing to files etc for debugging,+-- they allow use of protocols other than TCP/IP+-- and they allow customisation.+--+-- Instances of this class should not trim+-- the input in any way, e.g. leave LF on line+-- endings etc. Unless that is exactly the behaviour+-- you want from your twisted instances ;)+class Stream x where +    readLine   :: x -> IO (Result String)+    readBlock  :: x -> Int -> IO (Result String)+    writeBlock :: x -> String -> IO (Result ())+    close      :: x -> IO ()++++++-- Exception handler for socket operations+handleSocketError :: Socket -> Exception.SomeException -> IO (Result a)+handleSocketError sk e =+    do { se <- getSocketOption sk SoError+       ; if se == 0+            then throw e+            else return $ if se == 10054       -- reset+                then Left ErrorReset+                else Left $ ErrorMisc $ show se+       }+++++instance Stream Socket where+    readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)+        where+            fn x = do { str <- myrecv sk x+                      ; let len = length str+                      ; if len < x && len /= 0+                          then ( fn (x-len) >>= \more -> return (str++more) )                        +                          else return str+                      }++    -- Use of the following function is discouraged.+    -- The function reads in one character at a time, +    -- which causes many calls to the kernel recv()+    -- hence causes many context switches.+    readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)+            where+                fn str =+                    do { c <- myrecv sk 1 -- like eating through a straw.+                       ; if null c || c == "\n"+                           then return (reverse str++c)+                           else fn (head c:str)+                       }+    +    writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)+        where+            fn [] = return ()+            fn x  = send sk x >>= \i -> fn (drop i x)++    -- This slams closed the connection (which is considered rude for TCP\/IP)+    close sk = shutdown sk ShutdownBoth >> sClose sk++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++-- | 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 =+        do { val <- readBlock c n+           ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+           ; hFlush h+           ; return val+           }++    readLine (Dbg h c) =+        do { val <- readLine c+           ; hPutStrLn h ("readLine " ++ show val)+           ; return val+           }++    writeBlock (Dbg h c) str =+        do { val <- writeBlock c str+           ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+           ; return val+           }++    close (Dbg h c) =+        do { hPutStrLn h "closing..."+           ; hFlush h+           ; close c+           ; hPutStrLn h "...closed"+           ; hClose h+           }+++-- | Wraps a stream with logging I\/O, the first+-- argument is a filename which is opened in AppendMode.+debugStream :: (Stream a) => String -> a -> IO (Debug a)+debugStream file stm = +    do { h <- openFile file AppendMode+       ; hPutStrLn h "File opened for appending."+       ; return (Dbg h stm)+       }
+ src/HAppS/Server/HTTPClient/TCP.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  HAppS.Server.HTTPClient.TCP+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- License     :  BSD+--+-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- An easy access TCP library. Makes the use of TCP in Haskell much easier.+-- This was originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      +-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.TCP (+    -- ** Connections+    Conn(..),+    Connection(..),+    openTCP,+    openTCPPort,+    isConnectedTo+) where++import Control.Exception.Extensible as Exception++-- Networking+import Network.BSD+import Network.Socket+import HAppS.Server.HTTPClient.Stream++import Data.List (elemIndex)+import Data.Char+import Data.IORef+import System.IO++-----------------------------------------------------------------+------------------ TCP Connections ------------------------------+-----------------------------------------------------------------++-- | The 'Connection' newtype is a wrapper that allows us to make+-- connections an instance of the StreamIn\/Out classes, without ghc extensions.+-- While this looks sort of like a generic reference to the transport+-- layer it is actually TCP specific, which can be seen in the+-- implementation of the 'Stream Connection' instance.+newtype Connection = ConnRef {getRef :: IORef Conn}+++-- | The 'Conn' object allows input buffering, and maintenance of +-- some admin-type data.+data Conn = MkConn { connSock :: ! Socket+                   , connAddr :: ! SockAddr +                   , connBffr :: ! String +                   , connHost :: String+                   }+          | ConnClosed+    deriving(Eq)+++-- | Open a connection to port 80 on a remote host.+openTCP :: String -> IO Connection+openTCP host = openTCPPort host 80+++-- | This function establishes a connection to a remote+-- host, it uses "getHostByName" which interrogates the+-- DNS system, hence may trigger a network connection.+--+-- Add a "persistant" option?  Current persistant is default.+-- Use "Result" type for synchronous exception reporting?+openTCPPort :: String -> Int -> IO Connection+openTCPPort uri port = +    do { s <- socket AF_INET Stream 6+       ; setSocketOption s KeepAlive 1+       ; host <- Exception.catch (inet_addr uri)    -- handles ascii IP numbers+                       (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME+                            case hostAddresses host of+                                [] -> return (error "no addresses in host entry")+                                (h:_) -> return h)+       ; let a = SockAddrInet (toEnum port) host+       ; Exception.catch (connect s a) (\(e::SomeException) -> sClose s >> throw e)+       ; v <- newIORef (MkConn s a [] uri)+       ; return (ConnRef v)+       }++instance Stream Connection where+    readBlock ref n = +        readIORef (getRef ref) >>= \conn -> case conn of+            ConnClosed -> return (Left ErrorClosed)+            (MkConn sk _addr bfr _hst)+                | length bfr >= n ->+                    do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })+                       ; return (Right $ take n bfr)+                       }+                | otherwise ->+                    do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+                       ; more <- readBlock sk (n - length bfr)+                       ; return $ case more of+                            Left _ -> more+                            Right s -> (Right $ bfr ++ s)+                       }++    -- This function uses a buffer, at this time the buffer is just 1000 characters.+    -- (however many bytes this is is left to the user to decypher)+    readLine ref =+        readIORef (getRef ref) >>= \conn -> case conn of+             ConnClosed -> return (Left ErrorClosed)+             (MkConn sk _addr bfr _)+                 | null bfr ->  {- read in buffer -}+                      do { str <- myrecv sk 1000  -- DON'T use "readBlock sk 1000" !!+                                                -- ... since that call will loop.+                         ; let len = length str+                         ; if len == 0   {- indicates a closed connection -}+                              then return (Right "")+                              else modifyIORef (getRef ref) (\c -> c { connBffr=str })+                                   >> readLine ref  -- recursion+                         }+                 | otherwise ->+                      case elemIndex '\n' bfr of+                          Nothing -> {- need recursion to finish line -}+                              do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+                                 ; more <- readLine ref -- contains extra recursion                      +                                 ; return $ more `bindE` \str -> Right (bfr++str)+                                 }+                          Just i ->    {- end of line found -}+                              let (bgn,end) = splitAt i bfr in+                              do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })+                                 ; return (Right (bgn++['\n']))+                                 }++++    -- The 'Connection' object allows no outward buffering, +    -- since in general messages are serialised in their entirety.+    writeBlock ref str =+        readIORef (getRef ref) >>= \conn -> case conn of+            ConnClosed -> return (Left ErrorClosed)+            (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)+        where+            fn sk addr s+                | null s    = return (Right ())  -- done+                | otherwise =+                    getSocketOption sk SoError >>= \se ->+                    if se == 0+                        then sendTo sk s addr >>= \i -> fn sk addr (drop i s)+                        else writeIORef (getRef ref) ConnClosed >>+                             if se == 10054+                                 then return (Left ErrorReset)+                                 else return (Left $ ErrorMisc $ show se)+++    -- Closes a Connection.  Connection will no longer+    -- allow any of the other Stream functions.  Notice that a Connection may close+    -- at any time before a call to this function.  This function is idempotent.+    -- (I think the behaviour here is TCP specific)+    close ref = +        do { c <- readIORef (getRef ref)+           ; closeConn c `Exception.catch` (\(_::SomeException) -> return ()) -- FIXME see above+           ; writeIORef (getRef ref) ConnClosed+           }+        where+            -- Be kind to peer & close gracefully.+            closeConn (ConnClosed) = return ()+            closeConn (MkConn sk _addr [] _) =+                do { shutdown sk ShutdownSend+                   ; suck ref+                   ; shutdown sk ShutdownReceive+                   ; sClose sk+                   }+            closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported"++            suck :: Connection -> IO ()+            suck cn = readLine cn >>= +                      either (\_ -> return ()) -- catch errors & ignore+                             (\x -> if null x then return () else suck cn)++-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> String -> IO Bool+isConnectedTo conn name =+    do { v <- readIORef (getRef conn)+       ; case v of+            ConnClosed -> return False+            (MkConn sk _ _ h) ->+                if (map toLower h == map toLower name)+                then sIsConnected sk+                else return False+       }+
+ src/HAppS/Server/JSON.hs view
@@ -0,0 +1,29 @@+module HAppS.Server.JSON where+import Data.Char+import Data.List++data JSON = JBool Bool | JString String | JInt Int | JFloat Float | +            JObj [(String,JSON)] | JList [JSON] | JNull+++jInt :: Integral a => a -> JSON+jInt = JInt . fromIntegral++class ToJSON a where+    toJSON::a->JSON+instance ToJSON JSON where toJSON=id++jsonToString :: JSON -> String+jsonToString (JBool bool) = map toLower $ show bool+jsonToString (JString string) = show string+jsonToString (JInt int) = show int+jsonToString (JFloat float) = show float+jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}"+    where+    impl (name,val) = concat [show name,":",jsonToString val]+jsonToString (JList list) = +    '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]"+jsonToString JNull = "null"+type CallBack=String++data JSONCall x = JCall CallBack x
+ src/HAppS/Server/MessageWrap.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances #-}++module HAppS.Server.MessageWrap where++import Control.Monad.Identity+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.List as List+import Data.Maybe+import HAppS.Server.HTTP.Types as H+import HAppS.Server.HTTP.Multipart+import HAppS.Server.SURI as SURI+import HAppS.Util.Common++queryInput :: SURI -> [(String, Input)]+queryInput uri = formDecode (case SURI.query $ uri of+                               '?':r -> r+                               xs    -> xs)++bodyInput :: Request -> [(String, Input)]+bodyInput req | rqMethod req /= POST = []+bodyInput req =+    let ctype = getHeader "content-type" req >>= parseContentType . P.unpack+        getBS (Body bs) = bs+    in decodeBody ctype (getBS $ rqBody req)+++-- Decodes application\/x-www-form-urlencoded inputs.      +formDecode :: String -> [(String, Input)]+formDecode [] = []+formDecode qString = +    if null pairString then rest else +           (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest+    where (pairString,qString')= split (=='&') qString+          (name,val)=split (=='=') pairString+          rest=if null qString' then [] else formDecode qString'++decodeBody :: Maybe ContentType+           -> L.ByteString+           -> [(String,Input)]+decodeBody ctype inp+    = case ctype of+        Just (ContentType "application" "x-www-form-urlencoded" _)+            -> formDecode (L.unpack inp)+        Just (ContentType "multipart" "form-data" ps)+            -> multipartDecode ps inp+        Just _ -> [] -- unknown content-type, the user will have to+                     -- deal with it by looking at the raw content+        -- No content-type given, assume x-www-form-urlencoded+        Nothing -> formDecode (L.unpack inp)++-- | Decodes multipart\/form-data input.+multipartDecode :: [(String,String)] -- ^ Content-type parameters+                -> L.ByteString        -- ^ Request body+                -> [(String,Input)]  -- ^ Input variables and values.+multipartDecode ps inp =+    case lookup "boundary" ps of+         Just b -> case parseMultipartBody b inp of+                        Just (MultiPart bs) -> map bodyPartToInput bs+                        Nothing -> [] -- FIXME: report parse error+         Nothing -> [] -- FIXME: report that there was no boundary++bodyPartToInput :: BodyPart -> (String,Input)+bodyPartToInput (BodyPart hs b) =+    case getContentDisposition hs of+              Just (ContentDisposition "form-data" ps) ->+                  (fromMaybe "" $ lookup "name" ps,+                   Input { inputValue = b,+                           inputFilename = lookup "filename" ps,+                           inputContentType = ctype })+              _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error+    where ctype = fromMaybe defaultInputType (getContentType hs)+++simpleInput :: String -> Input+simpleInput v+    = Input { inputValue = L.pack v+            , inputFilename = Nothing+            , inputContentType = defaultInputType+            }++-- | The default content-type for variables.+defaultInputType :: ContentType+defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?++-- | Get the path components from a String.+pathEls :: String -> [String]+pathEls = (drop 1) . map SURI.unEscape . splitList '/' ++-- | Like 'Read' except Strings and Chars not quoted.+class (Read a)=>ReadString a where readString::String->a; readString =read ++instance ReadString Int +instance ReadString Double +instance ReadString Float +instance ReadString SURI.SURI where readString = read . show+instance ReadString [Char] where readString=id+instance ReadString Char where +    readString s= if length t==1 then head t else read t where t=trim s
+ src/HAppS/Server/MinHaXML.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+             OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}+++  +module HAppS.Server.MinHaXML where+-- Copyright (C) 2005 HAppS.org. All Rights Reserved.++import Prelude hiding (elem, pi)++import Text.XML.HaXml.Types as Types+import Text.XML.HaXml.Escape+import Text.XML.HaXml.Pretty as Pretty+import Text.XML.HaXml.Verbatim as Verbatim+import HAppS.Util.Common+import Data.Maybe+import System.Time++import HAppS.Data.Xml as Xml+import HAppS.Data.Xml.HaXml++type StyleURL=String+data StyleSheet = NoStyle+                | CSS {styleURL::StyleURL} +                | XSL {styleURL::StyleURL} deriving (Read,Show)+hasStyleURL :: StyleSheet -> Bool+hasStyleURL NoStyle = False+hasStyleURL _ = True +type Element = Types.Element++	++isCSS :: StyleSheet -> Bool+isCSS (CSS _)=True+isCSS _ = False+isXSL :: StyleSheet -> Bool+isXSL = not.isCSS++t :: Name -> [(Name, String)] -> CharData -> Types.Element+t=textElem+l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element+l=listElem+e :: Name -> [(Name, String)] -> Types.Element+e=emptyElem+(</<) :: Name+         -> [(Name, String)]+         -> [Types.Element]+         -> Types.Element+(</<)=l+(<>) :: Name -> [(Name, String)] -> CharData -> Types.Element+(<>)=t++++xmlElem :: (t -> [Content])+           -> Name+           -> [(Name, String)]+           -> t+           -> Types.Element+xmlElem f = \name attrs val -> xmlelem name attrs (f val)+	where +	xmlelem name attrs = Types.Elem name (map (uncurry attr) attrs)+	attr name val= (name,AttValue [Left val])++textElem :: Name -> [(Name, String)] -> CharData -> Types.Element+textElem = xmlElem (return.CString True)+emptyElem :: Name -> [(Name, String)] -> Types.Element+emptyElem = \n a->xmlElem id n a []+listElem :: Name+            -> [(Name, String)]+            -> [Types.Element]+            -> Types.Element+listElem = xmlElem $ map CElem++cdataElem :: CharData -> Content+cdataElem = CString  False++--	     Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root+simpleDocOld :: StyleSheet -> Types.Element -> String+simpleDocOld xsl = show . document . +                flip (Document (simpleProlog xsl) []) [] . xmlStdEscape++simpleDoc :: StyleSheet -> Types.Element -> String+simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"+++                      if hasStyleURL style then pi else "") +++                     (verbatim $ xmlStdEscape elem)+    where typeText=if isCSS style then "text/css" else "text/xsl"+          pi= "<?xml-stylesheet type=\""++ typeText  ++ +              "\" href=\""++styleURL style++"\" ?>\n"+++simpleDoc' :: StyleSheet -> Types.Element -> String+simpleDoc' style elem = (if hasStyleURL style then pi else "") +++                        (verbatim $ xmlStdEscape elem)+    where typeText=if isCSS style then "text/css" else "text/xsl"+          pi= "<?xml-stylesheet type=\""++ typeText  ++ +              "\" href=\""++styleURL style++"\" ?>\n"++++xmlEscaper :: XmlEscaper+xmlEscaper=stdXmlEscaper+xmlStdEscape :: Types.Element -> Types.Element+xmlStdEscape = xmlEscape stdXmlEscaper+verbim :: (Verbatim a) => a -> String+verbim x =verbatim x++simpleProlog :: StyleSheet -> Prolog+simpleProlog style = +    Prolog +    (Just (XMLDecl "1.0" +	   (Just $ EncodingDecl "UTF-8") +	   Nothing -- standalone declaration+	  ))+    [] Nothing+           (if url=="" then [] else [pi])+	where+	pi = PI ("xml-stylesheet", "type=\""++typeText++"\" href=\""++url++"\"")+	typeText = if isCSS style then "text/css" else "text/xsl"+	url=if hasStyleURL style then styleURL style else ""++nonEmpty :: Name -> String -> Maybe Types.Element+nonEmpty name val = if val=="" then Nothing+					else Just $ textElem name [] val++getRoot :: Document -> Types.Element+getRoot (Document _ _ root _) = root++--toXML .< "App" attrs ./>+--toXML .< "App" attrs .> []+data XML a = XML StyleSheet a++class ToElement x where toElement::x->Types.Element+		+instance (ToElement x) => ToElement (Maybe x) where +    toElement = maybe (emptyElem "Nothing" []) toElement++instance ToElement String where toElement s = textElem "String" [] s+instance ToElement Types.Element where toElement = id+instance ToElement CalendarTime where +    toElement = recToEl "CalendarTime" +                [attrFS "year" ctYear+                ,attrFS "month" (fromEnum.ctMonth)+                ,attrFS "day" ctDay+                ,attrFS "hour" ctHour+                ,attrFS "min" ctMin+                ,attrFS "sec" ctSec+                ,attrFS "time" time +                ] []+        where time ct = epochPico ct++instance ToElement Int where toElement = toElement . show+instance ToElement Integer where toElement = toElement . show+instance ToElement Float where toElement = toElement . show+instance ToElement Double where toElement = toElement . show+++instance (Xml a) => ToElement a where+    toElement = un . head . map toHaXml . toXml+        where+        un (CElem el) = el+        un _ = error "Case not handled in Xml toElement instance"++wrapElem :: (ToElement x) => Name -> x -> Types.Element+wrapElem tag x= listElem tag [] [toElement x]+elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element+elF tag f = wrapElem tag.f +-- label !<=! field = wrapField label field+attrF :: t1 -> (t -> String) -> t -> (t1, String)+attrF name f rec = (name,quoteEsc $ f rec)+attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String)+attrFS name f rec = (name,quoteEsc $ show $ f rec)+attrFMb :: (a -> String)+           -> String+           -> (a1 -> Maybe a)+           -> a1+           -> (String, String)+attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f ++--(\x->(name,quoteEsc $ r x)) . f +--(name,quoteEsc $ show $ f rec)++quoteEsc :: String -> String+quoteEsc [] = []+quoteEsc ('"':list) = "&quot;" ++ quoteEsc list+quoteEsc (x:xs) = x:quoteEsc xs++--quotescape \\ and " \"++recToEl :: Name+           -> [a -> (String, String)]+           -> [a -> Types.Element]+           -> a+           -> Types.Element+recToEl name attrs els rec = listElem name attrs' (revmap rec els)+    where+    attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)+listToEl :: (ToElement a) =>+            Name -> [(Name, String)] -> [a] -> Types.Element+listToEl name attrs = listElem name attrs . map toElement ++toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)]+toAttrs x = map (\ (s,f)->(s, f x)) ++{--+toElement rules:+1. if the attr is an instance of toElement then it is a child.+2. if it named and is type string then it is shown that way.+3. if it named and has non-string type then use show on the value.+4. if the attributes are not named then use the type as the label and+   make the text child be a show of the object.+--}+++newtype ElString = ElString {elString::String} deriving (Eq,Ord,Read,Show)
+ src/HAppS/Server/S3.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE PatternGuards #-}+module HAppS.Server.S3+    ( newS3        -- :: AccessKey -> SecretKey -> URI -> IO S3+    , closeS3      -- :: S3 -> IO ()+    , createBucket -- :: S3 -> BucketId -> IO ()+    , createObject -- :: S3 -> BucketId -> ObjectId -> String -> IO ()+    , getObject    -- :: S3 -> BucketId -> ObjectId -> IO String+    , deleteBucket -- :: S3 -> BucketId -> IO ()+    , deleteObject -- :: S3 -> BucketId -> ObjectId -> IO ()+    , listObjects  -- :: S3 -> BucketId -> IO [String]+    , sendRequest  -- :: S3 -> Request -> IO String+    , sendRequest_ -- :: S3 -> Request -> IO ()+--    , sendRequests -- :: S3 -> [Request] -> IO ()+    , BucketId, ObjectId, AccessKey, SecretKey+    , amazonURI+    ) where++import HAppS.Crypto.HMAC             ( hmacSHA1 )+import HAppS.Server.HTTPClient.HTTP+import qualified HAppS.Server.HTTPClient.Stream as Stream++import Network.URI hiding (path)+import Control.Concurrent               ( newMVar, modifyMVar, swapMVar+                                        , modifyMVar_, MVar )+import Data.Maybe                       ( fromJust, fromMaybe )+import Data.List                        ( intersperse )+import System.Time                      ( getClockTime, toCalendarTime+                                        , formatCalendarTime )+import System.Locale                    ( defaultTimeLocale, rfc822DateFormat )++import Text.XML.HaXml                   ( xmlParse, Document(..), Content(..) )+import Text.XML.HaXml.Xtract.Parse      ( xtract )++type BucketId = String+type ObjectId = String+type AccessKey = String+type SecretKey = String++data S3+    = S3+    { s3AccessKey        :: AccessKey+    , s3SecretKey        :: SecretKey+    , s3URI              :: URI+--    , s3KeepAliveTimeout :: Int+    , s3Conn             :: MVar (Maybe Connection)+    }++{-+  Sign a request using the access key and secret key from the S3 data+  type.+-}+signRequest :: S3 -> Request -> IO Request+signRequest s3+    = let akey = s3AccessKey s3+          skey = s3SecretKey s3+      in signRequest' akey skey++{-+  Fill in necessary information (such as a date header) and then sign+  then request.+-}+signRequest' :: AccessKey -> SecretKey -> Request -> IO Request+signRequest' akey skey request+    = do now <- getClockTime+         cal <- toCalendarTime now+         let isoDate = formatCalendarTime defaultTimeLocale rfc822DateFormat cal+             auth = fromJust (parseURIAuthority (authority (rqURI request)))+--             authErr = error "S3.hs: internal error: failed to parse authority"+         let dat = concat $ intersperse "\n"+                   [show (rqMethod request)+                   ,lookupHeader HdrContentMD5+                   ,lookupHeader HdrContentType+                   ,isoDate+                   ,uriPath (rqURI request)]+             authorization = Header HdrAuthorization $ "AWS " ++ akey ++ ":" ++ signature+             signature = hmacSHA1 skey dat+             lookupHeader hn = fromMaybe "" (findHeader hn request)+             dateHdr = Header HdrDate isoDate+             lengthHdr = Header HdrContentLength (show $ length (rqBody request))+             connHdr = Header HdrConnection "Keep-Alive"+             hostHdr = Header HdrHost (host auth)+         return $ request+                    { rqHeaders = hostHdr:connHdr:lengthHdr:dateHdr:+                                  authorization:rqHeaders request+                    , rqURI = (rqURI request) { uriScheme = ""+                                              , uriAuthority = Nothing}}++{-+  Return a connection to an S3 server. Will initiate a new+  connection if no previous was found.+-}+getConnection :: S3 -> IO Connection+getConnection s3+    = modifyMVar (s3Conn s3) $ \mbConn ->+      case mbConn of+        Just conn -> return (mbConn,conn)+        Nothing -> do print (host auth, port auth)+                      c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+                      return (Just c,c)+    where auth = fromJust (parseURIAuthority (authority (s3URI s3)))++createRequest :: S3 -> RequestMethod -> String -> String -> Request+createRequest _s3 method path body+    = Request uri method [] body+    where uri = localhost { uriPath = '/':escapeURIString isAllowedInURI path }++{-+  Send a single request to an S3 server returning the body+  of the result.+-}+sendRequest :: S3 -> Request -> IO String+sendRequest s3 request+    = loop =<< signRequest s3 request+    where loop request'+              = do c <- getConnection s3+                   ret <- sendHTTP c request'+                   case ret of+                     Left ErrorClosed+                         -> do putStrLn "Connection closed."+                               swapMVar (s3Conn s3) Nothing+                               loop request'+                     Left err  -> error ("Failed to connect: " ++ show err) -- FIXME+                     Right res+                         | (2,_,_) <- rspCode res -> return (rspBody res)+                         | otherwise -> error ("Server error: " ++ rspReason res)++{-+  Same as 'sendRequest' except that it ignored the result.+-}+sendRequest_ :: S3 -> Request -> IO ()+sendRequest_ s3 request+    = do sendRequest s3 request+         return ()++{-+  Sign and send requests pipelined over a keep-alive connection.+-}+{-+  S3 imposes a quite severe limitation on pipelined requests.+  Sending too many requests or exceeding a size limit will+  result in a disconnect. The precise borders of these limits+  are hard-wired and unknown to the general public. At the time+  of this writing, sending three requests at a time seems optimal.++  Quote from Amazons web-forum:+  (http://developer.amazonwebservices.com/connect/thread.jspa?messageID=39883)+  "OK, we have located the cause of the behavior you are seeing.+   Your pipelined requests are being aborted because one of the+   network devices handling the connection has certain limitations+   on the amount of pipelined data it is willing to accept per+   connection, and that limit is being exceeded. Unfortunately, this+   limit is phrased in very low-level terms so it isn't possible to+   say in a platform or network independent way whether any given+   size, sequence or number of requests will exceed the limit and+   cause a disconnection or not. We have engaged with the device+   vendor and found out that this limit is hard-wired and that this+   behavior is not likely to change any time soon.++   In light of these facts, here is some guidance on pipelining HTTP+   requests to Amazon S3.+    1) Be optimistic and pipeline a modest number of GET or HEAD+       requests, say two to four.+    2) Handle asynchronous disconnects by re-connecting and re-sending+       unacknowledged requests left in your pipeline. (As Colin points+       out, correct HTTP clients must do this anyway)+    3) If possible, try to minimize the number of TCP segments your+       pipelined requests generate. In particular, leave the TCP socket+       no delay option off and send as many requests per socket write call+       as is practical."+-}++--------------------------------------------------------------+-- Initiate+--------------------------------------------------------------++newS3 :: AccessKey -> SecretKey -> URI -> IO S3+newS3 akey skey uri+    = do conn <- newMVar Nothing+         return $ S3 { s3AccessKey = akey+                     , s3SecretKey = skey+                     , s3URI       = uri+--                     , s3KeepAliveTimeout :: Int+                     , s3Conn      = conn+                     }++closeS3 :: S3 -> IO ()+closeS3 s3+    = modifyMVar_ (s3Conn s3) $ \mbConn ->+      case mbConn of+        Nothing -> return Nothing+        Just conn -> do Stream.close conn+                        return Nothing+++--------------------------------------------------------------+-- Requests+--------------------------------------------------------------+++createBucket :: S3 -> BucketId -> Request+createBucket s3 bucket+    = createRequest s3 PUT bucket ""++createObject :: S3 -> BucketId -> ObjectId -> String -> Request+createObject s3 bucket object+    = createRequest s3 PUT (bucket ++ "/" ++ object)++getObject :: S3 -> BucketId -> ObjectId -> Request+getObject s3 bucket object+    = createRequest s3 GET (bucket ++ "/" ++ object) ""++deleteBucket :: S3 -> BucketId -> Request+deleteBucket s3 bucket+    = createRequest s3 DELETE bucket ""++deleteObject :: S3 -> BucketId -> ObjectId -> Request+deleteObject s3 bucket object+    = createRequest s3 DELETE (bucket ++ "/" ++ object) ""++--------------------------------------------------------------+-- Actions+--------------------------------------------------------------+++listObjects :: S3 -> BucketId -> IO [String]+listObjects s3 bucket+    = do lst <- sendRequest s3 (createRequest s3 GET bucket "")+         return $ ppContent . auxFilter . getContent . xmlParse bucket $ lst+    where auxFilter = xtract "*/Key/-"+          getContent (Document _ _ e _) = CElem e++          ppContent xs  = [ s | CString _ s <- xs ]++++amazonURI :: URI+amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"+localhost :: URI+localhost = fromJust $ parseURI "http://localhost/"+
+ src/HAppS/Server/SURI.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}++module HAppS.Server.SURI where+import Data.Maybe+import Data.Generics+import HAppS.Util.Common(mapFst)+import qualified Network.URI as URI++path, query, scheme :: SURI -> String+path  = URI.uriPath . suri+query  = URI.uriQuery . suri+scheme  = URI.uriScheme . suri++u_scheme, u_path :: (String -> String) -> SURI -> SURI+u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u})+u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u}+a_scheme, a_path :: String -> SURI -> SURI+a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a}+a_path a (SURI u) = SURI $ u {URI.uriPath=a}++escape, unEscape :: String -> String+unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)+escape = URI.escapeURIString URI.isAllowedInURI++isAbs :: SURI -> Bool+isAbs = not . null . URI.uriScheme . suri+--isAbs = maybe True ( mbParsed++newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)+instance Show SURI where+    showsPrec d (SURI uri) = showsPrec d $ show uri+instance Read SURI where+    readsPrec d = mapFst fromJust .  filter (isJust . fst) . mapFst parse . readsPrec d ++instance Ord SURI where+    compare a b = show a `compare` show b++--parse  = fmap SURI . URI.parseURIReference ::String->Maybe SURI++-- | Render should be used for prettyprinting URIs.+render :: (ToSURI a) => a -> String+render x = (show . suri . toSURI) x+parse :: String -> Maybe SURI+parse =  fmap SURI . URI.parseURIReference +++class ToSURI x where toSURI::x->SURI+instance ToSURI SURI where toSURI=id+instance ToSURI URI.URI where toSURI=SURI+instance ToSURI String where +    toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse+++--handling obtaining things from URI paths+class FromPath x where fromPath::String->x
+ src/HAppS/Server/SURI/ParseURI.hs view
@@ -0,0 +1,81 @@+module HAppS.Server.SURI.ParseURI(parseURIRef) where++import qualified Data.ByteString.Internal as BB+import qualified Data.ByteString.Unsafe   as BB+import Data.ByteString.Char8 as BC+import Prelude hiding(break,length,null,drop,splitAt)+import Network.URI++import HAppS.Util.ByteStringCompat++parseURIRef :: ByteString -> URI+parseURIRef fs =+  case break (\c -> ':' == c || '/' == c || '?' == c || '#' == c) fs of+  (initial,rest) ->+      let ui = unpack initial+      in case uncons rest of+         Nothing ->+             if null initial then nullURI -- empty uri+                             else -- uri not containing either ':' or '/'+                                  nullURI { uriPath = ui }+         Just (c, rrest) ->+             case c of+             ':' -> pabsuri   rrest $ URI (unpack initial)+             '/' -> puriref   fs    $ URI "" Nothing+             '?' -> pquery    rrest $ URI "" Nothing ui+             '#' -> pfragment rrest $ URI "" Nothing ui ""+             _   -> error "parseURIRef: Can't happen"++pabsuri :: ByteString+           -> (Maybe URIAuth -> String -> String -> String -> b)+           -> b+pabsuri fs cont =+  if length fs >= 2 && unsafeHead fs == '/' && unsafeIndex fs 1 == '/'+     then pauthority (drop 2 fs) cont+     else puriref fs $ cont Nothing+pauthority :: ByteString+              -> (Maybe URIAuth -> String -> String -> String -> b)+              -> b+pauthority fs cont =+  let (auth,rest) = breakChar '/' fs+  in puriref rest $! cont (Just $! pauthinner auth)+pauthinner :: ByteString -> URIAuth+pauthinner fs =+  case breakChar '@' fs of+    (a,b) -> pauthport b  $ URIAuth (unpack a)+pauthport :: ByteString -> (String -> String -> t) -> t+pauthport fs cont =+  let spl idx = splitAt (idx+1) fs+  in case unsafeHead fs of+      _ | null fs -> cont "" ""+      '['         -> case fmap spl (elemIndexEnd ']' fs) of+                       Just (a,b) | null b              -> cont (unpack a) ""+                                  | unsafeHead b == ':' -> cont (unpack a) (unpack $ unsafeTail b)+                       x                                -> error ("Parsing uri failed (pauthport):"++show x)+      _           -> case breakCharEnd ':' fs of+                       (a,b) -> cont (unpack a) (unpack b)+puriref :: ByteString -> (String -> String -> String -> b) -> b+puriref fs cont =+  let (u,r) = break (\c -> '#' == c || '?' == c) fs+  in case unsafeHead r of+      _ | null r -> cont (unpack u) "" ""+      '?'        -> pquery    (unsafeTail r) $ cont (unpack u)+      '#'        -> pfragment (unsafeTail r) $ cont (unpack u) ""+      _          -> error "unexpected match"+pquery :: ByteString -> (String -> String -> t) -> t+pquery fs cont =+  case breakChar '#' fs of+    (a,b) -> cont ('?':unpack a) (unpack b)+pfragment :: ByteString -> (String -> b) -> b+pfragment fs cont =+  cont $ unpack fs++++unsafeTail :: ByteString -> ByteString+unsafeTail = BB.unsafeTail+unsafeHead :: ByteString -> Char+unsafeHead = BB.w2c . BB.unsafeHead+unsafeIndex :: ByteString -> Int -> Char+unsafeIndex s = BB.w2c . BB.unsafeIndex s+
+ src/HAppS/Server/SimpleHTTP.hs view
@@ -0,0 +1,780 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,+    MultiParamTypeClasses, PatternGuards, PatternSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  HAppS.Server.SimpleHTTP+-- Copyright   :  (c) HAppS Inc 2007+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@vo.com+-- Stability   :  provisional+-- Portability :  requires mtl+--+-- SimpleHTTP provides a back-end independent API for handling HTTP requests.+--+-- By default, the built-in HTTP server will be used. However, other back-ends+-- like CGI\/FastCGI can used if so desired.+-----------------------------------------------------------------------------+module HAppS.Server.SimpleHTTP+    ( module HAppS.Server.HTTP.Types+    , module HAppS.Server.Cookie+    , -- * SimpleHTTP+      simpleHTTP -- , simpleHTTP'+    , parseConfig+    , FromReqURI(..)+    , RqData+    , FromData(..)+    , ToMessage(..)+    , ServerPart+    , ServerPartT(..)+    , Web+    , WebT(..)+    , Result(..)+    , noHandle+    , escape+++      -- * ServerPart primitives.+    , webQuery+    , webUpdate+    , flatten+    , localContext+    , dir         -- :: String -> [ServerPart] -> ServerPart+    , method      -- :: MatchMethod m => m -> IO Result -> ServerPart+    , methodSP+--    , method'     -- :: MatchMethod m => m -> IO (Maybe Result) -> ServerPart+    , path        -- :: FromReqURI a => (a -> [ServerPart]) -> ServerPart+    , proxyServe+    , rproxyServe+--    , limProxyServe+    , uriRest +    , anyPath+    , anyPath'+    , withData    -- :: FromData a => (a -> [ServerPart]) -> ServerPart+    , withDataFn+--    , modXml+    , require     -- :: IO (Maybe a) -> (a -> [ServerPart]) -> ServerPart+    , multi       -- :: [ServerPart] -> ServerPart+    , withRequest -- :: (Request -> IO Result) -> ServerPart+    , debugFilter+    , anyRequest+    , applyRequest+    , modifyResponse+    , setResponseCode+    , basicAuth+      -- * Creating Results.+    , ok          -- :: ToMessage a => a -> IO Result+--    , mbOk+    , badGateway+    , internalServerError+    , badRequest+    , unauthorized +    , forbidden+    , notFound+    , seeOther+    , found+    , movedPermanently+    , tempRedirect+    , addCookie+    , addCookies+      -- * Parsing input and cookies+    , lookInput   -- :: String -> Data Input+    , lookBS      -- :: String -> Data B.ByteString+    , look        -- :: String -> Data String+    , lookCookie  -- :: String -> Data Cookie+    , lookCookieValue -- :: String -> Data String+    , readCookieValue -- :: Read a => String -> Data a+    , lookRead    -- :: Read a => String -> Data a+    , lookPairs+      -- * XSLT+    , xslt ,doXslt+      -- * Error Handlng+    , errorHandlerSP+    , simpleErrorHandler+      -- * Output Validation+    , setValidator+    , setValidatorSP+    , validateConf+    , runValidator+    , wdgHTMLValidator+    , noopValidator+    , lazyProcValidator+    ) where+import HAppS.Server.HTTP.Client+import HAppS.Data.Xml.HaXml+import qualified HAppS.Server.MinHaXML as H++import HAppS.Server.HTTP.Types hiding (Version(..))+import qualified HAppS.Server.HTTP.Types as Types+import HAppS.Server.HTTP.Listen+import HAppS.Server.XSLT+import HAppS.Server.SURI (ToSURI)+import HAppS.Util.Common+import HAppS.Server.Cookie+import HAppS.State (QueryEvent, UpdateEvent, query, update)+import HAppS.Data -- used by default implementation of fromData+import Control.Applicative+import Control.Concurrent (forkIO)+import Control.Exception (evaluate)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Error+import Data.Maybe+import Data.Monoid+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Generics as G+import qualified Data.Map as M+import Text.Html (Html,renderHtml)+import qualified Text.XHtml as XHtml (Html,renderHtml)+import qualified HAppS.Crypto.Base64 as Base64+import Data.Char+import Data.List+import System.IO+import System.Console.GetOpt+import System.Process (runInteractiveProcess, waitForProcess)+import System.Exit+import Text.Show.Functions ()++type Web a = WebT IO a+type ServerPart a = ServerPartT IO a++newtype ServerPartT m a = ServerPartT { unServerPartT :: Request -> WebT m a }++instance (Monad m) => Monad (ServerPartT m) where+    f >>= g = ServerPartT $ \rq ->+              do a <- unServerPartT f rq+                 unServerPartT (g a) rq+    return x = ServerPartT $ \_ -> return x++instance (MonadIO m) => MonadIO (ServerPartT m) where+    liftIO m = ServerPartT $ const (liftIO m)++newtype WebT m a = WebT { unWebT :: m (Result a) }++data Result a = NoHandle+              | Ok (Response -> Response) a+              | Escape Response+                deriving Show++instance Functor Result where+    fmap _ NoHandle = NoHandle+    fmap fn (Ok out a) = Ok out (fn a)+    fmap _ (Escape r) = Escape r++instance Monad m => Monad (WebT m) where+    f >>= g = WebT $ do r <- unWebT f+                        case r of+                          NoHandle    -> return NoHandle+                          Escape res -> return $ Escape res+                          Ok out a    -> do r' <- unWebT (g a)+                                            case r' of+                                              NoHandle    -> return NoHandle+                                              Escape res -> return $ Escape res+                                              Ok out' a'  -> return $ Ok (out' . out) a'+    return x = WebT $ return (Ok id x)++instance (Monad m) => Monoid (ServerPartT m a)+ where mempty = ServerPartT $ \_ -> noHandle+       mappend a b = ServerPartT $ \rq -> (unServerPartT a rq)+                     `mappend` (unServerPartT b rq)++instance (Monad m) => Monoid (WebT m a) where+ mempty = noHandle+ mappend a b = WebT $ do a' <- unWebT a+                         case a' of+                             NoHandle -> unWebT b+                             _        -> return a'++instance MonadTrans WebT where+    lift m = WebT (liftM (Ok id) m)++instance MonadIO m => MonadIO (WebT m) where+    liftIO m = WebT (liftM (Ok id) $ liftIO m)++instance Functor m => Functor (WebT m) where+    fmap fn (WebT m) = WebT $ fmap (fmap fn) m++instance Functor m => Functor (ServerPartT m) where+    fmap fn (ServerPartT m) = ServerPartT $ fmap (fmap fn) m++instance (Monad m, Functor m) => Applicative (ServerPartT m) where+    pure = return+    (<*>) = ap++instance (Monad m, Functor m) => Applicative (WebT m) where+    pure = return+    (<*>) = ap++instance MonadReader r m => MonadReader r (WebT m) where+    ask = lift ask+    local fn m = WebT $ local fn (unWebT m)++instance MonadState st m => MonadState st (WebT m) where+    get = lift get+    put = lift . put++instance MonadError e m => MonadError e (WebT m) where+	throwError err = WebT $ throwError err+ 	catchError action handler = WebT $ catchError (unWebT action) (unWebT . handler)+++noHandle :: Monad m => WebT m a+noHandle = WebT $ return NoHandle++escape :: (Monad m, ToMessage resp) => WebT m resp -> WebT m a+escape gen = WebT $ do res <- unWebT gen+                       case res of+                         NoHandle    -> return NoHandle+                         Escape r -> return $ Escape r+                         Ok out a    -> return $ Escape $ out $ toResponse a++ho :: [OptDescr (Conf -> Conf)]+ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]++parseConfig :: [String] -> Either [String] Conf+parseConfig args+    = case getOpt Permute ho args of+        (flags,_,[]) -> Right $ foldr ($) nullConf flags+        (_,_,errs)   -> Left errs++-- | Use the built-in web-server to serve requests according to list of @ServerParts@.+simpleHTTP :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()+simpleHTTP conf hs+    = listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs req)+++-- | Generate a result from a list of @ServerParts@ and a @Request@. This is mainly used+-- by CGI (and fast-cgi) wrappers.+simpleHTTP' :: (ToMessage a, Monad m) => [ServerPartT m a] -> Request -> m Response+simpleHTTP' hs req+    = do res <- unWebT (unServerPartT (multi hs) req)+         case res of+           NoHandle    -> return $ result 404 "No suitable handler found"+           Escape r -> return r+           Ok out a    -> return $ out $ toResponse a++class FromReqURI a where+    fromReqURI :: String -> Maybe a++++instance FromReqURI String where fromReqURI = Just+instance FromReqURI Int where    fromReqURI = readM+instance FromReqURI Integer where    fromReqURI = readM+instance FromReqURI Float where  fromReqURI = readM+instance FromReqURI Double where fromReqURI = readM++type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a++class FromData a where+    fromData :: RqData a++instance (Eq a,Show a,Xml a,G.Data a) => FromData a where+    fromData = do mbA <- lookPairs >>= return . normalize . fromPairs+                  case mbA of+                    Just a -> return a+                    Nothing -> fail "FromData G.Data failure"+--    fromData = lookPairs >>= return . normalize . fromPairs++instance (FromData a, FromData b) => FromData (a,b) where+    fromData = liftM2 (,) fromData fromData+instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where+    fromData = liftM3 (,,) fromData fromData fromData+instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where+    fromData = liftM4 (,,,) fromData fromData fromData fromData+instance FromData a => FromData (Maybe a) where+    fromData = fmap Just fromData `mplus` return Nothing++{- |+  Minimal definition: 'toMessage'+-}+++class ToMessage a where+    toContentType :: a -> B.ByteString+    toContentType _ = B.pack "text/plain"+    toMessage :: a -> L.ByteString+    toMessage = error "HAppS.Server.SimpleHTTP.ToMessage.toMessage: Not defined"+    toResponse:: a -> Response+    toResponse val =+        let bs = toMessage val+            res = Response 200 M.empty nullRsFlags bs Nothing+        in setHeaderBS (B.pack "Content-Type") (toContentType val)+           res++instance ToMessage [Element] where+    toContentType _ = B.pack "application/xml"+    toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE+    toMessage x    = error ("HAppS.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)+++++instance ToMessage () where+    toContentType _ = B.pack "text/plain"+    toMessage () = L.empty+instance ToMessage String where+    toContentType _ = B.pack "text/plain"+    toMessage = L.pack+instance ToMessage Integer where+    toMessage = toMessage . show+instance ToMessage a => ToMessage (Maybe a) where+    toContentType _ = toContentType (undefined :: a)+    toMessage Nothing = toMessage "nothing"+    toMessage (Just x) = toMessage x+++instance ToMessage Html where+    toContentType _ = B.pack "text/html"+    toMessage = L.pack . renderHtml++instance ToMessage XHtml.Html where+    toContentType _ = B.pack "text/html"+    toMessage = L.pack . XHtml.renderHtml++instance ToMessage Response where+    toResponse = id++instance (Xml a)=>ToMessage a where+    toContentType = toContentType . toXml+    toMessage = toMessage . toPublicXml++--    toMessageM = toMessageM . toPublicXml+++class MatchMethod m where matchMethod :: m -> Method -> Bool+instance MatchMethod Method where matchMethod m = (== m) +instance MatchMethod [Method] where matchMethod methods = (`elem` methods)+instance MatchMethod (Method -> Bool) where matchMethod f = f +instance MatchMethod () where matchMethod () _ = True++webQuery :: (MonadIO m, QueryEvent ev res) => ev -> WebT m res+webQuery = liftIO . query++webUpdate :: (MonadIO m, UpdateEvent ev res) => ev -> WebT m res+webUpdate = liftIO . update++flatten :: (ToMessage a, Monad m) => ServerPartT m a -> ServerPartT m Response+flatten = liftM toResponse++localContext :: Monad m => (WebT m a -> WebT m' a) -> [ServerPartT m a] -> ServerPartT m' a+localContext fn hs+    = ServerPartT $ \rq -> fn (unServerPartT (multi hs) rq)+++-- | Pop a path element and run the @[ServerPart]@ if it matches the given string.+dir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a+dir staticPath handle+    = ServerPartT $ \rq -> case rqPaths rq of+                             (p:xs) | p == staticPath -> +                                           unServerPartT (multi handle) rq{rqPaths = xs}+                             _ -> noHandle+++-- | Guard against the method. Note, this function also guards against any+--   remaining path segments. See 'anyRequest'.+methodSP :: (MatchMethod method, Monad m) => method -> ServerPartT m a -> ServerPartT m a+methodSP m handle+    = ServerPartT $ \rq -> if matchMethod m (rqMethod rq) && null (rqPaths rq)+                           then unServerPartT handle rq+                           else noHandle++-- | Guard against the method. Note, this function also guards against any+--   remaining path segments. See 'anyRequest'.+method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a+method m handle = methodSP m (ServerPartT $ \_ -> handle)+++-- | Pop a path element and parse it.+path :: (FromReqURI a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r+path handle+    = ServerPartT $ \rq -> +      case rqPaths rq of+               (p:xs) | Just a <- fromReqURI p+                                  -> unServerPartT (multi $ handle a) rq{rqPaths = xs}+               _ -> noHandle++uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a+uriRest handle = withRequest $ \rq ->+                  unServerPartT (handle (rqURL rq)) rq+++anyPath :: (Monad m) => [ServerPartT m r] -> ServerPartT m r+anyPath x = path $ (\(_::String) -> x)+anyPath' :: (Monad m) => ServerPartT m r -> ServerPartT m r+anyPath' x = path $ (\(_::String) -> [x])++-- | Retrieve date from the input query or the cookies.+withData :: (FromData a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r+withData = withDataFn fromData++withDataFn :: Monad m => RqData a -> (a -> [ServerPartT m r]) -> ServerPartT m r+withDataFn fn handle+    = ServerPartT $ \rq -> case runReaderT fn (rqInputs rq,rqCookies rq) of+                             Nothing -> noHandle+                             Just a  -> unServerPartT (multi $ handle a) rq+++proxyServe :: MonadIO m => [String] -> ServerPartT m Response+proxyServe allowed = withRequest $ \rq -> +                        if cond rq then proxyServe' rq else noHandle +   where+   cond rq+     | "*" `elem` allowed = True+     | domain `elem` allowed = True+     | superdomain `elem` wildcards =True+     | otherwise = False+     where+     domain = head (rqPaths rq) +     superdomain = tail $ snd $ break (=='.') domain+     wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed)                                                                           ++proxyServe' :: (MonadIO m) => Request -> WebT m Response+proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=+                either (badGateway . toResponse . show) (escape . return)+++rproxyServe :: MonadIO m => String -> [(String, String)] -> ServerPartT m Response+rproxyServe defaultHost list  = withRequest $ \rq ->+                liftIO (getResponse (unrproxify defaultHost list rq)) >>=+                either (badGateway . toResponse . show) (escape . return)++-- | Run an IO action and, if it returns @Just@, pass it to the second argument.+require :: MonadIO m => IO (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r+require fn = requireM (liftIO fn)++requireM :: Monad m => m (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r+requireM fn handle+    = ServerPartT $ \rq -> do mbVal <- lift fn+                              case mbVal of+                                Nothing -> noHandle+                                Just a  -> unServerPartT (multi $ handle a) rq++-- FIXME: What to do with Escapes?+-- | Use @cmd@ to transform XML against @xslPath@.+--   This function only acts if the content-type is @application\/xml@.+xslt :: (MonadIO m, ToMessage r) =>+        XSLTCmd  -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.+     -> XSLPath      -- ^ Path to xslt stylesheet.+     -> [ServerPartT m r] -- ^ Affected @ServerParts@.+     -> ServerPartT m Response+xslt cmd xslPath parts =+    withRequest $ \rq -> +        do res <- unServerPartT (multi parts) rq+           if toContentType res == B.pack "application/xml"+              then liftM toResponse (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 }++++--io :: IO Result -> ServerPart+--io action = ReaderT $ \_ -> Just action+++modifyResponse :: Monad m => (Response -> Response) -> WebT m ()+modifyResponse modFn = WebT $ return $ Ok modFn ()++setResponseCode :: Monad m => Int -> WebT m ()+setResponseCode code+    = modifyResponse $ \r -> r{rsCode = code}++addCookie :: Monad m => Seconds -> Cookie -> WebT m ()+addCookie sec cookie+    = modifyResponse $ addHeader "Set-Cookie" (mkCookieHeader sec cookie)++addCookies :: Monad m => [(Seconds, Cookie)] -> WebT m ()+addCookies = mapM_ (uncurry addCookie)++resp :: (Monad m) => Int -> b -> WebT m b+resp status val = setResponseCode status >> return val++-- | Respond with @200 OK@.+ok :: Monad m => a -> WebT m a+ok = resp 200++internalServerError::Monad m => a -> WebT m a+internalServerError = resp 500++badGateway::Monad m=> a-> WebT m a+badGateway = resp 502++-- | Respond with @400 Bad Request@.+badRequest :: Monad m => a -> WebT m a+badRequest = resp 400++-- | Respond with @401 Unauthorized@.+unauthorized :: Monad m => a -> WebT m a+unauthorized val  = resp 401 val++-- | Respond with @403 Forbidden@.+forbidden :: Monad m => a -> WebT m a+forbidden val = resp 403 val++-- | Respond with @404 Not Found@.+notFound :: Monad m => a -> WebT m a+notFound val = resp 404 val++-- | Respond with @303 See Other@.+seeOther :: (Monad m, ToSURI uri) => uri -> res -> WebT m res+seeOther uri res = do modifyResponse $ redirect 303 uri+                      return res++-- | Respond with @302 Found@.+found :: (Monad m, ToSURI uri) => uri -> res -> WebT m res+found uri res = do modifyResponse $ redirect 302 uri+                   return res++-- | Respond with @301 Moved Permanently@.+movedPermanently :: (Monad m, ToSURI a) => a -> res -> WebT m res+movedPermanently uri res = do modifyResponse $ redirect 301 uri+                              return res++-- | Respond with @307 Temporary Redirect@.+tempRedirect :: (Monad m, ToSURI a) => a -> res -> WebT m res+tempRedirect val res = do modifyResponse $ redirect 307 val+                          return res+++multi :: Monad m => [ServerPartT m a] -> ServerPartT m a+multi ls = ServerPartT $ \rq -> foldr servPlus noHandle [ unServerPartT l rq | l <- ls ]+    where servPlus a b = WebT $+                         do a' <- unWebT a+                            case a' of+                              NoHandle -> unWebT b+                              _        -> return a'++withRequest :: (Request -> WebT m a) -> ServerPartT m a+withRequest fn = ServerPartT $ fn++debugFilter :: (MonadIO m, Show a) => [ServerPartT m a] -> [ServerPartT m a]+debugFilter handle = [+    ServerPartT $ \rq -> WebT $ do+                    r <- unWebT (unServerPartT (multi handle) rq)+                    return r]++anyRequest :: Monad m => WebT m a -> ServerPartT m a+anyRequest x = withRequest $ \_ -> x++applyRequest :: (ToMessage a, Monad m) =>+                [ServerPartT m a] -> Request -> Either (m Response) b+applyRequest hs = simpleHTTP' hs >>= return . Left++basicAuth :: (MonadIO m) => String -> M.Map String String -> [ServerPartT m a] -> ServerPartT m a+basicAuth realmName authMap xs = multi $ basicAuthImpl:xs+  where+    basicAuthImpl = withRequest $ \rq ->+      case getHeader "authorization" rq of+        Nothing -> err+        Just x  -> case parseHeader x of +                     (name, ':':pass) | validLogin name pass -> noHandle+                     _                                       -> err+    validLogin name pass = M.lookup name authMap == Just pass+    parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+    headerName  = "WWW-Authenticate"+    headerValue = "Basic realm=\"" ++ realmName ++ "\""+    err = escape $+          do unauthorized $ addHeader headerName headerValue $ toResponse "Not authorized"+++--------------------------------------------------------------+-- Query/Post data validating+--------------------------------------------------------------+++lookInput :: String -> RqData Input+lookInput name+    = do inputs <- asks fst+         case lookup name inputs of+           Nothing -> fail "input not found"+           Just i  -> return i++lookBS :: String -> RqData L.ByteString+lookBS = fmap inputValue . lookInput++look :: String -> RqData String+look = fmap L.unpack . lookBS++lookCookie :: String -> RqData Cookie+lookCookie name+    = do cookies <- asks snd+         case lookup (map toLower name) cookies of -- keys are lowercased+           Nothing -> fail "cookie not found"+           Just c  -> return c++lookCookieValue :: String -> RqData String+lookCookieValue = fmap cookieValue . lookCookie++readCookieValue :: Read a => String -> RqData a+readCookieValue name = readM =<< fmap cookieValue (lookCookie name)++lookRead :: Read a => String -> RqData a+lookRead name = readM =<< look name++lookPairs :: RqData [(String,String)]+lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))+++--------------------------------------------------------------+-- Error Handling+--------------------------------------------------------------++-- | This ServerPart modifier enables the use of throwError and catchError inside the+--   WebT actions, by adding the ErrorT monad transformer to the stack.+--+--   You can wrap the complete second argument to 'simpleHTTP' in this function.+--+--   See 'simpleErrorHandler' for an example error handler.+errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> [ServerPartT (ErrorT e m) a] -> [ServerPartT m a] +errorHandlerSP handler sps = [ ServerPartT $ \req -> WebT $ do+			eer <- runErrorT $ unWebT $ unServerPartT (multi sps) req+			case eer of+				Left err -> unWebT (handler req err)+				Right res -> return res+		]++-- | An example error Handler to be used with 'errorHandlerSP', which returns the+--   error message as a plain text message to the browser.+--+--   Another possibility is to store the error message, e.g. as a FlashMsg, and+--   then redirect the user somewhere.+simpleErrorHandler :: (Monad m) => Request -> String -> WebT m Response+simpleErrorHandler _ err = ok $ toResponse $ ("An error occured: " ++ err)++--------------------------------------------------------------+-- * Output validation+--------------------------------------------------------------++-- |Set the validator which should be used for this particular 'Response'+-- when validation is enabled.+--+-- Calling this function does not enable validation. That can only be+-- done by enabling the validation in the 'Conf' that is passed to+-- 'simpleHTTP'.+--+-- You do not need to call this function if the validator set in+-- 'Conf' does what you want already.+--+-- Example: (use 'noopValidator' instead of the default supplied by 'validateConf')+--+-- @+--  simpleHTTP validateConf [ anyRequest $ ok . setValidator noopValidator =<< htmlPage ]+-- @+--+-- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator'+setValidator :: (Response -> IO Response) -> Response -> Response+setValidator v r = r { rsValidator = Just v }++-- |ServerPart version of 'setValidator'+--+-- Example: (Set validator to 'noopValidator')+--+-- @+--   simpleHTTP validateConf $ [ setValidatorSP noopValidator (dir "ajax" [ ... ])]+-- @+--+-- See also: 'setValidator'+setValidatorSP :: (ToMessage r) => (Response -> IO Response) -> ServerPartT IO r -> ServerPartT IO Response+setValidatorSP v sp = return . setValidator v . toResponse =<< sp++-- |This extends 'nullConf' by enabling validation and setting+-- 'wdgHTMLValidator' as the default validator for @text\/html@.+--+-- Example:+--+-- @+--  simpleHTTP validateConf [ anyRequest $ ok htmlPage ]+-- @+validateConf :: Conf+validateConf = nullConf { validator = Just wdgHTMLValidator }++-- |Actually perform the validation on a 'Response'+-- +-- Run the validator specified in the 'Response'. If none is provide+-- use the supplied default instead. +--+-- Note: This function will run validation unconditionally. You+-- probably want 'setValidator' or 'validateConf'.+runValidator :: (Response -> IO Response) -> Response -> IO Response+runValidator defaultValidator r =+    case rsValidator r of+      Nothing -> defaultValidator r+      (Just altValidator) -> altValidator r++-- |Validate @text\/html@ content with @WDG HTML Validator@.+--+-- This function expects the executable to be named @validate@+-- and it must be in the default @PATH@.+--+-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'+wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response+wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse+    where+      handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]+      handledContentTypes Nothing = False++-- |A validator which always succeeds.+--+-- Useful for selectively disabling validation. For example, if you+-- are sending down HTML fragments to an AJAX application and the+-- default validator only understands complete documents.+noopValidator :: Response -> IO Response+noopValidator = return++-- |Validate the 'Response' using an external application.+-- +-- If the external application returns 0, the original response is+-- returned unmodified. If the external application returns non-zero, a 'Response'+-- containing the error messages and original response body is+-- returned instead.+--+-- This function also takes a predicate filter which is applied to the+-- content-type of the response. The filter will only be applied if+-- the predicate returns true.+--+-- NOTE: This function requirse the use of -threaded to avoid blocking.+-- However, you probably need that for HAppS anyway.+-- +-- See also: 'wdgHTMLValidator'+lazyProcValidator :: FilePath -- ^ name of executable+               -> [String] -- ^ arguements to pass to the executable+               -> Maybe FilePath -- ^ optional path to working directory+               -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)+               -> (Maybe B.ByteString -> Bool) -- ^ content-type filter+               -> Response -- ^ Response to validate+               -> IO Response+lazyProcValidator exec args wd env mimeTypePred response+    | mimeTypePred (getHeader "content-type" response) =+        do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env+           out <- hGetContents outh+           err <- hGetContents errh+           forkIO $ do L.hPut inh (rsBody response)+                       hClose inh+           forkIO $ evaluate (length out) >> return ()+           forkIO $ evaluate (length err) >> return ()+           ec <- waitForProcess ph+           case ec of+             ExitSuccess     -> return response+             (ExitFailure _) -> +                 return $ toResponse (unlines ([ "ExitCode: " ++ show ec+                                               , "stdout:"+                                               , out+                                               , "stderr:"+                                               , err+                                               , "input:"+                                               ] ++ +                                               showLines (rsBody response)))+    | otherwise = return response+    where+      column = "  " ++ (take 120 $ concatMap  (\n -> "         " ++ show n) (drop 1 $ cycle [0..9::Int]))+      showLines :: L.ByteString -> [String]+      showLines string = column : zipWith (\n -> \l  -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)
+ src/HAppS/Server/StdConfig.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables #-}+module HAppS.Server.StdConfig where++import Control.Monad.Trans+import HAppS.Server.SimpleHTTP+import HAppS.Server.HTTP.FileServe++binarylocation :: String+binarylocation = "haskell/Main"+loglocation :: String+loglocation = "public/log"+++errWrap :: MonadIO m => ServerPartT m Response+errWrap =  errorwrapper binarylocation loglocation+--stateFuns -- main actually has state so you can just import them
+ src/HAppS/Server/XSLT.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,+             DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables, PatternSignatures  #-}+-- | Implement XSLT transformations using xsltproc+module HAppS.Server.XSLT+    (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,+     xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd+    ) where+++import System.Log.Logger++import HAppS.Server.MinHaXML+import HAppS.Util.Common(runCommand)+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.IO+import System.IO.Unsafe(unsafePerformIO)+import Text.XML.HaXml.Verbatim(verbatim)+import HAppS.Data hiding (Element)++logMX :: Priority -> String -> IO ()+logMX = logM "HAppS.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'++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]++xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]+xsltFPS xsl inp = unsafePerformIO $ xsltFPSIO xsl inp++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]++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' :: XSLTCommand+xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])+xsltproc :: XSLTCmd+xsltproc = XSLTProc++-- | 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
+ src/HAppS/Store/Util.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, CPP,+             OverlappingInstances, DeriveDataTypeable, MultiParamTypeClasses #-}++module HAppS.Store.Util where+import HAppS.Data+import GHC.Conc+import HAppS.State+import Control.Monad.State+import HAppS.Data.IxSet+import HAppS.Data.Atom+import Language.Haskell.TH++import Control.Monad.State ++++--interface with State++$( deriveAll [''Show,''Default,''Read,''Eq,''Ord]+   [d|+       newtype Context = Context String  --this belongs elsewhere!+       newtype EpochTime = EpochTime Integer       +       data Wrap a = Wrap {unwrap::a}+       |])++type With st' st a = Ev (StateT st' STM) a -> Ev (StateT st STM) a+++byTime::(Typeable a) => IxSet a -> [a]+byTime = concat . map (\(Published _,es)->es) . groupBy+byRevTime::(Typeable a) => IxSet a -> [a]+byRevTime = concat . map (\(Published _,es)->es) . rGroupBy+++fun0_1 :: String -> String -> String -> Dec+fun0_1 name fun arg = +    FunD (mkName name)  +             [Clause [] (NormalB (AppE (VarE $ mkName fun) +                                           (ConE $ mkName arg))) +              []+             ]+fun0_2 :: String -> String -> String -> String -> Dec+fun0_2 name fun arg1 arg2 = +    FunD (mkName name)  +             [Clause [] (NormalB +                         (AppE (AppE (VarE $ mkName fun) +                                (ConE $ mkName arg1))+                                (ConE $ mkName arg2)))+              []+             ]
+ tests/HAppS/Server/Tests.hs view
@@ -0,0 +1,12 @@+-- |HUnit tests and QuickQuick properties for HAppS.Server.*+module HAppS.Server.Tests (allTests) where++import Test.HUnit as HU (Test(..),(~:),(~?))++-- |All of the tests for happstack-util should be listed here. +allTests :: Test+allTests = +    "happstack-server tests" ~: [dummyTest]++dummyTest :: Test+dummyTest = "dummyTest" ~: True ~? "True"
+ tests/Test.hs view
@@ -0,0 +1,19 @@+module Main where++import HAppS.Server.Tests (allTests)+import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT)+import System.Exit (exitFailure)+import System.IO (hIsTerminalDevice, stdout)++-- |A simple driver for running the local test suite.+main :: IO ()+main =+    do c <- do istty <- hIsTerminalDevice stdout+               if istty+                  then runTestTT allTests+                  else do (c,st) <- runTestText putTextToShowS allTests+                          putStrLn (st "")+                          return c+       case (failures c) + (errors c) of+         0 -> return ()+         n -> exitFailure