WebCont (empty) → 0.0.0

raw patch · 4 files changed

+257/−0 lines, 4 filesdep +applicative-extrasdep +basedep +concatenativesetup-changed

Dependencies added: applicative-extras, base, concatenative, containers, formlets, happstack-server, happstack-state, happstack-util, mtl, utf8-string, xhtml

Files

LICENSE +30/−0
Setup.hs +2/−0
WebCont.cabal +61/−0
WebCont.hs +164/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2010, Sam Anklesaria++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 Sam Anklesaria 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 = defaultMain

+ WebCont.cabal view

@@ -0,0 +1,61 @@+Name:                WebCont++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.0.0++-- A short (one-line) description of the package.+Synopsis:            Continuation based web programming for Happstack++-- A longer description of the package.+-- Description:         ++-- URL for the project homepage or repository.+Homepage:            http://patch-tag.com/r/salazar/webconts/snapshot/current/content/pretty++-- The license under which the package is released.+License:             BSD3++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Sam Anklesaria++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          amsay@amsay.net++-- A copyright notice.+-- Copyright:           ++Category:            Web++Description:        WebCont allows continuation based web programming to be integrated with Happstack, allowing+                    step based interfaces along with traditional handlers. It is based on <http://gist.github.com/260052>++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.2+++Library+  -- Modules exported by the library.+  Exposed-modules:     WebCont+  +  -- Packages needed in order to build this package.+  Build-depends:       happstack-server >= 0.5, happstack-state >= 0.5, happstack-util >= 0.5, mtl, concatenative >= 1, formlets < 1,+                       utf8-string, containers, xhtml, applicative-extras, base >= 3 && < 5+  +  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +

+ WebCont.hs view

