Migrate auth tokens

Author: bcardiff

init_db.sql

@@ -10,6 +10,13 @@ CREATE TABLE IF NOT EXISTS users (
     admin BOOLEAN NOT NULL
 );
 
+CREATE TABLE IF NOT EXISTS user_tokens (
+    id INTEGER PRIMARY KEY,
+    user_id INTEGER NOT NULL,
+    description TEXT NOT NULL,
+    token TEXT NOT NULL
+);
+
 CREATE TABLE IF NOT EXISTS account_details (
     user_id INTEGER PRIMARY KEY,
     name TEXT NOT NULL,

src/Distribution/Server/Features/Database.hs

@@ -114,7 +114,8 @@ initDatabaseFeature env = pure $ do
 
 data HackageDb f = HackageDb
   { _tblAccountDetails :: f (TableEntity AccountDetailsT),
-    _tblUsers :: f (TableEntity UsersT)
+    _tblUsers :: f (TableEntity UsersT),
+    _tblUserTokens :: f (TableEntity UserTokensT)
   }
   deriving stock (Generic)
 

src/Distribution/Server/Features/Users.hs

@@ -303,6 +303,17 @@ migrateStateToDatabase usersState adminsState DatabaseFeature{..} = do
             _uAuthInfo = authInfo,
             _uAdmin = Group.member uid admins
           }])
+
+      forM_ (Map.toList (userTokens uinfo)) $ \(token, desc) -> do
+        Database.runInsert $
+          insert
+            (_tblUserTokens Database.hackageDb)
+            (insertExpressions [UserTokensRow {
+              _utId = default_,
+              _utUserId = val_ uid,
+              _utToken = val_ token,
+              _utDescription = val_ desc
+            }])
 
 
 usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)

src/Distribution/Server/Users/AuthToken.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Distribution.Server.Users.AuthToken
     ( AuthToken
     , parseAuthToken, parseAuthTokenM, renderAuthToken
@@ -25,6 +26,11 @@ import qualified Distribution.Compat.CharParsing as P
 
 import Data.SafeCopy
 
+import Database.Beam
+import Database.Beam.Backend
+import Database.Beam.Sqlite
+import Database.Beam.Sqlite.Syntax
+
 -- | Contains the original token which will be shown to the user
 -- once and is NOT stored on the server. The user is expected
 -- to provide this token on each request that should be
@@ -36,6 +42,12 @@ newtype OriginalToken = OriginalToken Nonce
 newtype AuthToken = AuthToken BSS.ShortByteString
     deriving (Eq, Ord, Read, Show, MemSize)
 
+instance FromBackendRow Sqlite AuthToken where
+  fromBackendRow = AuthToken . BSS.toShort <$> fromBackendRow
+
+instance HasSqlValueSyntax SqliteValueSyntax AuthToken where
+  sqlValueSyntax (AuthToken v) = sqlValueSyntax (BSS.fromShort v)
+
 convertToken :: OriginalToken -> AuthToken
 convertToken (OriginalToken bs) =
     AuthToken $ BSS.toShort $ SHA256.hash $ getRawNonceBytes bs

src/Distribution/Server/Users/State.hs

@@ -20,6 +20,7 @@ import Control.Monad.Reader
 import qualified Control.Monad.State as State
 import qualified Data.Text as T
 
+import Data.Int
 import Data.Text
 import Database.Beam
 import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax (..), autoSqlValueSyntax)
@@ -217,4 +218,25 @@ instance FromBackendRow Sqlite UsersStatus where
   fromBackendRow = read . unpack <$> fromBackendRow
 
 newtype DBUserName = DBUserName Text
-  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax)
+  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax)
+
+data UserTokensT f
+  = UserTokensRow
+  { _utId :: Columnar f Int32,
+    _utUserId :: Columnar f UserId,
+    _utDescription :: Columnar f Text,
+    _utToken :: Columnar f AuthToken
+  }
+  deriving (Generic, Beamable)
+
+type UserTokenRow = UserTokensT Identity
+
+deriving instance Show UserTokenRow
+
+deriving instance Eq UserTokenRow
+
+type UserTokensId = PrimaryKey UserTokensT Identity
+
+instance Table UserTokensT where
+  data PrimaryKey UserTokensT f = UserTokensId (Columnar f Int32) deriving (Generic, Beamable)
+  primaryKey = UserTokensId . _utId  

src/Distribution/Server/Users/Types.hs

@@ -35,7 +35,6 @@ import Data.Hashable
 import Data.Serialize (Serialize)
 import Database.Beam
 import Database.Beam.Backend
-import Database.Beam.Backend.SQL.SQL92 ()
 import Database.Beam.Sqlite
 import Database.Beam.Sqlite.Syntax