Skip to content

Commit f282367

Browse files
dnulnetsdnulnets
committed
Added support for roles
1 parent 4a700dd commit f282367

File tree

14 files changed

+170
-86
lines changed

14 files changed

+170
-86
lines changed

‎backend/hadmin/Main.hs‎

Lines changed: 16 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -24,9 +24,7 @@ module Main where
2424
--
2525
-- Standard libraries
2626
--
27-
import Control.Monad ( forM_
28-
, void
29-
)
27+
import Control.Monad (forM_)
3028
import Control.Monad.IO.Class ( MonadIO
3129
, liftIO
3230
)
@@ -43,11 +41,8 @@ import Data.Maybe ( catMaybes )
4341
import qualified Data.Text as DT
4442
import qualified Data.Text.Encoding as DTE
4543
import Data.Time.Clock ( getCurrentTime )
46-
import Data.HexString ( fromBinary
47-
, hexString
48-
, toBinary
49-
, toText
50-
)
44+
import Data.HexString ( hexString
45+
, toBinary)
5146
import System.Environment ( getArgs
5247
, getEnv
5348
)
@@ -56,14 +51,16 @@ import System.Environment ( getArgs
5651
-- Persistence libraries
5752
--
5853
import Database.Persist
59-
import Database.Persist.Postgresql
60-
import Database.Persist.Sql
54+
import Database.Persist.Postgresql
55+
( SqlBackend, rawSql, runSqlPersistMPool, withPostgresqlPool )
56+
import Database.Persist.Sql ()
6157

6258
--
6359
-- Get our own items
6460
--
6561
import Accessability.Data.Geo
66-
import qualified Accessability.Data.Item as ADI
62+
import qualified Accessability.Data.Item as ADI
63+
import qualified Accessability.Data.User as ADU
6764
import Accessability.Model.Database
6865
import Accessability.Model.REST.Item
6966
import Accessability.Model.Transform
@@ -110,12 +107,13 @@ addUser
110107
:: (MonadIO m)
111108
=> Integer -- ^ bcrypt cost
112109
-> String -- ^ Username
110+
-> String -- ^ Role
113111
-> String -- ^ Email
114112
-> String -- ^ Password
115113
-> ReaderT SqlBackend m () -- ^ A database effect
116-
addUser cost uname uemail upw = do
114+
addUser cost uname urole uemail upw = do
117115
pw <- liftIO $ authHashPassword cost $ DT.pack upw
118-
ukey <- insert $ User (DT.pack uname) (DTE.decodeUtf8 pw) (DT.pack uemail)
116+
ukey <- insert $ User (DT.pack uname) (DTE.decodeUtf8 pw) (DT.pack uemail) (read urole)
119117
user <- get ukey
120118
case user of
121119
(Just u) ->
@@ -192,15 +190,16 @@ handleAddUser
192190
-> [String] -- ^ The command line arguments
193191
-> IO () -- ^ The effect
194192
handleAddUser database cost args = case length args of
195-
4 ->
193+
5 ->
196194
runFileLoggingT "hadmin.log"
197195
$ withPostgresqlPool (DB.pack database) 5
198196
$ \pool -> liftIO $ flip runSqlPersistMPool pool $ addUser
199197
cost
200198
(args !! 1)
201199
(args !! 2)
202200
(args !! 3)
203-
_ -> putStrLn "Usage: hadmin adduser <username> <email> <password>"
201+
(args !! 4)
202+
_ -> putStrLn "Usage: hadmin adduser <username> <role> <email> <password>"
204203

205204
-- |Handles the chapw command
206205
handleChangePassword
@@ -524,7 +523,7 @@ usage = do
524523
putStrLn ""
525524
putStrLn "User commands:"
526525
putStrLn ""
527-
putStrLn "adduser <username> <email> <password>"
526+
putStrLn "adduser <username> <role> <email> <password>"
528527
putStrLn "deluser <username>"
529528
putStrLn "chapw <username> <new password>"
530529
putStrLn "lsusers"
@@ -549,6 +548,7 @@ usage = do
549548
tid <- getCurrentTime
550549
putStrLn $ "UTC Timestamp: " <> DT.unpack
551550
(DTE.decodeUtf8 $ B.toStrict $ encode tid)
551+
putStrLn $ "Role:" <> show [ADU.Citizen, ADU.Administrator]
552552
putStrLn $ "Source: " <> show [ADI.Human, ADI.Machine]
553553
putStrLn $ "Modifier: " <> show [ADI.Static, ADI.Transient]
554554
putStrLn $ "Approval: " <> show [ADI.Waiting, ADI.Approved, ADI.Denied]

‎backend/src/Accessability/Data/User.hs‎

Lines changed: 15 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717
--
1818
module Accessability.Data.User
1919
( User(..)
20+
, Role(..)
2021
, Operation(..)
2122
, UserProperty(..)
2223
)
@@ -53,24 +54,33 @@ customOptions = defaultOptions
5354
--
5455
-- User
5556
--
57+
data Role = Citizen -- ^ Ordinary user, no administratpor rights
58+
| Administrator -- ^ Administrator, can do anything on the site
59+
deriving (Generic, Show, Read, Eq)
60+
61+
derivePersistField "Role"
62+
63+
instance ToJSON Role where
64+
toJSON = genericToJSON customOptions
65+
toEncoding = genericToEncoding customOptions
66+
67+
instance FromJSON Role where
68+
parseJSON = genericParseJSON customOptions
5669

5770
-- | Definition of the user
5871
data User = User {
5972
userId :: Maybe Text -- ^ User key
60-
, userUsername :: Text -- ^ The username used when looging in
73+
, userUsername :: Text -- ^ The username used when looging in
6174
, userPassword :: Text -- ^ The password, bcrypted
6275
, userEmail :: Text -- ^ The user email address
76+
, userRole :: Role -- ^ The role of the user
6377
} deriving (Generic)
6478

6579
-- |Automatically derive JSON but we do not want the first charatcer in the field to go out
6680
$(deriveJSON defaultOptions {
6781
fieldLabelModifier = firstLower . drop 4 -- Get rid of the 'user' in the field names
6882
} ''User)
6983

70-
--
71-
-- User Property
72-
--
73-
7484
-- |The property operation todetermine if they are accessible
7585
data Operation = GT -- ^ Greater than value
7686
| GTE -- ^ Greater than or equal to value

‎backend/src/Accessability/Foundation.hs‎

Lines changed: 19 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -25,8 +25,9 @@ module Accessability.Foundation (
2525
Handler,
2626
Route (..),
2727
resourcesServer,
28-
getAuthenticatedUser,
29-
requireAuthentication) where
28+
getAuthenticatedUserInfo,
29+
requireAuthentication,
30+
requireAuthenticationAndRole) where
3031

