yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Cleanup and minor reorg, HTML for Users

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-01-24 23:38:41 +01:00
parent a87f0e928b
commit 179a47aeed
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
4 changed files with 125 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

72
src/Aggreact/Comments/Views.hs
View file

@ -1,24 +1,24 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Aggreact.Comments
Description : Example of a library file.
@ -38,27 +38,27 @@ module Aggreact.Comments.Views
where
--------------------------------------------------------------------------------
import Protolude hiding (get, put)
import Protolude hiding (get, put)
--------------------------------------------------------------------------------
import Aggreact.Comments.Types
import Aggreact.Html (boilerplate, loginWidget,
urlEncode, cvt, extlink)
import Aggreact.User (NewUser (..), User)
import Aggreact.Html (boilerplate, cvt, extlink,
urlEncode)
import Aggreact.User (NewUser (..), User, loginWidget)
--------------------------------------------------------------------------------
import Data.Aeson (ToJSON (..))
import Data.Duration (approximativeDuration)
import qualified Data.IxSet.Typed as IxSet
import Data.String (IsString (..))
import Data.Time (UTCTime, diffUTCTime)
import Data.Time.Clock.Serialize ()
import Data.Time.Format ()
import qualified Data.UUID as UUID
import Database.Store (DefaultMetas (..), Entity (..))
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Data.Aeson (ToJSON (..))
import Data.Duration (approximativeDuration)
import qualified Data.IxSet.Typed as IxSet
import Data.String (IsString (..))
import Data.Time (UTCTime, diffUTCTime)
import Data.Time.Clock.Serialize ()
import Data.Time.Format ()
import qualified Data.UUID as UUID
import Database.Store (DefaultMetas (..), Entity (..))
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
-- * Single Comment Page

5
src/Aggreact/Homepage.hs
View file

@ -42,9 +42,8 @@ import Protolude
import Aggreact.Comments (Comment, CommentHandler(..),
Slug (..), displayOneComment)
import Aggreact.Css (genCss)
import Aggreact.Html (boilerplate, loginWidget,
urlEncode)
import Aggreact.User (User)
import Aggreact.Html (boilerplate, urlEncode)
import Aggreact.User (User,loginWidget)
import Clay (Css)
import Data.String (IsString (..))
import Data.Time (UTCTime, getCurrentTime)

8
src/Aggreact/Html.hs
View file

@ -30,7 +30,6 @@ Main datastructures
module Aggreact.Html
( boilerplate
, urlEncode
, loginWidget
, LoginPage(..)
, cvt
, extlink
@ -47,9 +46,6 @@ import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Printf
import Aggreact.User (NewUser (..), User)
import Database.Store (Entity (..))
container :: H.Html -> H.Html
container = H.div ! A.class_ "container"
@ -68,10 +64,6 @@ data LoginPage = LoginPage
instance H.ToMarkup LoginPage where
toMarkup _ = boilerplate (return ()) loginPage
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))
boilerplate :: H.Markup -> H.Markup -> H.Html
boilerplate headerHtml innerHtml =
H.html $ do

107
src/Aggreact/User.hs
View file

