hack-frontend-happstack 2009.6.1 → 2009.6.2

raw patch · 3 files changed

+100/−9 lines, 3 filesdep +bytestringdep +containersdep +utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, containers, utf8-string

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• hack-frontend-happstack.cabal +2/−2
• src/Hack/Frontend/Happstack.hs +91/−7

@@ -1,3 +1,10 @@+2009.6.2+--------++### Feature++* complete implementation+ 2009.6.1 --------- 

@@ -1,5 +1,5 @@ Name:                 hack-frontend-happstack-Version:              2009.6.1+Version:              2009.6.2 Build-type:           Simple Synopsis:             hack-frontend-happstack Description:@@ -18,7 +18,7 @@  library   ghc-options: -Wall-  build-depends: base, happstack-fastcgi, hack-frontend-monadcgi, happstack-server, hack >= 5.19+  build-depends: base, happstack-fastcgi, hack-frontend-monadcgi, happstack-server, hack >= 5.19, bytestring, containers, utf8-string   hs-source-dirs: src/   exposed-modules:                         Hack.Frontend.Happstack

@@ -1,11 +1,95 @@-{-# LANGUAGE NoMonomorphismRestriction#-}- module Hack.Frontend.Happstack where -import Hack.Frontend.MonadCGI (cgiToApp)-import Happstack.Server.FastCGI (serverPartToCGI)-import Hack (Application)-import Happstack.Server.SimpleHTTP (ToMessage, ServerPartT)+import Happstack.Server+import Happstack.Server.HTTP.Types (Request (..), Version (Version))+import qualified Data.ByteString.UTF8 as UBS+import qualified Happstack.Server as H+import Happstack.Server.SURI (parse)+import qualified Hack as Hack+import qualified Hack+import Hack (http, pathInfo, scriptName, queryString, hackInput, serverName, serverPort, Application)+import Data.Maybe+import Data.Foldable (toList) +-- | Converts a Happstack ServerPartT to a CGI handling function. serverPartToApp :: (ToMessage b) => ServerPartT IO b -> Application-serverPartToApp = cgiToApp . serverPartToCGI +serverPartToApp = convert . processRequest++convert :: (Request -> IO Response) -> Application+convert f = \env -> do+  let rq = toHappstackRequest env+  rs <- f rq+  let r = toHackResponse rs+  return r++toHackResponse :: Response -> Hack.Response+toHackResponse r = Hack.Response+  {+    Hack.body = rsBody r+  , Hack.status = rsCode r+  , Hack.headers = map convertHeader $ toList (rsHeaders r)+  }++-- | Sets all the headers coming from Happstack+convertHeader :: HeaderPair -> (String, String)+convertHeader (HeaderPair k v) = (UBS.toString k, UBS.toString (last v))++-- | Converts one request into another+toHappstackRequest :: Hack.Env -> Request+toHappstackRequest env =+  tmpRequest+    { rqInputs = queryInput uri ++ bodyInput tmpRequest }+  where+    uri = fromJust $ parse $ concat $ map (\f -> f env) +      [ serverName+      , show . serverPort+      , scriptName+      , pathInfo+      , add_q . queryString+      ]+    tmpRequest = +      Request { rqMethod  = convertRequestMethod $ Hack.requestMethod env+              , rqPaths   = split '/' $ pathInfo env+              , rqUri	    = scriptName env ++ pathInfo env+              , rqQuery   = add_q $ queryString env+              , rqInputs  = []+              , rqCookies = readCookies $ http env+              , rqVersion = Version 1 1+              , rqHeaders = mkHeaders $ http env+              , rqBody    = Body $ hackInput env+              , rqPeer    = (serverName env, serverPort env)+              }+  +    convertRequestMethod Hack.OPTIONS     =     OPTIONS+    convertRequestMethod Hack.GET         =     GET+    convertRequestMethod Hack.HEAD        =     HEAD+    convertRequestMethod Hack.POST        =     POST+    convertRequestMethod Hack.PUT         =     PUT+    convertRequestMethod Hack.DELETE      =     DELETE+    convertRequestMethod Hack.TRACE       =     TRACE+    convertRequestMethod Hack.CONNECT     =     CONNECT+    +    +    readCookies = map cookieWithName +      . either (const []) id . parseCookies . fromMaybe "" . lookup "Cookie"+      +    add_q [] = []+    add_q x = '?' : x++cookieWithName :: H.Cookie -> (String, H.Cookie)+cookieWithName x = (H.cookieName x, x)+++-- | Transforms a ServerPartT into a function. This is a copy of simpleHTTP'+processRequest :: (ToMessage b, Monad m, Functor m) => ServerPartT m b -> Request -> m Response+processRequest hs req =  (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))+    where+        standardNotFound = H.setHeader "Content-Type" "text/html" $ toResponse "Not found"+++-- | Splits a list by character, the resulting lists don't have the character in them.+split :: Char -> String -> [String]+split c cs = filter (not.null) $ worker [] cs+    where worker acc [] = [reverse acc]+          worker acc (c':cs') | c==c' = reverse acc:worker [] cs'+          worker acc (c':cs') = worker (c':acc) cs'