Commit 77a624b6 authored by Christopher League's avatar Christopher League
Browse files

ormolu

parent 43c975ee
......@@ -55,9 +55,9 @@ import Control.Monad.Reader (ReaderT (runReaderT))
import Data.List (sort)
import qualified Data.Map as Map
import Data.String (fromString)
import qualified Data.Text as Text
import Data.Typeable
import Network.Mail.Mime as Mail
import qualified Data.Text as Text
import Text.Pandoc hiding (getCurrentTime)
import Text.Shakespeare.Text (stext)
import UnliftIO.IORef (IORef, modifyIORef, readIORef)
......@@ -491,7 +491,7 @@ updateAuth :: AppHandler m => Text -> (User -> User) -> m UserEntity
updateAuth why change = do
uid <- requireAuthId
let mesg = Text.unwords [userIdText uid, why]
new <- runRw (logMessage mesg >> updatePureY uid change)
new <- runRw (logMessage mesg >> updatePureY uid change)
cacheSet (CachedAuth (uid, new))
return (uid, new)
......
......@@ -64,7 +64,8 @@ deleteMetaCacheR = do
-- <form method=post enctype=#{enctype}>
-- ^{widget}
-- <button .btn .btn-primary>Upload
-- |]
-- | ]
-- data SubmitFile
-- = SubmitFile
......@@ -98,8 +99,8 @@ deleteMetaCacheR = do
-- [whamlet|
-- <p>Got #{fileName} (#{fileContentType})
-- <p>Will upload to #{st}
-- |]
-- | ]
getPostR :: PostId -> Handler Html
getPostR pid = do
uid <- requireAuthId
......
......@@ -19,11 +19,11 @@ import App.Foundation
import App.Page
import App.Post
import App.Prelude
import App.User
import App.Quiz1
import App.User
import qualified Data.Set as Set
import Data.Time.LocalTime
import Data.Time.Format
import Data.Time.LocalTime
import Data.Tuple.Extra
formatDay :: FormatTime t => t -> String
......
......@@ -6,7 +6,7 @@
module App.Page
( PageId,
PageFormat(..),
PageFormat (..),
PageFile (..),
IsPageKey (..),
AssetId (..),
......
......@@ -8,25 +8,25 @@ module App.Post
( PostId (..),
listPostIds,
genPostId,
postTests
postTests,
)
where
import App.ByteStore
import App.Page
import App.Prelude
import App.TestUtils
import Control.Lens ((??))
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
import Test.Tasty
import qualified Text.Read as R
import Web.PathPieces
data PostId
= PostId
......@@ -68,6 +68,7 @@ instance IsPageKey PostId where
listPostIds :: ByteStoreRO m => m [PostId]
listPostIds =
listKeys <&> sortOn Down
-- devSendLatestByEmail :: Mailer -> IO ()
-- devSendLatestByEmail mailer = do
-- flip runReaderT (WorkDir "data") $ do
......@@ -82,7 +83,8 @@ listPostIds =
postTests :: TestTree
postTests =
testGroup "App.Post"
[ testGroup "PostId" $
[pathPieceRoundTrip, jsonRoundTrip, storeKeyRoundTrip] ?? genPostId
]
testGroup
"App.Post"
[ testGroup "PostId" $
[pathPieceRoundTrip, jsonRoundTrip, storeKeyRoundTrip] ?? genPostId
]
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module App.Prelude
( -- Eq, Ord
......@@ -152,7 +152,6 @@ 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)
......@@ -163,6 +162,7 @@ import Data.String.Conversions
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.Time.Clock as Clock
import Data.Word (Word, Word16)
import System.FilePath
import System.IO.Error (IOError, doesNotExistErrorType, isDoesNotExistError, mkIOError)
import qualified Text.Read as Read
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
......@@ -10,8 +7,10 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
......@@ -28,28 +27,31 @@ where
import App.Foundation
import App.Prelude
import Text.Blaze.Html (ToMarkup(..))
import App.TestUtils
import App.User
import Control.Lens (at, makeLenses, non)
import qualified Data.Binary as Bin
import Data.List ((!!), elem, elemIndex, reverse)
import Network.Wai (requestMethod)
import qualified Data.Text as Text
import Control.Lens (makeLenses, at, non)
import Data.Time.Format
import Data.Time.LocalTime
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Hedgehog.Range (Range)
import Network.Wai (requestMethod)
import Numeric (readInt, showIntAtBase)
import Test.Tasty
import Test.Tasty.Hedgehog
import Data.Time.LocalTime
import Data.Time.Format
import Text.Blaze.Html (ToMarkup (..))
u1ToBaseDeadline :: ZonedTime
u1ToBaseDeadline =
parseTimeOrError True defaultTimeLocale "%F %H:%M %Z"
"2020-02-05 23:59 EST"
parseTimeOrError
True
defaultTimeLocale
"%F %H:%M %Z"
"2020-02-05 23:59 EST"
u1ToBaseKey :: ActivityId
u1ToBaseKey = "u1to"
......@@ -122,24 +124,28 @@ fromBase b ds =
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)
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
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)
......@@ -156,8 +162,8 @@ genBaseConvert attemptR =
instance Bin.Binary BaseConvert where
put bc =
Bin.put (bc ^. bcBase)
*> Bin.put (bc ^. bcValue)
*> Bin.put (bc ^. bcAttempts)
*> Bin.put (bc ^. bcValue)
*> Bin.put (bc ^. bcAttempts)
get = do
b <- Bin.get
......@@ -168,7 +174,7 @@ instance Bin.Binary BaseConvert where
dropLead0s :: String -> String
dropLead0s "" = ""
dropLead0s "0" = "0"
dropLead0s ('0':s) = dropLead0s s
dropLead0s ('0' : s) = dropLead0s s
dropLead0s s = s
matchDigits :: BaseConvert -> Text -> Bool
......@@ -198,9 +204,9 @@ getBaseConvertSession key =
Right (_, _, bc) -> do
-- If this is a POST, then increment attempt count.
meth <- requestMethod <$> waiRequest
whenElse (meth == "POST") bc $
doRet (bc & bcAttempts %~ succ) $
setSessionBS key . convertString . Bin.encode
whenElse (meth == "POST") bc
$ doRet (bc & bcAttempts %~ succ)
$ setSessionBS key . convertString . Bin.encode
Left _ -> newBaseConvertSession key
englishBase :: BaseConvert -> Html
......@@ -218,8 +224,9 @@ englishBase bc =
_ -> "UNHANDLED"
u1Styles :: Widget
u1Styles = toWidget
[lucius|
u1Styles =
toWidget
[lucius|
sub {
font-size: 70%;
position: relative;
......@@ -239,15 +246,15 @@ sub {
columnValues :: BaseConvert -> Text
columnValues bc =
Text.intercalate ", " $ map tshow $ map (bc ^. bcBase ^) [n-1, n-2 .. 0]
where n = length (bc ^. bcDigits)
Text.intercalate ", " $ map tshow $ map (bc ^. bcBase ^) [n -1, n -2 .. 0]
where
n = length (bc ^. bcDigits)
fromBaseForm :: BaseConvert -> Html -> MForm Handler (FormResult BaseWord, Widget)
fromBaseForm bc extra = do
(result, input) <- mreq intField "" Nothing
let
isCorrect = maybe False (== bc ^. bcValue) $ maybeFormSuccess result
widget = do
let isCorrect = maybe False (== bc ^. bcValue) $ maybeFormSuccess result
widget = do
u1Styles
[whamlet|
#{extra}
......@@ -296,12 +303,16 @@ handleU1FromBaseR = do
let correct = response == bc ^. bcValue
when correct $ do
deleteSession u1FromKey
addMessage "success" [shamlet|
addMessage
"success"
[shamlet|
<b>
Great job!
|]
when (not correct) $ do
addMessage "danger" [shamlet|
addMessage
"danger"
[shamlet|
Sorry,
<b .text-monospace>#{response}
is not the correct value in base ten.
......@@ -309,7 +320,6 @@ is not the correct value in base ten.
The column values for base #{englishBase bc} are
#{columnValues bc}
|]
defaultLayout $ do
setTitle "Convert from a non-decimal base"
[whamlet|
......@@ -328,21 +338,21 @@ quiz1Tests :: TestTree
quiz1Tests =
testGroup
"App.Quiz1"
[ testGroup "BaseConvert"
[ binaryRoundTrip (genBaseConvert (Range.linear 0 5)),
baseToFrom,
baseFromTo
]
[ testGroup
"BaseConvert"
[ binaryRoundTrip (genBaseConvert (Range.linear 0 5)),
baseToFrom,
baseFromTo
]
]
toBaseForm :: BaseConvert -> Html -> MForm Handler (FormResult Text, Widget)
toBaseForm bc extra = do
(result, input) <- mreq textField "" Nothing
let
isCorrect = maybe False (matchDigits bc) $ maybeFormSuccess result
widget = do
u1Styles
[whamlet|
let isCorrect = maybe False (matchDigits bc) $ maybeFormSuccess result
widget = do
u1Styles
[whamlet|
#{extra}
$case result
$of FormFailure errs
......@@ -379,19 +389,24 @@ handleU1ToBaseR = do
when correct $ do
origPts <- (^. _2 . userScores . at u1ToBaseKey . non 0) <$> requireAuth
isLate <- (> zonedTimeToUTC u1ToBaseDeadline) <$> getCurrentTime
let
award =
if isLate then 0
else if bc ^. bcAttempts > 1 then 1
else 2
let award =
if isLate
then 0
else
if bc ^. bcAttempts > 1
then 1
else 2
newPts = min u1ToBaseMaxPoints (origPts + award)
deltaPts = newPts - origPts
when (deltaPts > 0) $ do
uid <- requireAuthId
updateAuth_ ("u1ToBase points := " <> show newPts)
updateAuth_
("u1ToBase points := " <> show newPts)
(userScores . at u1ToBaseKey ?~ newPts)
deleteSession u1ToBaseKey
addMessage "success" [shamlet|
addMessage
"success"
[shamlet|
<b>
$if isLate && (newPts < u1ToBaseMaxPoints)
You got it! However, the deadline has passed, so no further points
......@@ -414,7 +429,9 @@ $else
-- * Digits outside of the base
-- * Reverse order
-- * Columns hint
addMessage "danger" [shamlet|
addMessage
"danger"
[shamlet|
Sorry,
<b .text-monospace>#{response}
is not correct. #
......
......@@ -9,7 +9,7 @@ module App.TestUtils
storeKeyRoundTrip,
genDay,
genUtcTime,
genPrintableAscii
genPrintableAscii,
)
where
......@@ -18,11 +18,11 @@ import App.StoreKeys (Key (..))
import qualified Data.Aeson as Js
import qualified Data.Binary as Bin
import Data.Binary.Get (ByteOffset)
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isPrint)
import Data.Time.Calendar
import Data.Time.Clock
import Hedgehog (Gen, forAll, property, tripping)
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isPrint)
import qualified Hedgehog.Gen as Gen
import Hedgehog.Range (Range)
import qualified Hedgehog.Range as Range
......@@ -48,14 +48,14 @@ jsonRoundTrip gen =
a <- forAll gen
tripping a Js.encode Js.eitherDecode
binaryEndOfInput
:: Either (LazyByteString, ByteOffset, String) (LazyByteString, ByteOffset, a)
-> Either (LazyByteString, ByteOffset, String) a
binaryEndOfInput ::
Either (LazyByteString, ByteOffset, String) (LazyByteString, ByteOffset, a) ->
Either (LazyByteString, ByteOffset, String) a
binaryEndOfInput (Left e) = Left e
binaryEndOfInput (Right (extra, offset, a)) =
if LBS.null extra
then Right a
else Left (extra, offset, "Unconsumed input")
then Right a
else Left (extra, offset, "Unconsumed input")
binaryRoundTrip :: (Bin.Binary a, Show a, Eq a) => Gen a -> TestTree
binaryRoundTrip gen =
......
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -7,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
......@@ -45,36 +45,36 @@ module App.User
)
where
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', makeLenses)
import Control.Monad (sequence)
import Control.Monad.Writer
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', makeLenses)
import Control.Monad (sequence)
import Control.Monad.Writer
import "cryptohash" Crypto.Hash
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import Data.CaseInsensitive (foldCase)
import Data.Char (isDigit, isLower)
import Data.Hashable (Hashable)
import Data.Maybe (fromJust)
import qualified Data.Set as Set
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 Prelude (error)
import Test.Tasty
import Text.Blaze.Html (ToMarkup (..))
import Web.PathPieces
import Yesod.Auth.Email
import Data.Aeson as Js
import qualified Data.Aeson.Types as Js
import Data.CaseInsensitive (foldCase)
import Data.Char (isDigit, isLower)
import Data.Hashable (Hashable)
import Data.Maybe (fromJust)
import qualified Data.Set as Set
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 = UserId {userIdText :: Text}
deriving
......@@ -152,19 +152,21 @@ genUserVerify =
<*> Gen.maybe genUtcTime
instance ToJSON UserVerify where
toJSON UserVerify{..} =
toJSON UserVerify {..} =
Js.object . execWriter $ do
tell ["key" .= userKey]
forM_ userExpiry \e -> tell ["expiry" .= e]
tell ["key" .= userKey]
forM_ userExpiry \e -> tell ["expiry" .= e]
instance FromJSON UserVerify where
parseJSON = Js.withObject "UserVerify" \o ->
UserVerify
<$> o .: "key"
<*> o .:? "expiry"
<$> o .: "key"
<*> o .:? "expiry"
type ActivityId = Text
type Points = Word16
type Scores = Map ActivityId Points
data User
......@@ -186,27 +188,28 @@ data User
deriving (Show, Eq, Generic)
genUser :: Gen User
genUser = do
User
<$> lname -- userLastName
<*> fname -- userFirstName
<*> Gen.maybe fname -- userNickName
<*> Gen.integral (Range.constant 1000 9999) -- userStudentId
<*> Gen.maybe genVerKey -- userPassword
<*> email -- userEmail
<*> textOrEmpty -- userSchool
<*> Gen.element ["", "CS", "Bio", "Hist"] -- userMajor
<*> Gen.element ["", "Frosh", "Soph", "Junior", "Senior", "Grad"] -- userYear
<*> Gen.maybe genUserVerify -- userVerify
<*> posts -- userReadPosts
<*> textOrEmpty -- userAboutMe
<*> scores
genUser =
do
User
<$> lname -- userLastName
<*> fname -- userFirstName
<*> Gen.maybe fname -- userNickName
<*> Gen.integral (Range.constant 1000 9999) -- userStudentId
<*> Gen.maybe genVerKey -- userPassword
<*> email -- userEmail
<*> textOrEmpty -- userSchool
<*> Gen.element ["", "CS", "Bio", "Hist"] -- userMajor
<*> Gen.element ["", "Frosh", "Soph", "Junior", "Senior", "Grad"] -- userYear
<*> Gen.maybe genUserVerify -- userVerify
<*> posts -- userReadPosts
<*> textOrEmpty -- userAboutMe
<*> scores
where
fname = Gen.element ["Alice", "Bob", "Carol", "Doug", "Indy", "Josh"]
lname = Gen.element ["Effiong", "Fayad", "Grün", "Hilbert"]
dom = Gen.element ["example.com", "example.edu", "example.co.uk"]
email = Text.concat <$> sequence [Text.toLower <$> fname, pure "@", dom]
textOrEmpty = Gen.text (Range.linear 0 10) (Gen.element (' ':['a'..'z']))
textOrEmpty = Gen.text (Range.linear 0 10) (Gen.element (' ' : ['a' .. 'z']))
posts = Gen.set (Range.linear 0 5) genPostId
scores = Gen.map (Range.linear 0 5) ((,) <$> assns <*> points)
assns = Gen.text (Range.constant 3 8) Gen.lower
......@@ -240,38 +243,40 @@ emptyTell field value =
unless (value == mempty) (tell [field .= value])
instance ToJSON User where
toJSON User{..} =
toJSON User {..} =
Js.object . execWriter $ do
tell ["lastName" .= _userLastName,
tell
[ "lastName" .= _userLastName,
"firstName" .= _userFirstName,
"studentId" .= _userStudentId,
"email" .= _userEmail]
maybeTell "verify" _userVerify
maybeTell "password" _userPassword
maybeTell "nickName" _userNickName
emptyTell "year" _userYear
emptyTell "major" _userMajor
emptyTell "school" _userSchool
emptyTell "aboutMe" _userAboutMe
emptyTell "readPosts" _userReadPosts
emptyTell "scores" _userScores
"email" .= _userEmail
]
maybeTell "verify" _userVerify
maybeTell "password" _userPassword
maybeTell "nickName" _userNickName
emptyTell "year" _userYear
emptyTell "major" _userMajor
emptyTell "school" _userSchool
emptyTell "aboutMe" _userAboutMe
emptyTell "readPosts" _userReadPosts
emptyTell "scores" _userScores
instance FromJSON User where
parseJSON = Js.withObject "User" \o ->
User
<$> o .: "lastName"
<*> o .: "firstName"