@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
@ -21,7 +22,6 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{- |
Module : Aggreact.User
@ -42,9 +42,13 @@ where
import Protolude hiding (pass)
import Aggreact.Html (boilerplate, cvt, urlEncode)
import qualified Crypto.Scrypt as Crypt
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Data (Data (..))
import qualified Data.UUID as UUID
import Database.SQLite.Simple (NamedParam (..),
SQLData (..))
import Database.SQLite.Simple.FromField (FromField (..),
@ -63,9 +67,13 @@ import qualified Database.Store.CRUD as CRUD
import qualified Database.Store.Search as Search
import qualified Generics.SOP as SOP
import Servant
import Servant.Errors as Err
import Servant.HTML.Blaze (HTML)
import Servant.Auth.Server (AuthResult(..),FromJWT(..),ToJWT(..))
import Servant.Auth.Server (AuthResult (..),
FromJWT (..), ToJWT (..))
import Servant.Errors as Err
import Servant.HTML.Blaze (HTML)
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
-- NewUser
data NewUser =
@ -128,8 +136,8 @@ deriving anyclass instance ToJSON Role
instance FromField Role where
fromField f = case fieldData f of
SQLText "User" -> return User
SQLText "Admin" -> return Admin
SQLText "User" -> pure User
SQLText "Admin" -> pure Admin
_ -> returnError ConversionFailed f "need a text containing User or Admin"
instance ToField Role where toField = toField . (show :: Role -> Text)
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
@ -171,7 +179,7 @@ initDBUsers conf adminUser = do
(SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
case admins of
[] -> void $ createUser' dbstore adminUser
_ -> return ()
_ -> pure ()
pure dbstore
stopDBUsers' :: DBStore -> IO ()
@ -229,15 +237,15 @@ checkUserLogin uh loginNick loginPass = do
(Crypt.Pass (toS loginPass))
(Crypt.EncryptedPass (toS (password (val user))))
if goodPassword
then return (Just user)
else return Nothing
_ -> return Nothing
then pure (Just user)
else pure Nothing
_ -> pure Nothing
-- * User API
type UserAPI =
"users" :> Capture "userid" Id :> Get '[JSON] User
:<|> "users" :> Capture "userid" Id :> Delete '[JSON] Bool
"users" :> Capture "userid" Id :> 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
@ -248,25 +256,84 @@ userAPI :: UserHandler
userAPI userHandler authResult =
let muser = case authResult of
(Servant.Auth.Server.Authenticated user) -> Just user
_ -> Nothing
_ -> Nothing
in
getUserById userHandler
getUserById muser userHandler
:<|> deleteUserById muser userHandler
-- :<|> liftIO . searchUsers userHandler []
-- :<|> liftIO . createUser userHandler
getUserById :: UserHandler -> Id -> Handler User
getUserById userHandler userId = do
-- GET User
getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
getUserById muser userHandler userId = do
mu <- liftIO $ readUser userHandler userId
case mu of
Nothing -> Err.notFound "user not found"
Just u -> return u
Just u -> pure (UserPage u muser)
data UserPage =
UserPage
{ user :: User
, muser :: Maybe User
}
instance ToJSON UserPage where
toJSON = toJSON . user
instance H.ToMarkup UserPage where
toMarkup UserPage{..} = boilerplate (loginWidget muser) $ do
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 -> H.Markup
showUser user = do
let cid = UUID.toString (toS (id user))
nu = val user
H.div $ do
H.label "nick"
H.text (toS (nick nu))
H.div $ do
H.label "created"
H.text (show (created (metas user)))
H.div $ do
H.label "id"
H.text (toS cid)
-- DELETE User
data UserDeletedPage =
UserDeletedPage
{ deleted :: Bool
, deletedUser :: User
, muser :: Maybe User
}
instance ToJSON UserDeletedPage where
toJSON = toJSON . deletedUser
instance H.ToMarkup UserDeletedPage where
toMarkup UserDeletedPage{..} = boilerplate (loginWidget muser) $ do
let n = toS (nick (val deletedUser))
H.h2 $
H.text ("User " <> n <> if deleted then " was deleted" else " couldn't be deleted!")
deleteUserById :: Maybe User -- ^ Logged User
-> UserHandler
-> Id -- ^ User id to delete
-> Handler Bool
-> Handler UserDeletedPage
deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
deleteUserById (Just u) userHandler userId
| role (val u) == Admin = liftIO $ deleteUser userHandler userId
| role (val u) == Admin = do
userToDelete <- liftIO $ readUser userHandler userId
case userToDelete of
Nothing -> notFound "User not found!"
Just utd -> UserDeletedPage
<$> liftIO (deleteUser userHandler userId)
<*> pure utd
<*> pure (Just u)
| otherwise = forbidden "Only admins can delete users"
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))