diff --git a/app/CLI.hs b/app/CLI.hs index 8001c08..e5680cc 100644 --- a/app/CLI.hs +++ b/app/CLI.hs @@ -7,7 +7,7 @@ import Options.Applicative data CLIOptions = CLIOptions { cliSampleAmount :: Maybe Int , cliWeights :: [(Text, Int)] - , cliConfigPath :: FilePath + , cliConfigPath :: Maybe FilePath } cliParser :: Parser CLIOptions @@ -15,7 +15,7 @@ cliParser = CLIOptions <$> optional sampleAmount <*> many weights - <*> argument str (metavar "") + <*> optional (argument str (metavar "")) where sampleAmount = option diff --git a/app/Main.hs b/app/Main.hs index a30001d..d2bc7f2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,11 +11,13 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Graphics.Vty qualified as V import Graphics.Vty.CrossPlatform (mkVty) +import Registry (loadRegistry, registerConfig) import Sampling (SamplingStrategy (..), sampleQuestions) import State (AppState, Name, initialState) import System.Exit (exitFailure) import System.Random (newStdGen) import TUI.Attributes (theMap) +import TUI.ConfigSelect (selectConfig) import TUI.Draw (drawUI) import TUI.Event (CustomEvent (..), handleEvent) import Types (Config (..)) @@ -34,18 +36,33 @@ main :: IO () main = do opts <- parseCLIOpts - configBytes <- BS.readFile (cliConfigPath opts) + configPath <- case cliConfigPath opts of + Just p -> pure p + Nothing -> do + registry <- loadRegistry + if null registry + then do + putStrLn "No config path provided and no previously-used configs found." + putStrLn "Usage: cert-prep " + exitFailure + else do + mPath <- selectConfig registry + maybe exitFailure pure mPath + + configBytes <- BS.readFile configPath config <- case eitherDecodeStrict configBytes of Left err -> do putStrLn $ "Error parsing config: " ++ err exitFailure Right c -> return c - let sampleSize = fromMaybe (configSampleAmount config) (cliSampleAmount opts) + registerConfig configPath (title config) + + let sampleSize = fromMaybe (sampleAmount config) (cliSampleAmount opts) strategy = case cliWeights opts of - [] -> maybe Uniform Stratified $ configCategoryWeights config + [] -> maybe Uniform Stratified $ categoryWeights config ws -> Stratified (Map.fromList ws) - allQuestions = configQuestions config + allQuestions = questions config effectiveSize = min sampleSize (length allQuestions) gen <- newStdGen diff --git a/app/TUI/ConfigSelect.hs b/app/TUI/ConfigSelect.hs new file mode 100644 index 0000000..71280bd --- /dev/null +++ b/app/TUI/ConfigSelect.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TUI.ConfigSelect (selectConfig) where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Brick.Widgets.Center +import Brick.Widgets.List qualified as L +import Data.Time (defaultTimeLocale, formatTime) +import Data.Vector qualified as V +import Graphics.Vty qualified as Vty +import Graphics.Vty.CrossPlatform (mkVty) +import Lens.Micro.TH (makeLenses) +import Registry (Registry, RegistryEntry (..)) + +data SelectName = SelectList + deriving (Show, Eq, Ord) + +newtype SelectState = SelectState + { _selectList :: L.List SelectName RegistryEntry + } + +makeLenses ''SelectState + +drawSelectUI :: SelectState -> [Widget SelectName] +drawSelectUI (SelectState l) = [ui] + where + ui = + withBorderStyle unicode $ + borderWithLabel (str " Select a Config ") $ + center $ + hLimitPercent 80 $ + vLimitPercent 80 $ + vBox + [ L.renderList renderEntry True l + , hBorder + , padLeftRight 1 $ + str "[Enter] Select [q/Esc] Quit [Arrow Keys] Navigate" + ] + +renderEntry :: Bool -> RegistryEntry -> Widget SelectName +renderEntry selected entry = + let marker = if selected then ">" else " " + p = path entry + time = + formatTime + defaultTimeLocale + "%Y-%m-%d %H:%M" + (lastUsed entry) + in hBox + [ str marker + , str " " + , txt $ title entry + , padLeft Max $ str (time ++ " " ++ p) + ] + +handleSelectEvent :: + BrickEvent SelectName e -> EventM SelectName SelectState () +handleSelectEvent (VtyEvent (Vty.EvKey Vty.KEsc [])) = halt +handleSelectEvent (VtyEvent (Vty.EvKey Vty.KEnter [])) = halt +handleSelectEvent (VtyEvent (Vty.EvKey (Vty.KChar c) [])) = case c of + 'j' -> handleSelectEvent (VtyEvent (Vty.EvKey Vty.KDown [])) + 'k' -> handleSelectEvent (VtyEvent (Vty.EvKey Vty.KUp [])) + 'q' -> halt + _ -> return () +handleSelectEvent (VtyEvent e) = do + zoom selectList $ L.handleListEvent e +handleSelectEvent _ = return () + +selectConfig :: Registry -> IO (Maybe FilePath) +selectConfig entries = do + let list = + L.list + SelectList + (V.fromList entries) + 1 + initial = SelectState list + app = + App + { appDraw = drawSelectUI + , appChooseCursor = neverShowCursor + , appHandleEvent = handleSelectEvent + , appStartEvent = return () + , appAttrMap = + const $ + attrMap + Vty.defAttr + [(L.listSelectedFocusedAttr, Vty.defAttr `Vty.withStyle` Vty.reverseVideo)] + } + let buildVty = mkVty Vty.defaultConfig + initialVty <- buildVty + finalState <- customMain initialVty buildVty Nothing app initial + let mSelected = snd <$> L.listSelectedElement (_selectList finalState) + pure (path <$> mSelected) diff --git a/app/TUI/Draw.hs b/app/TUI/Draw.hs index ad33a52..5120b2c 100644 --- a/app/TUI/Draw.hs +++ b/app/TUI/Draw.hs @@ -62,49 +62,47 @@ drawExam s = ] where mQuestion = currentQuestion s - questionPanel = - withBorderStyle unicode $ - borderWithLabel + withBorderStyle unicode + $ borderWithLabel ( str $ " Question " ++ show (s ^. currentIndex + 1) ++ " of " ++ show (totalQuestions s) ++ " " - ) $ - hLimitPercent 50 $ - padAll 1 $ - case mQuestion of - Nothing -> str "No question" - Just q -> txtWrap (questionText q) + ) + $ padAll 1 + $ case mQuestion of + Nothing -> str "No question" + Just q -> txtWrap (text q) answersPanel = withBorderStyle unicode $ borderWithLabel (str " Answers ") $ - hLimitPercent 50 $ - padAll 1 $ - case mQuestion of - Nothing -> str "No answers" - Just q -> - let result = evalAnswer q (s ^. selectedAnswers) - in vBox $ zipWith (drawAnswer s result) [0 ..] (questionAnswerChoices q) + padAll 1 $ + case mQuestion of + Nothing -> str "No answers" + Just q -> + let result = evalAnswer q (s ^. selectedAnswers) + in vBox $ zipWith (drawAnswer s result) [0 ..] (answerChoices q) statusBar = padLeftRight 1 $ - hBox - [ str $ "Score: " ++ show (s ^. score) ++ "/" ++ show (s ^. currentIndex) - , str $ " Time: " ++ formatTime (s ^. elapsedSeconds) - , fill ' ' - , case s ^. phase of - Answering -> - clickable SubmitButton $ - withAttr submitAttr $ - str " [Enter] Submit " - Reviewing -> - clickable NextButton $ - withAttr nextAttr $ - str " [Enter] Next " - Finished -> str "" - , fill ' ' - , str "[q] Quit [Space] Toggle [Arrow Keys] Navigate" - ] + vLimitPercent 10 $ + hBox + [ str $ "Score: " ++ show (s ^. score) ++ "/" ++ show (totalQuestions s) + , str $ " Time: " ++ formatTime (s ^. elapsedSeconds) + , fill ' ' + , case s ^. phase of + Answering -> + clickable SubmitButton $ + withAttr submitAttr $ + str " [Enter] Submit " + Reviewing -> + clickable NextButton $ + withAttr nextAttr $ + str " [Enter] Next " + Finished -> str "" + , fill ' ' + , str "[q] Quit [Space] Toggle [Arrow Keys] Navigate" + ] drawAnswer :: AppState -> AnswerResult -> Int -> Text -> Widget Name drawAnswer s result idx answerText = @@ -115,9 +113,9 @@ drawAnswer s result idx answerText = where selected = IS.member idx (s ^. selectedAnswers) focused = s ^. focusedAnswer == idx && s ^. phase == Answering - isCorrectSelection = IS.member idx (answerResultCorrect result) - isMissed = IS.member idx (answerResultMissing result) - isWrong = IS.member idx (answerResultWrong result) + isCorrectSelection = IS.member idx (correct result) + isMissed = IS.member idx (missing result) + isWrong = IS.member idx (wrong result) applyFocus w = if focused then withAttr focusedAttr w else w @@ -142,4 +140,3 @@ drawAnswer s result idx answerText = | isWrong -> withAttr wrongAttr wrappedText | otherwise -> wrappedText _ -> wrappedText - diff --git a/app/TUI/Event.hs b/app/TUI/Event.hs index ef636bc..1475ca4 100644 --- a/app/TUI/Event.hs +++ b/app/TUI/Event.hs @@ -18,28 +18,31 @@ import Types (Question (..), isCorrect) data CustomEvent = Tick handleEvent :: BrickEvent Name CustomEvent -> EventM Name AppState () -handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt -handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt -handleEvent (VtyEvent (V.EvKey (V.KChar 'Q') [])) = halt -handleEvent (VtyEvent (V.EvKey V.KEnter [])) = do - s <- get - case s ^. phase of - Answering -> submitAnswer - Reviewing -> nextQuestion - Finished -> halt -handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = - whenPhase Answering $ do +handleEvent (VtyEvent (V.EvKey key [])) = case key of + V.KEsc -> halt + V.KChar 'q' -> halt + V.KChar 'Q' -> halt + V.KUp -> moveFocus (-1) + V.KChar 'k' -> moveFocus (-1) + V.KDown -> moveFocus 1 + V.KChar 'j' -> moveFocus 1 + V.KEnter -> do + s <- get + case s ^. phase of + Answering -> submitAnswer + Reviewing -> nextQuestion + Finished -> halt + V.KChar ' ' -> whenPhase Answering $ do mQ <- gets currentQuestion case mQ of Just q -> do s <- get - let numAnswers = length (questionAnswerChoices q) + let numAnswers = length (answerChoices q) idx = s ^. focusedAnswer when (idx < numAnswers) $ selectedAnswers .= toggleAnswerPure idx (s ^. selectedAnswers) Nothing -> return () -handleEvent (VtyEvent (V.EvKey V.KUp [])) = moveFocus (-1) -handleEvent (VtyEvent (V.EvKey V.KDown [])) = moveFocus 1 + _ -> return () handleEvent (MouseDown (AnswerChoice idx) _ _ _) = whenPhase Answering $ do sel <- use selectedAnswers @@ -75,7 +78,7 @@ moveFocus delta = case mQ of Just q -> do current <- use focusedAnswer - let numAnswers = length (questionAnswerChoices q) + let numAnswers = length (answerChoices q) focusedAnswer .= moveFocusPure delta current numAnswers Nothing -> return () diff --git a/cert-prep.cabal b/cert-prep.cabal index 8cd0969..26f0340 100644 --- a/cert-prep.cabal +++ b/cert-prep.cabal @@ -14,6 +14,7 @@ build-type: Simple library exposed-modules: + Registry Sampling Types Util @@ -22,9 +23,13 @@ library build-depends: aeson, base <5, + bytestring, containers, + directory, + filepath, random, - text + text, + time hs-source-dirs: src default-extensions: @@ -38,6 +43,7 @@ executable cert-prep CLI State TUI.Attributes + TUI.ConfigSelect TUI.Draw TUI.Event Paths_cert_prep @@ -54,6 +60,7 @@ executable cert-prep optparse-applicative, random, text, + time, vector, vty, vty-crossplatform @@ -74,6 +81,7 @@ test-suite spec StateSpec UtilSpec EventSpec + RegistrySpec State TUI.Event hs-source-dirs: @@ -89,14 +97,18 @@ test-suite spec aeson, base <5, brick, + bytestring, cert-prep, containers, + directory, hspec, microlens, microlens-mtl, microlens-th, random, + temporary, text, + time, vector, vty default-language: GHC2021 diff --git a/package.yaml b/package.yaml index 77d1590..2e9d811 100644 --- a/package.yaml +++ b/package.yaml @@ -21,7 +21,11 @@ library: - -O2 dependencies: - aeson + - bytestring + - directory + - filepath - random + - time executables: cert-prep: @@ -43,6 +47,7 @@ executables: - microlens-th - optparse-applicative - random + - time - vector - vty - vty-crossplatform @@ -64,12 +69,15 @@ tests: - StateSpec - UtilSpec - EventSpec + - RegistrySpec - State - TUI.Event dependencies: - aeson + - bytestring - cert-prep - containers + - directory - hspec - microlens - microlens-mtl @@ -77,5 +85,7 @@ tests: - brick - QuickCheck - random + - temporary + - time - vector - vty diff --git a/src/Registry.hs b/src/Registry.hs new file mode 100644 index 0000000..060b719 --- /dev/null +++ b/src/Registry.hs @@ -0,0 +1,81 @@ +module Registry ( + RegistryEntry (..), + Registry, + registryFilePath, + loadRegistry, + saveRegistry, + registerConfig, +) where + +import Data.Aeson ( + FromJSON, + ToJSON, + eitherDecodeStrict, + ) +import Data.ByteString qualified as BS +import Data.List (sortBy) +import Data.Ord (Down (..), comparing) +import Data.Text (Text) +import Data.Time (UTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.Directory ( + XdgDirectory (XdgConfig), + canonicalizePath, + createDirectoryIfMissing, + doesFileExist, + getXdgDirectory, + ) +import System.FilePath (takeDirectory, ()) + +import Data.Aeson qualified as Aeson + +data RegistryEntry = RegistryEntry + { title :: Text + , path :: FilePath + , lastUsed :: UTCTime + } + deriving (Show, Eq, Generic) + +type Registry = [RegistryEntry] + +instance FromJSON RegistryEntry +instance ToJSON RegistryEntry + +registryFilePath :: IO FilePath +registryFilePath = do + dir <- getXdgDirectory XdgConfig "cert-prep" + pure $ dir "registry.json" + +loadRegistry :: IO Registry +loadRegistry = do + path <- registryFilePath + exists <- doesFileExist path + if not exists + then pure [] + else do + bytes <- BS.readFile path + case eitherDecodeStrict bytes of + Left _ -> pure [] + Right entries -> pure entries + +saveRegistry :: Registry -> IO () +saveRegistry entries = do + p <- registryFilePath + createDirectoryIfMissing True (takeDirectory p) + BS.writeFile p (BS.toStrict $ Aeson.encode entries) + +registerConfig :: FilePath -> Text -> IO () +registerConfig p title = do + canonPath <- canonicalizePath p + now <- getCurrentTime + existing <- loadRegistry + let entry = + RegistryEntry + { title = title + , path = canonPath + , lastUsed = now + } + updated = + sortBy (comparing (Down . lastUsed)) $ + entry : filter (\e -> path e /= canonPath) existing + saveRegistry updated diff --git a/src/Sampling.hs b/src/Sampling.hs index a5170eb..cb02d2b 100644 --- a/src/Sampling.hs +++ b/src/Sampling.hs @@ -8,7 +8,6 @@ module Sampling ( import Data.List (foldl', sortBy) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust, isJust) import Data.Ord (Down (..), comparing) import System.Random (RandomGen, SplitGen, splitGen, uniformR) import Types (Category, Question (..)) @@ -38,7 +37,7 @@ sampleStratified gen n weights qs = grouped = Map.fromListWith (++) - [(fromJust (questionCategory q), [q]) | q <- qs, isJust (questionCategory q)] + [(cat, [q]) | q <- qs, Just cat <- [category q]] avails :: Map Category Int avails = Map.map length grouped @@ -150,8 +149,9 @@ concatSamples :: Map Category Int -> Map Category [Question] -> [Question] -concatSamples gen0 allocs grouped = shuffle gen0 $ go gen0 cats +concatSamples gen0 allocs grouped = shuffle genShuffle $ go genSample cats where + (genSample, genShuffle) = splitGen gen0 cats = Map.toAscList allocs go _ [] = [] go g ((cat, count) : rest) = sampled ++ go g2 rest diff --git a/src/Types.hs b/src/Types.hs index 18e4301..33bf527 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -8,19 +8,9 @@ module Types ( Config (..), ) where -import Data.Aeson ( - FromJSON (parseJSON), - Options (fieldLabelModifier), - ToJSON (toJSON), - defaultOptions, - genericParseJSON, - genericToJSON, - ) -import Data.Char (toLower) +import Data.Aeson (FromJSON, ToJSON) import Data.IntSet (IntSet, difference, intersection) -import Data.List (stripPrefix) import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics (Generic) @@ -29,55 +19,41 @@ type Answer = IntSet type Category = Text data Question = Question - { questionText :: Text - , questionAnswerChoices :: [Text] - , questionCorrectAnswer :: Answer - , questionCategory :: Maybe Category + { text :: Text + , answerChoices :: [Text] + , correctAnswer :: Answer + , category :: Maybe Category } deriving (Show, Eq, Generic) data AnswerResult = AnswerResult - { answerResultCorrect :: IntSet - , answerResultMissing :: IntSet - , answerResultWrong :: IntSet + { correct :: IntSet + , missing :: IntSet + , wrong :: IntSet } deriving (Show, Eq) evalAnswer :: Question -> Answer -> AnswerResult evalAnswer q ans = AnswerResult - { answerResultCorrect = questionCorrectAnswer q `intersection` ans - , answerResultMissing = questionCorrectAnswer q `difference` ans - , answerResultWrong = ans `difference` questionCorrectAnswer q + { correct = correctAnswer q `intersection` ans + , missing = correctAnswer q `difference` ans + , wrong = ans `difference` correctAnswer q } isCorrect :: Question -> Answer -> Bool -isCorrect q ans = questionCorrectAnswer q == ans +isCorrect q ans = correctAnswer q == ans data Config = Config - { configQuestions :: [Question] - , configSampleAmount :: Int - , configCategoryWeights :: Maybe (Map Text Int) + { title :: Text + , questions :: [Question] + , sampleAmount :: Int + , categoryWeights :: Maybe (Map Text Int) } deriving (Show, Eq, Generic) -toLowerFirstLetter :: String -> String -toLowerFirstLetter [] = [] -toLowerFirstLetter (x : xs) = toLower x : xs +instance FromJSON Question +instance ToJSON Question -prefixStripOptions :: String -> Options -prefixStripOptions prefix = - defaultOptions - { fieldLabelModifier = \s -> - toLowerFirstLetter $ fromMaybe s (stripPrefix prefix s) - } - -instance FromJSON Question where - parseJSON = genericParseJSON (prefixStripOptions "question") -instance ToJSON Question where - toJSON = genericToJSON (prefixStripOptions "question") - -instance FromJSON Config where - parseJSON = genericParseJSON (prefixStripOptions "config") -instance ToJSON Config where - toJSON = genericToJSON (prefixStripOptions "config") +instance FromJSON Config +instance ToJSON Config diff --git a/test/Generators.hs b/test/Generators.hs index 98b51ac..8e616c2 100644 --- a/test/Generators.hs +++ b/test/Generators.hs @@ -26,10 +26,10 @@ categoryPool = mkQuestion :: Text -> [Text] -> [Int] -> Maybe Text -> Question mkQuestion text choices correct cat = Question - { questionText = text - , questionAnswerChoices = choices - , questionCorrectAnswer = IS.fromList correct - , questionCategory = cat + { text = text + , answerChoices = choices + , correctAnswer = IS.fromList correct + , category = cat } arbitraryQuestion :: Gen Question @@ -47,10 +47,10 @@ arbitraryQuestion = do else pure Nothing pure Question - { questionText = text - , questionAnswerChoices = choices - , questionCorrectAnswer = IS.fromList correctIndices - , questionCategory = cat + { text = text + , answerChoices = choices + , correctAnswer = IS.fromList correctIndices + , category = cat } questionsWithCategories :: [Text] -> Gen [Question] @@ -62,7 +62,7 @@ questionsWithCategories cats = do n <- chooseInt (1, count) vectorOf n $ do q <- arbitraryQuestion - pure q{questionCategory = Just cat} + pure q{category = Just cat} largeQuestionsWithCategories :: [Text] -> Gen [Question] largeQuestionsWithCategories cats = do @@ -72,23 +72,34 @@ largeQuestionsWithCategories cats = do n <- chooseInt (5, 10) vectorOf n $ do q <- arbitraryQuestion - pure q{questionCategory = Just cat} + pure q{category = Just cat} instance Arbitrary Question where arbitrary = arbitraryQuestion +titlePool :: [Text] +titlePool = + [ "AWS Solutions Architect" + , "Azure Fundamentals" + , "GCP Associate" + , "Kubernetes Admin" + ] + instance Arbitrary Config where arbitrary = do + title <- elements titlePool qs <- listOf arbitraryQuestion n <- chooseInt (0, 100) useWeights <- arbitrary weights <- if useWeights - then Just . Map.fromList <$> listOf ((,) <$> elements categoryPool <*> chooseInt (1, 10)) + then + Just . Map.fromList <$> listOf ((,) <$> elements categoryPool <*> chooseInt (1, 10)) else pure Nothing pure Config - { configQuestions = qs - , configSampleAmount = n - , configCategoryWeights = weights + { title = title + , questions = qs + , sampleAmount = n + , categoryWeights = weights } diff --git a/test/RegistrySpec.hs b/test/RegistrySpec.hs new file mode 100644 index 0000000..3435f7c --- /dev/null +++ b/test/RegistrySpec.hs @@ -0,0 +1,91 @@ +module RegistrySpec (spec) where + +import Data.Aeson (decode, encode) +import Data.Text (Text) +import Data.Time (UTCTime, getCurrentTime) +import Registry +import System.Environment (setEnv) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +mkEntry :: Text -> FilePath -> UTCTime -> RegistryEntry +mkEntry title path lastUsed = + RegistryEntry + { title = title + , path = path + , lastUsed = lastUsed + } + +spec :: Spec +spec = do + describe "RegistryEntry JSON" $ do + it "roundtrips through JSON" $ do + now <- getCurrentTime + let entry = mkEntry "Test Config" "/tmp/test.json" now + decode (encode entry) `shouldBe` Just entry + + it "roundtrips a list through JSON" $ do + now <- getCurrentTime + let entries = + [ mkEntry "Config A" "/a.json" now + , mkEntry "Config B" "/b.json" now + ] + decode (encode entries) `shouldBe` Just entries + + describe "loadRegistry / saveRegistry" $ do + it "returns [] when no registry file exists" $ do + withSystemTempDirectory "cert-prep-test" $ \tmpDir -> do + setEnv "XDG_CONFIG_HOME" tmpDir + registry <- loadRegistry + registry `shouldBe` [] + + it "roundtrips entries through save/load" $ do + withSystemTempDirectory "cert-prep-test" $ \tmpDir -> do + setEnv "XDG_CONFIG_HOME" tmpDir + now <- getCurrentTime + let entries = + [ mkEntry "Config A" "/a.json" now + , mkEntry "Config B" "/b.json" now + ] + saveRegistry entries + loaded <- loadRegistry + loaded `shouldBe` entries + + describe "registerConfig" $ do + it "adds a new entry" $ do + withSystemTempDirectory "cert-prep-test" $ \tmpDir -> do + setEnv "XDG_CONFIG_HOME" tmpDir + -- Create a dummy file to canonicalize + let configPath = tmpDir <> "/test.json" + writeFile configPath "{}" + registerConfig configPath "My Config" + registry <- loadRegistry + case registry of + [e] -> title e `shouldBe` "My Config" + _ -> expectationFailure $ "Expected 1 entry, got " ++ show (length registry) + + it "upserts existing entry by path" $ do + withSystemTempDirectory "cert-prep-test" $ \tmpDir -> do + setEnv "XDG_CONFIG_HOME" tmpDir + let configPath = tmpDir <> "/test.json" + writeFile configPath "{}" + registerConfig configPath "Title v1" + registerConfig configPath "Title v2" + registry <- loadRegistry + case registry of + [e] -> title e `shouldBe` "Title v2" + _ -> expectationFailure $ "Expected 1 entry, got " ++ show (length registry) + + it "keeps entries sorted by lastUsed descending" $ do + withSystemTempDirectory "cert-prep-test" $ \tmpDir -> do + setEnv "XDG_CONFIG_HOME" tmpDir + let pathA = tmpDir <> "/a.json" + pathB = tmpDir <> "/b.json" + writeFile pathA "{}" + writeFile pathB "{}" + registerConfig pathA "Config A" + registerConfig pathB "Config B" + registry <- loadRegistry + case registry of + (e : _) -> title e `shouldBe` "Config B" + [] -> expectationFailure "Expected non-empty registry" diff --git a/test/SamplingSpec.hs b/test/SamplingSpec.hs index 9356240..3849885 100644 --- a/test/SamplingSpec.hs +++ b/test/SamplingSpec.hs @@ -111,7 +111,7 @@ spec = do (Stratified narrowWeights) qs in all - (\q -> questionCategory q == Just "AWS Storage") + (\q -> category q == Just "AWS Storage") result === True @@ -144,7 +144,7 @@ spec = do ] allQs = noCatQs ++ catQs result = sampleQuestions (mkStdGen 42) 10 (Stratified weights) allQs - all (isJust . questionCategory) result `shouldBe` True + all (isJust . category) result `shouldBe` True it "single category in weights" $ do let singleWeight = Map.fromList [("AWS Storage", 1)] @@ -155,7 +155,7 @@ spec = do ] result = sampleQuestions (mkStdGen 42) 3 (Stratified singleWeight) qs length result `shouldBe` 2 - all (\q -> questionCategory q == Just "AWS Storage") result `shouldBe` True + all (\q -> category q == Just "AWS Storage") result `shouldBe` True it "per-category counts approximate weight proportions" $ property $ @@ -164,7 +164,7 @@ spec = do Map.fromListWith (+) $ [ (c, 1 :: Int) | q <- qs - , Just c <- [questionCategory q] + , Just c <- [category q] , Map.member c weights ] -- Only test when every weighted category has @@ -184,7 +184,7 @@ spec = do countCat c = length $ filter - (\q -> questionCategory q == Just c) + (\q -> category q == Just c) result in conjoin [ let ideal = @@ -214,6 +214,6 @@ spec = do ] hasWeightedCategory :: Map.Map Text Int -> Question -> Bool -hasWeightedCategory weights q = case questionCategory q of +hasWeightedCategory weights q = case category q of Just c -> Map.member c weights Nothing -> False diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs index 15bbdef..79035da 100644 --- a/test/TypesSpec.hs +++ b/test/TypesSpec.hs @@ -43,110 +43,113 @@ spec = do let withExtra = "{\"text\":\"Q\",\"answerChoices\":[\"A\"],\"correctAnswer\":[0],\"bonus\":true}" case decode withExtra :: Maybe Question of Nothing -> expectationFailure "Should accept JSON with extra fields" - Just q' -> questionText q' `shouldBe` "Q" + Just q' -> text q' `shouldBe` "Q" describe "Config JSON" $ do it "roundtrips Config through JSON" $ property $ \(c :: Config) -> decode (encode c) === Just c it "parses config with category weights" $ do - let raw = "{\"questions\":[],\"sampleAmount\":10,\"categoryWeights\":{\"AWS Storage\":2}}" + let raw = + "{\"title\":\"Test\",\"questions\":[],\"sampleAmount\":10,\"categoryWeights\":{\"AWS Storage\":2}}" case decode raw :: Maybe Config of Nothing -> expectationFailure "Failed to parse config with weights" Just c -> do - configSampleAmount c `shouldBe` 10 - configQuestions c `shouldBe` [] - configCategoryWeights c `shouldNotBe` Nothing + sampleAmount c `shouldBe` 10 + questions c `shouldBe` [] + categoryWeights c `shouldNotBe` Nothing it "parses config without category weights" $ do - let raw = "{\"questions\":[],\"sampleAmount\":5}" + let raw = "{\"title\":\"Test\",\"questions\":[],\"sampleAmount\":5}" case decode raw :: Maybe Config of Nothing -> expectationFailure "Failed to parse config without weights" Just c -> do - configSampleAmount c `shouldBe` 5 - configCategoryWeights c `shouldBe` Nothing + sampleAmount c `shouldBe` 5 + categoryWeights c `shouldBe` Nothing it "rejects config missing required fields" $ do - let noQuestions = "{\"sampleAmount\":5}" - noSampleAmount = "{\"questions\":[]}" + let noQuestions = "{\"title\":\"T\",\"sampleAmount\":5}" + noSampleAmount = "{\"title\":\"T\",\"questions\":[]}" + noTitle = "{\"questions\":[],\"sampleAmount\":5}" (decode noQuestions :: Maybe Config) `shouldBe` Nothing (decode noSampleAmount :: Maybe Config) `shouldBe` Nothing + (decode noTitle :: Maybe Config) `shouldBe` Nothing it "parses config with zero sample amount" $ do - let raw = "{\"questions\":[],\"sampleAmount\":0}" + let raw = "{\"title\":\"Test\",\"questions\":[],\"sampleAmount\":0}" case decode raw :: Maybe Config of Nothing -> expectationFailure "Failed to parse config with sampleAmount 0" - Just c -> configSampleAmount c `shouldBe` 0 + Just c -> sampleAmount c `shouldBe` 0 it "parses config with negative sample amount" $ do - let raw = "{\"questions\":[],\"sampleAmount\":-5}" + let raw = "{\"title\":\"Test\",\"questions\":[],\"sampleAmount\":-5}" case decode raw :: Maybe Config of Nothing -> expectationFailure "Failed to parse config with negative sampleAmount" - Just c -> configSampleAmount c `shouldBe` (-5) + Just c -> sampleAmount c `shouldBe` (-5) describe "Eval Answers" $ do - let q' = q{questionCorrectAnswer = fromList [1, 2]} + let q' = q{correctAnswer = fromList [1, 2]} it "should check correct answers" $ do isCorrect q (fromList [1]) `shouldBe` True isCorrect q (fromList [2]) `shouldBe` False it "should correctly report missing and wrong answers" $ do evalAnswer q' (fromList [0, 1]) `shouldBe` AnswerResult - { answerResultCorrect = fromList [1] - , answerResultMissing = fromList [2] - , answerResultWrong = fromList [0] + { correct = fromList [1] + , missing = fromList [2] + , wrong = fromList [0] } it "returns all correct when answer matches exactly" $ do let result = evalAnswer q' (fromList [1, 2]) - answerResultCorrect result `shouldBe` fromList [1, 2] - answerResultMissing result `shouldBe` IS.empty - answerResultWrong result `shouldBe` IS.empty + correct result `shouldBe` fromList [1, 2] + missing result `shouldBe` IS.empty + wrong result `shouldBe` IS.empty it "returns all missing when answer is empty" $ do let result = evalAnswer q' IS.empty - answerResultCorrect result `shouldBe` IS.empty - answerResultMissing result `shouldBe` fromList [1, 2] - answerResultWrong result `shouldBe` IS.empty + correct result `shouldBe` IS.empty + missing result `shouldBe` fromList [1, 2] + wrong result `shouldBe` IS.empty it "returns all wrong when no correct answers selected" $ do let result = evalAnswer q' (fromList [0, 3]) - answerResultCorrect result `shouldBe` IS.empty - answerResultMissing result `shouldBe` fromList [1, 2] - answerResultWrong result `shouldBe` fromList [0, 3] + correct result `shouldBe` IS.empty + missing result `shouldBe` fromList [1, 2] + wrong result `shouldBe` fromList [0, 3] it "handles question with empty correct answer set" $ do - let emptyQ = q{questionCorrectAnswer = IS.empty} + let emptyQ = q{correctAnswer = IS.empty} result = evalAnswer emptyQ (fromList [0, 1]) - answerResultCorrect result `shouldBe` IS.empty - answerResultMissing result `shouldBe` IS.empty - answerResultWrong result `shouldBe` fromList [0, 1] + correct result `shouldBe` IS.empty + missing result `shouldBe` IS.empty + wrong result `shouldBe` fromList [0, 1] it "isCorrect with both empty correct set and empty answer" $ do - let emptyQ = q{questionCorrectAnswer = IS.empty} + let emptyQ = q{correctAnswer = IS.empty} isCorrect emptyQ IS.empty `shouldBe` True it "handles question with zero answer choices" $ do let noChoicesQ = mkQuestion "Empty?" [] [] Nothing result = evalAnswer noChoicesQ IS.empty - answerResultCorrect result `shouldBe` IS.empty - answerResultMissing result `shouldBe` IS.empty - answerResultWrong result `shouldBe` IS.empty + correct result `shouldBe` IS.empty + missing result `shouldBe` IS.empty + wrong result `shouldBe` IS.empty isCorrect noChoicesQ IS.empty `shouldBe` True it "partitions into disjoint sets covering all relevant indices" $ property $ \(q'' :: Question) -> - let numChoices = length (questionAnswerChoices q'') + let numChoices = length (answerChoices q'') in forAll (sublistOf [0 .. numChoices - 1]) $ \selected -> let ans = IS.fromList selected result = evalAnswer q'' ans - c = answerResultCorrect result - m = answerResultMissing result - w = answerResultWrong result + c = correct result + m = missing result + w = wrong result in conjoin [ IS.intersection c m === IS.empty , IS.intersection c w === IS.empty , IS.intersection m w === IS.empty , IS.union c m - === questionCorrectAnswer q'' + === correctAnswer q'' , IS.union c w === ans ] it "isCorrect iff evalAnswer has empty missing and wrong" $ property $ \(q'' :: Question) -> - let numChoices = length (questionAnswerChoices q'') + let numChoices = length (answerChoices q'') in forAll (sublistOf [0 .. numChoices - 1]) $ \selected -> let ans = IS.fromList selected result = evalAnswer q'' ans - m = answerResultMissing result - w = answerResultWrong result + m = missing result + w = wrong result in isCorrect q'' ans === (IS.null m && IS.null w)