Commit 44d1d239 authored by Christopher League's avatar Christopher League
Browse files

Integrate some round-trip testing; store U1 responses

parent e0ccf843
......@@ -14,6 +14,7 @@ module App.Prelude
otherwise,
not,
Int,
Integer,
Num (..),
Integral (..),
(^),
......@@ -24,6 +25,7 @@ module App.Prelude
fromMaybe,
maybe,
maybeReturn,
maybeToMonadPlus,
maybeThrow,
mapMaybeM,
mapMaybe,
......@@ -43,6 +45,7 @@ module App.Prelude
null,
-- Strings
String,
Char,
T.Text,
LazyText,
LazyByteString,
......@@ -53,7 +56,7 @@ module App.Prelude
showsPrec,
show,
tshow,
Read,
Read (readPrec),
readMaybe,
lowerFirst,
nonEmptyText,
......@@ -70,6 +73,7 @@ module App.Prelude
Applicative (..),
Alternative (..),
Monad (..),
mzero,
void,
join,
guard,
......@@ -161,7 +165,7 @@ import qualified System.Random as Rand
import qualified Text.Read as Read
import UnliftIO.Exception (throwString)
import Util (makeRelativeTo)
import Prelude hiding (map, print, putStrLn, show)
import Prelude hiding (drop, map, print, putStrLn, show, take)
import qualified Prelude as Pre
show :: (Show a, ConvertibleStrings String s) => a -> s
......@@ -214,6 +218,9 @@ maybeReturn = flip maybe return
maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow = maybeReturn . throwM
maybeToMonadPlus :: MonadPlus m => Maybe a -> m a
maybeToMonadPlus = maybeReturn mzero
eitherReturn :: Monad m => (e -> m a) -> Either e a -> m a
eitherReturn = flip either return
......@@ -241,3 +248,9 @@ 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
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
......@@ -12,39 +14,85 @@
module App.Quiz1
( getU1FromBaseR,
postU1FromBaseR,
quiz1Tests,
)
where
import App.Foundation
import App.Prelude
import Control.Monad.Random hiding (randomIO, randomRIO)
import App.TestUtils
import App.User (UserId)
import App.YamlStore
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import qualified Data.Binary as Bin
import Data.Ix (inRange)
import Data.List ((!!))
import Data.List ((!!), elem, elemIndex)
import Data.String (IsString)
import qualified Data.Text as Text
import Data.Word (Word)
import GHC.Generics
import Numeric (showIntAtBase)
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Hedgehog.Range (Range)
import Numeric (readInt, showIntAtBase)
import Test.Tasty
data BaseConvert
= BaseConvert
{ bcBase :: Word,
bcValue :: Word
bcValue :: Word,
bcDigits :: String
}
deriving (Show, Generic)
deriving (Show, Eq, Ord)
baseRange :: (Word, Word)
baseRange = (3, 9)
baseRange :: Range Word
baseRange = Range.constantFrom 5 2 9
valueRange :: (Word, Word)
valueRange = (100, 1000)
valueRange :: Range Word
valueRange = Range.constantFrom 400 100 1000
makeBaseConvert :: Alternative f => Word -> Word -> f BaseConvert
makeBaseConvert b v =
guard (inRange baseRange b)
*> guard (inRange valueRange v)
$> BaseConvert b v
inBounds :: Ord a => Range a -> a -> Bool
inBounds range value =
lo <= value && value <= hi
where
(lo, hi) = Range.bounds 99 range
digitChars :: String
digitChars = ['0' .. '9'] <> ['A' .. 'Z'] <> ['a' .. 'z'] <> "_-"
valueOfDigit :: Char -> Int
valueOfDigit c =
fromMaybe 0 $ elemIndex c digitChars
toBase :: Word -> Word -> String
toBase b v =
showIntAtBase b (digitChars !!) v ""
fromBase :: Word -> String -> Maybe Word
fromBase b ds =
case readInt b (`elem` take b digitChars) valueOfDigit ds of
(v, "") : _ -> Just v
_ -> Nothing
makeBaseConvertValue :: Alternative f => Word -> Word -> f BaseConvert
makeBaseConvertValue b v =
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
genBaseConvert :: Gen BaseConvert
genBaseConvert =
Gen.just $
makeBaseConvertValue
<$> Gen.integral baseRange
<*> Gen.integral valueRange
instance Bin.Binary BaseConvert where
put BaseConvert {..} =
......@@ -54,18 +102,88 @@ instance Bin.Binary BaseConvert where
get = do
b <- Bin.get
v <- Bin.get
makeBaseConvert b v
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
instance ToJSON U1Submit where
toJSON U1Submit {..} =
Js.object
[ "fromBase" .= u1From
]
instance Random BaseConvert where
random =
runRand $ BaseConvert <$> getRandomR baseRange <*> getRandomR valueRange
instance FromJSON U1Submit where
parseJSON Js.Null =
pure def
parseJSON (Js.Object o) =
U1Submit
<$> o .:? "fromBase" .!= mempty
parseJSON v =
Js.unexpected v
randomR _ =
random
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
instance YamlEntity U1SubmitKey U1Submit
newBaseConvertSession :: Text -> Handler BaseConvert
newBaseConvertSession key = do
bc <- randomIO
bc <- Gen.sample genBaseConvert
setSessionBS key $ convertString $ Bin.encode bc
return bc
......@@ -78,13 +196,6 @@ getBaseConvertSession key =
Right (_, _, bc) -> return bc
Left _ -> newBaseConvertSession key
digitChars :: String
digitChars = ['0' .. '9'] <> ['A' .. 'Z']
toBase :: BaseConvert -> String
toBase BaseConvert {..} =
showIntAtBase bcBase (digitChars !!) bcValue ""
englishBase :: IsString s => BaseConvert -> s
englishBase bc =
case bcBase bc of
......@@ -99,19 +210,10 @@ englishBase bc =
10 -> "ten"
_ -> "UNHANDLED"
correctBaseTen :: BaseConvert -> Word -> Either Text Word
correctBaseTen bc w
| w == bcValue bc =
Right w
| otherwise =
Left $ "Sorry, " <> show w <> " is not the correct value in base ten."
fromBaseForm :: BaseConvert -> Html -> MForm Handler (FormResult Word, Widget)
fromBaseForm bc extra = do
(wordResult, wordView) <-
mreq (check (correctBaseTen bc) intField) "" Nothing
let digits = toBase bc
ndigits = length digits
(wordResult, wordView) <- mreq intField "" Nothing
let ndigits = length (bcDigits bc)
columns = map (bcBase bc ^) [ndigits -1, ndigits -2 .. 0]
widget = do
toWidget
......@@ -127,20 +229,26 @@ sub {
|]
[whamlet|
#{extra}
$maybe err <- fvErrors wordView
<div .alert .alert-danger>
#{err}
<b>Hint:
The column values for base #{bcBase bc} are
#{Text.intercalate ", " (map show columns)}.
$case wordResult
$of FormSuccess _
<div .alert .alert-success>
<b>Great job!
$of _
$of FormSuccess response
$if response == bcValue bc
<div .alert .alert-success>
<b>Great job!
$else
<div .alert .alert-danger>
Sorry, #{response} is not the correct value in base ten.
<b>Hint:
The column values for base #{bcBase bc} are
#{Text.intercalate ", " (map show columns)}.
$of FormFailure errs
<div .alert .alert-danger>
$forall err <- errs
<p>
#{err}
$of FormMissing
<div .text-monospace style="font-size:150%">
<p>
$forall digit <- digits
$forall digit <- bcDigits bc
<span .px-2 .my-3 style="border-bottom: 2px solid #007bff">
#{digit}
<sub>#{bcBase bc}
......@@ -159,8 +267,13 @@ $case wordResult
u1FromKey :: Text
u1FromKey = "u1from"
onFormSuccess :: Applicative f => FormResult a -> (a -> f ()) -> f ()
onFormSuccess (FormSuccess a) m = m a
onFormSuccess _ _ = pure ()
getU1FromBaseR :: Handler Html
getU1FromBaseR = do
_ <- requireAuthId
bc <- getBaseConvertSession u1FromKey
(widget, enctype) <- generateFormPost $ fromBaseForm bc
defaultLayout $ do
......@@ -171,15 +284,18 @@ getU1FromBaseR = do
^{widget}
|]
isFormSuccess :: FormResult a -> Bool
isFormSuccess (FormSuccess _) = True
isFormSuccess _ = False
postU1FromBaseR :: Handler Html
postU1FromBaseR = do
uid <- requireAuthId
bc <- getBaseConvertSession u1FromKey
((result, widget), enctype) <- runFormPost $ fromBaseForm bc
when (isFormSuccess result) $ deleteSession u1FromKey
onFormSuccess result \response -> do
entry <- U1From bc response <$> getCurrentTime
let k = U1SubmitKey uid
runRw $ do
sub <- fromMaybe def <$> loadMaybeY k
saveY k sub {u1From = entry : u1From sub}
when (response == bcValue bc) $ deleteSession u1FromKey
defaultLayout $ do
setTitle $ "Convert from base " <> englishBase bc
[whamlet|
......@@ -187,3 +303,12 @@ postU1FromBaseR = do
<form method=post enctype=#{enctype}>
^{widget}
|]
quiz1Tests :: TestTree
quiz1Tests =
testGroup
"App.Quiz1"
[ testGroup "BaseConvert" [binaryRoundTrip genBaseConvert],
testGroup "U1From" [jsonRoundTrip genU1From],
testGroup "U1Submit" [jsonRoundTrip genU1Submit]
]
......@@ -70,7 +70,7 @@ schJsonOpts :: Js.Options
schJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 3
fieldLabelModifier = lowerFirst . drop @Int 3
}
instance ToJSON Schedule where
......@@ -189,7 +189,7 @@ meetJsonOpts :: Js.Options
meetJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 4
fieldLabelModifier = lowerFirst . drop @Int 4
}
instance ToJSON Meeting where
......
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module App.TestUtils
( showReadRoundTrip,
pathPieceRoundTrip,
jsonRoundTrip,
binaryRoundTrip,
storeKeyRoundTrip,
genDay,
genUtcTime,
)
where
import App.Prelude
import App.StoreKeys (Key (..))
import qualified Data.Aeson as Js
import qualified Data.Binary as Bin
import Data.Time.Calendar
import Data.Time.Clock
import Data.Tuple.Extra (thd3)
import Hedgehog (Gen, forAll, property, tripping)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Range (Range)
import qualified Hedgehog.Range as Range
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)
import Web.PathPieces (PathPiece (..))
showReadRoundTrip :: (Show a, Read a, Eq a) => Gen a -> TestTree
showReadRoundTrip gen =
testProperty "Show/Read round-trip" $ property $ do
a <- forAll gen
tripping a tshow readMaybe
pathPieceRoundTrip :: (PathPiece a, Show a, Eq a) => Gen a -> TestTree
pathPieceRoundTrip gen =
testProperty "PathPiece round-trip" $ property $ do
a <- forAll gen
tripping a toPathPiece fromPathPiece
jsonRoundTrip :: (Js.ToJSON a, Js.FromJSON a, Show a, Eq a) => Gen a -> TestTree
jsonRoundTrip gen =
testProperty "JSON round-trip" $ property $ do
a <- forAll gen
tripping a Js.encode Js.decode
binaryRoundTrip :: (Bin.Binary a, Show a, Eq a) => Gen a -> TestTree
binaryRoundTrip gen =
testProperty "Binary round-trip" $ property $ do
a <- forAll gen
tripping a Bin.encode (map thd3 . Bin.decodeOrFail)
storeKeyRoundTrip :: (Key a, Show a) => Gen a -> TestTree
storeKeyRoundTrip gen =
testProperty "Key/FilePath round-trip" $ property $ do
a <- forAll gen
tripping a keyToFileName keyFromFileName
tripping a (keyToFilePath @_ @Text) (keyFromFilePath @_ @Maybe)
genGregorianValid :: Range Integer -> Gen (Maybe Day)
genGregorianValid yearRange =
fromGregorianValid
<$> Gen.integral yearRange
<*> Gen.integral (Range.constant 1 12)
<*> Gen.integral (Range.constant 1 31)
genDayIn :: Range Integer -> Gen Day
genDayIn =
Gen.just . genGregorianValid
reasonableYearRange :: Range Integer
reasonableYearRange =
Range.linearFrom 2020 1990 2040
genDay :: Gen Day
genDay =
genDayIn reasonableYearRange
genDiffTime :: Gen DiffTime
genDiffTime =
Gen.realFrac_ $ Range.linearFracFrom 43200 0 86400
genUtcTime :: Gen UTCTime
genUtcTime =
UTCTime <$> genDay <*> genDiffTime
......@@ -37,6 +37,7 @@ module App.User
findUserByIdent,
markPostAsRead,
devImport,
userTests,
)
where
......@@ -44,10 +45,10 @@ import App.ByteStoreWorkDir (WorkDirT)
import App.Post
import App.Prelude
import App.StoreKeys
import App.TestUtils
import App.YamlStore
import Conduit
import Control.Lens (Lens')
import Control.Lens (makeLenses)
import Control.Lens ((??), Lens', makeLenses)
import "cryptohash" Crypto.Hash
import Data.Aeson as Js
import Data.CaseInsensitive (foldCase)
......@@ -59,18 +60,19 @@ import Data.String (IsString (..))
import qualified Data.Text as Text
import Data.Time.Clock
import GHC.Generics
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
import Text.Blaze.Html (ToMarkup (..))
import Web.PathPieces
import Yesod.Auth.Email
import Prelude (error)
newtype UserId
= UnsafeUserId {userIdText :: Text}
newtype UserId = UserId {userIdText :: Text}
deriving
( Eq,
Ord,
Show,
Read,
ToMarkup,
ToJSON,
FromJSONKey,
......@@ -82,43 +84,65 @@ makeUserId :: Text -> Maybe UserId
makeUserId orig =
case Text.uncons clean of
Just (c, cs)
| isLower c && Text.all okay cs -> Just (UnsafeUserId clean)
| isLower c && Text.all okay cs -> Just (UserId clean)
_ -> Nothing
where
clean = foldCase $ Text.strip orig
okay c = isLower c || isDigit c
instance Key UserId where
keyDir = "users"
keyToFileName uid =
convertString (userIdText uid) <.> "yaml"
genUserId :: Gen UserId
genUserId =
Gen.just $ makeUserId <$> Gen.text (Range.linear 3 9) Gen.alphaNum
keyFromFileName =
makeUserId . convertString <=< stripExtension "yaml"
instance Default UserId where
def = UserId "nobody"
instance IsString UserId where
fromString =
fromJust . makeUserId . convertString
instance Show UserId where
showsPrec p =
showsPrec p . userIdText
instance Read UserId where
readPrec =
maybeToMonadPlus . makeUserId =<< readPrec
instance PathPiece UserId where
toPathPiece = userIdText
fromPathPiece = makeUserId
instance FromJSON UserId where
parseJSON v =
parseJSON v <&> makeUserId >>= maybeReturn (fail "invalid UserId")
parseJSON =
maybeToMonadPlus . makeUserId <=< parseJSON
instance Default UserId where
def = UnsafeUserId "nobody"
instance Key UserId where
keyDir = "users"
keyToFileName uid =
convertString (userIdText uid) <.> "yaml"
keyFromFileName =
makeUserId . convertString <=< stripExtension "yaml"
genVerKey :: Gen VerKey
genVerKey =
Gen.text (Range.singleton 24) Gen.alphaNum
data UserVerify
= UserVerify
{ _userKey :: VerKey,
_userExpiry :: Maybe UTCTime
}
deriving (Show, Generic)
deriving (Show, Eq, Generic)
genUserVerify :: Gen UserVerify
genUserVerify =
UserVerify
<$> genVerKey
<*> Gen.maybe genUtcTime
data User
= User
......@@ -159,7 +183,7 @@ userJsonOpts :: Js.Options
userJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 5
fieldLabelModifier = lowerFirst . drop @Int 5
}
instance ToJSON UserVerify where
......@@ -200,7 +224,7 @@ createSampleUsers :: ByteStoreRW m => m ()
createSampleUsers =
mapM_
(uncurry saveY)
[ (UnsafeUserId "ralph", ralph),
[ (UserId "ralph", ralph),
("cindy", cindy)