user by nick, updated page
This commit is contained in:
parent
179a47aeed
commit
95db1db9ad
4 changed files with 41 additions and 7 deletions
|
@ -78,7 +78,7 @@ sqlCRUD step = withTestDB $ \tmpfile -> do
|
|||
foo2 <- readFoo store (id foo1)
|
||||
when (Just foo1 /= foo2) $ assertFailure "Foo1 and Foo2 should be equal"
|
||||
void $ step "Search created entity by name"
|
||||
Paginated foos _ _ <- searchFoos store (Filter {params = ["name" := ("Yann" :: Text)]})
|
||||
SR (Paginated foos _ _) <- searchFoos store (Filter {params = ["name" := ("Yann" :: Text)]})
|
||||
when (length foos /= 1) $ assertFailure "Bad numbers of found elements"
|
||||
when (head foos /= Just foo1) $ assertFailure "Search returned the bad result"
|
||||
void $ step "cleaning up temporary files"
|
||||
|
|
|
@ -128,6 +128,7 @@ genCss = do
|
|||
label ? do
|
||||
minWidth (em 7)
|
||||
display inlineBlock
|
||||
fontWeight (weight 100)
|
||||
label # byClass "togglelabel" ? do
|
||||
minWidth (em 2)
|
||||
display inlineBlock
|
||||
|
|
|
@ -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.HttpApiData as FormI
|
||||
|
||||
-- NewUser
|
||||
data NewUser =
|
||||
|
@ -87,6 +88,7 @@ newtype Nick = Nick Text
|
|||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Nick
|
||||
deriving anyclass instance ToJSON Nick
|
||||
instance FormI.FromHttpApiData Nick where parseUrlPiece = fmap Nick . FormI.parseUrlPiece
|
||||
deriving newtype instance FromField Nick
|
||||
deriving newtype instance ToField Nick
|
||||
instance StringConv Nick [Char] where strConv l (Nick sl) = strConv l sl
|
||||
|
@ -98,6 +100,7 @@ newtype Email = Email Text
|
|||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Email
|
||||
deriving anyclass instance ToJSON Email
|
||||
instance FormI.FromHttpApiData Email where parseUrlPiece = fmap Email . FormI.parseUrlPiece
|
||||
deriving newtype instance FromField Email
|
||||
deriving newtype instance ToField Email
|
||||
instance StringConv Email [Char] where strConv l (Email sl) = strConv l sl
|
||||
|
@ -244,7 +247,7 @@ checkUserLogin uh loginNick loginPass = do
|
|||
-- * User API
|
||||
|
||||
type UserAPI =
|
||||
"users" :> Capture "userid" Id :> Get '[HTML,JSON] UserPage
|
||||
"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
|
||||
|
@ -258,12 +261,21 @@ userAPI userHandler authResult =
|
|||
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
in
|
||||
getUserById muser userHandler
|
||||
getUserByNick muser userHandler
|
||||
:<|> deleteUserById muser userHandler
|
||||
-- :<|> liftIO . searchUsers userHandler []
|
||||
-- :<|> liftIO . createUser userHandler
|
||||
|
||||
-- GET User
|
||||
getUserByNick :: Maybe User -> UserHandler -> Nick -> Handler UserPage
|
||||
getUserByNick muser userHandler userNick = do
|
||||
SQL.SR (SQL.Paginated mu _ _) <- liftIO $
|
||||
searchUsers userHandler (Filter {params = ["nick" := userNick]})
|
||||
case mu of
|
||||
[] -> Err.notFound "user not found"
|
||||
[u] -> pure (UserPage u muser)
|
||||
_ -> Err.internalServerError "Incoherent DB"
|
||||
|
||||
getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
|
||||
getUserById muser userHandler userId = do
|
||||
mu <- liftIO $ readUser userHandler userId
|
||||
|
@ -294,12 +306,18 @@ showUser user = do
|
|||
H.div $ do
|
||||
H.label "nick"
|
||||
H.text (toS (nick nu))
|
||||
H.div $ do
|
||||
H.label "id"
|
||||
H.text (toS cid)
|
||||
H.div $ do
|
||||
H.label "created"
|
||||
H.text (show (created (metas user)))
|
||||
H.div $ do
|
||||
H.label "id"
|
||||
H.text (toS cid)
|
||||
H.label "email"
|
||||
H.text (toS (email (val user)))
|
||||
H.div $ do
|
||||
H.label "role"
|
||||
H.text (show (role (val user)))
|
||||
|
||||
-- DELETE User
|
||||
data UserDeletedPage =
|
||||
|
@ -336,4 +354,4 @@ 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.span $ H.text (toS (nick nu))
|
||||
loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
|
||||
|
|
|
@ -106,3 +106,18 @@ requestEntityTooLarge = throwJSONErr err413
|
|||
|
||||
requestURITooLong :: MonadError ServantErr m => Text -> m a
|
||||
requestURITooLong = throwJSONErr err414
|
||||
|
||||
internalServerError :: MonadError ServantErr m => Text -> m a
|
||||
internalServerError = throwJSONErr err500
|
||||
|
||||
notImplemented :: MonadError ServantErr m => Text -> m a
|
||||
notImplemented = throwJSONErr err501
|
||||
|
||||
badGateway :: MonadError ServantErr m => Text -> m a
|
||||
badGateway = throwJSONErr err502
|
||||
|
||||
serviceUnavailable :: MonadError ServantErr m => Text -> m a
|
||||
serviceUnavailable = throwJSONErr err503
|
||||
|
||||
gatewayTimeout :: MonadError ServantErr m => Text -> m a
|
||||
gatewayTimeout = throwJSONErr err504
|
||||
|
|
Loading…
Reference in a new issue