Commit 2a534b70 authored by Christopher League's avatar Christopher League
Browse files

Finally! Can award points for base-conversion

parent 44d1d239
......@@ -30,6 +30,8 @@ module App.Foundation
conRw,
runMailer,
requireAuth,
updateAuth,
updateAuth_,
maybeAuth,
isAuthenticated,
whenAuthenticated,
......@@ -93,16 +95,18 @@ mkYesodData
/cs101.ics Schedule101R GET
/ics/#Text ScheduleR GET
/me ProfileR GET POST
/unit/1/from-base U1FromBaseR GET POST
/unit/1/from-base U1FromBaseR
/unit/1/to-base U1ToBaseR
/page/#PageId PageDocR GET
!/page/#AssetId PageAssetR GET
/post/#PostId PostR GET
/submit/#Text SubmitR GET POST
/cache/meta MetaCacheR GET DELETE
/auth AuthR Auth getAuth
|]
-- /submit/#Text SubmitR GET POST
type AppHandler m = (MonadHandler m, HandlerSite m ~ App)
runRo :: AppHandler m => (forall s. ByteStoreRO s => s a) -> m a
......@@ -472,7 +476,7 @@ newtype CachedAuth
cachedAuth :: AppHandler m => UserId -> m UserEntity
cachedAuth uid =
unCachedAuth <$> cached (CachedAuth . (uid,) <$> (putStrLn @Text "CACHELOADUSER" >> runRo (loadY uid)))
unCachedAuth <$> cached (CachedAuth . (uid,) <$> runRo (loadY uid))
maybeAuth :: AppHandler m => m (Maybe UserEntity)
maybeAuth =
......@@ -482,6 +486,17 @@ requireAuth :: AppHandler m => m UserEntity
requireAuth =
requireAuthId >>= cachedAuth
updateAuth :: AppHandler m => (User -> User) -> m UserEntity
updateAuth change = do
uid <- requireAuthId
new <- runRw (updatePureY uid change)
cacheSet (CachedAuth (uid, new))
return (uid, new)
updateAuth_ :: AppHandler m => (User -> User) -> m ()
updateAuth_ change =
updateAuth change $> ()
isAuthenticated :: AppHandler m => m Bool
isAuthenticated =
maybeAuthId <&> isJust
......
......@@ -55,50 +55,50 @@ deleteMetaCacheR = do
writeIORef cacheRef mempty
return $ "meta cache: dropped " <> show num <> " entries.\n"
getSubmitR :: Text -> Handler Html
getSubmitR sid = do
(widget, enctype) <- generateFormPost $ renderDivs $ fileAFormReq "your-file"
defaultLayout
[whamlet|
<p>Submitting #{sid}
<form method=post enctype=#{enctype}>
^{widget}
<button .btn .btn-primary>Upload
|]
data SubmitFile
= SubmitFile
{ submitId :: Text,
submitUser :: UserId,
submitFileName :: Text
}
deriving (Eq, Ord, Show)
-- won't be able to list these keys because separate subdirs?
instance Key SubmitFile where
keyDir = "submit"
keyToFileName SubmitFile {..} =
convertString submitId
</> convertString (userIdText submitUser)
</> convertString submitFileName
postSubmitR :: Text -> Handler Html
postSubmitR sid = do
uid <- requireAuthId
((res, _), _) <- runFormPost $ renderDivs $ fileAFormReq "your-file"
case res of
FormSuccess FileInfo {..} -> do
let sf = SubmitFile sid uid fileName
st = keyToFilePath @_ @Text sf
runRw $ do
logMessage st
runConduit $
transPipe liftResourceT fileSourceRaw .| writeObj sf
defaultLayout
[whamlet|
<p>Got #{fileName} (#{fileContentType})
<p>Will upload to #{st}
|]
-- getSubmitR :: Text -> Handler Html
-- getSubmitR sid = undefined
-- (widget, enctype) <- generateFormPost $ renderDivs $ fileAFormReq "your-file"
-- defaultLayout
-- [whamlet|
-- <p>Submitting #{sid}
-- <form method=post enctype=#{enctype}>
-- ^{widget}
-- <button .btn .btn-primary>Upload
-- |]
-- data SubmitFile
-- = SubmitFile
-- { submitId :: Text,
-- submitUser :: UserId,
-- submitFileName :: Text
-- }
-- deriving (Eq, Ord, Show)
-- -- won't be able to list these keys because separate subdirs?
-- instance Key SubmitFile where
-- keyDir = "submit"
-- keyToFileName SubmitFile {..} =
-- convertString submitId
-- </> convertString (userIdText submitUser)
-- </> convertString submitFileName
-- postSubmitR :: Text -> Handler Html
-- postSubmitR sid = do
-- uid <- requireAuthId
-- ((res, _), _) <- runFormPost $ renderDivs $ fileAFormReq "your-file"
-- case res of
-- FormSuccess FileInfo {..} -> do
-- let sf = SubmitFile sid uid fileName
-- st = keyToFilePath @_ @Text sf
-- runRw $ do
-- logMessage st
-- runConduit $
-- transPipe liftResourceT fileSourceRaw .| writeObj sf
-- defaultLayout
-- [whamlet|
-- <p>Got #{fileName} (#{fileContentType})
-- <p>Will upload to #{st}
-- |]
getPostR :: PostId -> Handler Html
getPostR pid = do
......
......@@ -20,12 +20,13 @@ import App.Page
import App.Post
import App.Prelude
import App.User
import App.Quiz1
import qualified Data.Set as Set
import Data.Time.Calendar (Day)
import Data.Time.LocalTime
import Data.Time.Format
import Data.Tuple.Extra
formatDay :: Day -> String
formatDay :: FormatTime t => t -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
......@@ -103,8 +104,17 @@ unitTitle num title =
#{title}
|]
dueBadge :: ZonedTime -> Widget
dueBadge deadline = do
now <- getCurrentTime
let cls = if now > zonedTimeToUTC deadline then "danger" else "info" :: Text
[whamlet|
<span class="badge badge-#{cls}">
due #{formatDay deadline}
|]
unit1 :: Widget
unit1 =
unit1 = do
cardList (unitTitle 1 "Digital representations") $
[whamlet|
<li .list-group-item>
......@@ -115,6 +125,12 @@ unit1 =
Practice:
<a href=@{U1FromBaseR}>
Convert from base
<li .list-group-item>
Check-in:
<a href=@{U1ToBaseR}>
Convert to base
^{pointsBadgeU1ToBase}
^{dueBadge u1ToBaseDeadline}
|]
getHomeR :: Handler Html
......
......@@ -6,6 +6,7 @@
module App.Page
( PageId,
PageFormat(..),
PageFile (..),
IsPageKey (..),
AssetId (..),
......
......@@ -7,6 +7,8 @@
module App.Post
( PostId (..),
listPostIds,
genPostId,
postTests
)
where
......@@ -16,9 +18,15 @@ import App.Prelude
import Data.Aeson as Js
import Data.List (sortOn)
import Data.Ord (Down (..))
import Test.Tasty
import Data.Time.Calendar
import Control.Lens ((??))
import qualified Text.Read as R
import Web.PathPieces
import Hedgehog (Gen)
import App.TestUtils
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
data PostId
= PostId
......@@ -27,6 +35,13 @@ data PostId
}
deriving (Eq, Ord, Show, Read)
genPostId :: Gen PostId
genPostId = do
day <- genDay
slug <- Gen.text (Range.linear 3 9) Gen.lower
fmt <- Gen.element [OrgPage, MarkdownPage]
return $ PostId (PageFile (tshow day <> "-" <> slug) fmt) day
instance PathPiece PostId where
toPathPiece (PostId f _) = toPathPiece f
......@@ -64,3 +79,10 @@ listPostIds =
-- formatPandocMail doc
-- sendMail undefined
-- print pid
postTests :: TestTree
postTests =
testGroup "App.Post"
[ testGroup "PostId" $
[pathPieceRoundTrip, jsonRoundTrip, storeKeyRoundTrip] ?? genPostId
]
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module App.Prelude
( -- Eq, Ord
......@@ -14,11 +15,14 @@ module App.Prelude
otherwise,
not,
Int,
Word,
Word16,
Integer,
Num (..),
Integral (..),
(^),
fromIntegral,
succ,
-- Maybe, Either
Maybe (..),
Either (..),
......@@ -42,6 +46,7 @@ module App.Prelude
zip,
length,
filter,
all,
null,
-- Strings
String,
......@@ -52,6 +57,7 @@ module App.Prelude
BS.ByteString,
ConvertibleStrings,
convertString,
plural,
Show,
showsPrec,
show,
......@@ -123,9 +129,6 @@ module App.Prelude
undefined,
getCurrentTime,
Clock.UTCTime,
-- Random
randomIO,
randomRIO,
-- File paths
FilePath,
(</>),
......@@ -149,6 +152,7 @@ import Control.Monad.Fail
import Control.Monad.IO.Class (MonadIO (..))
import qualified Data.ByteString as BS
import Data.Char
import Data.Word (Word, Word16)
import Data.Default (Default (def))
import Data.Functor
import Data.List (find)
......@@ -161,7 +165,6 @@ import qualified Data.Text.IO as TIO
import qualified Data.Time.Clock as Clock
import System.FilePath
import System.IO.Error (IOError, doesNotExistErrorType, isDoesNotExistError, mkIOError)
import qualified System.Random as Rand
import qualified Text.Read as Read
import UnliftIO.Exception (throwString)
import Util (makeRelativeTo)
......@@ -243,14 +246,12 @@ notFoundExn :: String -> FilePath -> IOError
notFoundExn loc =
mkIOError doesNotExistErrorType loc Nothing . Just
randomIO :: (Rand.Random a, MonadIO m) => m a
randomIO = liftIO Rand.randomIO
randomRIO :: (Rand.Random a, MonadIO m) => (a, a) -> m a
randomRIO = liftIO . Rand.randomRIO
take :: Integral i => i -> [a] -> [a]
take = Pre.take . fromIntegral
drop :: Integral i => i -> [a] -> [a]
drop = Pre.drop . fromIntegral
plural :: (Integral i, Show i) => i -> T.Text -> T.Text
plural 1 noun = "1 " <> noun
plural k noun = tshow k <> " " <> noun <> "s"
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
......@@ -10,46 +13,83 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module App.Quiz1
( getU1FromBaseR,
postU1FromBaseR,
( handleU1FromBaseR,
handleU1ToBaseR,
u1ToBaseKey,
u1ToBaseDeadline,
u1ToBaseMaxPoints,
pointsBadgeU1ToBase,
quiz1Tests,
)
where
import App.Foundation
import App.Prelude
import Text.Blaze.Html (ToMarkup(..))
import App.TestUtils
import App.User (UserId)
import App.YamlStore
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import App.User
import qualified Data.Binary as Bin
import Data.List ((!!), elem, elemIndex)
import Data.String (IsString)
import Data.List ((!!), elem, elemIndex, reverse)
import Network.Wai (requestMethod)
import qualified Data.Text as Text
import Data.Word (Word)
import GHC.Generics
import Hedgehog (Gen)
import Control.Lens (makeLenses, at, non)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Hedgehog.Range (Range)
import Numeric (readInt, showIntAtBase)
import Test.Tasty
import Test.Tasty.Hedgehog
import Data.Time.LocalTime
import Data.Time.Format
u1ToBaseDeadline :: ZonedTime
u1ToBaseDeadline =
parseTimeOrError True defaultTimeLocale "%F %H:%M %Z"
"2020-02-05 23:59 EST"
u1ToBaseKey :: ActivityId
u1ToBaseKey = "u1to"
u1ToBaseMaxPoints :: Points
u1ToBaseMaxPoints = 8
pointsBadge :: ActivityId -> Points -> Widget
pointsBadge actId limit = do
pts <- (^. _2 . userScores . at actId . non 0) <$> requireAuth
let cls = if pts == limit then "success" else "primary" :: Text
[whamlet|
<span class="badge badge-#{cls}">
#{tshow pts}/#{tshow limit} points
|]
pointsBadgeU1ToBase :: Widget
pointsBadgeU1ToBase =
pointsBadge u1ToBaseKey u1ToBaseMaxPoints
type BaseWord = Word16
instance ToMarkup BaseWord where
toMarkup = toMarkup . tshow
data BaseConvert
= BaseConvert
{ bcBase :: Word,
bcValue :: Word,
bcDigits :: String
{ _bcBase :: BaseWord,
_bcValue :: BaseWord,
_bcDigits :: String,
_bcAttempts :: Word16
}
deriving (Show, Eq, Ord)
baseRange :: Range Word
makeLenses ''BaseConvert
baseRange :: Range BaseWord
baseRange = Range.constantFrom 5 2 9
valueRange :: Range Word
valueRange :: Range BaseWord
valueRange = Range.constantFrom 400 100 1000
inBounds :: Ord a => Range a -> a -> Bool
......@@ -65,140 +105,107 @@ valueOfDigit :: Char -> Int
valueOfDigit c =
fromMaybe 0 $ elemIndex c digitChars
toBase :: Word -> Word -> String
validDigitInBase :: BaseWord -> Char -> Bool
validDigitInBase b c =
c `elem` take b digitChars
toBase :: BaseWord -> BaseWord -> String
toBase b v =
showIntAtBase b (digitChars !!) v ""
fromBase :: Word -> String -> Maybe Word
fromBase :: BaseWord -> String -> Maybe BaseWord
fromBase b ds =
case readInt b (`elem` take b digitChars) valueOfDigit ds of
case readInt b (validDigitInBase b) valueOfDigit ds of
(v, "") : _ -> Just v
_ -> Nothing
makeBaseConvertValue :: Alternative f => Word -> Word -> f BaseConvert
makeBaseConvertValue b v =
baseToFrom :: TestTree
baseToFrom =
testProperty "Base to/from conversion" $ property $ do
b <- forAll $ Gen.integral $ Range.linearFrom 5 2 60
v <- forAll $ Gen.integral $ Range.linearFrom 400 100 32000
tripping v (toBase b) (fromBase b)
baseFromTo :: TestTree
baseFromTo =
testProperty "Base from/to conversion" $ property $ do
b <- forAll $ Gen.integral $ Range.linearFrom 5 2 40
let chars = take (b+1) digitChars
d <- forAll $ Gen.element (drop @Int 1 chars) -- Non-zero leading digit
ds <- forAll $ Gen.string (Range.linear 0 2) (Gen.element chars)
let str = d:ds
if all (validDigitInBase b) str
then tripping str (fromBase b) (map (toBase b))
else fromBase b str === Nothing
makeBaseConvertValue :: Alternative f =>
BaseWord -> BaseWord -> Word16 -> f BaseConvert
makeBaseConvertValue b v k =
guard (inBounds baseRange b)
*> guard (inBounds valueRange v)
$> BaseConvert b v (toBase b v)
makeBaseConvertDigits :: Alternative f => Word -> String -> f BaseConvert
makeBaseConvertDigits b ds =
case fromBase b ds of
Nothing -> empty
Just v -> makeBaseConvertValue b v
$> BaseConvert b v (toBase b v) k
genBaseConvert :: Gen BaseConvert
genBaseConvert =
genBaseConvert :: Range Word16 -> Gen BaseConvert
genBaseConvert attemptR =
Gen.just $
makeBaseConvertValue
<$> Gen.integral baseRange
<*> Gen.integral valueRange
<*> Gen.integral attemptR
instance Bin.Binary BaseConvert where
put BaseConvert {..} =
Bin.put bcBase
*> Bin.put bcValue
put bc =
Bin.put (bc ^. bcBase)
*> Bin.put (bc ^. bcValue)
*> Bin.put (bc ^. bcAttempts)
get = do
b <- Bin.get
v <- Bin.get
makeBaseConvertValue b v
data U1From
= U1From
{ u1fProblem :: BaseConvert,
u1fResponse :: Word,
u1fWhen :: UTCTime
}
deriving (Show, Eq)
genU1From :: Gen U1From
genU1From = do
u1fProblem <- genBaseConvert
u1fResponse <- Gen.choice [pure (bcValue u1fProblem), Gen.integral valueRange]
u1fWhen <- genUtcTime
return U1From {..}
isU1FromCorrect :: U1From -> Bool
isU1FromCorrect U1From {..} =
u1fResponse == bcValue u1fProblem
instance ToJSON U1From where
toJSON U1From {..} =
Js.object
[ "base" .= bcBase u1fProblem,
"digits" .= bcDigits u1fProblem,
"response" .= u1fResponse,
"when" .= u1fWhen
]
instance FromJSON U1From where
parseJSON = Js.withObject "U1From" \o -> do
b <- o .: "base"
ds <- o .: "digits"
u1fProblem <- makeBaseConvertDigits b ds
u1fResponse <- o .: "response"
u1fWhen <- o .: "when"
return U1From {..}
data U1Submit
= U1Submit
{ u1From :: [U1From]
}
deriving (Show, Eq)
genU1Submit :: Gen U1Submit
genU1Submit =
U1Submit <$> Gen.list (Range.linear 0 10) genU1From
instance Default U1Submit where
def = U1Submit mempty
k <- Bin.get
makeBaseConvertValue b v k
instance ToJSON U1Submit where
toJSON U1Submit {..} =
Js.object
[ "fromBase" .= u1From
]
instance FromJSON U1Submit where
parseJSON Js.Null =
pure def
parseJSON (Js.Object o) =
U1Submit
<$> o .:? "fromBase" .!= mempty
parseJSON v =
Js.unexpected v
newtype U1SubmitKey = U1SubmitKey {u1User :: UserId}
deriving (Show, Eq, Ord, Generic)
instance Key U1SubmitKey where
keyDir = "submit/u1"
keyToFileName k =
keyToFileName (u1User k)
keyFromFileName f =
U1SubmitKey <$> keyFromFileName f
dropLead0s :: String -> String
dropLead0s "" = ""
dropLead0s "0" = "0"
dropLead0s ('0':s) = dropLead0s s
dropLead0s s = s
instance YamlEntity U1SubmitKey U1Submit
matchDigits :: BaseConvert -> Text -> Bool
matchDigits bc t =
dropLead0s (convertString (Text.strip t)) == bc ^. bcDigits
newBaseConvertSession :: Text -> Handler BaseConvert
newBaseConvertSession key = do
bc <- Gen.sample genBaseConvert
bc <- Gen.sample $ genBaseConvert $ Range.singleton 0
setSessionBS key $ convertString $ Bin.encode bc
return bc
whenElse :: Applicative f => Bool -> a -> f a -> f a
whenElse flag fallback act =
if flag then act else pure fallback
doRet :: Applicative f => a -> (a -> f ()) -> f a
doRet a act =
act a *> pure a
getBaseConvertSession :: Text -> Handler BaseConvert
getBaseConvertSession key =
lookupSessionBS key >>= \case
Nothing -> newBaseConvertSession key
Just buf ->
case Bin.decodeOrFail (convertString buf) of
Right (_, _, bc) -> return bc
Right (_, _, bc) -> do
-- If this is a POST, then increment attempt count.
meth <- requestMethod <$> waiRequest
whenElse (