diff --git a/apps/hs/qua-server/config/routes b/apps/hs/qua-server/config/routes index 78351c89..719a2865 100644 --- a/apps/hs/qua-server/config/routes +++ b/apps/hs/qua-server/config/routes @@ -16,7 +16,8 @@ /admin AdminR GET /admin/exercise-editor AdminExerciseEditorR GET -/admin/exercise-editor/scenario AdminCreateExerciseR POST +/admin/exercise AdminExercisesR POST +/admin/exercise/#ExerciseId AdminExerciseR PUT /admin/user-manager AdminUserManagerR GET /admin/user-manageruser/create-user AdminCreateUserR POST /admin/criterion-editor AdminCriterionEditorR GET diff --git a/apps/hs/qua-server/src/Application.hs b/apps/hs/qua-server/src/Application.hs index bd4c3238..680b284f 100644 --- a/apps/hs/qua-server/src/Application.hs +++ b/apps/hs/qua-server/src/Application.hs @@ -25,6 +25,7 @@ import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort) +import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -147,7 +148,7 @@ makeApplication foundation = do logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation - return $ logWare $ defaultMiddlewaresNoLogging appPlain + return $ logWare $ methodOverride $ defaultMiddlewaresNoLogging appPlain makeLogWare :: App -> IO Middleware makeLogWare foundation = diff --git a/apps/hs/qua-server/src/Handler/Mooc/Admin/ExerciseEditor.hs b/apps/hs/qua-server/src/Handler/Mooc/Admin/ExerciseEditor.hs index 85e9a47a..7367aa64 100644 --- a/apps/hs/qua-server/src/Handler/Mooc/Admin/ExerciseEditor.hs +++ b/apps/hs/qua-server/src/Handler/Mooc/Admin/ExerciseEditor.hs @@ -2,10 +2,11 @@ {-# LANGUAGE RecordWildCards #-} module Handler.Mooc.Admin.ExerciseEditor ( getAdminExerciseEditorR - , postAdminCreateExerciseR + , getExerciseEditR + , postAdminExercisesR + , putAdminExerciseR , getExerciseImgR , getExerciseGeometryR - , getExerciseEditR , postExerciseAttachCriterionR , postExerciseDetachCriterionR ) where @@ -17,6 +18,7 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Function as Function (on) import qualified Data.List as List (groupBy, head) import qualified Data.Text as T +import Text.Blaze (preEscapedText) import Text.Blaze.Html.Renderer.Text import Text.RE.TDFA.Text @@ -30,84 +32,111 @@ import Yesod.Form.Bootstrap3 import Handler.Mooc.Admin getAdminExerciseEditorR :: Handler Html -getAdminExerciseEditorR = postAdminCreateExerciseR - -postAdminCreateExerciseR :: Handler Html -postAdminCreateExerciseR = do - requireAdmin - ((res, widget), enctype) <- - runFormPost $ renderBootstrap3 BootstrapBasicForm newScenarioForm - case res of - FormFailure msgs -> showFormError msgs widget enctype - FormMissing -> showFormWidget widget enctype - FormSuccess dat@NewScenarioData {..} -> do - imageBs <- - fmap LB.toStrict $ - runResourceT $ fileSource newScenarioDataImage $$ CB.sinkLbs - geometryBs <- - fmap LB.toStrict $ - runResourceT $ fileSource newScenarioDataGeometry $$ CB.sinkLbs +getAdminExerciseEditorR = postAdminExercisesR + +putAdminExerciseR :: ExerciseId -> Handler Html +putAdminExerciseR = createOrUpdateExercise . Just + +postAdminExercisesR :: Handler Html +postAdminExercisesR = createOrUpdateExercise Nothing + +createOrUpdateExercise :: Maybe ExerciseId -> Handler Html +createOrUpdateExercise mExId = do + requireAdmin + ((res, widget), enctype) <- + runFormPost $ renderBootstrap3 BootstrapBasicForm $ exerciseForm Nothing + case res of + FormFailure msgs -> showFormError msgs widget enctype + FormMissing -> showFormWidget widget enctype + FormSuccess dat@ExerciseData {..} -> do + mImg <- case newScenarioDataImage of + Just img -> getBs img + Nothing -> return Nothing + mGeo <- case newScenarioDataGeometry of + Just geo -> getBs geo + Nothing -> return Nothing + case mExId of + Just exId -> do + --update + void $ runDB $ P.update exId $ [ + ExerciseDescription P.=. newScenarioDataDescription + , ExerciseScale P.=. newScenarioDataScale + , ExerciseCanAddDeleteGeom P.=. newScenarioDataCanAddDeleteGeom + , ExerciseOnSubmitMsg P.=. changeLinks newScenarioDataOnSubmitMessage + ] -- optionally update image, geometry files: + ++ ((ExerciseImage P.=.) <$> maybeToList mImg) + ++ ((ExerciseGeometry P.=.) <$> maybeToList mGeo) + redirect $ ExerciseEditR exId + Nothing -> do + -- create invitationSecret <- liftIO generateInvitationSecret - runDB $ - insert_ - Exercise - { exerciseDescription = newScenarioDataDescription - , exerciseImage = imageBs - , exerciseGeometry = geometryBs - , exerciseScale = newScenarioDataScale - , exerciseCanAddDeleteGeom = newScenarioDataCanAddDeleteGeom - , exerciseInvitationSecret = invitationSecret - , exerciseOnSubmitMsg - = (*=~/ [edBS|(]*)>///$1 onclick="window.open(this.href)" target="_blank">|]) - . (*=~/ [edBS|onclick=\"[^\"]*\"///|]) - . (*=~/ [edBS|target=\"[^\"]*\"///|]) - . toStrict $ renderHtml $ newScenarioDataOnSubmitMessage - } - showForm (Just dat) [] widget enctype + case (mImg, mGeo) of + (Just img, Just geo) -> do + runDB $ insert_ Exercise { + exerciseDescription = newScenarioDataDescription + , exerciseImage = img + , exerciseGeometry = geo + , exerciseScale = newScenarioDataScale + , exerciseCanAddDeleteGeom = newScenarioDataCanAddDeleteGeom + , exerciseInvitationSecret = invitationSecret + , exerciseOnSubmitMsg = changeLinks newScenarioDataOnSubmitMessage + } + showForm (Just dat) [] widget enctype + _ -> showFormError ["Please upload both an image and geometry."] + widget enctype where + --change links to use `onclick` so they work in reflex renderer: + changeLinks = (*=~/ [edBS|(]*)>///$1 onclick="window.open(this.href)" target="_blank">|]) + . (*=~/ [edBS|onclick=\"[^\"]*\"///|]) + . (*=~/ [edBS|target=\"[^\"]*\"///|]) + . toStrict . renderHtml + getBs file = Just . LB.toStrict <$> (runResourceT $ fileSource file $$ CB.sinkLbs) showFormWidget = showForm Nothing [] showFormError = showForm Nothing showForm :: - Maybe NewScenarioData + Maybe ExerciseData -> [Text] -> WidgetT App IO () -> Enctype -> HandlerT App IO Html showForm mr msgs widget enctype = do scenarioWidgets <- getScenarioCards - adminLayout "Welcome to the exercise editor" $ do + adminLayout "Exercise editor" $ do setTitle "qua-kit - exercise editor" $(widgetFile "mooc/admin/exercise-editor") generateInvitationSecret :: IO Text generateInvitationSecret = T.pack <$> replicateM 16 (randomRIO ('a', 'z')) -data NewScenarioData = NewScenarioData - { newScenarioDataDescription :: Text - , newScenarioDataImage :: FileInfo - , newScenarioDataScale :: Double - , newScenarioDataGeometry :: FileInfo - , newScenarioDataCanAddDeleteGeom :: Bool - , newScenarioDataOnSubmitMessage :: Html +data ExerciseData = ExerciseData + { newScenarioDataDescription :: Text + , newScenarioDataImage :: Maybe FileInfo + , newScenarioDataScale :: Double + , newScenarioDataGeometry :: Maybe FileInfo + , newScenarioDataCanAddDeleteGeom :: Bool + , newScenarioDataOnSubmitMessage :: Html } -newScenarioForm :: AForm Handler NewScenarioData -newScenarioForm = - NewScenarioData <$> areq textField (labeledField "description") Nothing <*> - areq fileField (labeledField "image") Nothing <*> - areq doubleField (labeledField "scale (obsolete)") (Just 0.5) <*> - areq fileField (labeledField "geometry") Nothing <*> - areq boolField (labeledField "Allow students to add/delete objects.") (Just False) <*> - areq htmlField (labeledField "On-submit html message. Use ${userId}, ${userName}, and ${exerciseId} to customize it.") - (Just - [shamlet| -
Thank you, ${userName}! -

