Register

src/Aggreact/Html.hs

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

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

src/Database/Store/Backend/SQLite.hs

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