@@ -0,0 +1,164 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-| WebConts allow simple continuation based behavior in Happstack applications through the use of cookies+    and an IntMap on the server mapping cookie names to continuations. +    It is based on the paste <http://gist.github.com/260052>. For the arc challenge:++>    arc = do+>        name <- doform' frm+>        display $ samelink "click here"+>        display $ "you said" ++ name++    A more complicated example, creating a User datatype with a different page for each field:++>   data User = User {age:: Int, name::String, dead::Bool} deriving (Show)+>   makeUser = liftM3 User age name dead >>= (display . show) where+>       age = doform' $ label "Age: " *> frm+>       name = doform' $ label "Name: " *> frm+>       dead = doform' $ label "Dead?: " *> frm++    To run the continuations in Happstack, use 'runStateless' or 'runWithState', giving each continuation in a list+    as a parameter, depending on whether you want MACID support enabled:++>   runStateless nullConf [arc, makeUser] []++-}+module WebCont (+    doform, doform', runWithState, runStateless, frm, display, samelink,+    WebCont(..), Result(..), ContForm, DefaultForm, nullConf,+) where+import Happstack.Server.SimpleHTTP hiding (method)+import Happstack.State hiding (dup)+import Happstack.Util.Cron+import Control.Monad+import Control.Monad.Identity (Identity (..))+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Concurrent+import Control.Exception hiding (catch)+import Control.Concatenative+import Control.Applicative+import Control.Applicative.Error (Failing (..))+import Text.Formlets+import Text.XHtml.Strict.Formlets hiding (label)+import Text.XHtml.Strict hiding (input, checkbox)+import qualified Data.IntMap as Map+import Data.IntMap (IntMap)+import Data.Monoid+import Data.ByteString.Lazy.UTF8 (toString)+import qualified Happstack.Server.SimpleHTTP as H (ContentType(..))+import qualified Text.Formlets as F (ContentType(..))++data Result r a = Done a | Via r (WebCont r a) deriving Show++-- | A WebCont is a function from 'Env' to a value of a,+--   displaying a response of r. Both r and a must be+--   Html for runnable continuations.+newtype WebCont r a = WebCont {runWeb :: Env -> Result r a} deriving Show++runWeb' :: Env -> (MVar Int, MVar ContTable) -> WebCont Html () -> ServerPartT IO Response+runWeb' e t w = case runWeb w e of+    Done _ -> expireCookie "cont" >> mzero+    Via r w' -> serializeCont t w' >> ok (toResponse r)++type ContForm a = XHtmlForm Identity a++instance Monad (WebCont r) where+    return = WebCont . const . Done+    w >>= f = WebCont $ \e -> case (runWeb w e) of+        Done a -> runWeb (f a) e+        Via r w' -> Via r (w' >>= f)++instance (Monoid r, Monoid a) => Monoid (WebCont r a) where+    (WebCont f) `mappend` (WebCont g) = WebCont $ f &&. g >>@ c where+        (Done _) `c` x@(Via _ _) = x+        x@(Via _ _) `c` (Done _) = x+        (Via v a) `c` (Via t b) = Via (v `mappend` t) (a `mappend` b) -- this instance seems flawed+    mempty = WebCont . const . Done $ mempty++-- | Lift a form into the WebCont monad using a function+---  to modify its html, and a function to display errors+doform :: (Html -> r) -> ([String] -> Html -> r) -> ContForm a -> WebCont r a+doform l err f = WebCont . const $+    Via (l (createForm [] f)) succPage where+        succPage = WebCont $ dup >>. first parse >>@ formResult+        parse env = x where (Identity x, _, _) = runFormState env f+        formResult (Success a) _ = Done a+        formResult (Failure faults) e = Via (err faults (createForm e f)) succPage+        makeForm frm = form ! [method "POST"] << (frm +++ submit "submit" "submit")++createForm :: Env -> ContForm a -> Html+createForm env frm = form ! [method "POST"] << (xml +++ submit "submit" "Submit") where+  (extractor, xml, endState) = runFormState env frm++-- | Lift a form into the WebCont monad without embellishment, displaying errors inline+doform' :: ContForm a -> WebCont Html a+doform' = doform id $ curry (unlines **. id >>@ (+++))++-- | Display a page, ignoring the value+display :: HTML a => a -> WebCont Html ()+display h = WebCont $ const $ Via (toHtml h) (return ())++-- | Links to the same page, leading to the next step in a continuation+samelink :: HTML a => a -> HotLink+samelink a = hotlink "" (toHtml a)++type ContTable = IntMap (WebCont Html ())++runConts :: (MVar Int, MVar ContTable) -> ServerPartT IO Response+runConts t = withDataFn (lookCookieValue "cont") $ \c-> do+    w <- liftIO $ deserializeCont t c+    case w of+        Just w' -> do+            d <- lookInputPairs+            clearCont t c+            runWeb' (maybe [] id d) t w'+        Nothing -> mzero++lookInputPairs :: ServerPartT IO (Maybe Env)+lookInputPairs = getDataFn $ asks fst >>= (return . map f) where+    f (k,Input v Nothing _) = (k,Left (toString v))+    f (k,Input v (Just f) (H.ContentType t s p)) = (k,Right (File v f (F.ContentType t s p)))++deserializeCont :: (MVar Int, MVar ContTable) -> String -> IO (Maybe (WebCont Html ()))+deserializeCont (_,t) s = do+    e <- readMVar t+    let p = Map.lookup (read s :: Int) e+    return p++clearCont :: (MVar Int, MVar ContTable) -> String -> ServerPartT IO ()+clearCont (_,t) s = liftIO (takeMVar t >>= (putMVar t . Map.delete (read s)))++serializeCont :: (MVar Int, MVar ContTable) -> (WebCont Html ()) -> ServerPartT IO ()+serializeCont (i,t) f = do+    k <- liftIO $ takeMVar i+    liftIO $ putMVar i (k+1)+    liftIO $ takeMVar t >>= (putMVar t . Map.insert k f)+    addCookie 600 (mkCookie "cont" (show k))++-- | Entry point for the continuation server: sets up continuation table, MACID state,+--   and a chron job to add a checkpoint daily+runWithState :: (Methods a, Component a) => Conf -> Proxy a -> [WebCont Html ()] -> [ServerPartT IO Response] -> IO ()+runWithState c p conts controller =+    bracket (startSystemState p) (biM_ createCheckpoint shutdownSystem) $ \control->+        do withThread (runStateless c conts controller) $ do+           withThread (cron 86400 (createCheckpoint control)) $ waitForTermination+        where withThread init action = bracket (forkIO $ init) (killThread) (const action)++-- | Entry point for the continuation server: starts the server without MACID support+runStateless :: Conf -> [WebCont Html ()] -> [ServerPartT IO Response] -> IO ()+runStateless c conts controller = do+    e <- newMVar Map.empty+    counter <- newMVar (0 :: Int)+    let env = (counter, e)+    simpleHTTP c (runConts env `mplus` msum (map (runWeb' [] env) conts) `mplus` msum controller)++-- | Defines a normal form style to use for a given type+class DefaultForm i where frm :: Form Html Identity i+instance DefaultForm String where frm = input Nothing+instance DefaultForm Integer where frm = inputInteger Nothing+instance DefaultForm Int where frm = fromInteger <$> (inputInteger Nothing)+instance DefaultForm Bool where frm = checkbox Nothing+instance (DefaultForm a, DefaultForm b) => DefaultForm (a,b) where +  frm = (,) <$> frm <*> frm+instance HTML Integer where toHtml = toHtml . show+instance Applicative Identity where pure = return; (<*>) = ap;