Register
This commit is contained in:
parent
acc732a31f
commit
bafa7799f0
3 changed files with 76 additions and 16 deletions
|
@ -49,22 +49,25 @@ import Text.Printf
|
|||
container :: H.Html -> H.Html
|
||||
container = H.div ! A.class_ "container"
|
||||
|
||||
loginPage :: H.Html
|
||||
loginPage = do
|
||||
H.h2 "Login"
|
||||
H.form ! A.action "/login" ! A.method "post" $ do
|
||||
_userPasswordBlock :: H.Html
|
||||
_userPasswordBlock = do
|
||||
H.label ! A.for "username" $ H.text "username"
|
||||
H.input ! A.required "" ! A.placeholder "Enter Username" ! A.name "username"
|
||||
H.br
|
||||
H.label ! A.for "password" $ H.text "password"
|
||||
H.input ! A.required "" ! A.placeholder "Enter Password" ! A.type_ "password" ! A.name "password"
|
||||
H.br
|
||||
|
||||
loginPage :: H.Html
|
||||
loginPage = do
|
||||
H.h2 "Login"
|
||||
H.form ! A.action "/login" ! A.method "post" $ do
|
||||
_userPasswordBlock
|
||||
H.input ! A.type_ "submit" ! A.value "Login"
|
||||
H.hr
|
||||
H.h2 "Create Account"
|
||||
H.form ! A.action "/users" ! A.method "post" $ do
|
||||
H.label ! A.for "username" $ H.text "username"
|
||||
H.input ! A.required "" ! A.placeholder "Enter Username" ! A.name "username"
|
||||
H.label ! A.for "nick" $ H.text "username"
|
||||
H.input ! A.required "" ! A.placeholder "Enter Username" ! A.name "nick"
|
||||
H.br
|
||||
H.label ! A.for "password" $ H.text "password"
|
||||
H.input ! A.required "" ! A.placeholder "Enter Password" ! A.type_ "password" ! A.name "password"
|
||||
|
@ -72,6 +75,8 @@ loginPage = do
|
|||
H.label (H.text "email?")
|
||||
H.input ! A.type_ "email" ! A.placeholder "Enter Email" ! A.name "email"
|
||||
H.br
|
||||
H.input ! A.type_ "hidden" ! A.name "role" ! A.value "User"
|
||||
H.br
|
||||
H.input ! A.type_ "submit" ! A.value "Create Account"
|
||||
|
||||
data LoginPage = LoginPage
|
||||
|
|
|
@ -74,6 +74,7 @@ import Servant.HTML.Blaze (HTML)
|
|||
import Text.Blaze.Html5 ((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import qualified Web.FormUrlEncoded as Form
|
||||
import qualified Web.HttpApiData as FormI
|
||||
|
||||
-- NewUser
|
||||
|
@ -83,6 +84,8 @@ data NewUser =
|
|||
, password :: HashedPassword
|
||||
, role :: Role
|
||||
} deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
instance Form.FromForm NewUser where
|
||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||
|
||||
newtype Nick = Nick Text
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
|
@ -125,6 +128,7 @@ deriving anyclass instance FromJSON HashedPassword
|
|||
deriving anyclass instance ToJSON HashedPassword
|
||||
deriving newtype instance FromField HashedPassword
|
||||
deriving newtype instance ToField HashedPassword
|
||||
instance FormI.FromHttpApiData HashedPassword where parseUrlPiece = fmap HashedPassword . FormI.parseUrlPiece
|
||||
instance StringConv HashedPassword [Char] where strConv l (HashedPassword sl) = strConv l sl
|
||||
instance StringConv HashedPassword Text where strConv l (HashedPassword sl) = strConv l sl
|
||||
instance StringConv HashedPassword ByteString where strConv l (HashedPassword sl) = strConv l sl
|
||||
|
@ -136,6 +140,12 @@ data Role = User | Admin
|
|||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Role
|
||||
deriving anyclass instance ToJSON Role
|
||||
instance FormI.FromHttpApiData Role where
|
||||
parseUrlPiece "Admin" = pure Admin
|
||||
parseUrlPiece "admin" = pure Admin
|
||||
parseUrlPiece "User" = pure User
|
||||
parseUrlPiece "user" = pure User
|
||||
parseUrlPiece _ = Left "Should be admin or user"
|
||||
|
||||
instance FromField Role where
|
||||
fromField f = case fieldData f of
|
||||
|
@ -249,9 +259,9 @@ checkUserLogin uh loginNick loginPass = do
|
|||
type UserAPI =
|
||||
"users" :> Capture "usernick" Nick :> Get '[HTML,JSON] UserPage
|
||||
:<|> "users" :> Capture "userid" Id :> Delete '[HTML,JSON] UserDeletedPage
|
||||
-- :<|> "users" :> Get '[HTML,JSON] [User]
|
||||
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||
-- :> PostCreated '[HTML,JSON] User
|
||||
:<|> "users" :> Get '[HTML,JSON] UsersPage
|
||||
:<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||
:> PostCreated '[HTML,JSON] RegisteredUserPage
|
||||
|
||||
userAPI :: UserHandler
|
||||
-> AuthResult User
|
||||
|
@ -263,8 +273,8 @@ userAPI userHandler authResult =
|
|||
in
|
||||
getUserByNick muser userHandler
|
||||
:<|> deleteUserById muser userHandler
|
||||
-- :<|> liftIO . searchUsers userHandler []
|
||||
-- :<|> liftIO . createUser userHandler
|
||||
:<|> listUsers muser userHandler
|
||||
:<|> postUser muser userHandler
|
||||
|
||||
-- GET User
|
||||
getUserByNick :: Maybe User -> UserHandler -> Nick -> Handler UserPage
|
||||
|
@ -290,12 +300,12 @@ data UserPage =
|
|||
}
|
||||
|
||||
instance ToJSON UserPage where
|
||||
toJSON = toJSON . user
|
||||
toJSON = toJSON . (user :: UserPage -> User)
|
||||
|
||||
instance H.ToMarkup UserPage where
|
||||
toMarkup UserPage{..} = boilerplate (loginWidget muser) $ do
|
||||
let n = toS (nick (val user))
|
||||
H.h2 $ do
|
||||
H.h2 $
|
||||
H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
|
||||
showUser user
|
||||
|
||||
|
@ -355,3 +365,47 @@ deleteUserById (Just u) userHandler userId
|
|||
loginWidget :: Maybe User -> H.Markup
|
||||
loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login"
|
||||
loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
|
||||
|
||||
-- List Users
|
||||
data UsersPage =
|
||||
UsersPage
|
||||
{ users :: [User]
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON UsersPage where
|
||||
toJSON = toJSON . users
|
||||
|
||||
instance H.ToMarkup UsersPage where
|
||||
toMarkup UsersPage{..} = boilerplate (loginWidget muser) $ do
|
||||
H.h2 $ H.text "Users"
|
||||
traverse_ (\u -> showUser u >> H.hr) users
|
||||
|
||||
listUsers :: Maybe User -> UserHandler -> Handler UsersPage
|
||||
listUsers muser userHandler = do
|
||||
SQL.SR (SQL.Paginated mu _ _) <- liftIO $
|
||||
searchUsers userHandler (Filter {params = []})
|
||||
pure (UsersPage mu muser)
|
||||
|
||||
-- Create User
|
||||
data RegisteredUserPage =
|
||||
RegisteredUsersPage
|
||||
{ user :: User
|
||||
, muser :: Maybe User
|
||||
}
|
||||
|
||||
instance ToJSON RegisteredUserPage where
|
||||
toJSON = toJSON . (user :: RegisteredUserPage -> User)
|
||||
|
||||
instance H.ToMarkup RegisteredUserPage where
|
||||
toMarkup RegisteredUsersPage{..} = boilerplate (loginWidget muser) $ do
|
||||
H.h2 $ H.text "Users"
|
||||
showUser user
|
||||
|
||||
postUser :: Maybe User
|
||||
-> UserHandler
|
||||
-> NewUser
|
||||
-> Handler RegisteredUserPage
|
||||
postUser muser userHandler nu = do
|
||||
u <- liftIO $ createUser userHandler nu
|
||||
pure (RegisteredUsersPage u muser)
|
||||
|
|
|
@ -299,7 +299,7 @@ instance ( MonadIO m
|
|||
data SearchResult (SQLiteStore m ms a) = SR (Paginated (Entity ms a))
|
||||
|
||||
search SQLiteState{..} Filter{..} = do
|
||||
let querytxt = conv ("SELECT * FROM " <> stTablename <> " WHERE " <> toQueryTxt params)
|
||||
let querytxt = conv ("SELECT * FROM " <> stTablename <> toQueryTxt params)
|
||||
results <- liftIO $ queryNamed conn querytxt trparams
|
||||
return $ SR (Paginated results 1 1)
|
||||
where
|
||||
|
@ -307,7 +307,8 @@ instance ( MonadIO m
|
|||
trNamedParam (f := v) = (":" <> f) := v
|
||||
|
||||
toQueryTxt :: [NamedParam] -> Text
|
||||
toQueryTxt qf = Text.intercalate " AND " (fmap (\np -> let t = fieldOf np in t <> " = :" <> t) qf)
|
||||
toQueryTxt [] = Text.empty
|
||||
toQueryTxt qf = " WHERE " <> Text.intercalate " AND " (fmap (\np -> let t = fieldOf np in t <> " = :" <> t) qf)
|
||||
where fieldOf (f := _) = f
|
||||
|
||||
|
||||
|
|
Loading…
Reference in a new issue