Exercise editor: support updates

apps/hs/qua-server/config/models

@@ -73,6 +73,7 @@ Exercise
     description       Text
     scale             Double
     canAddDeleteGeom  Bool default=False
+    canEditProperties Bool default=False
     onSubmitMsg       Text default="'Thank you for the submission!'"
     invitationSecret  Text
     deriving Show

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

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 =

apps/hs/qua-server/src/Application/SetupProblemData.hs

@@ -37,7 +37,7 @@ importProblemRun0 pool = do
     flip runSqlPool pool $ do
       -- Id of the first problem (Sep-Nov 2016)
       let pId = toSqlKey 0
-      repsert pId (Exercise sctaskpreview sctaskfile "Empower Shack scenario" 0.001 False
+      repsert pId (Exercise sctaskpreview sctaskfile "Empower Shack scenario" 0.001 False False
          (toStrict $ renderHtml
            [shamlet|
               <p>Thank you, ${userName}!
@@ -73,7 +73,7 @@ importProblemRun1 pool = do
     flip runSqlPool pool $ do
       -- Id of the second problem
       let pId = toSqlKey 1
-      repsert pId (Exercise sctaskpreview sctaskfile "Empower Shack scenario 2" 0.5 False
+      repsert pId (Exercise sctaskpreview sctaskfile "Empower Shack scenario 2" 0.5 False False
          (toStrict $ renderHtml
            [shamlet|
               <p>Thank you, ${userName}!

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,116 @@ import Yesod.Form.Bootstrap3
 import Handler.Mooc.Admin
 
 getAdminExerciseEditorR :: Handler Html
-getAdminExerciseEditorR = postAdminCreateExerciseR
+getAdminExerciseEditorR = postAdminExercisesR
 
-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
+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
+              , ExerciseCanEditProperties P.=. newScenarioDataCanEditProperties
+              , 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|(<a[^>]*)>///$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
+                  , exerciseCanEditProperties = newScenarioDataCanEditProperties
+                  , 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|(<a[^>]*)>///$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
+    , newScenarioDataCanEditProperties :: 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|
-             <h5>Thank you, ${userName}!
-             <p>Your design submission has been saved.
-                Though you can continue working on it and re-submit it later.
-             <a href="https://httpbin.org/get?userId=${userId}&userName=${userName}&exId=${exerciseId}">
-                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 boolField (labeledField "Allow students to edit object properties.")
+    (Just $ fromMaybe False $ exerciseCanEditProperties <$> mE) <*>
+  areq htmlField (labeledField "On-submit html message. Use ${userId}, ${userName}, and ${exerciseId} to customize it.")
+     (Just $ fromMaybe
+        [shamlet|
+           <h5>Thank you, ${userName}!
+           <p>Your design submission has been saved.
+              Though you can continue working on it and re-submit it later.
+           <a href="https://httpbin.org/get?userId=${userId}&userName=${userName}&exId=${exerciseId}">
+              Proceed with a personalized link
+        |]
+        $ preEscapedText . exerciseOnSubmitMsg <$> mE )
 
 labeledField :: Text -> FieldSettings App
 labeledField = bfs
@@ -160,10 +194,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 +218,7 @@ getExerciseEditR exerciseId = do
     adminLayout
         (T.pack $
          unwords
-             [ "Welcome to the editor for scenario"
+             [ "Edit exercise"
              , show (fromSqlKey exerciseId) ++ ":"
              , T.unpack exerciseDescription
              ]) $ do

apps/hs/qua-server/src/Handler/QuaViewSettings.hs

@@ -31,7 +31,7 @@ getQuaViewExerciseSettingsR exId uId = do
   e <- runDB $ get404 exId
   quaViewSettingsR (SubmissionR exId uId) (Just exId) (Just uId)
     QuaTypes.Permissions
-       { canEditProperties      = False
+       { canEditProperties      = exerciseCanEditProperties e
        , canEraseReloadGeometry = False
        , canAddDeleteGeometry   = exerciseCanAddDeleteGeom e
        , canDownloadGeometry    = False

apps/hs/qua-server/templates/mooc/admin/exercise-editor.hamlet

@@ -12,19 +12,21 @@
             <ul .list-group list-group-flush>
               <li .list-group-item>
                 Description: #{newScenarioDataDescription dat}
-              <li .list-group-item>
-                Image: #{fileName $ newScenarioDataImage dat}
+              $maybe image <- newScenarioDataImage dat
+                <li .list-group-item>
+                  Image: #{fileName image}
               <li .list-group-item>
                 Scale: #{show $ newScenarioDataScale dat}
-              <li .list-group-item>
-                Geometry: #{fileName $ newScenarioDataGeometry dat}
+              $maybe geometry <- newScenarioDataGeometry dat
+                <li .list-group-item>
+                  Geometry: #{fileName geometry}
     $nothing
     <div .card>
       <div.card-main>
         <div.card-inner>
           <h4.card-title>
-            New Scenario Problem
-          <form role=form method=post enctype=#{enctype} action=@{AdminCreateExerciseR}>
+            New Exercise
+          <form role=form method=post enctype=#{enctype} action=@{AdminExercisesR}>
             ^{widget}
             <button type="submit" .btn .btn-default>
               Submit

apps/hs/qua-server/templates/mooc/admin/scenario-card.hamlet

@@ -33,4 +33,4 @@
       <a .btn .col-lg-6 .col-md-6 .col-md-6 .col-sm-6 href=@{ExerciseGeometryR exerciseId}>
         Download Geometry
       <a .btn .col-lg-6 .col-md-6 .col-md-6 .col-sm-6 href=@{ExerciseEditR exerciseId}>
-        Edit Scenario Problem
+        Edit Exercise

apps/hs/qua-server/templates/mooc/admin/scenario-edit.hamlet

@@ -2,6 +2,11 @@
   <div .card>
     <div .card-main>
       <img .card-img .pull-top .center-block src=@{ExerciseImgR exerciseId} height="350px" alt="Scenario Image">
+      <form role=form method=post enctype=#{enctype}
+        action=@{AdminExerciseR exerciseId}?_method=PUT>
+        ^{widget}
+        <button type="submit" .btn .btn-default>
+          Update
 
   <div .card>
     <div .card-inner>
@@ -33,4 +38,3 @@
               <form action=@{ExerciseAttachCriterionR exerciseId criterionId} method=post>
                 <button .btn type="submit">
                   Attach Criterion
-