Modify types, create instances

src/API.hs

@@ -18,14 +18,9 @@ import Servant.HTML.Lucid (HTML)
 import Lucid (HtmlT, ToHtml(..))
 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
-
 data Index = Index
 
 bulma :: Monad m => HtmlT m ()
@@ -53,7 +48,4 @@ handler = indexHandler :<|> Users.handler
 
 indexHandler :: AppM Index
 indexHandler = do
-  u <- runDB $ do
-    query $ select $ gen users
-  $logInfo $ "users: " <> (pack . show $ u)
   return Index

src/API/Users.hs

@@ -4,7 +4,8 @@
 {-# Language NoImplicitPrelude #-}
 {-# Language TypeOperators #-}
 {-# Language DuplicateRecordFields #-}
-module API.Users (API, handler) where
+{-# Language TypeApplications #-}
+module API.Users  where
 
 import Servant
 import ClassyPrelude
@@ -13,18 +14,21 @@ import Data.Aeson
 import Web.FormUrlEncoded
 import Database (runDB)
 import Database.User
+import Database.Schema
+import Control.Lens (view)
+import Data.Generics.Product
 
 data LoginForm = LoginForm { username :: Text
                            , password :: Text }
                deriving (Generic, Show)
 
-data RegisterForm = RegisterForm { username :: Text
-                                 , email :: Text
-                                 , password :: Text
-                                 , passwordAgain :: Text }
+data RegisterForm = RegisterForm { username :: Username
+                                 , email :: Email
+                                 , password :: PlainPassword
+                                 , passwordAgain :: PlainPassword }
                   deriving (Generic, Show)
 
-data LoginStatus = LoginStatus deriving Generic
+data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
 
 data RegisterStatus = RegisterStatus deriving Generic
 
@@ -42,6 +46,15 @@ instance FromJSON RegisterStatus
 instance FromForm RegisterForm
 instance ToForm RegisterForm
 
+-- generic-lens can convert similar types to this
+data SafeUser = SafeUser { email :: Email
+                         , username :: Username
+                         , role :: Role }
+              deriving (Show, Generic)
+
+instance ToJSON SafeUser where
+instance FromJSON SafeUser where
+
 type API = "login" :> ReqBody '[JSON, FormUrlEncoded] LoginForm :> Post '[JSON] LoginStatus
       :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
 
@@ -49,14 +62,16 @@ handler :: ServerT API AppM
 handler = loginHandler :<|> registerHandler
 
 loginHandler :: LoginForm -> AppM LoginStatus
-loginHandler LoginForm{..} = throwM err403
+loginHandler LoginForm{..} = do
+  user <- fmap (view (super @SafeUser)) <$> runDB (validateUser (Username username) (PlainPassword password))
+  return (LoginStatus user)
 
 registerHandler :: RegisterForm -> AppM RegisterStatus
 registerHandler RegisterForm{..} =
   case () of
        () | password /= passwordAgain -> noMatch
           | otherwise ->
-              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email (PlainPassword password))
+              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email password)
   where
     noMatch = throwM err403{errBody = "passwords don't match"}
     alreadyExists = throwM err403{errBody = "User already exists"}

src/Database/Schema.hs

@@ -2,6 +2,7 @@
 {-# Language DeriveGeneric #-}
 {-# Language OverloadedStrings #-}
 {-# Language DuplicateRecordFields #-}
+{-# Language GeneralizedNewtypeDeriving #-}
 module Database.Schema where
 
 import ClassyPrelude
@@ -9,15 +10,48 @@ import Database.Selda.Generic
 import Database.Selda
 import Database.Selda.Backend
 
+import Data.Aeson
+import Web.HttpApiData
+
 -- | User type
+newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq)
+newtype HashedPassword = HashedPassword {unHashed :: ByteString}
+data NoPassword = NoPassword
+
+newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
+
+newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
+
+instance SqlType HashedPassword where
+  mkLit = LCustom . LBlob . unHashed
+  fromSql (SqlBlob x) = HashedPassword x
+  fromSql _ = error "fromSql: Bad hash"
+  defaultValue = mkLit (HashedPassword "") -- Makes no sense
+
+instance SqlType Email where
+  mkLit = LCustom . LText . unEmail
+  fromSql (SqlString x) = Email x
+  fromSql _ = error "fromSql: Bad email"
+  defaultValue = mkLit (Email "")
+
+instance SqlType Username where
+  mkLit = LCustom . LText . unUsername
+  fromSql (SqlString x) = Username x
+  fromSql _ = error "fromSql: Bad username"
+  defaultValue = mkLit (Username "")
+
+
 data User pass = User { identifier :: RowID
-                      , email :: Text
-                      , username :: Text
+                      , email :: Email
+                      , username :: Username
                       , role :: Role
                       , password :: pass }
           deriving (Show, Generic)
 
-data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable)
+data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic)
+
+instance ToJSON Role
+instance FromJSON Role
 
 instance SqlType Role where
   mkLit = LCustom . LText . pack . show
@@ -27,10 +61,10 @@ instance SqlType Role where
 
   defaultValue = mkLit minBound
 
-users :: GenTable (User ByteString)
-users = genTable "users" [ (email :: User ByteString -> Text) :- uniqueGen
+users :: GenTable (User HashedPassword)
+users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen
                          , username :- uniqueGen
-                         , (identifier :: User ByteString -> RowID) :- autoPrimaryGen ]
+                         , (identifier :: User HashedPassword -> RowID) :- autoPrimaryGen ]
 
 -- | Book type
 newtype HashDigest = HashDigest { unHex :: Text } deriving Show

src/Database/User.hs

@@ -16,11 +16,8 @@ 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 :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
 insertUser username email (PlainPassword password) =
   getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
   where
@@ -29,7 +26,7 @@ insertUser username email (PlainPassword password) =
       lift $ $logInfo $ "Inserting new user as " <> pack (show role)
       let bytePass = encodeUtf8 password
       user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
-      insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user)
+      insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user)
 
 adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
 adminExists = do
@@ -42,13 +39,16 @@ adminExists = do
       restrict (r .== literal AdminRole)
       return (count r)
 
-getUser :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe (User NoPassword))
+getUser :: (MonadMask m, MonadIO m) => Username -> 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
+validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword))
+validateUser name _ = getUser name
+
+getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword ))
+getUser' name = listToMaybe . fmap fromRel <$> query q
   where
     q = do
-      u@(_ :*: username :*: _ :*: _ :*: _) <- select (gen users)
+      u@(_ :*: _ :*: username :*: _ ) <- select (gen users)
       restrict (username .== literal name)
       return u