diff --git a/Nomyx-Web.cabal b/Nomyx-Web.cabal --- a/Nomyx-Web.cabal +++ b/Nomyx-Web.cabal @@ -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 diff --git a/src/Nomyx/Web/Common.hs b/src/Nomyx/Web/Common.hs --- a/src/Nomyx/Web/Common.hs +++ b/src/Nomyx/Web/Common.hs @@ -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) diff --git a/src/Nomyx/Web/Game.hs b/src/Nomyx/Web/Game.hs --- a/src/Nomyx/Web/Game.hs +++ b/src/Nomyx/Web/Game.hs @@ -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 diff --git a/src/Nomyx/Web/MainPage.hs b/src/Nomyx/Web/MainPage.hs --- a/src/Nomyx/Web/MainPage.hs +++ b/src/Nomyx/Web/MainPage.hs @@ -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