+ 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 [] = []
diff --git a/src/Happstack/Server/HTTPClient/Stream.hs b/src/Happstack/Server/HTTPClient/Stream.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/HTTPClient/Stream.hs
@@ -0,0 +1,173 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Happstack.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 Happstack.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)
+ }
diff --git a/src/Happstack/Server/HTTPClient/TCP.hs b/src/Happstack/Server/HTTPClient/TCP.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/HTTPClient/TCP.hs
@@ -0,0 +1,193 @@
+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Happstack.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 Happstack.Server.HTTPClient.TCP (
+ -- ** Connections
+ Conn(..),
+ Connection(..),
+ openTCP,
+ openTCPPort,
+ isConnectedTo
+) where
+
+import Control.Exception.Extensible as Exception
+
+-- Networking
+import Network.BSD
+import Network.Socket
+import Happstack.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
+ }
+
diff --git a/src/Happstack/Server/JSON.hs b/src/Happstack/Server/JSON.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/JSON.hs
@@ -0,0 +1,29 @@
+module Happstack.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
diff --git a/src/Happstack/Server/MessageWrap.hs b/src/Happstack/Server/MessageWrap.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/MessageWrap.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Happstack.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 Happstack.Server.HTTP.Types as H
+import Happstack.Server.HTTP.Multipart
+import Happstack.Server.SURI as SURI
+import Happstack.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
diff --git a/src/Happstack/Server/MinHaXML.hs b/src/Happstack/Server/MinHaXML.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/MinHaXML.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances,
+ OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}
+
+
+
+module Happstack.Server.MinHaXML where
+-- Copyright (c) Happstack.com 2009; (c) HAppS.org 2005. 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 Happstack.Util.Common
+import Data.Maybe
+import System.Time
+
+import Happstack.Data.Xml as Xml
+import Happstack.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, String)]
+ -> [Types.Element]
+ -> Types.Element
+() :: 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 = Types.Elem name . map (uncurry attr)
+ 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 = ("\n"++
+ if hasStyleURL style then pi else "") ++
+ (verbatim $ xmlStdEscape elem)
+ where typeText=if isCSS style then "text/css" else "text/xsl"
+ pi= "\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= "\n"
+
+
+
+xmlEscaper :: XmlEscaper
+xmlEscaper=stdXmlEscaper
+xmlStdEscape :: Types.Element -> Types.Element
+xmlStdEscape = xmlEscape stdXmlEscaper
+verbim :: (Verbatim a) => a -> String
+verbim = verbatim
+
+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 = textElem "String" []
+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 = epochPico
+
+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) = """ ++ 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)
diff --git a/src/Happstack/Server/Parts.hs b/src/Happstack/Server/Parts.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/Parts.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}
+module Happstack.Server.Parts(
+ compressedResponseFilter
+ ,gzipFilter
+ ,deflateFilter
+ ,encodings
+) where
+import Happstack.Server.SimpleHTTP
+import Text.ParserCombinators.Parsec
+import Control.Monad
+import Data.Maybe
+import Data.List
+import qualified Data.ByteString.Char8 as BS
+import qualified Codec.Compression.GZip as GZ
+import qualified Codec.Compression.Zlib as Z
+
+-- | reads the \"Accept-Encoding\" header. Then, if possible
+-- will compress the response body with methods "gzip" or "deflate"
+--
+-- Returns the name of the coding chosen
+compressedResponseFilter::
+ (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)
+ => m String
+compressedResponseFilter = do
+ mbAccept<-getHeaderM "Accept-Encoding"
+ accept<- maybe mzero return mbAccept
+ let eEncoding = bestEncoding $ BS.unpack accept
+ (coding,action) <- case eEncoding of
+ Left _ -> do
+ setResponseCode 406
+ finishWith $ toResponse ""
+ Right a -> return (a, maybe (fail "Encoding returned not in the list of known encodings")
+ id (lookup a allEncodingHandlers))
+ setHeaderM "Content-Encoding" coding
+ action
+ return coding
+
+-- | compresses the body of the response with gzip.
+-- does not set any headers.
+gzipFilter::(FilterMonad Response m) => m()
+gzipFilter = do
+ composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r})
+
+-- | compresses the body of the response with zlib's
+-- deflate method
+-- does not set any headers.
+deflateFilter::(FilterMonad Response m) => m()
+deflateFilter = do
+ composeFilter (\r -> r{rsBody = Z.compress $ rsBody r})
+
+-- | based on the rules describe in rfc2616 sec. 14.3
+bestEncoding :: String -> Either String String
+bestEncoding encs = do
+ encList<-either (Left . show) (Right) $ parse encodings "" encs
+ case acceptable encList of
+ [] -> Left "no encoding found"
+ a -> Right $ head a
+ where
+ -- first intersect with the list of encodings we know how to deal with at all
+ knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]
+ knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings)
+ -- this expands the wildcard, by figuring out if we need to include "identity" in the list
+ -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).
+ --
+ -- note this implementation is a little conservative. if someone were to specify "*"
+ -- without a "q" value, it would be this server is willing to accept any format at all.
+ -- We pretty much assume we can't send them /any/ format and that they really
+ -- meant just "identity" this seems safe to me.
+ knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]
+ knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $
+ case lookup "*" (knownEncodings m) of
+ Nothing -> addIdent $ knownEncodings m
+ Just (Just a) | a>0 -> addIdent $ knownEncodings m
+ | otherwise -> knownEncodings m
+ Just (Nothing) -> addIdent $ knownEncodings m
+ dropZero (_, Just a) | a==0 = False
+ | otherwise = True
+ dropZero (_, Nothing) = True
+ addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]
+ addIdent m = if isNothing $ lookup "identity" m
+ then m ++ [("identity",Nothing)]
+ else m
+ -- finally we sort the list of available encodings.
+ acceptable:: [(String,Maybe Double)] -> [String]
+ acceptable l = map fst $ sortBy (flip cmp) $ knownEncodings' l
+ -- let the client choose but break ties with gzip
+ encOrder = reverse $ zip (reverse allEncodings) [1..]
+ m0 = maybe (0.0::Double) id
+ cmp (s,mI) (t,mJ) | m0 mI == m0 mJ
+ = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder)
+ | otherwise = compare (m0 mI) (m0 mJ)
+
+
+allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())]
+allEncodingHandlers = zip allEncodings handlers
+
+allEncodings :: [String]
+allEncodings =
+ ["gzip"
+ ,"x-gzip"
+-- ,"compress" -- as far as I can tell there is no haskell library that supports this
+-- ,"x-compress" -- as far as I can tell, there is no haskell library that supports this
+ ,"deflate"
+ ,"identity"
+ ,"*"
+ ]
+
+handlers::(FilterMonad Response m) => [m ()]
+handlers =
+ [gzipFilter
+ ,gzipFilter
+-- ,compressFilter
+-- ,compressFilter
+ ,deflateFilter
+ ,return ()
+ ,fail $ "chose * as content encoding"
+ ]
+
+-- | unsupported: a parser for the Accept-Encoding header
+encodings :: GenParser Char st [([Char], Maybe Double)]
+encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)
+ where
+ ws = many space
+ sep = do
+ ws
+ char ','
+ ws
+ encoding1 :: GenParser Char st ([Char], Maybe Double)
+ encoding1 = do
+ encoding <- many1 letter <|> string "*"
+ ws
+ quality<-optionMaybe qual
+ return (encoding, fmap read quality)
+ qual = do
+ char ';' >> ws >> char 'q' >> ws >> char '=' >> ws
+ q<-float
+ return $ q
+ int = many1 digit
+ float = do
+ wholePart<-many1 digit
+ fractionalPart<-option "" fraction
+ return $ wholePart ++ fractionalPart
+ <|>
+ do
+ fractionalPart<-fraction
+ return $ fractionalPart
+ fraction :: GenParser Char st String
+ fraction = do
+ char '.'
+ fractionalPart<-option "" int
+ return $ '.':fractionalPart
+
+
diff --git a/src/Happstack/Server/S3.hs b/src/Happstack/Server/S3.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/S3.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE PatternGuards #-}
+module Happstack.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 Happstack.Crypto.HMAC ( hmacSHA1 )
+import Happstack.Server.HTTPClient.HTTP
+import qualified Happstack.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 (uriAuthority (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 (uriRegName 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 (uriRegName auth, uriPort auth)
+ c <- openTCPPort (uriRegName auth) (if null $ uriPort auth then 80 else read$ uriPort auth)
+ return (Just c,c)
+ where auth = fromJust (uriAuthority (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/"
+
diff --git a/src/Happstack/Server/SURI.hs b/src/Happstack/Server/SURI.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/SURI.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}
+
+module Happstack.Server.SURI where
+import Data.Maybe
+import Data.Generics
+import Happstack.Util.Common(mapFst)
+import qualified Network.URI as URI
+
+-- | Retrieves the path component from the URI
+path :: SURI -> String
+path = URI.uriPath . suri
+
+-- | Retrieves the query component from the URI
+query :: SURI -> String
+query = URI.uriQuery . suri
+
+-- | Retrieves the scheme component from the URI
+scheme :: SURI -> String
+scheme = URI.uriScheme . suri
+
+-- | Modifies the scheme component of the URI using the provided function
+u_scheme :: (String -> String) -> SURI -> SURI
+u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u})
+
+-- | Modifies the path component of the URI using the provided function
+u_path :: (String -> String) -> SURI -> SURI
+u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u}
+
+-- | Sets the scheme component of the URI
+a_scheme :: String -> SURI -> SURI
+a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a}
+
+-- | Sets the path component of the URI
+a_path :: String -> SURI -> SURI
+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
+
+-- | Render should be used for prettyprinting URIs.
+render :: (ToSURI a) => a -> String
+render = show . suri . toSURI
+
+-- | Parses a URI from a String. Returns Nothing on failure.
+parse :: String -> Maybe SURI
+parse = fmap SURI . URI.parseURIReference
+
+-- | Convenience class for converting data types to URIs
+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
diff --git a/src/Happstack/Server/SURI/ParseURI.hs b/src/Happstack/Server/SURI/ParseURI.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/SURI/ParseURI.hs
@@ -0,0 +1,81 @@
+module Happstack.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 Happstack.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
+
diff --git a/src/Happstack/Server/SimpleHTTP.hs b/src/Happstack/Server/SimpleHTTP.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/SimpleHTTP.hs
@@ -0,0 +1,1355 @@
+{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,
+ MultiParamTypeClasses, PatternGuards, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternSignatures
+ #-}
+{-# OPTIONS -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Happstack.Server.SimpleHTTP
+-- Copyright : (c) Happstack.com 2009; (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.
+--
+-- So the general nature of 'simpleHTTP' is no different than what you'd expect
+-- from a web application container. First you figure out when function is
+-- going to process your request, process the request to generate a response,
+-- then return that response to the client. The web application container is
+-- started with 'simpleHTTP', which takes a configuration and a
+-- response-building structure ('ServerPartT' which I'll return too in a
+-- moment), and picks the first handler that is willing to accept the request,
+-- passes the request into the handler. A simple "hello world" style HAppS
+-- simpleHTTP server looks like:
+--
+-- @
+-- main = simpleHTTP nullConf $ return \"Hello World!\"
+-- @
+--
+-- @simpleHTTP nullConf@ creates a HTTP server on port 8000.
+-- return \"Hello World!\" creates a serverPartT that just returns that text.
+--
+-- 'ServerPartT' is the basic response builder. As you might expect, it's a
+-- container for a function that takes a Request and converts it a response
+-- suitable for sending back to the server. Most of the time though you don't
+-- even need to worry about that as ServerPartT hides almost all the machinery
+-- for building your response by exposing a few type classes.
+--
+-- 'ServerPartT' is a pretty rich monad. You can interact with your request,
+-- your response, do IO, etc. Here is a do block that validates basic
+-- authentication It takes a realm name as a string, a Map of username to
+-- password and a server part to run if authentication fails.
+--
+-- @basicAuth'@ acts like a guard, and only produces a response when
+-- authentication fails. So put it before any ServerPartT you want to demand
+-- authentication for in any collection of ServerPartTs.
+--
+-- @
+--
+-- main = simpleHTTP nullConf $ myAuth, return \"Hello World!\"
+-- where
+-- myAuth = basicAuth\' \"Test\"
+-- (M.fromList [(\"hello\", \"world\")]) (return \"Login Failed\")
+--
+-- basicAuth\' realmName authMap unauthorizedPart =
+-- do
+-- let validLogin name pass = M.lookup name authMap == Just pass
+-- let parseHeader = break (\':\'==) . Base64.decode . B.unpack . B.drop 6
+-- authHeader <- getHeaderM \"authorization\"
+-- case authHeader of
+-- Nothing -> err
+-- Just x -> case parseHeader x of
+-- (name, \':\':pass) | validLogin name pass -> mzero
+-- | otherwise -> err
+-- _ -> err
+-- where
+-- err = do
+-- unauthorized ()
+-- setHeaderM headerName headerValue
+-- unauthorizedPart
+-- headerValue = \"Basic realm=\\\"\" ++ realmName ++ \"\\\"\"
+-- headerName = \"WWW-Authenticate\"
+-- @
+--
+-- Here is another example that uses liftIO to embed IO in a request process
+--
+-- @
+-- main = simpleHTTP nullConf $ myPart
+-- myPart = do
+-- line <- liftIO $ do -- IO
+-- putStr \"return? \"
+-- getLine
+-- when (take 2 line \/= \"ok\") $ (notfound () >> return \"refused\")
+-- return \"Hello World!\"
+-- @
+--
+-- This example will ask in the console \"return? \" if you type \"ok\" it will
+-- show \"Hello World!\" and if you type anything else it will return a 404.
+--
+-----------------------------------------------------------------------------
+module Happstack.Server.SimpleHTTP
+ ( module Happstack.Server.HTTP.Types
+ , module Happstack.Server.Cookie
+ -- * SimpleHTTP
+ , simpleHTTP
+ , simpleHTTP'
+ , parseConfig
+ -- * ServerPartT
+ , ServerPartT(..)
+ , ServerPart
+ , runServerPartT
+ , mapServerPartT
+ , mapServerPartT'
+ , withRequest
+ , anyRequest
+ -- * WebT
+ , WebT(..)
+ , FilterFun
+ , Web
+ , mkWebT
+ , ununWebT
+ , runWebT
+ , mapWebT
+ -- * Type Classes
+ , FromReqURI(..)
+ , ToMessage(..)
+
+ -- * Manipulating requests
+ , FromData(..)
+ , ServerMonad(..)
+ , RqData
+ , noHandle
+ , getHeaderM
+ , escape
+ , escape'
+ , multi
+ -- * Manipulating responses
+ , FilterMonad(..)
+ , ignoreFilters
+ , SetAppend(..)
+ , FilterT(..)
+ , WebMonad(..)
+ , ok
+ , modifyResponse
+ , setResponseCode
+ , badGateway
+ , internalServerError
+ , badRequest
+ , unauthorized
+ , forbidden
+ , notFound
+ , seeOther
+ , found
+ , movedPermanently
+ , tempRedirect
+ , addCookie
+ , addCookies
+ , addHeaderM
+ , setHeaderM
+
+ -- * guards and building blocks
+ , guardRq
+ , dir
+ , method
+ , methodSP
+ , methodM
+ , methodOnly
+ , nullDir
+ , path
+ , anyPath
+ , anyPath'
+ , withData
+ , withDataFn
+ , getDataFn
+ , getData
+ , require
+ , requireM
+ , basicAuth
+ , uriRest
+ , flatten
+ , localContext
+ -- * proxying
+ , proxyServe
+ , rproxyServe
+ -- * unknown
+ , debugFilter
+ , applyRequest
+ -- * 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
+ , spUnwrapErrorT
+ -- * Output Validation
+ , setValidator
+ , setValidatorSP
+ , validateConf
+ , runValidator
+ , wdgHTMLValidator
+ , noopValidator
+ , lazyProcValidator
+ ) where
+import qualified Paths_happstack_server as Cabal
+import qualified Data.Version as DV
+import Happstack.Server.HTTP.Client
+import Happstack.Data.Xml.HaXml
+import qualified Happstack.Server.MinHaXML as H
+
+import Happstack.Server.HTTP.Types hiding (Version(..))
+import qualified Happstack.Server.HTTP.Types as Types
+import Happstack.Server.HTTP.Listen as Listen
+import Happstack.Server.XSLT
+import Happstack.Server.SURI (ToSURI)
+import Happstack.Util.Common
+import Happstack.Server.Cookie
+import Happstack.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 Control.Monad.Trans()
+import Control.Monad.Maybe
+import Control.Monad.Writer as Writer
+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 Happstack.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 ()
+
+-- | An alias for WebT when using IO
+type Web a = WebT IO a
+-- | An alias for using ServerPartT when using the IO
+type ServerPart a = ServerPartT IO a
+
+--------------------------------------
+-- HERE BEGINS ServerPartT definitions
+
+-- | ServerPartT is a container for processing requests and returning results
+newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }
+ deriving (Monad, MonadIO, MonadPlus, Functor)
+
+-- | particularly useful when combined with runWebT to produce
+-- a @m (Maybe Response)@ from a request.
+runServerPartT :: ServerPartT m a -> Request -> WebT m a
+runServerPartT = runReaderT . unServerPartT
+
+withRequest :: (Request -> WebT m a) -> ServerPartT m a
+withRequest = ServerPartT . ReaderT
+
+-- | Used to manipulate the containing monad. Very useful when embedding a
+-- monad into a ServerPartT, since simpleHTTP requires a @ServerPartT IO a@.
+-- Refer to 'WebT' for an explanation of the structure of the monad.
+--
+-- Here is an example. Suppose you want to embed an ErrorT into your
+-- ServerPartT to enable throwError and catchError in your Monad.
+--
+-- @
+-- type MyServerPartT e m a = ServerPartT (ErrorT e m) a
+-- @
+--
+-- Now suppose you want to pass MyServerPartT into a function
+-- that demands a @ServerPartT IO a@ (e.g. simpleHTTP). You
+-- can provide the function:
+--
+-- @
+-- unpackErrorT:: (Monad m, Show e) =>
+-- -> (ErrorT e m) (Maybe ((Either Response a), FilterFun Response))
+-- -> m (Maybe ((Either Response a), FilterFun Response))
+-- unpackErrorT handler et = do
+-- eitherV <- runErrorT et
+-- case eitherV of
+-- Left err -> return $ Just (Left "Catastrophic failure " ++ show e, Set $ Endo \r -> r{rsCode = 500})
+-- Right x -> return x
+-- @
+--
+-- With @unpackErrorT@ you can now call simpleHTTP. Just wrap your @ServerPartT@ list.
+--
+-- @
+-- simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart \`catchError\` myHandler)
+-- @
+--
+-- Or alternatively:
+--
+-- @
+-- simpleHTTP' unpackErrorT nullConf (myPart \`catchError\` myHandler)
+-- @
+--
+-- Also see 'spUnwrapErrorT' for a more sophisticated version of this function
+--
+mapServerPartT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b
+mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)
+
+-- | A varient of mapServerPartT where the first argument, also takes a request.
+-- useful if you want to runServerPartT on a different ServerPartT inside your
+-- monad (see spUnwrapErrorT)
+mapServerPartT' :: (Request -> m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b
+mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)
+instance MonadTrans (ServerPartT) where
+ lift m = withRequest (\_ -> lift m)
+
+instance (Monad m) => Monoid (ServerPartT m a)
+ where mempty = mzero
+ mappend = mplus
+
+instance (Monad m, Functor m) => Applicative (ServerPartT m) where
+ pure = return
+ (<*>) = ap
+
+instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where
+ tell = lift . tell
+ listen m = withRequest $ \rq -> Writer.listen (runServerPartT m rq) >>= return
+ pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return
+
+instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where
+ throwError e = lift $ throwError e
+ catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler)
+
+instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where
+ ask = lift ask
+ local fn m = withRequest $ \rq-> local fn (runServerPartT m rq)
+
+instance Monad m => FilterMonad Response (ServerPartT m) where
+ setFilter = anyRequest . setFilter
+ composeFilter = anyRequest . composeFilter
+ getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq)
+
+instance Monad m => WebMonad Response (ServerPartT m) where
+ finishWith r = anyRequest $ finishWith r
+
+-- | yes, this is exactly like 'ReaderT' with new names.
+-- Why you ask? Because ServerT can lift up a ReaderT.
+-- If you did that, it would shadow ServerT's behavior
+-- as a ReaderT, thus meaning if you lifted the ReaderT
+-- you could no longer modify the Request. This way
+-- you can add a ReaderT to your monad stack without
+-- any trouble.
+class Monad m => ServerMonad m where
+ askRq :: m Request
+ localRq :: (Request->Request)->m a->m a
+
+instance (Monad m) => ServerMonad (ServerPartT m) where
+ askRq = ServerPartT $ ask
+ localRq f m = ServerPartT $ local f (unServerPartT m)
+-------------------------------
+-- HERE BEGINS WebT definitions
+
+-- | A monoid operation container.
+-- If a is a monoid, then SetAppend is a monoid with the following behaviors:
+--
+-- @
+-- Set x `mappend` Append y = Set (x `mappend` y)
+-- Append x `mappend` Append y = Append (x `mappend` y)
+-- \_ `mappend` Set y = Set y
+-- @
+--
+-- A simple way of sumerizing this is, if the left side is Append, then the
+-- right is appended to the left. If the left side is Set, then the right side
+-- is ignored.
+data SetAppend a = Set a | Append a
+ deriving (Eq, Show)
+instance Monoid a => Monoid (SetAppend a) where
+ mempty = Append mempty
+ Set x `mappend` Append y = Set (x `mappend` y)
+ Append x `mappend` Append y = Append (x `mappend` y)
+ _ `mappend` Set y = Set y
+
+value :: SetAppend t -> t
+value (Set x) = x
+value (Append x) = x
+
+instance Functor (SetAppend) where
+ fmap f (Set x) = Set $ f x
+ fmap f (Append x) = Append $ f x
+
+-- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@
+type FilterFun a = SetAppend (Dual (Endo a))
+
+newtype FilterT a m b =
+ FilterT { unFilterT :: WriterT (FilterFun a) m b }
+ deriving (Monad, MonadTrans, Functor, MonadIO)
+
+-- | A set of functions for manipulating filters. A ServerPartT implements
+-- FilterMonad Response so these methods are the fundamental ways of
+-- manipulating the response object, especially before you've converted your
+-- monadic value to a 'Response'
+class Monad m => FilterMonad a m | m->a where
+ -- | Ignores all previous
+ -- alterations to your filter
+ --
+ -- As an example:
+ --
+ -- @
+ -- do
+ -- composeFilter f
+ -- setFilter g
+ -- return \"Hello World\"
+ -- @
+ --
+ -- setFilter g will cause the first composeFilter to be
+ -- ignored.
+ setFilter :: (a->a) -> m ()
+ -- |
+ -- composes your filter function with the
+ -- existing filter function.
+ composeFilter :: (a->a) -> m ()
+ -- | retrives the filter from the environment
+ getFilter :: m b -> m (b,a->a)
+
+instance (Monad m) => FilterMonad a (FilterT a m) where
+ setFilter f = FilterT $ Writer.tell $ Set $ Dual $ Endo f
+ composeFilter f = FilterT $ Writer.tell $ Append $ Dual $ Endo f
+ getFilter m = FilterT $ Writer.listens (appEndo . getDual . value) (unFilterT m)
+
+-- | The basic response building object.
+-- It is worth discussing the unpacked structure of WebT a bit as it's exposed
+-- in 'mapServerPartT' and 'mapWebT'.
+--
+-- A fully unpacked WebT has a structure that looks like:
+--
+-- @
+-- ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))
+-- @
+--
+-- So, ignoring m, as it is just the containing Monad, the outermost layer is
+-- a Maybe. This is 'Nothing' if 'mzero' was called or @Just (Either Response
+-- a, SetAppend (Endo Response))@ if 'mzero' wasn't called. Inside the Maybe,
+-- there is a pair. The second element of the pair is our filter function
+-- @FilterFun Response@. @FilterFun Response@ is a type alias for @SetAppend
+-- (Dual (Endo Response))@. This is just a wrapper for a @Response->Response@
+-- function with a particular Monoid behavior. The value
+--
+-- @
+-- Append (Dual (Endo f))
+-- @
+--
+-- Causes f to be composed with the previous filter.
+--
+-- @
+-- Set (Dual (Endo f))
+-- @
+--
+-- Causes f to not be composed with the previous filter.
+--
+-- Finally, the first element of the pair is either @Left Response@ or @Right a@.
+--
+-- Another way of looking at all these pieces is from the behaviors they control. The Maybe
+-- controls the mzero behavior. @Set (Endo f)@ comes from the setFilter behavior.
+-- Likewise, @Append (Endo f)@ is from composeFilter. @Left Response@ is what you
+-- get when you call "finishWith" and @Right a@ is the normal exit.
+--
+-- An example case statement looks like:
+-- @
+-- ex1 webt = do
+-- val <- ununWebT webt
+-- case val of
+-- Nothing -> Nothing -- this is the interior value when mzero was used
+-- Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"
+-- -- f is our filter function
+-- Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value
+-- -- f is still our filter function
+-- @
+--
+newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }
+ deriving (MonadIO, Functor)
+
+instance Monad m => Monad (WebT m) where
+ m >>= f = WebT $ unWebT m >>= unWebT . f
+ return a = WebT $ return a
+ fail s = mkFailMessage s
+
+instance Error Response where
+ strMsg = toResponse
+
+class Monad m => WebMonad a m | m->a where
+ -- | A control structure
+ -- It ends the computation and returns the Response you passed into it
+ -- immediately. This provides an alternate escape route. In particular
+ -- it has a monadic value of any type. And unless you call @'setFilter' id@
+ -- first your response filters will be applied normally.
+ --
+ -- Extremely useful when you're deep inside a monad and decide that you
+ -- want to return a completely different content type, since it doesn't
+ -- force you to convert all your return types to Response early just to
+ -- accomodate this.
+ finishWith :: a -> m b
+
+instance (Monad m) => WebMonad Response (WebT m) where
+ finishWith r = WebT $ throwError r
+
+instance MonadTrans WebT where
+ lift = WebT . lift . lift . lift
+
+instance (Monad m) => MonadPlus (WebT m) where
+ -- | Aborts a computation.
+ --
+ -- This is primarily useful because msum will take an array
+ -- of MonadPlus and return the first one that isn't mzero,
+ -- which is exactly the semantics expected from objects
+ -- that take lists of ServerPartT
+ mzero = WebT $ lift $ lift $ mzero
+ mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)
+ where lower = (unFilterT . runErrorT . unWebT)
+
+-- | deprecated. use mzero
+noHandle :: (MonadPlus m) => m a
+noHandle = mzero
+{-# DEPRECATED noHandle "Use mzero" #-}
+
+instance (Monad m) => FilterMonad Response (WebT m) where
+ setFilter f = WebT $ lift $ setFilter $ f
+ composeFilter f = WebT . lift . composeFilter $ f
+ getFilter m = WebT $ ErrorT $ getFilter (runErrorT $ unWebT m) >>= liftWebT
+ where liftWebT (Left r, _) = return $ Left r
+ liftWebT (Right a, f) = return $ Right (a, f)
+
+instance (Monad m) => Monoid (WebT m a) where
+ mempty = mzero
+ mappend = mplus
+
+-- | takes your WebT, converts the monadic value to a Response,
+-- applys your filter, and returns it wrapped in a Maybe.
+runWebT :: (ToMessage b, Monad m) => WebT m b -> m (Maybe Response)
+runWebT m = runMaybeT $ do
+ (r,ed) <- runWriterT $ unFilterT $ runErrorT $ unWebT $ m
+ let f = appEndo $ getDual $ value ed
+ return $ either (f) (f . toResponse) r
+-- | for when you really need to unpack a WebT entirely (and not
+-- just unwrap the first layer with unWebT)
+ununWebT :: WebT m a
+ -> m (Maybe
+ (Either Response a,
+ FilterFun Response))
+ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT
+
+-- | for wrapping a WebT back up. @mkWebT . ununWebT = id@
+mkWebT :: m (Maybe
+ (Either Response a,
+ FilterFun Response)) -> WebT m a
+mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT
+
+-- | see 'mapServerPartT' for a discussion of this function
+mapWebT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> WebT m a -> WebT n b
+mapWebT f ma = mkWebT $ f (ununWebT ma)
+
+
+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 = mkWebT $ local fn (ununWebT 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 = lift $ throwError err
+ catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)
+
+instance MonadWriter w m => MonadWriter w (WebT m) where
+ tell = lift . Writer.tell
+ listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT)
+ where liftWebT (Nothing, _) = Nothing
+ liftWebT (Just (Left x,f), _) = Just (Left x,f)
+ liftWebT (Just (Right x,f),w) = Just (Right (x,w),f)
+ pass m = mkWebT $ ununWebT m >>= liftWebT
+ where liftWebT Nothing = return Nothing
+ liftWebT (Just (Left x,f)) = return $ Just (Left x, f)
+ liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f))
+
+-- | An alias for setFilter id
+-- It resets all your filters
+ignoreFilters :: (FilterMonad a m) => m ()
+ignoreFilters = setFilter id
+
+-- | Used to ignore all your filters
+-- and immediately end the computation. A combination of
+-- 'ignoreFilters' and 'finishWith'
+escape :: (WebMonad a m, FilterMonad a m) => m a -> m b
+escape gen = ignoreFilters >> gen >>= finishWith
+
+-- | An alternate form of 'escape' that can
+-- be easily used within a do block.
+escape' :: (WebMonad a m, FilterMonad a m) => a -> m b
+escape' a = ignoreFilters >> finishWith a
+
+----------------------------------------------
+-- additional types
+
+
+-- | An array of 'OptDescr', useful for processing
+-- command line options into an 'Conf' for 'simpleHTTP'
+ho :: [OptDescr (Conf -> Conf)]
+ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]
+
+-- | parseConfig tries to parse your command line options
+-- into a Conf.
+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 a 'ServerPartT'.
+-- Use msum to pick the first handler from a list of handlers that doesn't call
+-- noHandle.
+simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()
+simpleHTTP = simpleHTTP' id
+
+-- | a combination of simpleHTTP and 'mapServerPartT'. See 'mapServerPartT' for a discussion
+-- of the first argument of this function.
+simpleHTTP' :: (Monad m, ToMessage b) =>
+ (m (Maybe (Either Response a, FilterFun Response))
+ -> IO (Maybe (Either Response b, FilterFun Response)))
+ -> Conf
+ -> ServerPartT m a
+ -> IO ()
+simpleHTTP' toIO conf hs = do
+ Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))
+
+
+-- | Generate a result from a 'ServerPart' and a 'Request'. This is mainly used
+-- by CGI (and fast-cgi) wrappers.
+simpleHTTP'' :: (ToMessage b, Monad m) => ServerPartT m b -> Request -> m Response
+simpleHTTP'' hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))
+ where
+ standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml
+
+
+-- | a wrapper for Read apparently. Pretty much only used for 'path' and probably
+-- unnecessarily, as it is exactly "readM"
+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
+
+-- | Useful for withData and getData' implement this on your preferred type
+-- to use those functions
+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'
+--
+-- Used to convert arbitrary types into an HTTP response. You need to implement
+-- this if you want to pass @ServerPartT m@ containing your type into simpleHTTP
+class ToMessage a where
+ toContentType :: a -> B.ByteString
+ toContentType _ = B.pack "text/plain"
+ toMessage :: a -> L.ByteString
+ toMessage = error "Happstack.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 ("Happstack.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
+
+-- | flatten turns your arbitrary @m a@ and converts it too
+-- a @m 'Response'@ with @'toResponse'@
+flatten :: (ToMessage a, Functor f) => f a -> f Response
+flatten = fmap toResponse
+
+-- | This is kinda like a very oddly shaped mapServerPartT or mapWebT
+-- You probably want one or the other of those.
+localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a
+localContext fn hs
+ = withRequest $ \rq -> fn (runServerPartT hs rq)
+
+
+-- | Get a header out of the request
+getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)
+getHeaderM a = askRq >>= return . (getHeader a)
+
+-- | adds headers into the response.
+-- This method does not overwrite any existing header of
+-- the same name, hence the name addHeaderM. If you
+-- want to replace a header use setHeaderM.
+addHeaderM :: (FilterMonad Response m) => String -> String -> m ()
+addHeaderM a v = composeFilter $ \res-> addHeader a v res
+
+-- | sets a header into the response. This will replace
+-- an existing header of the same name. Use addHeaderM, if you
+-- want to add more than one header of the same name.
+setHeaderM :: (FilterMonad Response m) => String -> String -> m ()
+setHeaderM a v = composeFilter $ \res -> setHeader a v res
+-------------------------------------
+-- guards
+
+-- | guard using an arbitrary function on the request
+guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()
+guardRq f = do
+ rq <- askRq
+ when ( f rq /= True ) mzero
+
+-- | Guard against the method. This function also guards against
+-- any remaining path segments. See methodOnly for the version
+-- that guards only by method
+methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
+methodM meth = methodOnly meth >> nullDir
+
+-- | guard against the method only. (as opposed to 'methodM')
+methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
+methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)
+
+-- | Guard against the method. Note, this function also guards against any
+-- remaining path segments.
+methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b
+methodSP m handle = methodM m >> handle
+
+-- | Guard against the method. Note, this function also guards against any
+-- remaining path segments. This function id deprecated. You can probably
+-- just use methodSP (or methodM) now.
+method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a
+method m handle = methodSP m (anyRequest handle)
+{-# DEPRECATED method "you should be able to use methodSP" #-}
+
+-- | Guard against non-empty remaining path segments
+nullDir :: (ServerMonad m, MonadPlus m) => m ()
+nullDir = guardRq $ \rq -> null (rqPaths rq)
+
+-- | Pop a path element and run the @ServerPartT@ if it matches the given string.
+dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
+dir staticPath handle =
+ do
+ rq <- askRq
+ case rqPaths rq of
+ (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle
+ | otherwise -> mzero
+ _ -> mzero
+
+-- | Pop a path element and parse it. Annoyingly enough, rather than just using Read
+-- (or providing a parser argument), this method uses 'FromReqURI' which is just a wrapper
+-- for Read.
+path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b
+path handle = do
+ rq <- askRq
+ case rqPaths rq of
+ (p:xs) | Just a <- fromReqURI p
+ -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)
+ | otherwise -> mzero
+ _ -> mzero
+
+-- | grabs the rest of the URL (dirs + query) and passes it to your handler
+uriRest :: (ServerMonad m) => (String -> m a) -> m a
+uriRest handle = askRq >>= handle . rqURL
+
+-- | pops any path element and ignores when chosing a ServerPartT to handle the
+--
+-- request.
+anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r
+anyPath x = path $ (\(_::String) -> x)
+
+-- | Deprecated. Use 'anyPath'.
+anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r
+anyPath' = anyPath
+{-# DEPRECATED anyPath' "Use anyPath" #-}
+
+-- | used to read parse your request with a RqData (a ReaderT, basically)
+-- For example here is a simple GET or POST variable based authentication
+-- guard. It handles the request with errorHandler if authentication fails.
+--
+-- @
+-- myRqData = do
+-- username <- lookInput \"username\"
+-- password <- lookInput \"password\"
+-- return (username, password)
+-- checkAuth errorHandler = do
+-- d <- getData myRqDataA
+-- case d of
+-- Nothing -> errorHandler
+-- Just a | isValid a -> mzero
+-- Just a | otherwise -> errorHandler
+-- @
+getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a)
+getDataFn rqData = do
+ rq <- askRq
+ return $ runReaderT rqData (rqInputs rq, rqCookies rq)
+
+-- | An varient of getData that uses FromData to chose your
+-- RqData for you. The example from 'getData' becomes:
+--
+-- @
+-- myRqData = do
+-- username <- lookInput \"username\"
+-- password <- lookInput \"password\"
+-- return (username, password)
+-- instance FromData (String,String) where
+-- fromData = myRqData
+-- checkAuth errorHandler = do
+-- d <- getData\'
+-- case d of
+-- Nothing -> errorHandler
+-- Just a | isValid a -> mzero
+-- Just a | otherwise -> errorHandler
+-- @
+getData :: (ServerMonad m, FromData a) => m (Maybe a)
+getData = getDataFn fromData
+
+-- | Retrieve data from the input query or the cookies.
+withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r
+withData = withDataFn fromData
+
+-- | withDataFn is like with data, but you pass in a RqData monad
+-- for reading.
+withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r
+withDataFn fn handle = do
+ d <- getDataFn fn
+ case d of
+ Nothing -> mzero
+ Just a -> handle a
+
+-- | proxyServe is for creating ServerPartT's that proxy.
+-- The sole argument [String] is a list of allowed domains for
+-- proxying. This matches the domain part of the request
+-- and the wildcard * can be used. E.g.
+--
+-- * \"*\" to match anything.
+--
+-- * \"*.example.com\" to match anything under example.com
+--
+-- * \"example.com\" to match just example.com
+--
+--
+-- TODO: annoyingly enough, this method eventually calls escape, so
+-- any headers you set won't be used, and the computation immediatly ends.
+proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response
+proxyServe allowed = do
+ rq <- askRq
+ if cond rq then proxyServe' rq else mzero
+ 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)
+
+-- | Takes a proxy Request and creates a Response. Your basic proxy
+-- building block. See 'unproxify'
+--
+-- TODO: this would be more useful if it didn\'t call "escape" (e.g. it let you
+-- modify the response afterwards, or set additional headers)
+proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response
+proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=
+ either (badGateway . toResponse . show) escape'
+
+-- | This is a reverse proxy implementation.
+-- see 'unrproxify'
+--
+-- TODO: this would be more useful if it didn\'t call "escape", just like
+-- proxyServe'
+rproxyServe :: (MonadIO m, WebMonad Response m) =>
+ String -- ^ defaultHost
+ -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy
+ -> ServerPartT m Response -- ^ the result is a ServerPartT that will reverse proxy for you.
+rproxyServe defaultHost list = withRequest $ \rq ->
+ liftIO (getResponse (unrproxify defaultHost list rq)) >>=
+ either (badGateway . toResponse . show) (escape')
+
+-- | Run an IO action and, if it returns @Just@, pass it to the second argument.
+require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r
+require fn handle = do
+ mbVal <- liftIO fn
+ case mbVal of
+ Nothing -> mzero
+ Just a -> handle a
+
+-- | A varient of require that can run in any monad, not just IO
+requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r
+requireM fn handle = do
+ mbVal <- lift fn
+ case mbVal of
+ Nothing -> mzero
+ Just a -> handle a
+
+-- | Use @cmd@ to transform XML against @xslPath@.
+-- This function only acts if the content-type is @application\/xml@.
+xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>
+ XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.
+ -> XSLPath -- ^ Path to xslt stylesheet.
+ -> m r -- ^ Affected @ServerParts@.
+ -> m Response
+xslt cmd xslPath parts = do
+ res <- parts
+ 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 }
+
+-- | deprecated. Same as 'composeFilter'
+modifyResponse :: (FilterMonad a m) => (a -> a) -> m()
+modifyResponse = composeFilter
+{-# DEPRECATED modifyResponse "Use composeFilter" #-}
+
+-- | sets the return code in your response
+setResponseCode :: FilterMonad Response m => Int -> m ()
+setResponseCode code
+ = composeFilter $ \r -> r{rsCode = code}
+
+-- | adds the cookie with a timeout to the response
+addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m ()
+addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec
+
+-- | adds the list of cookie timeout pairs to the response
+addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m ()
+addCookies = mapM_ (uncurry addCookie)
+
+-- | same as setResponseCode status >> return val
+resp :: (FilterMonad Response m) => Int -> b -> m b
+resp status val = setResponseCode status >> return val
+
+-- | Respond with @200 OK@.
+ok :: (FilterMonad Response m) => a -> m a
+ok = resp 200
+
+internalServerError :: (FilterMonad Response m) => a -> m a
+internalServerError = resp 500
+
+badGateway :: (FilterMonad Response m) => a -> m a
+badGateway = resp 502
+
+-- | Respond with @400 Bad Request@.
+badRequest :: (FilterMonad Response m) => a -> m a
+badRequest = resp 400
+
+-- | Respond with @401 Unauthorized@.
+unauthorized :: (FilterMonad Response m) => a -> m a
+unauthorized = resp 401
+
+-- | Respond with @403 Forbidden@.
+forbidden :: (FilterMonad Response m) => a -> m a
+forbidden = resp 403
+
+-- | Respond with @404 Not Found@.
+notFound :: (FilterMonad Response m) => a -> m a
+notFound = resp 404
+
+-- | Respond with @303 See Other@.
+seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
+seeOther uri res = do modifyResponse $ redirect 303 uri
+ return res
+
+-- | Respond with @302 Found@.
+found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
+found uri res = do modifyResponse $ redirect 302 uri
+ return res
+
+-- | Respond with @301 Moved Permanently@.
+movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
+movedPermanently uri res = do modifyResponse $ redirect 301 uri
+ return res
+
+-- | Respond with @307 Temporary Redirect@.
+tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
+tempRedirect val res = do modifyResponse $ redirect 307 val
+ return res
+
+-- | deprecated. Just use msum
+multi :: Monad m => [ServerPartT m a] -> ServerPartT m a
+multi = msum
+{-# DEPRECATED multi "Use msum instead" #-}
+
+-- | what is this for, exactly? I don't understand why @Show a@ is even in the context
+-- This appears to do nothing at all.
+debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a
+debugFilter handle =
+ withRequest $ \rq -> do
+ r <- runServerPartT handle rq
+ return r
+
+-- | a constructor for a ServerPartT when you don't care about the request
+anyRequest :: Monad m => WebT m a -> ServerPartT m a
+anyRequest x = withRequest $ \_ -> x
+
+-- | again, why is this useful?
+applyRequest :: (ToMessage a, Monad m) =>
+ ServerPartT m a -> Request -> Either (m Response) b
+applyRequest hs = simpleHTTP'' hs >>= return . Left
+
+-- | a simple HTTP basic authentication guard
+basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>
+ String -- ^ the realm name
+ -> M.Map String String -- ^ the username password map
+ -> m a -- ^ the part to guard
+ -> m a
+basicAuth realmName authMap xs = basicAuthImpl `mplus` xs
+ where
+ basicAuthImpl = do
+ aHeader <- getHeaderM "authorization"
+ case aHeader of
+ Nothing -> err
+ Just x -> case parseHeader x of
+ (name, ':':password) | validLogin name password -> mzero
+ | otherwise -> err
+ _ -> err
+ validLogin name password = M.lookup name authMap == Just password
+ parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6
+ headerName = "WWW-Authenticate"
+ headerValue = "Basic realm=\"" ++ realmName ++ "\""
+ err = do
+ unauthorized ()
+ setHeaderM headerName headerValue
+ escape' $ toResponse "Not authorized"
+
+--------------------------------------------------------------
+-- Query/Post data validating
+--------------------------------------------------------------
+
+-- | Useful inside the RqData monad. Gets the named input parameter (either
+-- from a POST or a GET)
+lookInput :: String -> RqData Input
+lookInput name
+ = do inputs <- asks fst
+ case lookup name inputs of
+ Nothing -> fail "input not found"
+ Just i -> return i
+
+-- | Gets the named input parameter as a lazy byte string
+lookBS :: String -> RqData L.ByteString
+lookBS = fmap inputValue . lookInput
+
+-- | Gets the named input as a String
+look :: String -> RqData String
+look = fmap L.unpack . lookBS
+
+-- | Gets the named cookie
+-- the cookie name is case insensitive
+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
+
+-- | gets the named cookie as a string
+lookCookieValue :: String -> RqData String
+lookCookieValue = fmap cookieValue . lookCookie
+
+-- | gets the named cookie as the requested Read type
+readCookieValue :: Read a => String -> RqData a
+readCookieValue name = readM =<< fmap cookieValue (lookCookie name)
+
+-- | like look, but Reads for you.
+lookRead :: Read a => String -> RqData a
+lookRead name = readM =<< look name
+
+-- | gets all the input parameters, and converts them to a string
+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.
+--
+errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a
+errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do
+ eer <- runErrorT $ ununWebT $ runServerPartT sps req
+ case eer of
+ Left err -> ununWebT (handler req err)
+ Right res -> return res
+{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-}
+
+-- | An example error Handler to be used with 'spUnWrapErrorT', 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) => String -> ServerPartT m Response
+simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err)
+
+-- | This is a for use with mapServerPartT\' It it unwraps
+-- the interior monad for use with simpleHTTP. If you
+-- have a ServerPartT (ErrorT e m) a, this will convert
+-- that monad into a ServerPartT m a. Used with
+-- mapServerPartT\' to allow throwError and catchError inside your
+-- monad. Eg.
+--
+-- @
+-- simpleHTTP conf $ mapServerPartT\' (spUnWrapErrorT failurePart) $ myPart \`catchError\` errorPart
+-- @
+--
+-- Note that @failurePart@ will only be run if errorPart threw an error
+-- so it doesn\'t have to be very complex.
+spUnwrapErrorT:: Monad m =>
+ (e -> ServerPartT m a)
+ -> Request
+ -> ErrorT e m (Maybe (Either Response a, FilterFun Response))
+ -> m (Maybe (Either Response a, FilterFun Response))
+spUnwrapErrorT handler rq = \x -> do
+ err <- runErrorT x
+ case err of
+ Left e -> ununWebT $ runServerPartT (handler e) rq
+ Right a -> return a
+
+--------------------------------------------------------------
+-- * 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 :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m 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 Happstack 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)
+
+mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b
+mkFailMessage s = do
+ ignoreFilters
+ internalServerError ()
+ setHeaderM "Content-Type" "text/html"
+ res <- return $ toResponse $ failHtml s
+ finishWith $ res
+
+failHtml:: String->String
+failHtml errString = "Happstack "
+ ++ ver ++ " Internal Server Error"
+ ++ "Happstack " ++ ver ++ "
"
+ ++ "Something went wrong here
"
+ ++ "Internal server error
"
+ ++ "Everything has stopped
"
+ ++ "The error was \"" ++ errString ++ "\"
"
+ where ver = DV.showVersion Cabal.version
+
+notFoundHtml :: String
+notFoundHtml = "Happstack "
+ ++ ver ++ " File not found"
+ ++ "Happstack " ++ ver ++ "
"
+ ++ "Your file is not found
"
+ ++ "To try again is useless
"
+ ++ "It is just not here
"
+ ++ ""
+ where ver = DV.showVersion Cabal.version
diff --git a/src/Happstack/Server/StdConfig.hs b/src/Happstack/Server/StdConfig.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/StdConfig.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Happstack.Server.StdConfig where
+
+import Control.Monad.Trans
+import Control.Monad
+import Happstack.Server.SimpleHTTP
+import Happstack.Server.HTTP.FileServe
+
+-- | Is equal to "haskell/Main"
+binarylocation :: String
+binarylocation = "haskell/Main"
+
+-- | Is equal to "public/log"
+loglocation :: String
+loglocation = "public/log"
+
+-- | Convenience function around 'errorwrapper'
+-- with the default binary location set to 'binarylocation' and the
+-- log location set to 'loglocation'.
+errWrap :: (MonadPlus m, FilterMonad Response m, MonadIO m) => m Response
+errWrap = errorwrapper binarylocation loglocation
+--stateFuns -- main actually has state so you can just import them
diff --git a/src/Happstack/Server/XSLT.hs b/src/Happstack/Server/XSLT.hs
new file mode 100644
--- /dev/null
+++ b/src/Happstack/Server/XSLT.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,
+ DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,
+ PatternSignatures #-}
+module Happstack.Server.XSLT
+ (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,
+ xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd
+ ) where
+
+
+import System.Log.Logger
+
+import Happstack.Server.MinHaXML
+import Happstack.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 Happstack.Data hiding (Element)
+
+logMX :: Priority -> String -> IO ()
+logMX = logM "Happstack.Server.XSLT"
+
+type XSLPath = FilePath
+
+$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]
+ [d|
+ data XSLTCmd = XSLTProc | Saxon
+ |]
+ )
+
+xsltCmd :: XSLTCmd
+ -> XSLPath
+ -> FilePath
+ -> FilePath
+ -> (FilePath, [String])
+xsltCmd XSLTProc = xsltproc'
+xsltCmd Saxon = saxon'
+
+-- | Uses 'xsltString' to transform the given XML 'Element' into a
+-- a 'String'.
+xsltElem :: XSLPath -> Element -> String
+xsltElem xsl = xsltString xsl . verbatim
+
+
+procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString
+procLBSIO xsltp' xsl inp =
+ withTempFile "happs-src.xml" $ \sfp sh -> do
+ withTempFile "happs-dst.xml" $ \dfp dh -> do
+ let xsltp = xsltCmd xsltp'
+ L.hPut sh inp
+ hClose sh
+ hClose dh
+ xsltFileEx xsltp xsl sfp dfp
+ s <- L.readFile dfp
+ logMX DEBUG (">>> XSLT: result: "++ show s)
+ return s
+
+
+procFPSIO :: XSLTCommand
+ -> XSLPath
+ -> [P.ByteString]
+ -> IO [P.ByteString]
+procFPSIO xsltp xsl inp =
+ withTempFile "happs-src.xml" $ \sfp sh -> do
+ withTempFile "happs-dst.xml" $ \dfp dh -> do
+ mapM_ (P.hPut sh) inp
+ hClose sh
+ hClose dh
+ xsltFileEx xsltp xsl sfp dfp
+ s <- P.readFile dfp
+ logMX DEBUG (">>> XSLT: result: "++ show s)
+ return [s]
+
+-- | Performs an XSL transformation with lists of ByteStrings instead of
+-- a String.
+xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]
+xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl
+
+-- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level
+-- ByteString operations.
+xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]
+xsltFPSIO xsl inp =
+ withTempFile "happs-src.xml" $ \sfp sh -> do
+ withTempFile "happs-dst.xml" $ \dfp dh -> do
+ mapM_ (P.hPut sh) inp
+ hClose sh
+ hClose dh
+ xsltFile xsl sfp dfp
+ s <- P.readFile dfp
+ logMX DEBUG (">>> XSLT: result: "++ show s)
+ return [s]
+
+-- | Uses the provided xsl file to transform the given string.
+-- This function creates temporary files during its execution, but
+-- guarantees their cleanup.
+xsltString :: XSLPath -> String -> String
+xsltString xsl inp = unsafePerformIO $
+ withTempFile "happs-src.xml" $ \sfp sh -> do
+ withTempFile "happs-dst.xml" $ \dfp dh -> do
+ hPutStr sh inp
+ hClose sh
+ hClose dh
+ xsltFile xsl sfp dfp
+ s <- readFileStrict dfp
+ logMX DEBUG (">>> XSLT: result: "++ show s)
+ return s
+
+-- | Note that the xsl file must have .xsl suffix.
+xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()
+xsltFile = xsltFileEx xsltproc'
+
+-- | Use @xsltproc@ to transform XML.
+xsltproc :: XSLTCmd
+xsltproc = XSLTProc
+xsltproc' :: XSLTCommand
+xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])
+
+
+-- | Use @saxon@ to transform XML.
+saxon :: XSLTCmd
+saxon = Saxon
+saxon' :: XSLTCommand
+saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",
+ ["com.icl.saxon.StyleSheet"
+ ,"-o",dst,src,xsl])
+
+type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])
+xsltFileEx :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()
+xsltFileEx xsltp xsl src dst = do
+ let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])
+ logMX DEBUG msg
+ uncurry runCommand $ xsltp dst xsl src
+ logMX DEBUG (">>> XSLT: xsltproc done")
+
+-- Utilities
+
+withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a
+withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)
+
+readFileStrict :: FilePath -> IO String
+readFileStrict fp = do
+ let fseqM [] = return []
+ fseqM xs = last xs `seq` return xs
+ fseqM =<< readFile fp
+
+{-# NOINLINE tempDir #-}
+tempDir :: FilePath
+tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err
+ where err = return "/tmp"
+
+tryAny :: [IO a] -> IO a -> IO a
+tryAny [] c = c
+tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x
diff --git a/tests/HAppS/Server/Tests.hs b/tests/HAppS/Server/Tests.hs
deleted file mode 100644
--- a/tests/HAppS/Server/Tests.hs
+++ /dev/null
@@ -1,12 +0,0 @@
--- |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"
diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Happstack/Server/Tests.hs
@@ -0,0 +1,41 @@
+-- |HUnit tests and QuickQuick properties for Happstack.Server.*
+module Happstack.Server.Tests (allTests) where
+
+import Test.HUnit as HU (Test(..),(~:),(~?),(@?=))
+import Happstack.Server.Cookie
+import Happstack.Server.Parts
+import Text.ParserCombinators.Parsec
+
+-- |All of the tests for happstack-util should be listed here.
+allTests :: Test
+allTests =
+ "happstack-server tests" ~: [cookieParserTest, acceptEncodingParserTest]
+
+cookieParserTest :: Test
+cookieParserTest =
+ "cookieParserTest" ~:
+ [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"
+ @?= (Right [
+ Cookie "1" "/testpath" "example.com" "cookie1" "value1"
+ , Cookie "1" "" "" "cookie2" "value2"
+ ])
+ ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ "
+ @?= (Right [
+ Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|"
+ ])
+ ,parseCookies " cookie1 = value1 "
+ @?= (Right [
+ Cookie "" "" "" "cookie1" "value1"
+ ])
+ ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe "
+ @?= (Right [
+ Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe"
+ ])
+ ]
+
+acceptEncodingParserTest :: Test
+acceptEncodingParserTest =
+ "acceptEncodingParserTest" ~:
+ [either (Left . show) Right (parse encodings "" " gzip;q=1,*, compress ; q = 0.5 ")
+ @?= (Right [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])
+ ]
diff --git a/tests/Test.hs b/tests/Test.hs
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -1,6 +1,6 @@
module Main where
-import HAppS.Server.Tests (allTests)
+import Happstack.Server.Tests (allTests)
import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT)
import System.Exit (exitFailure)
import System.IO (hIsTerminalDevice, stdout)