Your design submission has been saved. - Though you can continue working on it and re-submit it later. - - Proceed with a personalized link - |] - ) +-- | renders data from supplied exercise or default values +exerciseForm :: Maybe Exercise -> AForm Handler ExerciseData +exerciseForm mE = ExerciseData <$> + areq textField (labeledField "description") (exerciseDescription <$> mE) <*> + aopt fileField (labeledField "image") Nothing <*> + areq doubleField (labeledField "scale (obsolete)") + (Just $ fromMaybe 0.5 $ exerciseScale <$> mE) <*> + aopt fileField (labeledField "geometry") Nothing <*> + areq boolField (labeledField "Allow students to add/delete objects.") + (Just $ fromMaybe False $ exerciseCanAddDeleteGeom <$> mE) <*> + areq htmlField (labeledField "On-submit html message. Use ${userId}, ${userName}, and ${exerciseId} to customize it.") + (Just $ fromMaybe + [shamlet| +

Thank you, ${userName}! +

Your design submission has been saved. + Though you can continue working on it and re-submit it later. + + Proceed with a personalized link + |] + $ preEscapedText . exerciseOnSubmitMsg <$> mE ) labeledField :: Text -> FieldSettings App labeledField = bfs @@ -160,10 +189,14 @@ getExerciseGeometryR exerciseId = do ("text/plain" :: ByteString , toContent $ exerciseGeometry scenario) +-- | render edit GUI getExerciseEditR :: ExerciseId -> Handler Html getExerciseEditR exerciseId = do requireAdmin - Exercise {..} <- runDB $ get404 exerciseId + exercise <- runDB $ get404 exerciseId + let Exercise {..} = exercise + ((_, widget), enctype) <- + runFormPost $ renderBootstrap3 BootstrapBasicForm $ exerciseForm $ Just exercise cs <- runDB $ select $ @@ -180,7 +213,7 @@ getExerciseEditR exerciseId = do adminLayout (T.pack $ unwords - [ "Welcome to the editor for scenario" + [ "Edit exercise" , show (fromSqlKey exerciseId) ++ ":" , T.unpack exerciseDescription ]) $ do diff --git a/apps/hs/qua-server/templates/mooc/admin/exercise-editor.hamlet b/apps/hs/qua-server/templates/mooc/admin/exercise-editor.hamlet index 86e40037..831b3098 100644 --- a/apps/hs/qua-server/templates/mooc/admin/exercise-editor.hamlet +++ b/apps/hs/qua-server/templates/mooc/admin/exercise-editor.hamlet @@ -12,19 +12,21 @@