Add user subscription field

Also improved the test situation, did some refactors, and now listing the user's
past analyses on their account page.

5 files changed, 235 insertions, 64 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index ab6f5bb..ed34009 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -149,7 +149,7 @@ main = Cli.main <| Cli.Plan help move test
   where
     test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)]
     move args =
-      IO.hSetBuffering stdout IO.NoBuffering
+      IO.hSetBuffering stdout IO.LineBuffering
         >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
         /> catMaybes
         /> filter isBuildableNs
diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 3836ef7..835d97b 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ExtendedDefaultRules #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
@@ -55,16 +56,19 @@ import Biz.App (CSS (..), HtmlApp (..))
 import qualified Biz.Cli as Cli
 import qualified Biz.Id as Id
 import qualified Biz.Look
-import Biz.Test ((@=?))
+import Biz.Test ((@=?), (@?!=))
 import qualified Biz.Test as Test
 import qualified CMark as Cmark
 import qualified CMark.Lucid as Cmark
 import Clay (em, pct, px, rem, sec, (?))
 import qualified Clay
+import qualified Clay.Font
+import qualified Clay.Render as Clay
 import qualified Control.Exception as Exception
 import Crypto.JOSE.JWK (JWK)
 import Data.Acid (makeAcidic)
 import qualified Data.Acid as Acid
+import qualified Data.Acid.Advanced as Acid
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as LBS
 import Data.Data (Data, Typeable)
@@ -75,7 +79,8 @@ import Data.SafeCopy (base, deriveSafeCopy)
 import qualified Data.String as String
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
-import qualified Data.Time.Clock as Clock
+import qualified Data.Time.Calendar as Time
+import qualified Data.Time.Clock as Time
 import qualified Data.Time.Format as Time
 import Data.Vector (Vector)
 import qualified Data.Vector as Vector
@@ -102,7 +107,10 @@ import qualified Web.FormUrlEncoded
 
 -- * persistent data
 
--- this must go first because of template haskell splicing
+-- This must go first because of template haskell splicing.
+--
+-- When changing a persisted type T, first make `T0 == T`, then make the
+-- `SafeCopy.Migrate T` class compile, then make changes to `T`.
 
 newtype UserEmail = UserEmail {unUserEmail :: Text}
   deriving (Eq, Ord, Data, Typeable, Generic, Show)
@@ -132,12 +140,27 @@ instance Auth.FromJWT GitHubId
 
 $(deriveSafeCopy 0 'base ''GitHubId)
 
+data Subscription = Free | Invoice
+  deriving (Eq, Data, Typeable, Ord, Generic, Show)
+
+instance Aeson.ToJSON Subscription
+
+instance Aeson.FromJSON Subscription
+
+instance Auth.ToJWT Subscription
+
+instance Auth.FromJWT Subscription
+
+$(deriveSafeCopy 0 'base ''Subscription)
+
 -- | The main representation of a user.
 data User = User
   { userEmail :: UserEmail,
     userGitHubId :: GitHubId,
     -- | So we can make GitHub API calls on their behalf.
-    userGitHubToken :: Text
+    userGitHubToken :: Text,
+    userSubscription :: Subscription,
+    userId :: Id.Id User
   }
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
@@ -154,18 +177,27 @@ $(deriveSafeCopy 0 'base ''User)
 instance Indexable User where
   empty =
     ixSet
-      [ ixFun <| \u -> [userEmail u],
-        ixFun <| \u -> [userGitHubId u]
+      [ ixFun <| \User {..} -> [userEmail],
+        ixFun <| \User {..} -> [userGitHubId],
+        ixFun <| \User {..} -> [userSubscription]
       ]
 
 newtype Commit = Sha Text
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
+instance Lucid.ToHtml Commit where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (Sha txt) = Lucid.toHtml txt
+
 $(deriveSafeCopy 0 'base ''Commit)
 
 newtype URL = URL Text
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
+instance Lucid.ToHtml URL where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (URL txt) = Lucid.toHtml txt
+
 $(deriveSafeCopy 0 'base ''URL)
 
 -- | The result of analyzing a git repo.
@@ -192,7 +224,7 @@ data Analysis = Analysis
     -- | Which commit this analysis was run against.
     commit :: Commit,
     -- | Who asked for this analysis
-    askedBy :: User
+    askedBy :: Id.Id User
   }
   deriving (Eq, Ord, Generic, Show, Data, Typeable)
 
@@ -211,6 +243,7 @@ instance Indexable Analysis where
 -- | The database.
 data Keep = Keep
   { users :: IxSet User,
+    nextUserId :: Id.Id User,
     analyses :: IxSet Analysis,
     nextAnalysisId :: Id.Id Analysis
   }
@@ -221,13 +254,18 @@ $(deriveSafeCopy 0 'base ''Keep)
 createUser :: User -> Acid.Update Keep User
 createUser u = do
   keep <- get
-  put <| keep {users = IxSet.insert u (users keep)}
-  return u
+  let newUser = u {userId = nextUserId keep}
+  put
+    <| keep
+      { users = IxSet.insert newUser (users keep),
+        nextUserId = succ <| nextUserId keep
+      }
+  return newUser
 
 updateUser :: User -> Acid.Update Keep User
-updateUser u = do
+updateUser u@User {..} = do
   keep <- get
-  put <| keep {users = IxSet.updateIx (userGitHubId u) u (users keep)}
+  put <| keep {users = IxSet.updateIx userGitHubId u (users keep)}
   return u
 
 getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User)
@@ -235,22 +273,31 @@ getUserByEmail email = do
   Keep {..} <- ask
   return <| IxSet.getOne <| users @= email
 
+getUsers :: Acid.Query Keep [User]
+getUsers = do
+  Keep {..} <- ask
+  return <| IxSet.toList users
+
 createAnalysis :: Analysis -> Acid.Update Keep Analysis
 createAnalysis a = do
   keep@Keep {..} <- get
+  let newAnalysis = a {analysisId = nextAnalysisId}
   put
     <| keep
-      { analyses = IxSet.insert a analyses,
-        nextAnalysisId =
-          succ
-            nextAnalysisId
+      { analyses = IxSet.insert newAnalysis analyses,
+        nextAnalysisId = succ nextAnalysisId
       }
-  return a
+  return newAnalysis
+
+getAnalyses :: Acid.Query Keep [Analysis]
+getAnalyses = do
+  Keep {..} <- ask
+  return <| IxSet.toList analyses
 
 getAnalysesByAsker :: User -> Acid.Query Keep [Analysis]
 getAnalysesByAsker user = do
   Keep {..} <- ask
-  return <| IxSet.toList <| analyses @= user
+  return <| IxSet.toList <| analyses @= userId user
 
 getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis)
 getAnalysisByUrlAndCommit url sha = do
@@ -261,8 +308,10 @@ $( makeAcidic
      ''Keep
      [ 'createUser,
        'updateUser,
+       'getUsers,
        'getUserByEmail,
        'createAnalysis,
+       'getAnalyses,
        'getAnalysesByAsker,
        'getAnalysisByUrlAndCommit
      ]
@@ -270,7 +319,6 @@ $( makeAcidic
 
 upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User
 upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of
-  -- Nothing -> throwError err502 { errBody = "No user email" }
   Nothing -> panic "No user email"
   Just email ->
     Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case
@@ -283,13 +331,49 @@ upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of
             User
               { userEmail = UserEmail email,
                 userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
-                userGitHubToken = Encoding.decodeUtf8 tok
+                userGitHubToken = Encoding.decodeUtf8 tok,
+                userSubscription = Free,
+                userId = mempty
               }
 
+test_upsertGitHubUser :: IO (Config, Application, Acid.AcidState Keep) -> Test.Tree
+test_upsertGitHubUser load =
+  Test.group
+    "upsertUser"
+    [ Test.unit "userId is not mempty" <| do
+        (_, _, k) <- load
+        User {..} <- upsertGitHubUser k "token" ghUser
+        userId @?!= mempty
+    ]
+  where
+    ghUser =
+      GitHub.User
+        { GitHub.userId = GitHub.mkId (Proxy :: Proxy GitHub.User) 123,
+          GitHub.userEmail = Just "user@example.com",
+          GitHub.userLogin = "example",
+          GitHub.userName = Nothing,
+          GitHub.userType = GitHub.OwnerUser,
+          GitHub.userCreatedAt =
+            Time.UTCTime (Time.ModifiedJulianDay 1) (Time.secondsToDiffTime 100),
+          GitHub.userPublicGists = 123,
+          GitHub.userAvatarUrl = GitHub.URL "http://example.com",
+          GitHub.userFollowers = 0,
+          GitHub.userFollowing = 0,
+          GitHub.userHireable = Nothing,
+          GitHub.userBlog = Nothing,
+          GitHub.userBio = Nothing,
+          GitHub.userPublicRepos = 0,
+          GitHub.userLocation = Nothing,
+          GitHub.userCompany = Nothing,
+          GitHub.userUrl = GitHub.URL "http://example.com",
+          GitHub.userHtmlUrl = GitHub.URL "http://example.com"
+        }
+
 init :: Keep
 init =
   Keep
     { nextAnalysisId = Id.mk (Proxy :: Proxy Analysis) 1,
+      nextUserId = Id.mk (Proxy :: Proxy User) 1,
       users = IxSet.empty,
       analyses = IxSet.empty
     }
@@ -311,29 +395,32 @@ Usage:
 
 move :: Cli.Arguments -> IO ()
 move _ = Exception.bracket startup shutdown run
-  where
-    startup = do
-      cfg <- Envy.decodeWithDefaults Envy.defConfig
-      oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
-      kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep)
-      jwk <- Auth.generateKey
-      putText "@"
-      putText "devalloc"
-      putText <| "area: " <> (show <| area cfg)
-      putText <| "port: " <> (show <| port cfg)
-      putText <| "depo: " <> (Text.pack <| depo cfg)
-      putText <| "keep: " <> (Text.pack <| keep cfg)
-      let jwtCfg = Auth.defaultJWTSettings jwk
-      let cooks = case area cfg of
-            Test -> testCookieSettings
-            Live -> liveCookieSettings
-      let ctx = cooks :. jwtCfg :. EmptyContext
-      let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs)
-      return (cfg, app, kp)
-    shutdown :: (Config, Application, Acid.AcidState Keep) -> IO ()
-    shutdown (_, _, kp) = Acid.closeAcidState kp
-    run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO ()
-    run (cfg, app, _) = Warp.run (port cfg) (logStdout app)
+
+startup :: IO (Config, Application, Acid.AcidState Keep)
+startup = do
+  cfg <- Envy.decodeWithDefaults Envy.defConfig
+  oAuthArgs <- Envy.decodeWithDefaults Envy.defConfig
+  kp <- Acid.openLocalStateFrom (keep cfg) init :: IO (Acid.AcidState Keep)
+  jwk <- Auth.generateKey
+  putText "@"
+  putText "devalloc"
+  putText <| "area: " <> (show <| area cfg)
+  putText <| "port: " <> (show <| port cfg)
+  putText <| "depo: " <> (Text.pack <| depo cfg)
+  putText <| "keep: " <> (Text.pack <| keep cfg)
+  let jwtCfg = Auth.defaultJWTSettings jwk
+  let cooks = case area cfg of
+        Test -> testCookieSettings
+        Live -> liveCookieSettings
+  let ctx = cooks :. jwtCfg :. EmptyContext
+  let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs)
+  return (cfg, app, kp)
+
+shutdown :: (Config, Application, Acid.AcidState Keep) -> IO ()
+shutdown (_, _, kp) = Acid.closeAcidState kp
+
+run :: (Config, Wai.Application, Acid.AcidState Keep) -> IO ()
+run (cfg, app, _) = Warp.run (port cfg) (logStdout app)
 
 liveCookieSettings :: Auth.CookieSettings
 liveCookieSettings =
@@ -354,7 +441,8 @@ test :: Test.Tree
 test =
   Test.group
     "Biz.Devalloc"
-    [ test_calculateScore
+    [ test_calculateScore,
+      Test.with startup shutdown test_upsertGitHubUser
     ]
 
 -- * app configurations
@@ -511,16 +599,18 @@ htmlApp cooks kp cfg jwk oAuthArgs =
         Auth.NoSuchUser -> throwError err401 {errBody = "No such user"}
         Auth.BadPassword -> throwError err401 {errBody = "Bad password"}
         Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"}
-        Auth.Authenticated user -> pure <| HtmlApp <| UserHome user,
+        Auth.Authenticated user@User {..} -> do
+          analyses <- Acid.query' kp <| GetAnalysesByAsker user
+          pure <| HtmlApp <| UserHome user analyses,
       selectRepo = \case
         Auth.NoSuchUser -> throwError err401 {errBody = "No such user"}
         Auth.BadPassword -> throwError err401 {errBody = "Bad password"}
         Auth.Indefinite -> throwError err401 {errBody = "Incorrect authentication method"}
-        Auth.Authenticated user -> do
+        Auth.Authenticated user@User {..} -> do
           erepos <-
             liftIO
               <| GitHub.github
-                (GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user)
+                (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken)
                 (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll)
           case erepos of
             Left err -> throwError err502 {errBody = show err}
@@ -529,7 +619,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
         Auth.NoSuchUser -> panic "No such user"
         Auth.BadPassword -> panic "Bad password"
         Auth.Indefinite -> panic "Incorrect authentication method"
-        Auth.Authenticated user -> \owner repo ->
+        Auth.Authenticated user@User {..} -> \owner repo ->
           liftIO
             <| analyzeGitHub
               kp
@@ -605,7 +695,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
             Clay.textAlign Clay.center
             "h1" ? do
               Clay.fontSize (Clay.rem 3)
-            "h1, h2" ? do
+            "h1" <> "h2" ? do
               Clay.textAlign Clay.center
             "section" ? do
               Clay.padding (rem 3) 0 (rem 3) 0
@@ -690,21 +780,46 @@ instance Lucid.ToHtml Home where
       h1 = Lucid.h1_
       h2 = Lucid.h2_ <. markdown
 
-newtype UserHome = UserHome User
+data UserHome = UserHome User [Analysis]
+
+instance Lucid.ToHtml Subscription where
+  toHtmlRaw = Lucid.toHtml
+  toHtml Free = "Free"
+  toHtml Invoice = "Invoice me"
 
 instance Lucid.ToHtml UserHome where
   toHtmlRaw = Lucid.toHtml
-  toHtml (UserHome user) = do
+  toHtml (UserHome user@User {..} analyses) = do
     header <| Just user
     Lucid.main_ <| do
       Lucid.h1_ <. Lucid.toHtml <| "Welcome, " <> email <> "!"
+      Lucid.section_ <| do
+        Lucid.h2_ "Subscription"
+        Lucid.p_ <| do
+          "You are currently on the "
+          Lucid.strong_ <| Lucid.toHtml userSubscription
+          " plan."
+        when (userSubscription == Invoice) <| do
+          Lucid.p_ "You will received an invoice by email next month."
+      Lucid.section_ <| do
+        Lucid.h2_ "Your Analyses"
+        Lucid.div_ <| do
+          forM_ analyses <| \Analysis {..} ->
+            Lucid.a_ [{- href analysisId, -} style <| Biz.Look.marginAll (em 1)] <| do
+              Lucid.div_ <| Lucid.toHtml url
+              Lucid.div_ [style <| Clay.fontSizeCustom Clay.Font.small]
+                <| Lucid.toHtml commit
       Lucid.p_
         <| Lucid.a_
           [Lucid.linkHref_ "/" <| fieldLink selectRepo]
           "Analyze one of your repos"
     footer
     where
-      UserEmail email = userEmail user
+      -- href aid = Lucid.linkHref_ "/" <| fieldLink analysis analysisId
+      UserEmail email = userEmail
+
+style :: Clay.Css -> Lucid.Attribute
+style = Lucid.style_ <. toStrict <. Clay.renderWith Clay.htmlInline []
 
 -- | A type for parsing JSON auth responses, used in 'getAccessToken' below.
 -- Should be moved to Biz.Auth with others.
@@ -732,9 +847,11 @@ auth keep cooks jwt oAuthArgs (Just code) = do
     Right user -> return user
   user <- liftIO <| upsertGitHubUser keep token ghUser
   mApplyCookies <- liftIO <| Auth.acceptLogin cooks (Auth.defaultJWTSettings jwt) user
+  analyses <- Acid.query' keep <| GetAnalysesByAsker user
   case mApplyCookies of
     Nothing -> panic "login didn't work"
-    Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user
+    -- I think this should redirect to instead of rendering UserHome
+    Just applyCookies -> return <. applyCookies <. HtmlApp <| UserHome user analyses
 
 -- | POST to GitHub's oAuth service and return the user's oAuth token.
 -- TODO: I can also get access scope etc from this response
@@ -873,12 +990,11 @@ instance Lucid.ToHtml Analysis where
         Lucid.ul_ <| do
           forM_ stale <| \(path, days) ->
             Lucid.li_ <| Lucid.toHtml <| path <> " (" <> show days <> " days)"
-      slen = Text.pack <. show <. length
-      tshow = Text.pack <. show
+      slen = tshow <. length
 
 -- | Takes a list of active authors and a path to a bare git repo and runs a
 -- regular analysis
-analyze :: Acid.AcidState Keep -> User -> [Text] -> URL -> FilePath -> IO Analysis
+analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> IO Analysis
 analyze keep askedBy activeAuthors url bareRepo = do
   commit <- Sha </ Text.strip </ Text.pack </ git ["log", "-n1", "--format=%H"]
   Acid.query keep (GetAnalysisByUrlAndCommit url commit) >>= \case
@@ -919,7 +1035,7 @@ analyze keep askedBy activeAuthors url bareRepo = do
       Acid.update keep
         <| CreateAnalysis
         <| Analysis
-          { analysisId = Id.Id 0, -- make this mempty?
+          { analysisId = mempty,
             stale =
               [ (path, days)
                 | (path, days) <- stalenessMap,
@@ -964,7 +1080,7 @@ test_calculateScore =
 
 lastTouched :: FilePath -> FilePath -> IO (FilePath, Int)
 lastTouched bareRepo path = do
-  now <- Clock.getCurrentTime
+  now <- Time.getCurrentTime
   timestamp <-
     Process.readProcess
       "git"
@@ -980,7 +1096,7 @@ lastTouched bareRepo path = do
       /> filter (/= '\n')
       -- TODO: this fails if time is empty?
       /> Time.parseTimeOrError True Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z"
-  let days = round <| Clock.diffUTCTime now timestamp / Clock.nominalDay
+  let days = round <| Time.diffUTCTime now timestamp / Time.nominalDay
   return (path, days)
 
 -- | Given a git dir and a path inside the git repo, return a list of tuples
@@ -1026,8 +1142,8 @@ analyzeGitHub ::
   -- | GitHub repo
   Text ->
   IO Analysis
-analyzeGitHub keep user cfg o r = do
-  let githubAuth = GitHub.OAuth <. Encoding.encodeUtf8 <| userGitHubToken user
+analyzeGitHub keep User {..} cfg o r = do
+  let githubAuth = GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken
   -- I currently have no way of getting active users... getting a list of
   -- collaborators on a repo requires authentication for some reason.
   --
@@ -1054,9 +1170,9 @@ analyzeGitHub keep user cfg o r = do
   case eRepo of
     Left err -> throwIO <| toException err
     Right repo -> do
-      let GitHub.URL url = GitHub.repoUrl repo
+      let GitHub.URL url = GitHub.repoHtmlUrl repo
       bareRepo <- fetchBareRepo cfg <. GitHub.getUrl <| GitHub.repoHtmlUrl repo
-      analyze keep user activeAuthors (URL url) bareRepo
+      analyze keep userId activeAuthors (URL url) bareRepo
   where
     ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o
     ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r
diff --git a/Biz/Id.hs b/Biz/Id.hs
index 89c74bf..9bce013 100644
--- a/Biz/Id.hs
+++ b/Biz/Id.hs
@@ -40,3 +40,10 @@ instance FromJSON (Id entity) where
 
 instance ToJSON (Id entity) where
   toJSON = toJSON <. untag
+
+-- this is just provided to satisfy Monoid, no reason to actually use it
+instance Semigroup (Id entity) where
+  a <> b = mk (Proxy :: Proxy entity) <| untag a + untag b
+
+instance Monoid (Id entity) where
+  mempty = mk (Proxy :: Proxy entity) 0
diff --git a/Biz/Look.hs b/Biz/Look.hs
index 27bc8c5..a6bb626 100644
--- a/Biz/Look.hs
+++ b/Biz/Look.hs
@@ -20,6 +20,8 @@ module Biz.Look
     textDecorationWidth,
     -- | Elements
     hoverButton,
+    -- | Geometry
+    marginAll,
   )
 where
 
@@ -120,3 +122,6 @@ textDecorationThickness = Clay.key "text-decoration-thickness"
 
 textDecorationWidth :: Size LengthUnit -> Css
 textDecorationWidth = Clay.key "text-decoration-width"
+
+marginAll :: Size a -> Css
+marginAll x = Clay.margin x x x x
diff --git a/Biz/Test.hs b/Biz/Test.hs
index 7f6da61..7571008 100644
--- a/Biz/Test.hs
+++ b/Biz/Test.hs
@@ -8,12 +8,16 @@ module Biz.Test
     group,
     unit,
     prop,
+    with,
     (@=?),
+    (@?=),
+    (@?!=),
   )
 where
 
+import Alpha hiding (group)
 import qualified Test.Tasty as Tasty
-import Test.Tasty.HUnit ((@=?))
+import Test.Tasty.HUnit ((@=?), (@?=))
 import qualified Test.Tasty.HUnit as HUnit
 import qualified Test.Tasty.QuickCheck as QuickCheck
 
@@ -27,3 +31,42 @@ unit = HUnit.testCase
 
 prop :: QuickCheck.Testable a => Tasty.TestName -> a -> Tasty.TestTree
 prop = QuickCheck.testProperty
+
+with ::
+  -- | Startup
+  IO a ->
+  -- | Shutdown
+  (a -> IO ()) ->
+  -- | A test group where the first argument is a function that gets the resource
+  (IO a -> Tree) ->
+  Tree
+with = Tasty.withResource
+
+-- | How is this not part of HUnit??
+assertNotEqual ::
+  (Eq a, Show a, HasCallStack) =>
+  -- | The message prefix
+  String ->
+  -- | The not-expected value
+  a ->
+  -- | The actual value
+  a ->
+  HUnit.Assertion
+assertNotEqual preface notexpected actual =
+  unless (actual /= notexpected) (HUnit.assertFailure msg)
+  where
+    msg =
+      (if null preface then "" else preface ++ "\n")
+        ++ "expected not: "
+        ++ show notexpected
+        ++ "\n but got: "
+        ++ show actual
+
+(@?!=) ::
+  (Eq a, Show a, HasCallStack) =>
+  -- | The not-expected value
+  a ->
+  -- | The actual value
+  a ->
+  HUnit.Assertion
+expected @?!= actual = assertNotEqual "" expected actual