WebCont-0.0.1: WebCont.hs

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-| 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, button, link,
    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, button)
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 a) => Monoid (WebCont a a) where
    (WebCont f) `mappend` (WebCont g) = WebCont $ f &&. g >>@ c where
        (Done h1) `c` (Via h2 a) = Via (h1 `mappend` h2) a
        (Via h1 a) `c` (Done h2) = Via (h1 `mappend` h2) a
        (Via v a) `c` (Via t b) = Via (v `mappend` t) (a `mappend` b)
    mempty = WebCont . const . Done $ mempty

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)
    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 ())

-- | Button with an associated value
button :: String -> a -> WebCont Html a
button s a = display (form ! [method "POST"] << (submit "submit" s)) >> return a

-- | Link with an associated value
link :: HTML l => l -> a -> WebCont Html a
link l a = display (samelink l) >> return a

-- | 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;