diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/imprevu-happstack.cabal b/imprevu-happstack.cabal new file mode 100644 --- /dev/null +++ b/imprevu-happstack.cabal @@ -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 diff --git a/src/Imprevu/Happstack/Forms.hs b/src/Imprevu/Happstack/Forms.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Happstack/Forms.hs @@ -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] + diff --git a/src/Imprevu/Happstack/Test.hs b/src/Imprevu/Happstack/Test.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Happstack/Test.hs @@ -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 () diff --git a/src/Imprevu/Happstack/TestServer.hs b/src/Imprevu/Happstack/TestServer.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Happstack/TestServer.hs @@ -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 + diff --git a/src/Imprevu/Happstack/Types.hs b/src/Imprevu/Happstack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imprevu/Happstack/Types.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,10 @@ + +module Test where + +import Imprevu.Happstack.Test as T +import Distribution.TestSuite + +tests :: IO [Test] +tests = do + T.tests + return []