imprevu-happstack (empty) → 0.1.0
raw patch · 10 files changed
+380/−0 lines, 10 filesdep +Cabaldep +DebugTraceHelpersdep +HTTPsetup-changed
Dependencies added: Cabal, DebugTraceHelpers, HTTP, NoTrace, base, blaze-html, containers, ghc, happstack-server, imprevu, imprevu-happstack, lens, monad-extras, mtl, old-locale, reform, reform-blaze, reform-happstack, safe, stm, text
Files
- AUTHORS +1/−0
- LICENSE +27/−0
- README.md +27/−0
- Setup.lhs +6/−0
- imprevu-happstack.cabal +58/−0
- src/Imprevu/Happstack/Forms.hs +105/−0
- src/Imprevu/Happstack/Test.hs +27/−0
- src/Imprevu/Happstack/TestServer.hs +87/−0
- src/Imprevu/Happstack/Types.hs +32/−0
- test/Test.hs +10/−0
+ AUTHORS view
@@ -0,0 +1,1 @@+Corentin Dupont <corentin.dupont@gmail.com>
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2012, Corentin Dupont. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of its 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.
+ README.md view
@@ -0,0 +1,27 @@++Introduction+============++This library provide Happstack bindings to Imprevu.++Installation+============++To install from the git repository:++ git clone git://github.com/cdupont/Nomyx.git+ cd Nomyx/Imprevu-Happstack+ stack install++Tests+====++Run:++ stack test++Contact+=======++Bug-reports, questions, suggestions and patches are all welcome.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ imprevu-happstack.cabal view
@@ -0,0 +1,58 @@+name: imprevu-happstack+version: 0.1.0+cabal-version: >=1.8+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2016 Corentin Dupont+maintainer: Corentin Dupont+stability: Experimental+synopsis: Imprevu support for Happstack+description:+category: Language+Homepage: http://www.nomyx.net+author: Corentin Dupont+data-files:+data-dir: ""+extra-source-files: AUTHORS README.md++library+ build-depends: DebugTraceHelpers == 0.12.*,+ imprevu == 0.1.*,+ base >= 4.6 && < 5,+ containers == 0.5.*,+ lens >= 4.7 && < 4.15,+ ghc >= 7.6 && < 8.1,+ mtl >= 2.1 && < 2.3,+ old-locale == 1.0.*,+ blaze-html >= 0.7 && < 0.9,+ happstack-server >= 7.3 && < 7.5,+ reform == 0.2.*,+ reform-blaze == 0.2.*,+ reform-happstack == 0.2.*,+ text >= 1.1 && < 1.3,+ monad-extras -any,+ stm,+ safe,+ HTTP,+ NoTrace+ exposed-modules: Imprevu.Happstack.Forms+ Imprevu.Happstack.Types+ Imprevu.Happstack.TestServer+ Imprevu.Happstack.Test+ exposed: True+ buildable: True+ hs-source-dirs: src+ ghc-options: -W++Test-Suite test+ type: detailed-0.9+ test-module: Test+ hs-source-dirs: test+ build-depends: base,+ imprevu-happstack == 0.1.0,+ Cabal >= 0.22++source-repository head+ type: git+ location: https://github.com/cdupont/imprevu-happstack.git
+ src/Imprevu/Happstack/Forms.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}++module Imprevu.Happstack.Forms where++import Control.Monad.Extra (mapMaybeM)+import Control.Concurrent.STM+import Control.Monad.State+import Data.String+import Data.Text (Text, unpack)+import Data.Typeable+import Imprevu+import Imprevu.Evaluation+import Imprevu.Happstack.Types+import Happstack.Server as HS (Response, Method (..), methodM, seeOther, toResponse, ServerPartT)+import Text.Blaze.Html5 (ToMarkup, Html, toHtml, td, toValue, tr, (!), input)+import qualified Text.Blaze.Html5 as H (form, label)+import Text.Blaze.Html5.Attributes as A (id, type_, name, value, checked, for, action, method, enctype)+import Text.Reform (eitherForm, viewForm, (<++), (++>), ErrorInputType, Form, FormError (..), FormInput)+import Text.Reform.Blaze.String (inputCheckboxes, label, textarea)+import qualified Text.Reform.Blaze.String as RB+import Text.Reform.Happstack (environment)+import qualified Text.Reform.Generalized as G+import Debug.NoTrace++default (Integer, Double, Data.Text.Text)++type BackLink = EventNumber -> Input -> Text++viewInput :: ClientNumber -> BackLink -> EventNumber -> [SomeSignal] -> ServerPartT IO (Maybe Html)+viewInput cn bl en ss = do+ ds <- mapMaybeM (viewInput' cn bl en) ss + return $ if null ds+ then Nothing+ else Just $ sequence_ ds+viewInput _ _ _ _ = return Nothing++viewInput' :: ClientNumber -> BackLink -> EventNumber -> SomeSignal -> ServerPartT IO (Maybe Html)+viewInput' me backlink en (SomeSignal (Signal s)) = do+ traceM $ "viewInput' " ++ (show s)+ case (cast s) of+ Just is@(Input i cn) | me == cn -> do+ lf <- viewForm "user" $ inputForm' i+ let link = backlink en is+ traceM $ "viewInput' backlink=" ++ (unpack link)+ return $ Just $ tr $ td $ do+ --fromString title+ fromString " "+ blazeForm lf link ! A.id "InputForm"+ _ -> return Nothing++inputForm' :: InputField -> ImpForm InputData+inputForm' (Radio s choices) = RadioData <$> RB.label s ++> (inputRadio' choices (== 0)) <++ RB.label (" " :: String)+inputForm' (Text s) = TextData <$> RB.label s ++> (RB.inputText "") <++ label (" " :: String)+inputForm' (TextArea s) = TextAreaData <$> RB.label s ++> (textarea 50 5 "") <++ label (" " :: String)+inputForm' (Button s) = pure ButtonData <$> RB.label s+inputForm' (Checkbox s choices) = CheckboxData <$> RB.label s ++> (inputCheckboxes choices $ const False) <++ label (" " :: String)+++-- | a form result has been sent+newInput :: Input -> EventNumber -> TVar s -> UpdateSession s -> Text -> ServerPartT IO Response+newInput is@(Input i _) en tv updateSession bl = toResponse <$> do+ methodM POST+ r <- eitherForm environment "user" (inputForm' i)+ case r of+ (Right id) -> liftIO $ updateSession tv is id en+ (Left _) -> liftIO $ putStrLn "cannot retrieve form data"+ seeOther bl "Redirecting..."++-- | Create a group of radio elements without BR between elements+reformInputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) =>+ [(a, lbl)] -- ^ value, label, initially checked+ -> (a -> Bool) -- ^ isDefault+ -> Form m input error Html () a+reformInputRadio' choices isDefault =+ G.inputChoice isDefault choices mkRadios+ where+ mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'+ mkRadio nm (i, val, lbl, checked) =+ [ (if checked then (! A.checked "checked") else Prelude.id) $ input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val)+ , " ", H.label ! A.for (toValue i) $ toHtml lbl]+++blazeForm :: Html -> Text -> Html+blazeForm html link =+ H.form ! A.action (toValue link)+ ! A.method "POST"+ ! A.enctype "multipart/form-data" $+ do html+ input ! A.type_ "submit" ! A.value "Submit"++-- | Create a group of radio elements without BR between elements+inputRadio' :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, ToMarkup lbl) =>+ [(a, lbl)] -- ^ value, label, initially checked+ -> (a -> Bool) -- ^ isDefault+ -> Form m input error Html () a+inputRadio' choices isDefault =+ G.inputChoice isDefault choices mkRadios+ where+ mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'+ mkRadio nm (i, val, lbl, checked) =+ [ (if checked then (! A.checked "checked") else Prelude.id) $ input ! A.type_ "radio" ! A.id (toValue i) ! A.name (toValue nm) ! A.value (toValue val)+ , " ", H.label ! A.for (toValue i) $ toHtml lbl]+
+ src/Imprevu/Happstack/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Imprevu.Happstack.Test where++import Imprevu.Happstack.TestServer+import Imprevu+import Imprevu.Test.Test+import Imprevu.Test.TestMgt+import Control.Monad+import Control.Applicative++tests :: IO ()+tests = startTest $ do+ onEvent_ (inputText 1 "Enter text: ") (putStrLn' . show)++ onEvent_ (True <$ inputButton 2 "Click to respond True " <|> False <$ inputButton 2 "Click to respond False ") (putStrLn' . show)++ onEvent_ ((,) <$> inputText 3 "enter first value: " <*> inputText 3 "Enter second value: ") (putStrLn' . show)++ let e = do+ a <- inputText 4 "Enter text: "+ guard (a == "coco") >> inputText 4 "Hello coco! Enter additional text: "+ void $ onEvent_ e (\a -> putStrLn' a)+ + onEvent_ (inputRadio 5 "enter first value: " [(True, "Yes"), (False, "No")]) (\a -> putStrLn' (if a then "Yes" else "No"))+ + return ()
+ src/Imprevu/Happstack/TestServer.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Imprevu.Happstack.TestServer where++import Control.Concurrent.STM+import Control.Concurrent+import Control.Monad+import Control.Monad.State+import Data.Maybe+import Data.Text hiding (concatMap, map)+import Data.Typeable+import Happstack.Server as HS hiding (Input)+import Imprevu.Happstack.Forms+import Imprevu.Happstack.Types+import Imprevu.Evaluation+import Imprevu.Test.Test+import Imprevu.Test.TestMgt+import Text.Blaze.Html5 (toHtml, Html)+import Imprevu+import Control.Applicative+import Network.HTTP (urlEncode)+++startTest :: TestM () -> IO ()+startTest t = do+ let ts = execSignals t [] defaultEvalEnv+ tv <- atomically $ newTVar ts+ launchWebServer tv++launchWebServer :: TVar TestState -> IO ()+launchWebServer tv = do+ putStrLn $ "Starting web server on http://localhost:8080/test/main"+ let conf = nullConf {HS.port = 8080}+ --forkIO $ launchTimeEvents tv defaultEvalConf+ simpleHTTP conf $ server tv++--serving Nomyx web page as well as data from this package and the language library package+server :: TVar TestState -> ServerPartT IO Response+server tv = do+ decodeBody (defaultBodyPolicy "/tmp/" 102400 4096 4096)+ msum [dirs "test/main" (mainPage tv),+ dirs "test/do-input" $+ path $ \en ->+ path $ \is ->+ newInput is en tv updateSessionTest "/test/main"]+++updateSessionTest :: TVar TestState -> Input -> InputData -> EventNumber -> IO ()+updateSessionTest tvs is id _ = do+ s <- atomically $ readTVar tvs+ putStrLn $ show s+ putStrLn $ "input result: Form " ++ show is ++ ", choice " ++ show id+ let ev = runEvalError $ triggerInput is id+ let (EvalEnv s' _) = execState ev (EvalEnv s defaultEvalConf)+ atomically $ writeTVar tvs s'++mainPage :: TVar TestState -> ServerPartT IO Response+mainPage tts = do+ s@(TestState eis os _) <- liftIO $ atomically $ readTVar tts+ let link en iv = pack $ "/test/do-input/" ++ (urlEncode $ show en) ++ "/" ++ (urlEncode $ show iv)+ m1 <- mapM (getViewEvent 1 s link) eis+ m2 <- mapM (getViewEvent 2 s link) eis+ m3 <- mapM (getViewEvent 3 s link) eis+ m4 <- mapM (getViewEvent 4 s link) eis+ m5 <- mapM (getViewEvent 5 s link) eis+ return $ toResponse $ do+ "Test simple input:"--+ sequence_ $ catMaybes m1+ "Test sum of events (first input wins):"+ sequence_ $ catMaybes m2+ "Test product of events (both inputs are necessary):"+ sequence_ $ catMaybes m3+ "Test monadic events (enter \"coco\" to get a second input)"+ sequence_ $ catMaybes m4+ "Test radio events:"+ sequence_ $ catMaybes m5+ "Results:\n"+ toHtml $ show os++getViewEvent :: ClientNumber -> TestState -> BackLink -> EventInfoN TestM -> ServerPartT IO (Maybe Html)+getViewEvent cn ts link ei@(EventInfo en _ _ SActive _) = do+ let ss = getRemainingSignals ei (EvalEnv ts defaultEvalConf)+ viewInput cn link en ss+getViewEvent _ _ _ _ = return Nothing +
+ src/Imprevu/Happstack/Types.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Imprevu.Happstack.Types where++import Control.Concurrent.STM+import Control.Lens+import Happstack.Server (ServerPartT, FromReqURI(..))+import qualified Happstack.Server as HS (Input)+import Imprevu+import Imprevu.Evaluation+import Text.Blaze.Html5 (Html)+import Text.Reform (CommonFormError, ErrorInputType, Form, FormError (..))+import Safe++type UpdateSession s = TVar s -> Input -> InputData -> EventNumber -> IO () -- update the session after an input is submitted++type ImpForm a = Form (ServerPartT IO) [HS.Input] ImpFormError Html () a++data ImpFormError = ImpFormError (CommonFormError [HS.Input])++instance FormError ImpFormError where+ type ErrorInputType ImpFormError = [HS.Input]+ commonFormError = ImpFormError++instance FromReqURI Input where+ fromReqURI = readMay++instance FromReqURI InputData where+ fromReqURI = readMay
+ test/Test.hs view
@@ -0,0 +1,10 @@++module Test where++import Imprevu.Happstack.Test as T+import Distribution.TestSuite++tests :: IO [Test]+tests = do+ T.tests+ return []