From 95db1db9adece73619be893378350a5d1723c824 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Fri, 25 Jan 2019 22:31:23 +0100 Subject: [PATCH] user by nick, updated page --- src-test/Database/Store/Backend/SQLiteTest.hs | 2 +- src/Aggreact/Css.hs | 1 + src/Aggreact/User.hs | 30 +++++++++++++++---- src/Servant/Errors.hs | 15 ++++++++++ 4 files changed, 41 insertions(+), 7 deletions(-) diff --git a/src-test/Database/Store/Backend/SQLiteTest.hs b/src-test/Database/Store/Backend/SQLiteTest.hs index 3f88862..a77c38d 100644 --- a/src-test/Database/Store/Backend/SQLiteTest.hs +++ b/src-test/Database/Store/Backend/SQLiteTest.hs @@ -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" diff --git a/src/Aggreact/Css.hs b/src/Aggreact/Css.hs index c691255..4655466 100644 --- a/src/Aggreact/Css.hs +++ b/src/Aggreact/Css.hs @@ -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 diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs index 91fffdf..e39e53b 100644 --- a/src/Aggreact/User.hs +++ b/src/Aggreact/User.hs @@ -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 @@ -285,7 +297,7 @@ instance H.ToMarkup UserPage where let n = toS (nick (val user)) H.h2 $ do H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n) - showUser user + showUser user showUser :: User -> H.Markup showUser user = do @@ -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)) diff --git a/src/Servant/Errors.hs b/src/Servant/Errors.hs index 0edaf9d..b19b685 100644 --- a/src/Servant/Errors.hs +++ b/src/Servant/Errors.hs @@ -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