packages feed

hxweb (empty) → 0.1

raw patch · 8 files changed

+349/−0 lines, 8 filesdep +basedep +cgidep +fastcgibuild-type:Customsetup-changed

Dependencies added: base, cgi, fastcgi, libxml, mtl, xslt

Files

+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2004-2006, David Himmelstrup+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++    * Redistributions of source code must retain+      the above copyright notice, this list of+      conditions and the following disclaimer.+    * Redistributions in binary form must reproduce+      the above copyright notice, this list of+      conditions and the following disclaimer in the+      documentation and/or other materials provided+      with the distribution.+    * Neither the name of David Himmelstrup nor the+      names of other contributors may be used to+      endorse or promote products derived from this+      software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ hxweb.cabal view
@@ -0,0 +1,23 @@+Name: hxweb+Version: 0.1+Maintainer: Lemmih (lemmih@gmail.com)+Author: Lemmih (lemmih@gmail.com)+Copyright: 2006, Lemmih+License-File: LICENSE+License: BSD3+Category: Web+Synopsis: Minimal webframework using fastcgi, libxml2 and libxslt.+Description:+  Fast template based web-framework using libxslt and fastcgi.+Build-Depends: base, cgi, fastcgi, mtl, libxml, xslt+Extensions: NoMonomorphismRestriction OverlappingInstances+GHC-Options: -fglasgow-exts -fwarn-duplicate-exports -Werror+             -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches+Hs-Source-Dirs: src+GHC-Prof-options: -auto-all+Exposed-modules:+  Network.HxWeb+  Network.HxWeb.Monad+  Network.HxWeb.Utils+  Network.HxWeb.XSLT+  Network.HxWeb.Cache
+ src/Network/HxWeb.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HxWeb+-- Copyright   :  (c) David Himmelstrup 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Network.HxWeb+    ( module Network.HxWeb.Monad+    , module Network.HxWeb.Utils+    , module Network.HxWeb.XSLT+    ) where++import Network.HxWeb.Monad+import Network.HxWeb.Utils+import Network.HxWeb.XSLT
+ src/Network/HxWeb/Cache.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HxWeb.Catch+-- Copyright   :  (c) David Himmelstrup 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (requires System.Mem.StableName)+--+-----------------------------------------------------------------------------+module Network.HxWeb.Cache+    ( memoFn'+    , memoFn+    , memo+    , static+    ) where++import Network.CGI++import Data.IORef            ( IORef, newIORef, readIORef, writeIORef )+import System.Time           ( ClockTime, getClockTime, addToClockTime, TimeDiff(..) )+import System.IO.Unsafe      ( unsafePerformIO )++import qualified Data.HashTable as HT+import System.Mem.StableName+import Control.Monad+import Data.Maybe++import Network.HxWeb.Monad   ( WebPage )++{-# NOINLINE memoFn' #-}+memoFn' :: Eq a => Int -> (a -> WebPage st b) -> (a -> WebPage st b, a -> WebPage st ())+memoFn' mins webpage+    = unsafePerformIO $+      do now <- getClockTime+         let delay = TimeDiff 0 0 0 0 mins 0 0+             expire = addToClockTime delay now+         ht <- HT.new (==) (\a -> unsafePerformIO $+                                  do stableA <- makeStableName a+                                     return (HT.hashInt (hashStableName stableA)))+         ref <- newIORef expire+         return (worker delay ref ht webpage+                ,\key -> liftIO $ HT.delete ht key)++{-# INLINE memoFn #-}+memoFn :: Eq a => Int -> (a -> WebPage st b) -> (a -> WebPage st b)+memoFn mins page = fst (memoFn' mins page)++worker :: Eq a => TimeDiff -> IORef ClockTime -> HT.HashTable a b -> (a -> WebPage st b)+       -> (a -> WebPage st b)+worker delay ref ht webFunc a+    = do now <- liftIO $ getClockTime+         expire <- liftIO $ readIORef ref+         mbB <- liftIO $ HT.lookup ht a+         case mbB of+           Just b | now < expire -> return b+           _otherwise -> do b <- webFunc a+                            when (isJust mbB) $ liftIO $ writeIORef ref (addToClockTime delay now)+                            liftIO $ HT.insert ht a b+                            return b++{-+  Cache a WebPage for @n@ minutes.+-}+{-# NOINLINE memo #-}+memo :: Int -> WebPage st a -> WebPage st a+memo mins+    = unsafePerformIO $+           do now <- getClockTime+              let delay = TimeDiff 0 0 0 0 mins 0 0+                  expire = addToClockTime delay now+              ref <- newIORef (Nothing,expire)+              return (applyFn delay ref)++applyFn :: TimeDiff -> IORef (Maybe a,ClockTime) -> WebPage st a -> WebPage st a+applyFn delay ref webPage+    = do now <- liftIO $ getClockTime+         (mbA, expire) <- liftIO $ readIORef ref+         case mbA of+           Just a | now < expire -> return a+           _otherwise -> do a <- webPage+                            liftIO (writeIORef ref (Just a,addToClockTime delay now))+                            return a++{-+  Mark page as static. The WebPage will only+  be run once.+-}+{-# NOINLINE static #-}+static :: WebPage st a -> WebPage st a+static+    = unsafePerformIO $+         do ref <- newIORef Nothing+            let loop webPage+                    = do mbA <- liftIO $ readIORef ref+                         case mbA of+                           Just a -> return a+                           Nothing -> do a <- webPage+                                         liftIO (writeIORef ref (Just a))+                                         return a+            return loop
+ src/Network/HxWeb/Monad.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HxWeb.Monad+-- Copyright   :  (c) David Himmelstrup 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Network.HxWeb.Monad where++import Control.Monad.State+import Network.CGI+import Network.CGI.Monad++newtype WebPage st a+    = WebPage { unWebPage :: StateT st (CGIT IO) (WebResult a) }++data WebResult ret+    = WebResult ret+    | Redirect String+    | Fail String+      deriving Show++instance Monad (WebPage st) where+    WebPage g >>= f+        = WebPage $+          do g' <- g+             case g' of+               Redirect url -> return (Redirect url)+               Fail msg -> return (Fail msg)+               WebResult ret -> unWebPage (f ret)+    fail = WebPage . return . Fail+    return = WebPage . return . WebResult++instance MonadPlus (WebPage st) where+    mzero = WebPage $ return (Fail "mzero")+    mplus a b = WebPage $+                do a' <- unWebPage a+                   case a' of+                     Fail _ -> unWebPage b+                     _ -> return a'++instance MonadIO (WebPage st) where+    liftIO io = WebPage (do a <- liftIO io+                            return (WebResult a))+++instance MonadState st (WebPage st) where+    get = WebPage (liftM WebResult get)+    put s = WebPage (liftM WebResult $ put s)++instance Functor (WebPage st) where+    fmap fn a = do a' <- a+                   return (fn a')++instance MonadCGI (WebPage st) where+    cgiAddHeader h v = WebPage (liftM WebResult $ lift (cgiAddHeader h v))+    cgiGet fn = WebPage (liftM WebResult $ lift (cgiGet fn))+
+ src/Network/HxWeb/Utils.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HxWeb.Utils+-- Copyright   :  (c) David Himmelstrup 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Network.HxWeb.Utils+    ( readM       -- (Monad m, Read a) => String -> m a+    , getInput'   -- String -> WebPage st String+    , readInput'  -- Read a => String -> WebPage st a+    , escape      -- String -> WebPage st a+    , runWebPage  -- st -> WebPage st CGIResult -> CGI CGIResult+    ) where++import Network.CGI           ( CGI, CGIResult, output, redirect+                             , getInput )+import Control.Monad.State   ( evalStateT )++import Network.HxWeb.Monad   ( WebPage(..), WebResult(..) )++readM :: (Monad m,Read a) => String -> m a+readM str = case reads str of+              [] -> fail "No parse"+              [(val,_)] -> return val+              _ -> fail "Ambiguous parse"++getInput' :: String -> WebPage st String+getInput' key = do mbVal <- getInput key+                   case mbVal of+                     Nothing -> fail $ "Failed to lookup key: " ++ key+                     Just val -> return val++readInput' :: Read a => String -> WebPage st a+readInput' key+    = do val <- getInput' key+         readM val++escape :: String -> WebPage st a+escape redirect+    = WebPage (return (Redirect redirect))++runWebPage :: st -> WebPage st CGIResult -> CGI CGIResult+runWebPage st (WebPage r)+    = do ret <- evalStateT r st+         case ret of+           WebResult a  -> return a+           Fail str     -> output $ "Uncaught error: " ++ str+           Redirect url -> redirect url
+ src/Network/HxWeb/XSLT.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HxWeb.XSLT+-- Copyright   :  (c) David Himmelstrup 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Network.HxWeb.XSLT+    ( displayXml+    ) where++import qualified Text.XML.LibXML as XML+import qualified Text.XML.XSLT as XSLT+import Text.XML.XSLT (Stylesheet)+import Text.XML.LibXML (Node)++import qualified Data.ByteString.Lazy as Lazy+import Data.ByteString (ByteString)++import Data.Maybe++import Network.CGI++import Network.HxWeb.Monad++renderXML :: FilePath -> Node -> IO ByteString+renderXML path node+    = do doc <- XML.newDocument "1.0"+         piNode <- XML.newDocumentPI doc "xml-stylesheet" ("type=\"text/xsl\" href=\""++path++"\"")+         XML.setDocumentRootElement doc piNode+         XML.addSibling piNode node+         XML.documentDumpMemory doc++displayXml :: (FilePath -> WebPage st Stylesheet)+           -> Bool  -- ^ usexsl. False => transform xml on the server.+                    -- True => send xml + stylesheet to the client.+           -> (FilePath, Node) -> WebPage st CGIResult+displayXml fetchStylesheet usexsl (path, node)+    = do xml <- liftIO $ renderXML path node+         if usexsl+            then do setHeader "Content-type" "text/xml; charset=ISO-8859-1"+                    outputFPS (Lazy.LPS [xml])+            else do setHeader "Content-type" "text/html; charset=ISO-8859-1"+                    sheet <- fetchStylesheet path+                    doc <- liftIO $ XML.parseMemory xml+                    res <- liftIO $ XSLT.applyStylesheet sheet (Just doc) []+                    resBS <- liftIO $ XSLT.saveResultToString res sheet+                    outputFPS (Lazy.LPS [resBS])