3132
--
3233
-- Standard libraries
@@ -50,6 +51,8 @@ import Network.HTTP.Types (status403)
5051
--
5152
import Accessability.Settings (AppSettings (..))
5253
import Accessability.Utils.JWT (tokenToJson)
54+
import Accessability.Model.REST.Authenticate (TokenInfo(..))
55+
import Accessability.Data.User (Role)
5356

5457
--
5558
-- The HTTP server and network libraries
@@ -119,15 +122,24 @@ instance YesodPersist Server where
119122
-- return with a Permission Denied to the REST caller.
120123
requireAuthentication :: Handler () -- ^ The Handler
121124
requireAuthentication = do
122-
userId <- getAuthenticatedUser
123-
case userId of
125+
userInfo <- getAuthenticatedUserInfo
126+
case userInfo of
124127
Nothing -> sendStatusJSON status403 ()
125128
Just _ -> pure ()
126129

130+
-- | Requires that the user is authenticated. if not it will short circuit the Handler and
131+
-- return with a Permission Denied to the REST caller.
132+
requireAuthenticationAndRole :: Role->Handler () -- ^ The Handler
133+
requireAuthenticationAndRole r = do
134+
mti <- getAuthenticatedUserInfo
135+
case mti of
136+
Nothing -> sendStatusJSON status403 ()
137+
Just (TokenInfo uid role) -> if role == r then pure () else sendStatusJSON status403 ()
138+
127139
-- | Checks to see if the caller is authenticated, if so it returns with the user identity
128140
-- that was part of the JWT the caller sent with the request.
129-
getAuthenticatedUser ::Handler (Maybe Text) -- ^ The user identity
130-
getAuthenticatedUser = do
141+
getAuthenticatedUserInfo ::Handler (Maybe TokenInfo) -- ^ The user identity
142+
getAuthenticatedUserInfo = do
131143
bearer <- lookupBearerAuth
132144
seconds <- liftIO $ fromIntegral . systemSeconds <$> getSystemTime
133145
secret <- tokenSecret . appSettings <$> getYesod
@@ -139,4 +151,4 @@ getAuthenticatedUser = do
139151
Just info ->
140152
case fromJSON info of
141153
Error _ -> Nothing
142-
Success uid -> Just uid
154+
Success ui -> Just ui

