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
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
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
doform' :: ContForm a -> WebCont Html a
doform' = doform id $ curry (unlines **. id >>@ (+++))
display :: HTML a => a -> WebCont Html ()
display h = WebCont $ const $ Via (toHtml h) (return ())
button :: String -> a -> WebCont Html a
button s a = display (form ! [method "POST"] << (submit "submit" s)) >> return a
link :: HTML l => l -> a -> WebCont Html a
link l a = display (samelink l) >> return a
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))
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)
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)
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;