Register new users

src/Database/Schema.hs

@@ -1,15 +1,29 @@
 {-# Language NoImplicitPrelude #-}
 {-# Language DeriveGeneric #-}
 {-# Language OverloadedStrings #-}
+{-# Language DuplicateRecordFields #-}
 module Database.Schema where
 
 import ClassyPrelude
 import Database.Selda.Generic
+import Database.Selda
+import Database.Selda.Backend
 
-data User = User { email :: Text
-                 , username :: Text
-                 , password :: ByteString }
+data User pass = User { email :: Text
+                      , username :: Text
+                      , role :: Role
+                      , password :: pass }
           deriving (Show, Generic)
 
-users :: GenTable User
+data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable)
+
+instance SqlType Role where
+  mkLit = LCustom . LText . pack . show
+  fromSql sql = case sql of
+                     SqlString x -> fromMaybe (error "fromSql: Not a valid role") . readMay . unpack $ x
+                     _ -> error "fromSql: Not a valid role"
+
+  defaultValue = mkLit minBound
+
+users :: GenTable (User ByteString)
 users = genTable "users" [ email :- primaryGen ]

src/Database/User.hs

@@ -0,0 +1,54 @@
+{-# Language LambdaCase #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language TemplateHaskell #-}
+module Database.User where
+
+import ClassyPrelude
+import Database
+import Database.Schema
+import Database.Selda
+import Control.Lens (over, _Just)
+import Data.Generics.Product
+import Crypto.KDF.BCrypt
+import Crypto.Random.Types (MonadRandom)
+import Control.Monad.Logger
+
+data UserExistsError = UserExistsError
+
+newtype PlainPassword = PlainPassword Text
+newtype HashedPassword = HashedPassword {unHashed :: ByteString}
+data NoPassword = NoPassword
+
+insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Text -> Text -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
+insertUser username email (PlainPassword password) =
+  getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
+  where
+    insert' = adminExists >>= \e -> Right <$> if e then insertAs UserRole else insertAs AdminRole
+    insertAs role = do
+      lift $ $logInfo $ "Inserting new user as " <> pack (show role)
+      let bytePass = encodeUtf8 password
+      user <- User email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
+      insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user)
+
+adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
+adminExists = do
+  r <- query q
+  lift $ $logInfo $ "Admin users: " <> (pack (show r))
+  return $ maybe False (> 0) . listToMaybe $ r
+  where
+    q = aggregate $ do
+      (_ :*: _ :*: r :*: _) <- select (gen users)
+      restrict (r .== literal AdminRole)
+      return (count r)
+
+getUser :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe (User NoPassword))
+getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name
+
+getUser' :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe ( User HashedPassword ))
+getUser' name = over (_Just . field @"password") HashedPassword . listToMaybe . fmap fromRel <$> query q
+  where
+    q = do
+      u@(username :*: _ :*: _ :*: _) <- select (gen users)
+      restrict (username .== literal name)
+      return u