‎backend/src/Accessability/Handler/REST/Authenticate.hs‎

Lines changed: 11 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -37,12 +37,13 @@ import Yesod
3737
-- Internal imports
3838
--
3939
import Accessability.Foundation (Handler, Server (..),
40-
getAuthenticatedUser)
40+
getAuthenticatedUserInfo)
4141
import Accessability.Model.Database
4242
( Unique(UniqueUserUsername),
43-
User(userEmail, userUsername, userPassword) )
43+
User(userEmail, userUsername, userPassword, userRole) )
4444
import Accessability.Model.REST.Authenticate (Authenticate (..),
45-
UserInfo (..))
45+
UserInfo (..),
46+
TokenInfo(..))
4647
import Accessability.Model.Transform (keyToText, textToKey)
4748
import Accessability.Settings (AppSettings (..))
4849
import Accessability.Utils.JWT (jsonToToken)
@@ -60,26 +61,26 @@ postAuthenticateR = do
6061
len = tokenExpiration appset
6162
in case dbuser of
6263
Just (Entity userId user) | authValidatePassword (userPassword user) (password auth) -> do
63-
let token = jsonToToken secret seconds len $ toJSON $ keyToText userId
64-
returnJson $ UserInfo (keyToText userId) token (userUsername user) (userEmail user)
64+
let token = jsonToToken secret seconds len $ toJSON $ TokenInfo (keyToText userId) (userRole user)
65+
returnJson $ UserInfo (keyToText userId) token (userUsername user) (userRole user) (userEmail user)
6566
_ -> sendResponseStatus status401 Null
6667

6768
-- |Get the authentication bearer so we can extract the userid out of it and search for the
6869
-- user and return with it if it exists
6970
getAuthenticateR :: Handler Value
7071
getAuthenticateR = do
71-
key <- getAuthenticatedUser
72-
case key of
72+
mui <- getAuthenticatedUserInfo
73+
case mui of
7374
Nothing ->
7475
sendResponseStatus status401 Null
75-
Just uid -> do
76+
Just ui -> do
7677
token <- lookupBearerAuth
7778
case token of
7879
Just k -> do
79-
dbuser <- runDB $ get $ textToKey uid
80+
dbuser <- runDB $ get $ textToKey $ tiuserid ui
8081
case dbuser of
8182
Just user ->
82-
returnJson $ UserInfo uid k (userUsername user) (userEmail user)
83+
returnJson $ UserInfo (tiuserid ui) k (userUsername user) (userRole user) (userEmail user)
8384
_ ->
8485
sendResponseStatus status401 Null
8586
_ ->

‎backend/src/Accessability/Handler/REST/Item.hs‎

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -44,14 +44,16 @@ import Yesod
4444
import Accessability.Data.Analysis (evaluatePOI)
4545
import Accessability.Data.Functor
4646
import Accessability.Data.Geo
47+
import Accessability.Data.User (Role(..))
4748
import Accessability.Data.Item (Attribute (..), Item (..),
4849
ItemValue (..))
49-
import Accessability.Foundation (Handler, getAuthenticatedUser,
50-
requireAuthentication)
50+
import Accessability.Foundation (Handler, getAuthenticatedUserInfo,
51+
requireAuthentication, requireAuthenticationAndRole)
5152
import qualified Accessability.Handler.Database as DBF
5253
import qualified Accessability.Model.Database as DB
5354
import Accessability.Model.REST.Item
5455
import Accessability.Model.Transform
56+
import Accessability.Model.REST.Authenticate(TokenInfo(..))
5557

