Commit 602b904a authored by Christopher League's avatar Christopher League
Browse files

Allow submit A1?

parent 7c2f1e29
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Asset
( streamAsset,
)
where
import App.ByteStore
import App.Foundation
import App.Prelude
import Conduit
import Network.Mime
streamAsset :: Key k => k -> (k -> FileName) -> Handler TypedContent
streamAsset k f = do
ex <- runRo $ existsObj k
if ex
then respondSource typ $ conRo $ readObj k .| mapC toFlushBuilder
else notFound
where
typ = case defaultMimeLookup (f k) of
"image/vnd.microsoft.icon" -> "image/x-icon"
t -> t
......@@ -6,12 +6,16 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Assn1
( handleU1HuffAssnR,
postU1HuffUploadR,
getU1HuffDeleteR,
getU1HuffViewR,
assn1,
a1SubmittedBadge,
assn1Tests,
......@@ -19,22 +23,27 @@ module App.Assn1
where
import App.Activity
import App.Asset
import App.Foundation
import App.Page
import App.Prelude
import App.TestUtils
import App.User
import App.YamlStore
import Conduit
import Control.Lens (at)
import Data.Aeson as Js
import Data.List (break)
import qualified Data.ByteString as BS
import Data.List (elem)
import qualified Data.Text as Text
import GHC.Generics
import Hedgehog hiding (check)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Network.Mime
import Test.Tasty
import Text.Pandoc (runPure, writeHtml5String)
import Yesod.Core.Types (FileInfo (..))
assn1 :: Activity
assn1 =
......@@ -82,7 +91,7 @@ genA1ImageKey =
<*> Gen.element ["jpg", "JPG", "png", "tiff", ""]
instance Key A1ImageKey where
keyDir = keyDir @A1AnswersKey
keyDir = "submit/a1/attach"
keyToFileName (A1ImageKey uid fn) =
convertString $ userIdText uid <> "-" <> fn
......@@ -100,7 +109,8 @@ data A1Answers
a1q3 :: Char,
a1q4 :: Int,
a1q5 :: Int,
a1q6 :: Int
a1q6 :: Int,
a1q7 :: Maybe Text
}
deriving (Eq, Show, Generic)
......@@ -167,20 +177,10 @@ answerForm prev =
"How many bits does your encoding use to encode the entire phrase \
\you were given?"
(a1q6 <$> prev)
data A1Form
= A1Form
{ a1answers :: A1Answers,
a1tree :: FileInfo,
a1bits :: FileInfo
}
-- a1form :: AppHandler m => Maybe A1Answers -> AForm m A1Form
-- a1form prev =
-- A1Form
-- <$> answerForm prev
-- <*> fileAFormReq "file1"
-- <*> fileAFormReq "file2"
<*> aopt
(convertField unTextarea Textarea textareaField)
"You may use this space to include any comments about your solution."
(a1q7 <$> prev)
a1SubmittedBadge :: Widget
a1SubmittedBadge = do
......@@ -203,17 +203,22 @@ $else
handleU1HuffAssnR :: Handler Html
handleU1HuffAssnR = do
uid <- requireAuthId
(phraseOpt, submitOpt, doc) <- runRo $ do
po <- (^. at uid) <$> loadY A1GivenKey
so <- loadMaybeY (A1AnswersKey uid)
doc <- fetchPage @PageId "assn1.org"
return (po, so, doc)
body <- eitherThrow . runPure $ writeHtml5String def doc
submitOpt <- runRo $ loadMaybeY $ A1AnswersKey uid
((result, widget), enctype) <- runFormPost $ renderTable $ answerForm submitOpt
onFormSuccess result \sub -> do
runRw $ saveY (A1AnswersKey uid) sub
runRw $ do
logMessage $ userIdText uid <> " A1 save"
saveY (A1AnswersKey uid) sub
addMessage "success" "Your answers have been saved."
redirect U1HuffAssnR
(phraseOpt, doc, images) <-
runRo $
(,,)
<$> ((^. at uid) <$> loadY A1GivenKey)
<*> fetchPage @PageId "assn1.org"
<*> (filter (\A1ImageKey {..} -> a1ImgUser == uid) <$> listKeys)
body <- eitherThrow . runPure $ writeHtml5String def doc
(upfile, encfile) <- generateFormPost $ renderDivs $ fileAFormReq ""
defaultLayout $ do
setTitle "Assignment 1: Text compression"
toWidget
......@@ -249,21 +254,34 @@ handleU1HuffAssnR = do
<h3>Answer questions
<div .alert .alert-danger>
<b>Note:
Online submission is not ready yet, check back in a few days
or contact the instructor
<table .table>
^{widget}
<form .mb-4 method=post enctype=#{enctype}>
<table .table>
^{widget}
<input .btn .btn-primary type=submit value="Save">
<h3>Upload images
<div .alert .alert-danger>
Not ready yet
|]
-- <form method=post enctype=#{enctype}>
-- <button .btn .btn-primary>Submit
<p>
In this section, you can upload photos of your tree and any other work,
such as your encoding as bits and frequency analysis. Showing your work
can improve your score!
<form .mb-4 method=post action=@{U1HuffUploadR} enctype=#{encfile}>
^{upfile}
<input .btn .btn-primary .mt-2 type=submit value="Upload">
<p>#{plural (length images) "file"} submitted
$forall A1ImageKey _ image <- images
<div .col-lg-6 .mb-4>
$if BS.isPrefixOf "image/" (defaultMimeLookup image)
<img src=@{U1HuffViewR image} width=250 style="border:1px solid #ccc">
$else
<a href=@{U1HuffViewR image}>📁
<br>
<a .btn .btn-danger .mt-1 href=@{U1HuffDeleteR image}>Delete
#{image}
|]
assn1Tests :: TestTree
assn1Tests =
......@@ -273,3 +291,36 @@ assn1Tests =
"A1ImageKey"
[storeKeyRoundTrip genA1ImageKey]
]
getU1HuffDeleteR :: Text -> Handler ()
getU1HuffDeleteR name = do
uid <- requireAuthId
runRw $ do
logMessage $ userIdText uid <> " A1 delete " <> name
deleteObj $ A1ImageKey uid name
addMessage "success" $ toHtml $ "Deleted " <> name
redirect U1HuffAssnR
postU1HuffUploadR :: Handler ()
postU1HuffUploadR = do
uid <- requireAuthId
((res, _), _) <- runFormPost $ renderDivs $ fileAFormReq ""
case res of
FormSuccess FileInfo {..} -> do
let bannedChars = " /()[]" :: [Char]
newName =
Text.intercalate "-" $ Text.split (`elem` bannedChars) fileName
runRw $ do
logMessage $ userIdText uid <> " A1 upload " <> newName
runConduit $
transPipe liftResourceT fileSourceRaw
.| writeObj (A1ImageKey uid newName)
addMessage "success" $ toHtml $ "Uploaded " <> newName
_ ->
addMessage "danger" "Upload failed"
redirect U1HuffAssnR
getU1HuffViewR :: Text -> Handler TypedContent
getU1HuffViewR name = do
uid <- requireAuthId
streamAsset (A1ImageKey uid name) a1ImgFile
......@@ -102,8 +102,11 @@ mkYesodData
/unit/1/to-base U1ToBaseR
/unit/1/hex-spell U1HexSpellR GET POST
/assn/1/huffman U1HuffAssnR
!/assn/1/#AssetId U1HuffAssetR GET
/assn/1/huffman U1HuffAssnR
/assn/1/huffman/upload U1HuffUploadR POST
/assn/1/huffman/show/#Text U1HuffViewR GET
/assn/1/huffman/delete/#Text U1HuffDeleteR GET
!/assn/1/#AssetId U1HuffAssetR GET
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
......
......@@ -10,9 +10,11 @@
module App.Main
( main,
test,
)
where
import App.Asset
import App.Assn1
import App.ByteStoreDynamic
import App.ByteStoreGitDir (bareRepo)
......@@ -114,15 +116,8 @@ getPageDocR :: PageId -> Handler Html
getPageDocR = getPandocPage
getPageAssetR :: AssetId -> Handler TypedContent
getPageAssetR name = do
ex <- runRo $ existsObj name
if ex
then respondSource typ $ conRo $ readObj name .| mapC toFlushBuilder
else notFound
where
typ = case defaultMimeLookup (assetName name) of
"image/vnd.microsoft.icon" -> "image/x-icon"
t -> t
getPageAssetR aid =
streamAsset aid assetName
getU1HuffAssetR :: AssetId -> Handler TypedContent
getU1HuffAssetR = getPageAssetR
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment