Add a create-user command in flora-cli (#86)

* Add a create-user command in flora-cli

* Rework the test fixtures

* Properly provision

.github/workflows/ci.yml

@@ -65,6 +65,7 @@ jobs:
         createdb -h "${FLORA_DB_HOST}" -p "${FLORA_DB_PORT}" -U "${FLORA_DB_USER}" -w "${FLORA_DB_DATABASE}"
         migrate init "${FLORA_PG_CONNSTRING}" 
         migrate migrate "${FLORA_PG_CONNSTRING}" migrations
+        cabal run -- flora-cli create-user --username "hackage-user" --email "[email protected]" --password "foobar2000"
         cabal test
       env:
         PGPASSWORD: "postgres"

Makefile

@@ -33,6 +33,7 @@ db-setup: db-create ## Setup the dev database
 db-reset: db-drop db-setup db-provision ## Reset the dev database (uses Cabal)
 
 db-provision: build ## Load the development data in the database
+	@cabal run -- flora-cli create-user --username "hackage-user" --email "[email protected]" --password "foobar2000"
 	@cabal run -- flora-cli provision-fixtures
 
 repl: soufflé ## Start a cabal REPL

app/cli/Main.hs

@@ -1,23 +1,23 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-
 module Main where
 
 import Control.Monad
-import Control.Monad.Trans.Class
+import Data.Password.Types
 import Database.PostgreSQL.Entity.DBT
-import qualified Log
 import Optics.Core
 import Options.Applicative
 
 import Flora.Environment
 import Flora.Import.Categories (importCategories)
 import Flora.Import.Package
 import Flora.Model.Package
-import qualified Flora.Model.User
+import Flora.Model.User
 import Flora.Model.User.Update
-import Flora.UserFixtures
 
 import CoverageReport
+import Data.Maybe
+import Data.Text (Text)
+import qualified Flora.Model.User.Query as Query
+import GHC.Generics (Generic)
 
 data Options = Options
   { cliCommand :: Command
@@ -27,8 +27,18 @@ data Options = Options
 data Command
   = Provision
   | CoverageReport CoverageReportOptions
+  | CreateUser UserCreationOptions
   deriving stock (Show, Eq)
 
+data UserCreationOptions = UserCreationOptions
+  { username :: Text
+  , email :: Text
+  , password :: Text
+  , isAdmin :: Bool
+  , canLogin :: Bool
+  }
+  deriving stock (Generic, Show, Eq)
+
 main :: IO ()
 main = runOptions =<< execParser (parseOptions `withInfo` "CLI helper for flora-server")
 
@@ -39,8 +49,9 @@ parseOptions =
 parseCommand :: Parser Command
 parseCommand =
   subparser $
-    command "provision-fixtures" (parseProvision `withInfo` "Load the fixtures into the database")
+    command "provision-fixtures" (parseProvision `withInfo` "Load the test fixtures into the database")
       <> command "coverage-report" (parseCoverageReport `withInfo` "Run a coverage report of the category mapping")
+      <> command "create-user" (parseCreateUser `withInfo` "Create a user in the system")
 
 parseProvision :: Parser Command
 parseProvision = pure Provision
@@ -50,13 +61,40 @@ parseCoverageReport =
   CoverageReport . CoverageReportOptions
     <$> switch (long "force-download" <> help "Always download and extract the package index")
 
+parseCreateUser :: Parser Command
+parseCreateUser =
+  CreateUser
+    <$> ( UserCreationOptions
+            <$> option str (long "username" <> metavar "<username>" <> help "The username for this user")
+            <*> option str (long "email" <> metavar "<email>" <> help "The email address for this user")
+            <*> option str (long "password" <> metavar "<password>" <> help "The password for this user")
+            <*> switch (long "admin" <> help "The user has administrator privileges")
+            <*> switch (long "can-login" <> help "The user can log in")
+        )
+
 runOptions :: Options -> IO ()
+runOptions (Options (CreateUser opts)) = do
+  env <- getFloraEnv
+  withPool (env ^. #pool) $ do
+    let username = opts ^. #username
+        email = opts ^. #email
+        canLogin = opts ^. #canLogin
+    password <- hashPassword (mkPassword (opts ^. #password))
+    if opts ^. #isAdmin
+      then
+        addAdmin AdminCreationForm{..}
+          >>= \admin ->
+            if canLogin
+              then pure ()
+              else lockAccount (admin ^. #userId)
+      else do
+        templateUser <- mkUser UserCreationForm{..}
+        let user = if canLogin then templateUser else templateUser & #userFlags % #canLogin .~ False
+        insertUser user
 runOptions (Options Provision) = do
   env <- getFloraEnv
   withPool (env ^. #pool) $ do
-    insertUser hackageUser
-    insertUser user2
-    insertUser adminUser
+    hackageUser <- fromJust <$> Query.getUserByUsername "hackage-user"
 
     void importCategories
 

environment.test.sh

@@ -1,7 +1,7 @@
 . environment.sh
 
 export FLORA_HTTP_PORT=8085
-export FLORA_ENVIRONMENT="tests"
+export FLORA_ENVIRONMENT="test"
 export FLORA_DOMAIN="localhost"
 
 export FLORA_DB_DATABASE="flora_test"

flora.cabal

@@ -235,29 +235,18 @@ executable flora-cli
     , colourista
     , directory
     , flora
-    , flora-test-fixtures
     , log-base
     , monad-control
     , optics-core
     , optparse-applicative  ^>=0.16
+    , password-types
     , pg-entity
     , pg-transact
     , text
     , text-display
     , transformers
     , typed-process
 
-library flora-test-fixtures
-  import:          common-extensions
-  import:          common-ghc-options
-  hs-source-dirs:  test/fixtures
-  build-depends:
-    , base
-    , flora
-    , password
-
-  exposed-modules: Flora.UserFixtures
-
 test-suite flora-test
   import:         common-extensions
   import:         common-ghc-options
@@ -270,7 +259,6 @@ test-suite flora-test
     , containers
     , exceptions
     , flora
-    , flora-test-fixtures
     , hedgehog
     , http-client           ==0.7.10
     , optics-core

scripts/run-tests.sh

@@ -9,6 +9,8 @@ export DATALOG_DIR="cbits/"
 make db-drop
 make db-setup
 
+cabal run -- flora-cli create-user --username "hackage-user" --email "[email protected]" --password "foobar2000"
+
 if [ -z "$1" ] ;
 then
   cabal test

src/Flora/Model/User.hs

@@ -5,8 +5,8 @@ module Flora.Model.User
   ( UserId (..)
   , User (..)
   , UserFlags (..)
-  , UserCreationForm
-  , AdminCreationForm
+  , UserCreationForm (..)
+  , AdminCreationForm (..)
   , mkUser
   , mkAdmin
   , hashPassword

test/Flora/CategorySpec.hs

@@ -17,7 +17,6 @@ import Flora.Model.Package
 import qualified Flora.Model.Package.Query as Query
 import Flora.Model.User
 import Flora.TestUtils
-import Flora.UserFixtures
 
 spec :: TestM TestTree
 spec =

test/Flora/PackageSpec.hs

@@ -2,14 +2,12 @@
 
 module Flora.PackageSpec where
 
-import Control.Monad.IO.Class
 import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Vector as Vector
 import Optics.Core
 import Test.Tasty
 
-import qualified Control.Concurrent as System
 import Data.Foldable
 import Data.Function
 import qualified Data.Vector as V
@@ -22,32 +20,29 @@ import Flora.Model.Release
 import qualified Flora.Model.Release.Query as Query
 import Flora.Model.User
 import Flora.TestUtils
-import Flora.UserFixtures
 
-spec :: TestM TestTree
-spec =
+spec :: Fixtures -> TestM TestTree
+spec fixtures =
   testThese
     "packages"
-    [ testThis "Insert base and its dependencies, and fetch it" testGetPackageById
-    , testThis "Insert containers and its dependencies" testInsertContainers
-    , testThis "@haskell/base belongs to the \"Prelude\" category" testThatBaseisInPreludeCategory
-    , testThis
-        "@hackage/semigroups belongs to appropriate categories"
-        testThatSemigroupsIsInMathematicsAndDataStructures
-    , testThis "The \"haskell\" namespace has the correct number of packages" testCorrectNumberInHaskellNamespace
-    , testThis "Searching for \"base\" returns the correct results" testSearchingForBase
-    , testThis "@haskell/bytestring has the correct number of dependents" testBytestringDependents
+    [ testThis "Insert base and its dependencies, and fetch it" $ testGetPackageById fixtures
+    , testThis "Insert containers and its dependencies" $ testInsertContainers fixtures
+    , testThis "@haskell/base belongs to the \"Prelude\" category" $ testThatBaseisInPreludeCategory fixtures
+    , testThis "@hackage/semigroups belongs to appropriate categories" $ testThatSemigroupsIsInMathematicsAndDataStructures fixtures
+    , testThis "The \"haskell\" namespace has the correct number of packages" $ testCorrectNumberInHaskellNamespace fixtures
+    , testThis "Searching for \"base\" returns the correct results" $ testSearchingForBase fixtures
+    , testThis "@haskell/bytestring has the correct number of dependents" $ testBytestringDependents fixtures
     ]
 
-testGetPackageById :: TestM ()
-testGetPackageById = do
+testGetPackageById :: Fixtures -> TestM ()
+testGetPackageById Fixtures{hackageUser} = do
   let cabalPath = "./test/fixtures/Cabal/base.cabal"
   liftDB $ importCabal (hackageUser ^. #userId) (PackageName "base") cabalPath "./test/fixtures/Cabal/"
   result <- liftDB $ Query.getPackageByNamespaceAndName (Namespace "haskell") (PackageName "base")
   assertEqual (Just (PackageName "base")) (preview (_Just % #name) result)
 
-testInsertContainers :: TestM ()
-testInsertContainers = do
+testInsertContainers :: Fixtures -> TestM ()
+testInsertContainers Fixtures{hackageUser} = do
   _result <- liftDB $ importPackage (hackageUser ^. #userId) (PackageName "containers") "./test/fixtures/Cabal/"
   dependencies <- liftDB $ do
     mPackage <- Query.getPackageByNamespaceAndName (Namespace "haskell") (PackageName "containers")
@@ -78,21 +73,21 @@ testFetchGHCPrimDependents = do
     )
     (Set.fromList . fmap (view #name) $ Vector.toList result)
 
-testThatBaseisInPreludeCategory :: TestM ()
-testThatBaseisInPreludeCategory = do
+testThatBaseisInPreludeCategory :: Fixtures -> TestM ()
+testThatBaseisInPreludeCategory Fixtures{hackageUser} = do
   liftDB $ importPackage (hackageUser ^. #userId) (PackageName "base") "./test/fixtures/Cabal/"
   result <- liftDB $ Query.getPackagesFromCategorySlug "prelude"
   assertEqual (Set.fromList [PackageName "base"]) (Set.fromList $ V.toList $ fmap (view #name) result)
 
-testThatSemigroupsIsInMathematicsAndDataStructures :: TestM ()
-testThatSemigroupsIsInMathematicsAndDataStructures = do
+testThatSemigroupsIsInMathematicsAndDataStructures :: Fixtures -> TestM ()
+testThatSemigroupsIsInMathematicsAndDataStructures Fixtures{hackageUser} = do
   liftDB $ importPackage (hackageUser ^. #userId) (PackageName "semigroups") "./test/fixtures/Cabal/"
   Just semigroups <- liftDB $ Query.getPackageByNamespaceAndName (Namespace "hackage") (PackageName "semigroups")
   result <- liftDB $ Query.getPackageCategories (semigroups ^. #packageId)
   assertEqual (Set.fromList ["data-structures", "maths"]) (Set.fromList $ slug <$> V.toList result)
 
-testCorrectNumberInHaskellNamespace :: TestM ()
-testCorrectNumberInHaskellNamespace = do
+testCorrectNumberInHaskellNamespace :: Fixtures -> TestM ()
+testCorrectNumberInHaskellNamespace Fixtures{hackageUser} = do
   liftDB $
     importCabal
       (hackageUser ^. #userId)
@@ -102,8 +97,8 @@ testCorrectNumberInHaskellNamespace = do
   results <- liftDB $ Query.getPackagesByNamespace (Namespace "haskell")
   assertEqual 21 (Vector.length results)
 
-testSearchingForBase :: TestM ()
-testSearchingForBase = do
+testSearchingForBase :: Fixtures -> TestM ()
+testSearchingForBase Fixtures{hackageUser} = do
   liftDB $
     importCabal
       (hackageUser ^. #userId)
@@ -121,8 +116,8 @@ testSearchingForBase = do
     (Vector.fromList [(PackageName "base", 1.0), (PackageName "base-orphans", 0.3846154)])
     (result <&> (,) <$> view _2 <*> view _5)
 
-testBytestringDependents :: TestM ()
-testBytestringDependents = do
+testBytestringDependents :: Fixtures -> TestM ()
+testBytestringDependents Fixtures{hackageUser} = do
   liftDB $
     importCabal
       (hackageUser ^. #userId)

test/Flora/TestUtils.hs

@@ -20,7 +20,7 @@ module Flora.TestUtils
   , assertClientLeft'
 
     -- * Database migration
-  , migrate
+  , testMigrations
 
     -- * Random fixtures
   , randomUser
@@ -38,9 +38,11 @@ module Flora.TestUtils
 
     -- * TestM and helpers
   , TestM (..)
+  , Fixtures (..)
   , liftDB
   , runTestM
   , getTestEnv
+  , getFixtures
 
     -- * HUnit re-exports
   , TestTree
@@ -82,18 +84,29 @@ import Test.Tasty
 import qualified Test.Tasty as Test
 import qualified Test.Tasty.HUnit as Test
 
+import Data.Maybe (fromJust)
 import Flora.Environment
 import Flora.Import.Categories (importCategories)
 import Flora.Model.User
+import qualified Flora.Model.User.Query as Query
 import Flora.Model.User.Update
 import qualified Flora.Model.User.Update as Update
 import Flora.Publish
-import Flora.UserFixtures
 import FloraWeb.Client
 
 newtype TestM (a :: Type) = TestM {getTestM :: ReaderT TestEnv IO a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadFail)
 
+data Fixtures = Fixtures
+  { hackageUser :: User
+  }
+  deriving stock (Generic, Show, Eq)
+
+getFixtures :: DBT IO Fixtures
+getFixtures = do
+  hackageUser <- fromJust <$> Query.getUserByUsername "hackage-user"
+  pure Fixtures{..}
+
 liftDB :: DBT IO a -> TestM a
 liftDB comp = do
   env <- getTestEnv
@@ -188,13 +201,12 @@ getEnv mgrSettings = do
 managerSettings :: ManagerSettings
 managerSettings = defaultManagerSettings
 
-migrate :: Connection -> IO ()
-migrate conn = do
+testMigrations :: Connection -> IO ()
+testMigrations conn = do
   void $ runMigrations conn defaultOptions [MigrationInitialization, MigrationDirectory "./migrations"]
   pool <- newPool (pure conn) close 10 1
   withPool pool $ do
     importCategories
-    insertUser hackageUser
 
 genWord32 :: MonadGen m => m Word32
 genWord32 = H.word32 (Range.constant minBound maxBound)