Nomyx-Web 0.6.2 → 0.7.0
raw patch · 4 files changed
+43/−40 lines, 4 filesdep ~Nomyx-Coredep ~Nomyx-Languagedep ~base
Dependency ranges changed: Nomyx-Core, Nomyx-Language, base, fb
Files
- Nomyx-Web.cabal +6/−6
- src/Nomyx/Web/Common.hs +6/−1
- src/Nomyx/Web/Game.hs +30/−32
- src/Nomyx/Web/MainPage.hs +1/−1
Nomyx-Web.cabal view
@@ -1,5 +1,5 @@ name: Nomyx-Web-version: 0.6.2+version: 0.7.0 cabal-version: >=1.6 build-type: Simple license: BSD3@@ -16,15 +16,15 @@ extra-source-files: README.md library- build-depends: Nomyx-Language == 0.6.2,- Nomyx-Core == 0.6.2,- base == 4.6.*,+ build-depends: Nomyx-Language == 0.7.0,+ Nomyx-Core == 0.7.0,+ base >= 4.6 && <5, blaze-html == 0.7.*, blaze-markup == 0.6.*, bytestring == 0.10.*, data-lens == 2.10.*, data-lens-fd == 2.0.*,- fb == 0.15.*,+ fb >= 0.15 && < 2, filepath == 1.3.*, happstack-authenticate == 0.10.*, happstack-server == 7.3.*,@@ -57,4 +57,4 @@ source-repository head type: git- location: https://github.com/cdupont/Nomyx-Web.git+ location: https://github.com/cdupont/Nomyx.git
src/Nomyx/Web/Common.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module Nomyx.Web.Common where @@ -70,7 +73,7 @@ | LeaveGame GameName | DelGame GameName | ForkGame GameName- | DoInput EventNumber InputNumber GameName+ | DoInput EventNumber FieldAddress GameName | NewRule GameName | NewGame | SubmitNewGame@@ -90,6 +93,8 @@ type RoutedNomyxServer a = RouteT PlayerCommand (ServerPartT IO) a +instance PathInfo FieldAddressElem+instance PathInfo FieldAddress $(derivePathInfo ''PlayerCommand) $(derivePathInfo ''LoginName)
src/Nomyx/Web/Game.hs view
@@ -32,7 +32,7 @@ import Web.Routes.RouteT (showURL, liftRouteT) import Safe import qualified Nomyx.Web.Help as Help-import Nomyx.Web.Common+import Nomyx.Web.Common as NWC import Nomyx.Core.Types as T import Nomyx.Core.Mail import Nomyx.Core.Utils@@ -171,26 +171,24 @@ p $ titleWithHelpIcon (h4 "Variables:") Help.variables viewVars (_variables g) p $ titleWithHelpIcon (h4 "Events:") Help.events- viewEvents (_events g)+ viewEvents g p $ h4 "Log:" viewLogs (_logs g) pn --viewEvents :: [EventInfo] -> Html-viewEvents ehs = table ! class_ "table" $ do+viewEvents :: Game -> Html+viewEvents g = table ! class_ "table" $ do thead $ do td ! class_ "td" $ "Event Number" td ! class_ "td" $ "By Rule" td ! class_ "td" $ "Event"- mapM_ viewEvent $ sort ehs-+ mapM_ (viewEvent g) (sort $ _events g) -viewEvent :: EventInfo -> Html-viewEvent (EventInfo eventNumber ruleNumber event _ status env) = if status == SActive then disp else disp ! style "background:gray;" where+viewEvent :: Game -> EventInfo -> Html+viewEvent g ei@(EventInfo eventNumber ruleNumber _ _ status _) = if status == SActive then disp else disp ! style "background:gray;" where disp = tr $ do td ! class_ "td" $ fromString . show $ eventNumber td ! class_ "td" $ fromString . show $ ruleNumber- td ! class_ "td" $ fromString . show $ getEventFields event env+ td ! class_ "td" $ fromString . show $ getEventFields ei g viewIOs :: PlayerNumber -> Game -> RoutedNomyxServer Html viewIOs pn g = do@@ -210,17 +208,17 @@ viewIORuleM :: PlayerNumber -> RuleNumber -> Game -> RoutedNomyxServer (Maybe Html) viewIORuleM pn rn g = do- vir <- viewInputsRule pn rn (_events g) (_gameName g)+ vir <- viewInputsRule pn rn (_events g) g let vor = viewOutputsRule pn rn g return $ if isJust vir || isJust vor then Just $ do when (isJust vir) $ fromJust vir when (isJust vor) $ fromJust vor else Nothing -viewInputsRule :: PlayerNumber -> RuleNumber -> [EventInfo] -> GameName -> RoutedNomyxServer (Maybe Html)-viewInputsRule pn rn ehs gn = do+viewInputsRule :: PlayerNumber -> RuleNumber -> [EventInfo] -> Game -> RoutedNomyxServer (Maybe Html)+viewInputsRule pn rn ehs g = do let filtered = filter (\e -> _ruleNumber e == rn) ehs- mis <- mapM (viewInput pn gn) $ sort filtered+ mis <- mapM (viewInput pn g) $ sort filtered let is = catMaybes mis case is of [] -> return Nothing@@ -228,7 +226,6 @@ viewOutputsRule :: PlayerNumber -> RuleNumber -> Game -> Maybe Html viewOutputsRule pn rn g = do- tracePN 0 "in viewOutputsRule" let filtered = filter (\o -> _oRuleNumber o == rn) (_outputs g) let myos = filter (isPn pn) (reverse filtered) case myos of@@ -239,18 +236,18 @@ isPn _ (Output _ _ Nothing _ SActive) = True isPn _ _ = False -viewInput :: PlayerNumber -> GameName -> EventInfo -> RoutedNomyxServer (Maybe Html)-viewInput me gn (EventInfo en _ ev _ SActive env) = do- ds <- mapMaybeM (viewInput' me gn en) (getEventFields ev env)+viewInput :: PlayerNumber -> Game -> EventInfo -> RoutedNomyxServer (Maybe Html)+viewInput me g ei@(EventInfo en _ _ _ SActive _) = do+ ds <- mapMaybeM (viewInput' me (_gameName g) en) (getEventFields ei g) return $ if null ds then Nothing else Just $ sequence_ ds viewInput _ _ _ = return Nothing -viewInput' :: PlayerNumber -> GameName -> EventNumber -> SomeField -> RoutedNomyxServer (Maybe Html)-viewInput' me gn en ev@(SomeField (Input inputNumber pn title _)) | me == pn = do+viewInput' :: PlayerNumber -> GameName -> EventNumber -> (FieldAddress, SomeField) -> RoutedNomyxServer (Maybe Html)+viewInput' me gn en (fa, ev@(SomeField (Input pn title _))) | me == pn = do lf <- lift $ viewForm "user" $ inputForm ev- link <- showURL (DoInput en (fromJust inputNumber) gn)+ link <- showURL (DoInput en fa gn) return $ Just $ tr $ td $ do fromString title fromString " "@@ -335,20 +332,21 @@ td $ fromString $ formatTime defaultTimeLocale "%Y/%m/%d_%H:%M" t td $ p $ fromString s -newInput :: EventNumber -> InputNumber -> GameName -> TVar Session -> RoutedNomyxServer Response-newInput en inum gn ts = toResponse <$> do+-- | a form result has been sent+newInput :: EventNumber -> FieldAddress -> GameName -> TVar Session -> RoutedNomyxServer Response+newInput en fa gn ts = toResponse <$> do pn <- fromJust <$> getPlayerNumber ts s <- liftIO $ atomically $ readTVar ts- let g = find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s)- let ei = getEventInfo en (_loggedGame $ fromJust g)+ let lg = _loggedGame $ fromJust $ find ((== gn) . getL gameNameLens) (_gameInfos $ _multi s)+ let ei = getEventInfo en lg methodM POST- case (getInput ei inum) of+ case (getInput ei fa (_game lg)) of Nothing -> error "Input not found" Just bs -> do r <- liftRouteT $ eitherForm environment "user" (inputForm bs) link <- showURL MainPage case r of- (Right c) -> webCommand ts $ S.inputResult pn en inum c gn+ (Right c) -> webCommand ts $ S.inputResult pn en fa c gn (Left _) -> liftIO $ putStrLn "cannot retrieve form data" seeOther (link `appendAnchor` inputAnchor) "Redirecting..." @@ -368,11 +366,11 @@ inputForm :: SomeField -> NomyxForm InputData-inputForm (SomeField (Input _ _ _ (Radio choices))) = RadioData <$> inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label " "-inputForm (SomeField (Input _ _ _ Text)) = TextData <$> RB.inputText "" <++ label " "-inputForm (SomeField (Input _ _ _ TextArea)) = TextAreaData <$> textarea 50 5 "" <++ label " "-inputForm (SomeField (Input _ _ _ Button)) = pure ButtonData-inputForm (SomeField (Input _ _ _ (Checkbox choices))) = CheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label " "+inputForm (SomeField (Input _ _ (Radio choices))) = RadioData <$> NWC.inputRadio' (zip [0..] (snd <$> choices)) (== 0) <++ label (" " :: String)+inputForm (SomeField (Input _ _ Text)) = TextData <$> RB.inputText "" <++ label (" " :: String)+inputForm (SomeField (Input _ _ TextArea)) = TextAreaData <$> textarea 50 5 "" <++ label (" " :: String)+inputForm (SomeField (Input _ _ Button)) = pure ButtonData+inputForm (SomeField (Input _ _ (Checkbox choices))) = CheckboxData <$> inputCheckboxes (zip [0..] (snd <$> choices)) (const False) <++ label (" " :: String) inputForm _ = error "Not an input form" showHideTitle :: String -> Bool -> Bool -> Html -> Html -> Html
src/Nomyx/Web/MainPage.hs view
@@ -93,7 +93,7 @@ H.a "Rules examples" ! (href "/html/Language-Nomyx-Examples.html") ! target "_blank" >> br H.a "Nomyx language" ! (href "/html/Language-Nomyx.html") ! target "_blank" >> br when (fmods /= []) $ do- br >> "Uploaded files:" >> br+ br >> b "Uploaded files:" >> br mapM_ (\f -> (H.a $ toHtml f ) ! (href $ toValue (pathSeparator : uploadDir </> f)) >> br) (sort fmods) br >> b "Settings:" >> br H.a "Player settings" ! (href $ toValue settingsLink) >> br