5658
-- | The REST GET handler for an item, i.e. return with the data of an item based on the items
5759
-- key provided in the URL api/item/0000000000000001
@@ -76,7 +78,7 @@ getItemR key = do
7678
deleteItemR:: Text -- ^ The item key
7779
-> Handler () -- ^ The item as a JSON response
7880
deleteItemR key = do
79-
requireAuthentication
81+
requireAuthenticationAndRole Administrator
8082
result <- UIOE.catchAny (DBF.dbDeleteItem $ textToKey key)
8183
(pure . Left . show)
8284
case result of
@@ -92,7 +94,7 @@ putItemR
9294
:: Text -- ^ The item key
9395
-> Handler Value -- ^ The item as a JSON response
9496
putItemR key = do
95-
requireAuthentication
97+
requireAuthenticationAndRole Administrator
9698
queryBody <- requireCheckJsonBody :: Handler PutItemBody
9799
result <- UIOE.catchAny
98100
( fffmap toGenericItem
@@ -121,7 +123,7 @@ putItemR key = do
121123
-- and return with the data as stored in the database.
122124
postCreateItemR :: Handler Value -- ^ The item as a JSON response
123125
postCreateItemR = do
124-
requireAuthentication
126+
requireAuthenticationAndRole Administrator
125127
body <- requireCheckJsonBody :: Handler PostItemBody
126128
result <- UIOE.catchAny
127129
(fffmap toGenericItem DBF.dbCreateItem $ DB.Item
@@ -180,13 +182,11 @@ postItemsAndValuesR = do
180182
requireAuthentication
181183

182184
-- Get the user properties
183-
mkey <- getAuthenticatedUser
184-
props <- case mkey of
185-
Just key -> do
185+
mui <- getAuthenticatedUserInfo
186+
props <- case mui of
187+
Just ui -> do
186188
result <- UIOE.catchAny
187-
(fffmap toGenericUserProperty $ DBF.dbFetchUserProperties $ textToKey
188-
key
189-
)
189+
(fffmap toGenericUserProperty $ DBF.dbFetchUserProperties $ textToKey $ tiuserid ui)
190190
(pure . Left . show)
191191
case result of
192192
Left _ -> pure []
@@ -278,7 +278,7 @@ getItemAttributesR key = do
278278
-- If the record has no attributeValueID and no value it is ignored
279279
putItemAttributesR :: Text -> Handler Value
280280
putItemAttributesR key = do
281-
requireAuthentication
281+
requireAuthenticationAndRole Administrator
282282
queryBody <- requireCheckJsonBody :: Handler [PutItemAttributes]
283283
result <- UIOE.catchAny
284284
(DBF.dbUpdateItemAttributes (doit <$> queryBody))

‎backend/src/Accessability/Handler/REST/User.hs‎

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -31,28 +31,28 @@ import Yesod
3131
-- My own imports
3232
--
3333
import Accessability.Data.Functor
34-
import Accessability.Foundation (Handler, getAuthenticatedUser)
34+
import Accessability.Foundation (Handler, getAuthenticatedUserInfo)
3535
import qualified Accessability.Handler.Database as DBF
3636
import qualified Accessability.Model.Database as DB
3737
import Accessability.Model.REST.User
3838
import Accessability.Model.Transform
39+
import Accessability.Model.REST.Authenticate
40+
( TokenInfo(tiuserid) )
3941

4042
-- | The REST GET handler for an item, i.e. return with the data of an item based on the items
4143
-- key provided in the URL api/item/0000000000000001
4244
getUserPropertiesR :: Handler Value -- ^ The list of possible attributes and their values, if any
4345
getUserPropertiesR = do
44-
mkey <- getAuthenticatedUser
45-
case mkey of
46-
Just key -> do
46+
mui <- getAuthenticatedUserInfo
47+
case mui of
48+
Just ui -> do
4749
result <- UIOE.catchAny
48-
(fffmap toGenericUserProperty $ DBF.dbFetchUserProperties $ textToKey
49-
key
50-
)
50+
(fffmap toGenericUserProperty $ DBF.dbFetchUserProperties $ textToKey $ tiuserid ui)
5151
(pure . Left . show)
5252
case result of
5353
Left e ->
5454
invalidArgs
55-
$ ["Unable to get the item from the database", key]
55+
$ ["Unable to get the item from the database", tiuserid ui]
5656
<> splitOn "\n" (pack e)
5757
Right a -> sendStatusJSON status200 a
5858
Nothing ->
@@ -66,18 +66,18 @@ getUserPropertiesR = do
6666
-- If the record has no attributeValueID and no operation it is ignored
6767
putUserPropertiesR :: Handler Value
6868
putUserPropertiesR = do
69-
mkey <- getAuthenticatedUser
70-
case mkey of
71-
Just key -> do
69+
mui <- getAuthenticatedUserInfo
70+
case mui of
71+
Just ui -> do
7272
queryBody <- requireCheckJsonBody :: Handler [PutUserProperty]
7373
liftIO $ print queryBody
7474
result <- UIOE.catchAny
75-
(DBF.dbUpdateUserProperties (doit key <$> queryBody))
75+
(DBF.dbUpdateUserProperties (doit (tiuserid ui) <$> queryBody))
7676
(pure . Left . show)
7777
case result of
7878
Left e ->
7979
invalidArgs
80-
$ ["Unable to update the items parameters ", key]
80+
$ ["Unable to update the items parameters ", tiuserid ui]
8181
<> splitOn "\n" (pack e)
8282
Right _ -> sendResponseStatus status200 Null
8383
Nothing ->

0 commit comments

Comments
 (0)