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)
|
foo2 <- readFoo store (id foo1)
|
||||||
when (Just foo1 /= foo2) $ assertFailure "Foo1 and Foo2 should be equal"
|
when (Just foo1 /= foo2) $ assertFailure "Foo1 and Foo2 should be equal"
|
||||||
void $ step "Search created entity by name"
|
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 (length foos /= 1) $ assertFailure "Bad numbers of found elements"
|
||||||
when (head foos /= Just foo1) $ assertFailure "Search returned the bad result"
|
when (head foos /= Just foo1) $ assertFailure "Search returned the bad result"
|
||||||
void $ step "cleaning up temporary files"
|
void $ step "cleaning up temporary files"
|
||||||
|
|
|
@ -128,6 +128,7 @@ genCss = do
|
||||||
label ? do
|
label ? do
|
||||||
minWidth (em 7)
|
minWidth (em 7)
|
||||||
display inlineBlock
|
display inlineBlock
|
||||||
|
fontWeight (weight 100)
|
||||||
label # byClass "togglelabel" ? do
|
label # byClass "togglelabel" ? do
|
||||||
minWidth (em 2)
|
minWidth (em 2)
|
||||||
display inlineBlock
|
display inlineBlock
|
||||||
|
|
|
@ -74,6 +74,7 @@ import Servant.HTML.Blaze (HTML)
|
||||||
import Text.Blaze.Html5 ((!))
|
import Text.Blaze.Html5 ((!))
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Text.Blaze.Html5 as H
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
import qualified Text.Blaze.Html5.Attributes as A
|
||||||
|
import qualified Web.HttpApiData as FormI
|
||||||
|
|
||||||
-- NewUser
|
-- NewUser
|
||||||
data NewUser =
|
data NewUser =
|
||||||
|
@ -87,6 +88,7 @@ newtype Nick = Nick Text
|
||||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||||
deriving anyclass instance FromJSON Nick
|
deriving anyclass instance FromJSON Nick
|
||||||
deriving anyclass instance ToJSON Nick
|
deriving anyclass instance ToJSON Nick
|
||||||
|
instance FormI.FromHttpApiData Nick where parseUrlPiece = fmap Nick . FormI.parseUrlPiece
|
||||||
deriving newtype instance FromField Nick
|
deriving newtype instance FromField Nick
|
||||||
deriving newtype instance ToField Nick
|
deriving newtype instance ToField Nick
|
||||||
instance StringConv Nick [Char] where strConv l (Nick sl) = strConv l sl
|
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 (Eq,Ord,Data,Typeable,Generic,Show)
|
||||||
deriving anyclass instance FromJSON Email
|
deriving anyclass instance FromJSON Email
|
||||||
deriving anyclass instance ToJSON Email
|
deriving anyclass instance ToJSON Email
|
||||||
|
instance FormI.FromHttpApiData Email where parseUrlPiece = fmap Email . FormI.parseUrlPiece
|
||||||
deriving newtype instance FromField Email
|
deriving newtype instance FromField Email
|
||||||
deriving newtype instance ToField Email
|
deriving newtype instance ToField Email
|
||||||
instance StringConv Email [Char] where strConv l (Email sl) = strConv l sl
|
instance StringConv Email [Char] where strConv l (Email sl) = strConv l sl
|
||||||
|
@ -244,7 +247,7 @@ checkUserLogin uh loginNick loginPass = do
|
||||||
-- * User API
|
-- * User API
|
||||||
|
|
||||||
type UserAPI =
|
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" :> Capture "userid" Id :> Delete '[HTML,JSON] UserDeletedPage
|
||||||
-- :<|> "users" :> Get '[HTML,JSON] [User]
|
-- :<|> "users" :> Get '[HTML,JSON] [User]
|
||||||
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
-- :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
|
||||||
|
@ -258,12 +261,21 @@ userAPI userHandler authResult =
|
||||||
(Servant.Auth.Server.Authenticated user) -> Just user
|
(Servant.Auth.Server.Authenticated user) -> Just user
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
in
|
in
|
||||||
getUserById muser userHandler
|
getUserByNick muser userHandler
|
||||||
:<|> deleteUserById muser userHandler
|
:<|> deleteUserById muser userHandler
|
||||||
-- :<|> liftIO . searchUsers userHandler []
|
-- :<|> liftIO . searchUsers userHandler []
|
||||||
-- :<|> liftIO . createUser userHandler
|
-- :<|> liftIO . createUser userHandler
|
||||||
|
|
||||||
-- GET User
|
-- 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 :: Maybe User -> UserHandler -> Id -> Handler UserPage
|
||||||
getUserById muser userHandler userId = do
|
getUserById muser userHandler userId = do
|
||||||
mu <- liftIO $ readUser userHandler userId
|
mu <- liftIO $ readUser userHandler userId
|
||||||
|
@ -285,7 +297,7 @@ instance H.ToMarkup UserPage where
|
||||||
let n = toS (nick (val user))
|
let n = toS (nick (val user))
|
||||||
H.h2 $ do
|
H.h2 $ do
|
||||||
H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
|
H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
|
||||||
showUser user
|
showUser user
|
||||||
|
|
||||||
showUser :: User -> H.Markup
|
showUser :: User -> H.Markup
|
||||||
showUser user = do
|
showUser user = do
|
||||||
|
@ -294,12 +306,18 @@ showUser user = do
|
||||||
H.div $ do
|
H.div $ do
|
||||||
H.label "nick"
|
H.label "nick"
|
||||||
H.text (toS (nick nu))
|
H.text (toS (nick nu))
|
||||||
|
H.div $ do
|
||||||
|
H.label "id"
|
||||||
|
H.text (toS cid)
|
||||||
H.div $ do
|
H.div $ do
|
||||||
H.label "created"
|
H.label "created"
|
||||||
H.text (show (created (metas user)))
|
H.text (show (created (metas user)))
|
||||||
H.div $ do
|
H.div $ do
|
||||||
H.label "id"
|
H.label "email"
|
||||||
H.text (toS cid)
|
H.text (toS (email (val user)))
|
||||||
|
H.div $ do
|
||||||
|
H.label "role"
|
||||||
|
H.text (show (role (val user)))
|
||||||
|
|
||||||
-- DELETE User
|
-- DELETE User
|
||||||
data UserDeletedPage =
|
data UserDeletedPage =
|
||||||
|
@ -336,4 +354,4 @@ deleteUserById (Just u) userHandler userId
|
||||||
|
|
||||||
loginWidget :: Maybe User -> H.Markup
|
loginWidget :: Maybe User -> H.Markup
|
||||||
loginWidget Nothing = H.a ! A.href "/login" $ H.text "Login"
|
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 :: MonadError ServantErr m => Text -> m a
|
||||||
requestURITooLong = throwJSONErr err414
|
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