user by nick, updated page

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"

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

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
@@ -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.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
 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))

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