Commit 7c2f1e29 authored by Christopher League's avatar Christopher League
Browse files

Publish assignment 1 (without submit for now)

parent e81f58f6
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Activity
( Activity (..),
makeActivity,
pointsBadge,
isPast,
userPointsFor,
dueBadge,
formatDay,
maybeFormSuccess,
onFormSuccess,
)
where
import App.Foundation
import App.Prelude
import App.User
import Control.Lens (at, non)
import Data.Time.Format
import Data.Time.LocalTime
data Activity
= Activity
{ actId :: ActivityId,
actDeadline :: ZonedTime,
actMaxPoints :: Points
}
makeActivity :: ActivityId -> Points -> String -> Activity
makeActivity actId actMaxPoints timeStr =
Activity {..}
where
actDeadline =
parseTimeOrError
False -- Allow leading spaces
defaultTimeLocale
"%F %H:%M %Z"
timeStr
userPointsFor :: ActivityId -> UserEntity -> Points
userPointsFor aid =
view $ _2 . userScores . at aid . non 0
pointsBadge :: Activity -> Widget
pointsBadge Activity {..} = do
pts <- userPointsFor actId <$> requireAuth
let cls = if pts == actMaxPoints then "success" else "primary" :: Text
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow actMaxPoints} points
|]
isPast :: MonadIO m => ZonedTime -> m Bool
isPast zt =
(> zonedTimeToUTC zt) <$> getCurrentTime
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
isLate <- isPast deadline
let cls = if isLate then "danger" else "info" :: Text
[whamlet|
<span class="badge badge-#{cls}">
due #{formatDay deadline}
|]
maybeFormSuccess :: FormResult a -> Maybe a
maybeFormSuccess (FormSuccess a) = Just a
maybeFormSuccess _ = Nothing
onFormSuccess :: Monad m => FormResult a -> (a -> m ()) -> m ()
onFormSuccess r m = forM_ (maybeFormSuccess r) m
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.Assn1
( handleU1HuffAssnR,
assn1,
a1SubmittedBadge,
assn1Tests,
)
where
import App.Activity
import App.Foundation
import App.Page
import App.Prelude
import App.TestUtils
import App.User
import App.YamlStore
import Control.Lens (at)
import Data.Aeson as Js
import Data.List (break)
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 Test.Tasty
import Text.Pandoc (runPure, writeHtml5String)
assn1 :: Activity
assn1 =
makeActivity "a1" 60 "2020-02-12 23:59 EST"
data A1GivenKey = A1GivenKey
deriving (Eq, Ord, Show)
instance Key A1GivenKey where
keyDir = "course"
keyToFileName A1GivenKey = "assn1.yaml"
keyFromFileName fn
| fn == keyToFileName A1GivenKey = Just A1GivenKey
| otherwise = Nothing
instance YamlEntity A1GivenKey (Map UserId Text)
data A1AnswersKey
= A1AnswersKey
{ a1User :: UserId
}
deriving (Eq, Ord, Show)
instance Key A1AnswersKey where
keyDir = "submit/a1"
keyToFileName (A1AnswersKey uid) = keyToFileName uid
keyFromFileName fn = A1AnswersKey <$> keyFromFileName fn
data A1ImageKey
= A1ImageKey
{ a1ImgUser :: UserId,
a1ImgFile :: Text
}
deriving (Eq, Ord, Show)
genA1ImageKey :: Gen A1ImageKey
genA1ImageKey =
A1ImageKey <$> genUserId <*> (convertString <$> genImgFile)
where
genImgFile =
(<.>)
<$> Gen.string (Range.linear 2 12) Gen.alphaNum
<*> Gen.element ["jpg", "JPG", "png", "tiff", ""]
instance Key A1ImageKey where
keyDir = keyDir @A1AnswersKey
keyToFileName (A1ImageKey uid fn) =
convertString $ userIdText uid <> "-" <> fn
keyFromFileName fn = do
let (uidT, restT) = Text.break (== '-') (convertString fn)
uid <- makeUserId uidT
(c, img) <- Text.uncons restT
guard (c == '-')
return $ A1ImageKey uid img
data A1Answers
= A1Answers
{ a1q1 :: Int,
a1q2 :: Int,
a1q3 :: Char,
a1q4 :: Int,
a1q5 :: Int,
a1q6 :: Int
}
deriving (Eq, Show, Generic)
a1JsonOpts :: Js.Options
a1JsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop @Int 2
}
instance ToJSON A1Answers where
toJSON = genericToJSON a1JsonOpts
instance FromJSON A1Answers where
parseJSON = genericParseJSON a1JsonOpts
instance YamlEntity A1AnswersKey A1Answers
charField :: AppHandler m => Field m Char
charField =
convertField firstChar Text.singleton (check ok textField)
where
ok txt =
if Text.length clean == 1
then Right txt
else Left @Text "Must be exactly one character"
where
clean = Text.strip txt
firstChar txt
| Text.null txt = '?'
| otherwise = Text.head txt
answerForm :: AppHandler m => Maybe A1Answers -> AForm m A1Answers
answerForm prev =
A1Answers
<$> areq
intField
"How many distinct characters does your phrase contain? \
\(It should be the same as the number of leaves in your tree.)"
(a1q1 <$> prev)
<*> areq
intField
"If we were using a fixed-width encoding, how many bits per \
\character would you need to represent just those characters?"
(a1q2 <$> prev)
<*> areq
charField
"What is the most frequent character in your phrase? If there is \
\tie, then just choose one. If it's the space character, then enter \
\it as an underscore (shift-hyphen)."
(a1q3 <$> prev)
<*> areq
intField
"In your encoding tree, how many bits used for that most frequent \
\character (in the previous question)."
(a1q4 <$> prev)
<*> areq
intField
"What is the most number of bits used to encode any character in \
\your phrase?"
(a1q5 <$> prev)
<*> areq
intField
"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"
a1SubmittedBadge :: Widget
a1SubmittedBadge = do
(uid, user) <- requireAuth
submitted <- runRo $ existsObj $ A1AnswersKey uid
let outOf = tshow (actMaxPoints assn1)
[whamlet|
$if submitted
$maybe pts <- user ^. (userScores . at (actId assn1))
<span class="badge badge-success">
#{tshow pts}/#{outOf} points
$nothing
<span class="badge badge-secondary">
submitted: TBD/#{outOf} points
$else
<span class="badge badge-primary">
0/#{outOf} points
|]
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
((result, widget), enctype) <- runFormPost $ renderTable $ answerForm submitOpt
onFormSuccess result \sub -> do
runRw $ saveY (A1AnswersKey uid) sub
addMessage "success" "Your answers have been saved."
redirect U1HuffAssnR
defaultLayout $ do
setTitle "Assignment 1: Text compression"
toWidget
[lucius|
.errors {
color: #dc3545;
}
.bigger-text {
font-size: 120%;
}
|]
[whamlet|
<div .col-12>
<p>
^{a1SubmittedBadge}
^{dueBadge (actDeadline assn1)}
#{preEscapedToMarkup body}
$maybe phrase <- phraseOpt
<p .bigger-text .border .border-success .p-2>
Your phrase is:  
<span .text-monospace>
#{phrase}
<p>
(We use the underscore character to indicate spaces, so that they
are visible. You should count that as a character when you produce
your tree and encoding.)
$nothing
<div .alert .alert-danger>
You have not been assigned a phrase yet! Please ask the instructor
to assign one ASAP.
<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}
<h3>Upload images
<div .alert .alert-danger>
Not ready yet
|]
-- <form method=post enctype=#{enctype}>
-- <button .btn .btn-primary>Submit
assn1Tests :: TestTree
assn1Tests =
testGroup
"App.Assn1"
[ testGroup
"A1ImageKey"
[storeKeyRoundTrip genA1ImageKey]
]
......@@ -101,6 +101,10 @@ mkYesodData
/unit/1/from-base U1FromBaseR
/unit/1/to-base U1ToBaseR
/unit/1/hex-spell U1HexSpellR GET POST
/assn/1/huffman U1HuffAssnR
!/assn/1/#AssetId U1HuffAssetR GET
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
......
......@@ -13,6 +13,7 @@ module App.Main
)
where
import App.Assn1
import App.ByteStoreDynamic
import App.ByteStoreGitDir (bareRepo)
import App.ByteStoreWorkDir
......@@ -34,6 +35,7 @@ import qualified Data.Yaml as Yaml
import Network.Mime
import System.Environment
import System.Exit
import Test.Tasty
import Text.Pandoc (Pandoc (..), runPure, writeHtml5String)
import qualified Text.Pandoc.Highlighting as PH
import UnliftIO.IORef (newIORef, readIORef, writeIORef)
......@@ -122,6 +124,9 @@ getPageAssetR name = do
"image/vnd.microsoft.icon" -> "image/x-icon"
t -> t
getU1HuffAssetR :: AssetId -> Handler TypedContent
getU1HuffAssetR = getPageAssetR
getPandocPage :: IsPageKey k => k -> Handler Html
getPandocPage k =
runRo (fetchPageMaybe k) >>= \case
......@@ -132,7 +137,8 @@ getPandocPage k =
defaultLayout $ do
addStylesheet PandocStyleR
setTitle title
toWidget [lucius|
toWidget
[lucius|
.answers {
border: solid #{accentColor};
border-width: 0 0 6px 6px;
......@@ -204,3 +210,15 @@ main = do
print app
putStrLn @Text $ "Listening on http://localhost:" <> show port <> "/"
warp port app
test :: IO ()
test =
defaultMain $
testGroup
"All tests"
[ userTests,
pageTests,
postTests,
quiz1Tests,
assn1Tests
]
......@@ -14,6 +14,8 @@ module App.Outline
)
where
import App.Activity
import App.Assn1
import App.ByteStoreWorkDir
import App.Foundation
import App.Page
......@@ -128,6 +130,12 @@ unit1 = do
Notes:
<a href=@{PageDocR "notes130-text.org"}>
Text encoding
<li .list-group-item>
Assignment:
<a href=@{U1HuffAssnR}>
Text compression
^{a1SubmittedBadge}
^{dueBadge (actDeadline assn1)}
|]
getHomeR :: Handler Html
......
......@@ -14,16 +14,22 @@ module App.Page
fetchPageMaybe,
parseJsonPathPiece,
formatTitle,
pageTests,
)
where
import App.ByteStore
import App.Prelude
import App.TestUtils
import Data.Aeson as Js
import Data.Aeson.Types as Js
import Data.Maybe (maybe)
import Data.String
import qualified Data.Text as Text
import Hedgehog hiding (check)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
import Text.Blaze.Html
import Text.Pandoc
import Web.PathPieces
......@@ -45,6 +51,12 @@ data PageFile
}
deriving (Eq, Ord, Show, Read)
genPageFile :: Gen PageFile
genPageFile =
PageFile
<$> Gen.text (Range.linear 2 12) Gen.alphaNum
<*> Gen.element [OrgPage, MarkdownPage]
instance ToJSONKey PageFile
instance PathPiece PageFile where
......@@ -82,6 +94,10 @@ class Key k => IsPageKey k where
newtype PageId = PageId PageFile
deriving (Eq, Ord, Show, Read, PathPiece, ToJSON, FromJSON, IsString)
genPageId :: Gen PageId
genPageId =
PageId <$> genPageFile
instance Key PageId where
keyDir = "pages"
......@@ -95,6 +111,10 @@ instance IsPageKey PageId where
newtype AssetId = AssetId {assetName :: Text}
deriving (Eq, Ord, Show, Read)
genAssetId :: Gen AssetId
genAssetId =
AssetId <$> Gen.text (Range.linear 2 12) Gen.alphaNum
instance PathPiece AssetId where
toPathPiece = assetName
fromPathPiece = Just . AssetId
......@@ -127,3 +147,18 @@ formatTitle :: MonadThrow m => Meta -> m Html
formatTitle meta =
eitherThrow . runPure $ writeHtml5 def $
Pandoc nullMeta [Plain (docTitle meta)]
pageTests :: TestTree
pageTests =
testGroup
"App.Page"
[ testGroup
"PageFile"
[pathPieceRoundTrip genPageFile, jsonRoundTrip genPageFile],
testGroup
"PageId"
[storeKeyRoundTrip genPageId],
testGroup
"AssetId"
[storeKeyRoundTrip genAssetId]
]
......@@ -16,29 +16,24 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.Quiz1
( Activity (..),
handleU1FromBaseR,
( handleU1FromBaseR,
handleU1ToBaseR,
getU1HexSpellR,
postU1HexSpellR,
u1ToBase,
pointsBadge,
dueBadge,
formatDay,
quiz1Tests,
)
where
import App.Activity
import App.Foundation
import App.Prelude
import App.TestUtils
import App.User
import Control.Lens (at, makeLenses, non)
import Control.Lens (at, makeLenses)
import qualified Data.Binary as Bin
import Data.List ((!!), elem, elemIndex, reverse)
import qualified Data.Text as Text
import Data.Time.Format
import Data.Time.LocalTime
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
......@@ -50,59 +45,10 @@ import Test.Tasty.Hedgehog
import Text.Blaze.Html (ToMarkup (..))
import Text.Julius (rawJS)
data Activity
= Activity
{ actId :: ActivityId,
actDeadline :: ZonedTime,
actMaxPoints :: Points
}
deriving (Show)
makeActivity :: ActivityId -> Points -> String -> Activity
makeActivity actId actMaxPoints timeStr =
Activity {..}
where
actDeadline =
parseTimeOrError
False -- Allow leading spaces
defaultTimeLocale
"%F %H:%M %Z"
timeStr
u1ToBase :: Activity
u1ToBase =
makeActivity "u1to" 8 "2020-02-05 23:59 EST"
userPointsFor :: ActivityId -> UserEntity -> Points
userPointsFor aid =
view $ _2 . userScores . at aid . non 0
pointsBadge :: Activity -> Widget
pointsBadge Activity {..} = do
pts <- userPointsFor actId <$> requireAuth
let cls = if pts == actMaxPoints then "success" else "primary" :: Text
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow actMaxPoints} points
|]
isPast :: MonadIO m => ZonedTime -> m Bool
isPast zt =
(> zonedTimeToUTC zt) <$> getCurrentTime
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
isLate <- isPast deadline
let cls = if isLate then "danger" else "info" :: Text
[whamlet|
<span class="badge badge-#{cls}">
due #{formatDay deadline}
|]
type BaseWord = Word16
instance ToMarkup BaseWord where
......@@ -325,13 +271,6 @@ $else
u1FromKey :: Text
u1FromKey = "u1from"
maybeFormSuccess :: FormResult a -> Maybe a
maybeFormSuccess (FormSuccess a) = Just a
maybeFormSuccess _ = Nothing
onFormSuccess :: Monad m => FormResult a -> (a -> m ()) -> m ()
onFormSuccess r m = forM_ (maybeFormSuccess r) m
handleU1FromBaseR :: Handler Html
handleU1FromBaseR = do
bc <- getBaseConvertSession u1FromKey
......
......@@ -18,6 +18,7 @@ module App.User
UserEntity,
ActivityId,
Points,
genUserId,
makeUserId,
userIdText,
userStudentId,
......
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