Register new users

src/API.hs

@@ -20,6 +20,8 @@ import qualified Lucid.Html5 as H
 import Types
 import Control.Monad.Logger
 
+import qualified API.Users as Users
+
 -- XXX: Temporary
 import Database.Schema
 import Database
@@ -44,9 +46,13 @@ instance ToHtml Index where
   toHtmlRaw = toHtml
 
 type API = Get '[HTML] Index
+      :<|> Users.API
 
 handler :: ServerT API AppM
-handler = do
+handler = indexHandler :<|> Users.handler
+
+indexHandler :: AppM Index
+indexHandler = do
   u <- runDB $ do
     query $ select $ gen users
   $logInfo $ "users: " <> (pack . show $ u)

src/API/Users.hs

@@ -0,0 +1,62 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language OverloadedStrings #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language TypeOperators #-}
+{-# Language DuplicateRecordFields #-}
+module API.Users (API, handler) where
+
+import Servant
+import ClassyPrelude
+import Types
+import Data.Aeson
+import Web.FormUrlEncoded
+import Database (runDB)
+import Database.User
+
+data LoginForm = LoginForm { username :: Text
+                           , password :: Text }
+               deriving (Generic, Show)
+
+data RegisterForm = RegisterForm { username :: Text
+                                 , email :: Text
+                                 , password :: Text
+                                 , passwordAgain :: Text }
+                  deriving (Generic, Show)
+
+data LoginStatus = LoginStatus deriving Generic
+
+data RegisterStatus = RegisterStatus deriving Generic
+
+instance FromJSON LoginForm
+instance ToJSON LoginForm
+instance ToJSON LoginStatus
+instance FromJSON LoginStatus
+instance FromForm LoginForm
+instance ToForm LoginForm
+
+instance FromJSON RegisterForm
+instance ToJSON RegisterForm
+instance ToJSON RegisterStatus
+instance FromJSON RegisterStatus
+instance FromForm RegisterForm
+instance ToForm RegisterForm
+
+type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus
+      :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
+
+handler :: ServerT API AppM
+handler = loginHandler :<|> registerHandler
+
+loginHandler :: LoginForm -> AppM LoginStatus
+loginHandler LoginForm{..} = throwM err403
+
+registerHandler :: RegisterForm -> AppM RegisterStatus
+registerHandler RegisterForm{..} =
+  case () of
+       () | password /= passwordAgain -> noMatch
+          | otherwise ->
+              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email (PlainPassword password))
+  where
+    noMatch = throwM err403{errBody = "passwords don't match"}
+    alreadyExists = throwM err403{errBody = "User already exists"}

src/Database.hs

@@ -7,7 +7,10 @@ module Database
   , runDB
   , query
   , select
-  , gen )
+  , gen
+  , fromRel
+  , toRel
+  , SeldaT )
   where
 
 import Data.Generics.Product
@@ -15,7 +18,7 @@ import Control.Lens (view)
 import Data.Pool (Pool, withResource)
 import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
 import Database.Selda (query, select)
-import Database.Selda.Generic (gen)
+import Database.Selda.Generic (gen, fromRel, toRel)
 import ClassyPrelude
 
 type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))

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

src/Devel/Main.hs

@@ -1,7 +1,8 @@
-{-# Language OverloadedStrings #-}
 module Devel.Main where
 
-import Main (defaultMain)
+import Prelude
+import Control.Monad.Trans.Reader (runReaderT)
+import Main (withApp, defaultMain)
 import Control.Concurrent
 import Control.Monad (void)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@@ -9,6 +10,10 @@ import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
 import GHC.Word (Word32)
 import Dhall (input, auto)
 
+import Database.Schema
+import Database.Selda (tryCreateTable)
+import Database
+
 update :: IO ()
 update = do
   lookupStore tidStoreNum >>= maybe setupNew restart
@@ -25,7 +30,17 @@ update = do
       withStore doneStore takeMVar
       readStore doneStore >>= start
     start :: MVar () -> IO ThreadId
-    start done = forkFinally (input auto "./config/devel.dhall" >>= defaultMain) (\_ -> putMVar done ())
+    start done = forkFinally develMain (\_ -> putMVar done ())
+
+develMain :: IO ()
+develMain = do
+  conf <- input auto "./config/devel.dhall"
+  withApp conf $ \app -> do
+    void $ runReaderT (runDB migrate) app
+    defaultMain app
+  where
+    migrate = do
+      tryCreateTable (gen users)
 
 modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
 modifyStoredIORef store f = withStore store $ \ref -> do

src/Main.hs

@@ -17,28 +17,20 @@ import Data.Generics.Product
 import Data.Pool (createPool)
 import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
 
-defaultMain :: Config -> IO ()
-defaultMain config = do
+defaultMain :: App -> IO ()
+defaultMain = run 8080 . server
+
+withApp :: Config -> (App -> IO ()) -> IO ()
+withApp config f = do
   let pgHost = view (field @"database" . field @"host") config
       pgPort = 5432
       pgDatabase = view (field @"database" . field @"database") config
       pgUsername = Just (view (field @"database" . field @"username") config)
       pgPassword = Just (view (field @"database" . field @"password") config)
   database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
-  let app = App{..}
-  run 8080 (server app)
-
--- migrate :: Pg -> IO ()
--- migrate Pg{..} = do
---   -- Credentials visible on ps
---   -- XXX: Modify this to write the credentials to a temporary file or something
---   callProcess "flyway" $ fmap unpack [ "migrate"
---                                      , "-locations=filesystem:migrations/"
---                                      , "-url=jdbc:postgresql://" <> host <> "/" <> database
---                                      , "-user=" <> username
---                                      , "-password=" <> password]
+  f App{..}
 
 main :: IO ()
 main = do
   c <- input auto "./config/config.dhall"
-  defaultMain c
+  withApp c defaultMain

src/Types.hs

@@ -1,5 +1,7 @@
 {-# Language NoImplicitPrelude #-}
 {-# Language DeriveGeneric #-}
+{-# Language TypeSynonymInstances #-}
+{-# Language FlexibleInstances #-}
 module Types where
 
 import ClassyPrelude
@@ -7,9 +9,13 @@ import Control.Monad.Logger
 import Configuration
 import Data.Pool (Pool)
 import Database.Selda.Backend (SeldaConnection)
+import Crypto.Random.Types (MonadRandom(..))
 
 data App = App { config :: Config
                , database :: Pool SeldaConnection }
          deriving (Generic)
 
 type AppM = LoggingT (ReaderT App IO)
+
+instance MonadRandom AppM where
+  getRandomBytes = lift . lift . getRandomBytes