Compare commits
No commits in common. "ec9fb25517ba5fb98074585e177db3d17e0f7dec" and "7ebc6b0eda35a73ff2ef86c59de5c0325c4ce30d" have entirely different histories.
ec9fb25517
...
7ebc6b0eda
|
|
@ -1,6 +1,2 @@
|
|||
**/db/schema.sql
|
||||
**/client_session_key.aes
|
||||
**/*.o
|
||||
**/*.hi
|
||||
**/*.dyn_o
|
||||
**/*.dyn_hi
|
||||
|
|
|
|||
|
|
@ -7,8 +7,6 @@
|
|||
#:use-module ((guix licenses) #:prefix license:)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (gnu packages golang)
|
||||
#:use-module (gnu packages golang-xyz)
|
||||
#:use-module (gnu packages golang-compression)
|
||||
#:use-module (gnu packages golang-check)
|
||||
#:use-module (gnu packages syncthing)
|
||||
#:use-module (gnu packages haskell)
|
||||
|
|
@ -761,7 +759,7 @@ README for more information.")
|
|||
(define-public go-github-com-jmoiron-sqlx
|
||||
(package
|
||||
(name "go-github-com-jmoiron-sqlx")
|
||||
(version "1.4.0")
|
||||
(version "1.3.5")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
|
|
@ -770,7 +768,7 @@ README for more information.")
|
|||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"10rg9b6cl1j7jjr6z95xa1k45016mhicii3cmz0pkwrxw3dpfzfh"))))
|
||||
"09snd3gfi3sm3gib7jdc6p8zxpn2ah0isqnibbag6f63k473yj14"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/jmoiron/sqlx"))
|
||||
|
|
@ -784,29 +782,29 @@ README for more information.")
|
|||
"Package sqlx provides general purpose extensions to database/sql.")
|
||||
(license license:expat)))
|
||||
|
||||
(define-public go-github-com-bkaradzic-go-lz4
|
||||
(define-public go-github-com-pierrec-lz4
|
||||
(package
|
||||
(name "go-github-com-bkaradzic-go-lz4")
|
||||
(version "1.0.0")
|
||||
(source
|
||||
(origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
(url "https://github.com/bkaradzic/go-lz4")
|
||||
(commit (string-append "v" version))))
|
||||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32 "1vdid8v0c2v2qhrg9rzn3l7ya1h34jirrxfnir7gv7w6s4ivdvc1"))))
|
||||
(name "go-github-com-pierrec-lz4")
|
||||
(version "v2.0.5+incompatible")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
(url "https://github.com/pierrec/lz4")
|
||||
(commit (go-version->git-ref version))))
|
||||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"0y5rh7z01zycd59nnjpkqq0ydyjmcg9j1xw15q1i600l9j9g617p"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
(list
|
||||
#:import-path "github.com/bkaradzic/go-lz4"))
|
||||
(home-page "https://github.com/bkaradzic/go-lz4")
|
||||
(synopsis "go-lz4")
|
||||
'(#:import-path "github.com/pierrec/lz4"))
|
||||
(home-page "https://github.com/pierrec/lz4")
|
||||
(synopsis "lz4 : LZ4 compression in pure Go")
|
||||
(description
|
||||
"go-lz4 is port of LZ4 lossless compression algorithm to Go. The original C code
|
||||
is located at:.")
|
||||
(license license:bsd-2)))
|
||||
"Package lz4 implements reading and writing lz4 compressed data (a frame), as
|
||||
specified in
|
||||
@url{http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html,http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html}.")
|
||||
(license license:bsd-3)))
|
||||
|
||||
(define-public go-github-com-clickhouse-clickhouse-go
|
||||
(package
|
||||
|
|
@ -841,7 +839,7 @@ ClickHouse}")
|
|||
(define-public go-github-com-joho-godotenv
|
||||
(package
|
||||
(name "go-github-com-joho-godotenv")
|
||||
(version "1.5.1")
|
||||
(version "1.4.0")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
|
|
@ -850,7 +848,7 @@ ClickHouse}")
|
|||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"03vijs05k31jdf24pzj3vlk6b5jxf894v1kvzals4wzclyq2h3ch"))))
|
||||
"1036h59vyhb58n817az6yg0zw5wa87yb86i7fnbdq8cw46mnjgw8"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/joho/godotenv"))
|
||||
|
|
@ -861,9 +859,9 @@ ClickHouse}")
|
|||
(@url{https://github.com/bkeepers/dotenv,https://github.com/bkeepers/dotenv})")
|
||||
(license license:expat)))
|
||||
|
||||
(define-public go-github-com-zenizh-go-capturer
|
||||
(define-public go-github-com-kami-zh-go-capturer
|
||||
(package
|
||||
(name "go-github-com-zenizh-go-capturer")
|
||||
(name "go-github-com-kami-zh-go-capturer")
|
||||
(version "0.0.0-20211219060012-52ea6c8fed04")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
|
|
@ -876,8 +874,8 @@ ClickHouse}")
|
|||
"0zwz9gr1863z32gz9nyysg66mg124w6nql4m99g2dg6fbq2klda4"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/zenizh/go-capturer"))
|
||||
(home-page "https://github.com/zenizh/go-capturer")
|
||||
'(#:import-path "github.com/kami-zh/go-capturer"))
|
||||
(home-page "https://github.com/kami-zh/go-capturer")
|
||||
(synopsis "go-capturer")
|
||||
(description
|
||||
"Capture @code{os.Stdout} and/or @code{os.Stderr} in Go. This package is useful
|
||||
|
|
@ -887,7 +885,7 @@ for writing tests which print some outputs using @code{fmt} package.")
|
|||
(define-public go-github-com-cloudflare-golz4
|
||||
(package
|
||||
(name "go-github-com-cloudflare-golz4")
|
||||
(version "0.0.0-20240916140612-caecf3c00c06")
|
||||
(version "0.0.0-20150217214814-ef862a3cdc58")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
|
|
@ -896,7 +894,7 @@ for writing tests which print some outputs using @code{fmt} package.")
|
|||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"15nppvbav7kj3hh9qv9qbn15pd0c9lpljs5syl004cz6mif43as3"))))
|
||||
"0ckiwp3aa010sdnki6vd32f0n08768ppnggc8d7syzh3kkn9zvn1"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/cloudflare/golz4"
|
||||
|
|
@ -906,12 +904,53 @@ for writing tests which print some outputs using @code{fmt} package.")
|
|||
(description "Package lz4 implements compression using lz4.c and lz4hc.c")
|
||||
(license license:bsd-3)))
|
||||
|
||||
(define-public go-github-com-cpuguy83-go-md2man-v2
|
||||
(package
|
||||
(name "go-github-com-cpuguy83-go-md2man-v2")
|
||||
(version "2.0.2")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
(url "https://github.com/cpuguy83/go-md2man")
|
||||
(commit (string-append "v" version))))
|
||||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"19qri18cinpzxblkid6ngz2vcxslv73s1aid900q0gfzvc71mqqb"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/cpuguy83/go-md2man/v2"))
|
||||
(propagated-inputs (list go-github-com-russross-blackfriday-v2))
|
||||
(home-page "https://github.com/cpuguy83/go-md2man")
|
||||
(synopsis "go-md2man")
|
||||
(description "Converts markdown into roff (man pages).")
|
||||
(license license:expat)))
|
||||
|
||||
(define-public go-github-com-russross-blackfriday-v2
|
||||
(package
|
||||
(name "go-github-com-russross-blackfriday-v2")
|
||||
(version "2.1.0")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
(url "https://github.com/russross/blackfriday")
|
||||
(commit (string-append "v" version))))
|
||||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"0d1rg1drrfmabilqjjayklsz5d0n3hkf979sr3wsrw92bfbkivs7"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/russross/blackfriday/v2"))
|
||||
(home-page "https://github.com/russross/blackfriday")
|
||||
(synopsis "Blackfriday")
|
||||
(description "Package blackfriday is a markdown processor.")
|
||||
(license license:bsd-2)))
|
||||
|
||||
(define-public dbmate
|
||||
(package
|
||||
(name "dbmate")
|
||||
(version "1.16.2")
|
||||
(version "1.15.0")
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
|
|
@ -920,16 +959,22 @@ for writing tests which print some outputs using @code{fmt} package.")
|
|||
(file-name (git-file-name name version))
|
||||
(sha256
|
||||
(base32
|
||||
"0mp06dg8x19pkbl51k0b5xj7bamaj6f61fyi0cfbd1dldwzw0676"))))
|
||||
"1dbhm2aqppn4m55xnx18017shsy109hqv2nhksxb4ix83bjaq5vq"))))
|
||||
(build-system go-build-system)
|
||||
(arguments
|
||||
'(#:import-path "github.com/amacneil/dbmate"))
|
||||
(propagated-inputs
|
||||
(list go-github-com-zenizh-go-capturer
|
||||
(list go-gopkg-in-yaml-v3
|
||||
go-github-com-russross-blackfriday-v2
|
||||
go-github-com-pmezard-go-difflib
|
||||
go-github-com-davecgh-go-spew
|
||||
go-github-com-cpuguy83-go-md2man-v2
|
||||
go-github-com-cloudflare-golz4
|
||||
go-github-com-urfave-cli-v2
|
||||
go-github-com-stretchr-testify
|
||||
go-github-com-mattn-go-sqlite3
|
||||
go-github-com-lib-pq
|
||||
go-github-com-kami-zh-go-capturer
|
||||
go-github-com-joho-godotenv
|
||||
go-github-com-go-sql-driver-mysql
|
||||
go-github-com-clickhouse-clickhouse-go))
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@ authBearer Nothing m = m
|
|||
authBearer (Just (BearerToken bearer)) m = do
|
||||
let getUserPermissions = do
|
||||
Right DBToken {..} <- lift $ dbGetTokenBySecret bearer
|
||||
permissions' <- lift dbTokenPermissions
|
||||
permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions
|
||||
DBUser {..} <- lift dbTokenUser
|
||||
userID <- lift dbUserId
|
||||
pure (Just userID, permissions')
|
||||
|
|
@ -140,7 +140,8 @@ authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
|
|||
authBasic Nothing m = m
|
||||
authBasic (Just basic) m = do
|
||||
DBUser {..} <- verifyBasic basic
|
||||
permissions <- lift dbUserPermissions
|
||||
permissions <- readPermission <$> lift dbUserPermissions >>=
|
||||
fromMaybeFail status500 "Internal server error"
|
||||
userID <- lift dbUserId
|
||||
flip local m $ \state -> state
|
||||
{ stateCurrentUser = Just userID
|
||||
|
|
@ -165,7 +166,7 @@ newtype APIM a = APIM (ReaderT RequestState IO a)
|
|||
|
||||
data RequestState = RequestState
|
||||
{ stateCurrentUser :: Maybe UserID
|
||||
, statePermissions :: Permissions
|
||||
, statePermissions :: Map Scope Permission
|
||||
, stateConfig :: Config
|
||||
}
|
||||
|
||||
|
|
@ -213,15 +214,28 @@ instance MonadRandom APIM where
|
|||
getRandomBytes = liftIO . getRandomBytes
|
||||
|
||||
instance MonadPermissions APIM where
|
||||
currentPermissions = asks statePermissions
|
||||
defaultPermissions =
|
||||
maybe mempty (\user -> Permissions $ fromList [(Profile user, ReadWrite)]) <$>
|
||||
asks stateCurrentUser
|
||||
currentPermissions = show <$> asks statePermissions
|
||||
defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
|
||||
toPermissions = pure . fmap show . readPermission
|
||||
hasPermission scope permission = (>= permission) <$> findPermission scope
|
||||
where findPermission :: Scope -> APIM Permission
|
||||
findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
|
||||
findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
|
||||
findPermission scope = findPermission' scope <$> asks statePermissions
|
||||
findPermission' :: Scope -> Map Scope Permission -> Permission
|
||||
findPermission' = findWithDefault None
|
||||
selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
|
||||
selfPermissions scope user own = do
|
||||
isSelf <- (Just user ==) <$> currentUser
|
||||
let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
|
||||
else findPermission' scope
|
||||
|
||||
f <$> asks statePermissions
|
||||
|
||||
runAPIM :: Config -> APIM a -> IO a
|
||||
runAPIM config (APIM m) = runReaderT m RequestState
|
||||
{ stateCurrentUser = Nothing
|
||||
, statePermissions = Permissions $ fromList []
|
||||
, statePermissions = fromList []
|
||||
, stateConfig = config
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
|
|||
import qualified "base64" Data.ByteString.Base64 as B64
|
||||
|
||||
import Control.Monad.Except (MonadError, throwError, catchError)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Morpheus.Server (deriveApp, runApp)
|
||||
import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
|
||||
import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
|
||||
|
|
@ -83,24 +82,18 @@ sendVerificationSecret DBUser {..} = do
|
|||
sendVerificationEmail secret' pendingEmail' >> pure True
|
||||
_ -> pure False
|
||||
|
||||
updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m, MonadPermissions m) =>
|
||||
updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
|
||||
UpdateArgs -> UserID -> m UpdateData
|
||||
updateArgsToData UpdateArgs {..} user = do
|
||||
when (maybe False T.null name) $ throwError "Name must not be empty"
|
||||
when (maybe False T.null password) $ throwError "Password must not be empty"
|
||||
when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
|
||||
requestPermissions <- currentPermissions
|
||||
let permissions' = inputPermissionsToPermissions <$> permissions
|
||||
when (maybe False (> requestPermissions) permissions') $ throwError "Permissions must not be greater than the request's"
|
||||
dbUser <- dbGetUser user >>= liftDBEither
|
||||
isMember <- fmap isJust $ dbUserAccepted $ dbUser
|
||||
isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
|
||||
when (isMember && isJust application) $ throwError "Members can't update their applications"
|
||||
passwordHash <- sequence $ hashPassword <$> password
|
||||
updateTime <- currentTime
|
||||
verificationSecret <- genVerificationSecret
|
||||
oldPermissions <- dbUserPermissions dbUser
|
||||
pure UpdateData {permissions = (<> oldPermissions) <$> permissions', ..}
|
||||
-- Map's (and thus Permissions') <> prefers values from the left operand
|
||||
pure UpdateData {..}
|
||||
|
||||
updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
|
||||
MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
|
||||
|
|
@ -115,7 +108,7 @@ newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
|
|||
newTokenArgsToData NewTokenArgs {..} user = do
|
||||
tokenData <- B64.encodeBase64 <$> getRandomBytes 128
|
||||
issued <- currentTime
|
||||
permissions <- maybe currentPermissions pure $ inputPermissionsToPermissions <$> permissions
|
||||
permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
|
||||
let expires = Nothing
|
||||
pure NewTokenData {..}
|
||||
|
||||
|
|
@ -162,7 +155,7 @@ resolveQuery = Query
|
|||
, user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
|
||||
(Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
|
||||
, applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
|
||||
, permissions = fromPermissions <$> currentPermissions
|
||||
, permissions = currentPermissions
|
||||
}
|
||||
|
||||
resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
|
||||
|
|
@ -210,14 +203,13 @@ data UpdateArgs = UpdateArgs
|
|||
, nickname :: Maybe Text
|
||||
, homeplace :: Maybe Text
|
||||
, application :: Maybe Text
|
||||
, permissions :: Maybe [InputScopePermission]
|
||||
} deriving (Generic, GQLType, Eq, Show)
|
||||
|
||||
data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
|
||||
deriving (Generic, GQLType, Eq, Show)
|
||||
|
||||
data NewTokenArgs = NewTokenArgs
|
||||
{ comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe [InputScopePermission] }
|
||||
{ comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
|
||||
deriving (Generic, GQLType)
|
||||
|
||||
data User m = User
|
||||
|
|
@ -231,7 +223,7 @@ data User m = User
|
|||
, homeplace :: m Text
|
||||
, registered :: m Time
|
||||
, accepted :: m (Maybe Time)
|
||||
, permissions :: m [ScopePermission]
|
||||
, permissions :: m Text
|
||||
, isMember :: m Bool
|
||||
, application :: m Text
|
||||
, tokens :: m [Token m]
|
||||
|
|
@ -254,15 +246,14 @@ data Token m = Token
|
|||
, comment :: m Text
|
||||
, issued :: m Time
|
||||
, expires :: m (Maybe Time)
|
||||
, permissions :: m [ScopePermission]
|
||||
, owner :: m (User m)
|
||||
, permissions :: m Text
|
||||
} deriving (Generic, GQLType)
|
||||
|
||||
data Query m = Query
|
||||
{ users :: m [User m]
|
||||
, user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
|
||||
, applications :: m [User m]
|
||||
, permissions :: m [ScopePermission]
|
||||
, permissions :: m Text
|
||||
} deriving (Generic, GQLType)
|
||||
|
||||
data Mutation m = Mutation
|
||||
|
|
@ -288,7 +279,7 @@ dbUserToUser DBUser {..} = User
|
|||
, homeplace = dbUserHomeplace
|
||||
, registered = dbUserRegistered
|
||||
, accepted = dbUserAccepted
|
||||
, permissions = fromPermissions <$> dbUserPermissions
|
||||
, permissions = dbUserPermissions
|
||||
, isMember = isJust <$> dbUserAccepted
|
||||
, application = dbUserApplication
|
||||
, tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
|
||||
|
|
@ -305,7 +296,7 @@ dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
|
|||
, comment = dbPGPKeyComment
|
||||
}
|
||||
|
||||
dbTokenToToken :: (MonadPermissions m, MonadError GQLError m) => DBToken m -> Token m
|
||||
dbTokenToToken :: Monad m => DBToken m -> Token m
|
||||
dbTokenToToken DBToken {..} = Token
|
||||
{ id = dbTokenId
|
||||
, name = dbTokenName
|
||||
|
|
@ -313,20 +304,5 @@ dbTokenToToken DBToken {..} = Token
|
|||
, comment = dbTokenComment
|
||||
, issued = dbTokenIssued
|
||||
, expires = dbTokenExpires
|
||||
, permissions = fromPermissions <$> dbTokenPermissions
|
||||
, owner = dbUserToUser <$> dbTokenUser
|
||||
, permissions = dbTokenPermissions
|
||||
}
|
||||
|
||||
inputPermissionsToPermissions :: [InputScopePermission] -> Permissions
|
||||
inputPermissionsToPermissions = Permissions .
|
||||
Map.fromList . map (\InputScopePermission {..} -> (scope, permission))
|
||||
|
||||
fromPermissions :: Permissions -> [ScopePermission]
|
||||
fromPermissions (Permissions perms) =
|
||||
map (\(scope, permission) -> ScopePermission scope permission) $ Map.toList perms
|
||||
|
||||
data InputScopePermission = InputScopePermission {scope :: Scope, permission :: Permission}
|
||||
deriving (Generic, GQLType, Eq, Show)
|
||||
|
||||
data ScopePermission = ScopePermission {scope :: Scope, permission :: Permission}
|
||||
deriving (Generic, GQLType)
|
||||
|
|
|
|||
|
|
@ -31,10 +31,7 @@ dbUpdateUser UpdateData {..} = do
|
|||
, SetUserPhoneNumber <$> phoneNumber
|
||||
, SetUserApplication <$> application
|
||||
]
|
||||
userUpdates = catMaybes
|
||||
[ (SqlUserPasswordCrypt =.) <$> passwordHash
|
||||
, (SqlUserPermissions =.) <$> permissions
|
||||
]
|
||||
userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
|
||||
sqlUser <- runQuery $ do
|
||||
Sql.updateUserData user userUpdates memberDataUpdates
|
||||
case email of
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@
|
|||
|
||||
module Datarekisteri.Backend.Sql.Queries where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Logger (LoggingT)
|
||||
import Data.Aeson (fromJSON, toJSON, Result(..))
|
||||
import Data.Maybe (listToMaybe)
|
||||
|
|
@ -47,11 +46,11 @@ getKeys user = select $ do
|
|||
getKey :: KeyID -> SqlM (Maybe SqlKey)
|
||||
getKey = get . fromID
|
||||
|
||||
getPermissions :: UserID -> SqlM (Maybe Permissions)
|
||||
getPermissions :: UserID -> SqlM (Maybe Text)
|
||||
getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user
|
||||
|
||||
setPermissions :: UserID -> Permissions -> SqlM ()
|
||||
setPermissions user permissions = void $ updateUserData user [SqlUserPermissions Persist.=. permissions] []
|
||||
setPermissions :: UserID -> Text -> SqlM ()
|
||||
setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return ()
|
||||
|
||||
getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey))
|
||||
getPrimaryKey user = fmap listToMaybe $ select $ do
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ mkPersist sqlSettings [persistUpperCase|
|
|||
SqlUser sql=users
|
||||
registered Time
|
||||
passwordCrypt PasswordHash
|
||||
permissions Permissions
|
||||
permissions Text
|
||||
accepted (Maybe Time)
|
||||
memberData Value sqltype=jsonb
|
||||
|
||||
|
|
@ -68,7 +68,7 @@ SqlToken sql=tokens
|
|||
comment Text
|
||||
issued Time
|
||||
expires (Maybe Time)
|
||||
permissions Permissions
|
||||
permissions Text
|
||||
|
||||
UniqueNameUid name uid
|
||||
UniqueData data
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ forward :: Monad m => [a] -> m [Maybe a]
|
|||
forward = pure . map Just
|
||||
|
||||
requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m ()
|
||||
requirePermission scope permission = unlessM (hasPermission scope permission <$> currentPermissions) $
|
||||
requirePermission scope permission = unlessM (hasPermission scope permission) $
|
||||
throwError $ "Insufficient permissions, " <> show permission <> " for "
|
||||
<> show scope <> " required."
|
||||
|
||||
|
|
@ -64,7 +64,7 @@ data ApplicationData = ApplicationData
|
|||
, registered :: Time
|
||||
, verificationSecret :: Text
|
||||
, passwordHash :: PasswordHash
|
||||
, permissions :: Permissions
|
||||
, permissions :: Text
|
||||
} deriving (Generic, Eq, Show)
|
||||
|
||||
data UpdateData = UpdateData
|
||||
|
|
@ -78,7 +78,6 @@ data UpdateData = UpdateData
|
|||
, user :: UserID
|
||||
, updateTime :: Time
|
||||
, verificationSecret :: Text
|
||||
, permissions :: Maybe Permissions
|
||||
} deriving (Generic, Eq, Show)
|
||||
|
||||
data NewKeyData = NewKeyData
|
||||
|
|
@ -100,7 +99,7 @@ data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
|
|||
data NewTokenData = NewTokenData
|
||||
{ comment :: Maybe Text
|
||||
, name :: Maybe Text
|
||||
, permissions :: Permissions
|
||||
, permissions :: Text
|
||||
, tokenData :: Text
|
||||
, issued :: Time
|
||||
, expires :: Maybe Time
|
||||
|
|
@ -123,7 +122,7 @@ data DBUser m = DBUser
|
|||
, dbUserHomeplace :: m Text
|
||||
, dbUserRegistered :: m Time
|
||||
, dbUserAccepted :: m (Maybe Time)
|
||||
, dbUserPermissions :: m Permissions
|
||||
, dbUserPermissions :: m Text
|
||||
, dbUserApplication :: m Text
|
||||
, dbUserPasswordHash :: m PasswordHash
|
||||
, dbUserTokens :: m [DBToken m]
|
||||
|
|
@ -147,7 +146,7 @@ data DBToken m = DBToken
|
|||
, dbTokenComment :: m Text
|
||||
, dbTokenIssued :: m Time
|
||||
, dbTokenExpires :: m (Maybe Time)
|
||||
, dbTokenPermissions :: m Permissions
|
||||
, dbTokenPermissions :: m Text
|
||||
}
|
||||
|
||||
class Monad m => MonadTime m where
|
||||
|
|
@ -181,8 +180,10 @@ class Monad m => MonadRequest m where
|
|||
currentUser :: m (Maybe UserID)
|
||||
|
||||
class Monad m => MonadPermissions m where
|
||||
currentPermissions :: m Permissions
|
||||
defaultPermissions :: m Permissions
|
||||
hasPermission :: Scope -> Permission -> m Bool
|
||||
currentPermissions :: m Text
|
||||
defaultPermissions :: m Text
|
||||
toPermissions :: Text -> m (Maybe Text)
|
||||
|
||||
instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
|
||||
dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
|
||||
|
|
@ -203,8 +204,10 @@ instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) whe
|
|||
currentUser = lift currentUser
|
||||
|
||||
instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where
|
||||
hasPermission scope permission = lift $ hasPermission scope permission
|
||||
defaultPermissions = lift defaultPermissions
|
||||
currentPermissions = lift currentPermissions
|
||||
toPermissions = lift . toPermissions
|
||||
|
||||
instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where
|
||||
sendEmail = lift . sendEmail
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ addUserMain AddUserOpts {..} = do
|
|||
userID <- Sql.addUser $ SqlUser
|
||||
{ sqlUserRegistered = time
|
||||
, sqlUserPasswordCrypt = passwordHash
|
||||
, sqlUserPermissions = addUserPermissions
|
||||
, sqlUserPermissions = show addUserPermissions
|
||||
, sqlUserAccepted = Just time
|
||||
, sqlUserMemberData = toJSON $ MemberData
|
||||
{ nickname = addUserNickname
|
||||
|
|
@ -82,7 +82,7 @@ updateUserMain UpdateUserOpts {..} = runQuery $ do
|
|||
Just application -> Sql.updateUserData updateUserId [] [Sql.SetUserApplication application]
|
||||
case updateUserPermissions of
|
||||
Nothing -> pure ()
|
||||
Just permissions -> Sql.setPermissions updateUserId permissions
|
||||
Just permissions -> Sql.setPermissions updateUserId $ show permissions
|
||||
|
||||
cliOptions :: Parser CLIOptions
|
||||
cliOptions = CLIOptions
|
||||
|
|
@ -114,8 +114,8 @@ updateUserCommand = fmap UpdateUser $ UpdateUserOpts
|
|||
<*> optional (strOption (long "application" <> metavar "TEXT"))
|
||||
<*> optional permissionsParser
|
||||
|
||||
permissionsParser :: Parser Permissions
|
||||
permissionsParser = Permissions . fromList <$> many permissionParser
|
||||
permissionsParser :: Parser (Map Scope Permission)
|
||||
permissionsParser = fromList <$> many permissionParser
|
||||
|
||||
permissionParser :: Parser (Scope, Permission)
|
||||
permissionParser = (,)
|
||||
|
|
@ -136,7 +136,7 @@ data CLISubCommand = AddUser AddUserOpts
|
|||
data UpdateUserOpts = UpdateUserOpts
|
||||
{ updateUserId :: UserID
|
||||
, updateUserApplication :: Maybe Text
|
||||
, updateUserPermissions :: Maybe Permissions
|
||||
, updateUserPermissions :: Maybe (Map Scope Permission)
|
||||
}
|
||||
|
||||
data AddUserOpts = AddUserOpts
|
||||
|
|
@ -146,7 +146,7 @@ data AddUserOpts = AddUserOpts
|
|||
, addUserHomeplace :: Text
|
||||
, addUserPhoneNumber :: PhoneNumber
|
||||
, addUserEmail :: Email
|
||||
, addUserPermissions :: Permissions
|
||||
, addUserPermissions :: Map Scope Permission
|
||||
, addUserApplication :: Text
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(url "https://git.savannah.gnu.org/git/guix.git")
|
||||
(branch "master")
|
||||
(commit
|
||||
"faf8ba9b43323dc61988a368690b20008611fc87")
|
||||
"a96f1c1bc0fa186414359890025e8acacbb1de02")
|
||||
(introduction
|
||||
(make-channel-introduction
|
||||
"9edb3f66fd807b096b48283debdcddccfea34bad"
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@ library
|
|||
morpheus-graphql-core,
|
||||
morpheus-graphql-server,
|
||||
persistent,
|
||||
persistent-postgresql,
|
||||
relude,
|
||||
text,
|
||||
time,
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ module Datarekisteri.Core.Types
|
|||
, Email
|
||||
, KeyID(..)
|
||||
, Permission(..)
|
||||
, Permissions(..)
|
||||
, PhoneNumber
|
||||
, Scope(..)
|
||||
, Time(..)
|
||||
|
|
@ -22,7 +21,7 @@ module Datarekisteri.Core.Types
|
|||
, addTime
|
||||
, base64Decode
|
||||
, base64Encode
|
||||
, hasPermission
|
||||
, readPermission
|
||||
, renderDate
|
||||
, renderEmail
|
||||
, renderPhoneNumber
|
||||
|
|
@ -37,22 +36,18 @@ import Relude
|
|||
|
||||
import qualified "base64" Data.ByteString.Base64 as B64
|
||||
|
||||
import Data.Aeson (Value, ToJSON(..), FromJSON(..), Result(..), ToJSONKey(..), FromJSONKey(..), FromJSONKeyFunction(..), ToJSONKeyFunction(..), fromJSON, eitherDecodeStrict)
|
||||
import Data.Aeson.Encoding (string)
|
||||
import Data.Aeson (ToJSON(..), FromJSON(..))
|
||||
import Data.Char (isSpace)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Morpheus.Server.Types (SCALAR, TYPE)
|
||||
import Data.Morpheus.Server.Types (SCALAR)
|
||||
import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..), ScalarValue(..))
|
||||
import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
|
||||
import Data.Time (UTCTime, NominalDiffTime, addUTCTime, Day)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
|
||||
import Database.Persist.Class (PersistField(..))
|
||||
import Database.Persist.PersistValue (PersistValue(..))
|
||||
import Database.Persist.Postgresql.JSON () -- persistent instances for Aeson's Value
|
||||
import Database.Persist.Sql (PersistFieldSql(..))
|
||||
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
base64Encode :: ByteString -> Base64
|
||||
|
|
@ -82,63 +77,21 @@ renderDate (Date x) = toText $ iso8601Show x
|
|||
addTime :: NominalDiffTime -> Time -> Time
|
||||
addTime diff (Time time) = Time $ addUTCTime diff time
|
||||
|
||||
data Scope = Profile UserID
|
||||
data Scope = OwnProfile
|
||||
| OwnTokens
|
||||
| Profile UserID
|
||||
| Tokens UserID
|
||||
| Members
|
||||
| Applications
|
||||
deriving (Show, Eq, Ord, Read, Generic)
|
||||
|
||||
instance DecodeScalar Scope where
|
||||
decodeScalar (String s) = maybe (Left $ "invalid Scope: \"" <> s <> "\"") Right $ readMaybe (toString s)
|
||||
decodeScalar _ = Left "Invalid type for Scope, should be string"
|
||||
|
||||
instance EncodeScalar Scope where
|
||||
encodeScalar = String . show
|
||||
|
||||
instance GQLType Scope where type KIND Scope = SCALAR
|
||||
instance ToJSON Scope where toJSON = scalarToJSON
|
||||
instance FromJSON Scope where parseJSON = scalarFromJSON <=< parseJSON
|
||||
instance ToJSONKey Scope where toJSONKey = ToJSONKeyText (fromString . show) (string . show)
|
||||
instance FromJSONKey Scope
|
||||
where fromJSONKey = FromJSONKeyTextParser $
|
||||
either fail pure . (eitherDecodeStrict . encodeUtf8)
|
||||
deriving (Show, Eq, Ord, Read)
|
||||
|
||||
data Permission = None
|
||||
| ReadOnly
|
||||
| ReadWrite
|
||||
deriving (Show, Eq, Ord, Read, Generic)
|
||||
deriving (Show, Eq, Ord, Read)
|
||||
|
||||
instance DecodeScalar Permission where
|
||||
decodeScalar (String s) = maybe (Left $ "invalid Permission: \"" <> s <> "\"") Right $ readMaybe (toString s)
|
||||
decodeScalar _ = Left "Invalid type for Permission, should be string"
|
||||
|
||||
instance EncodeScalar Permission where
|
||||
encodeScalar = String . show
|
||||
|
||||
instance GQLType Permission where type KIND Permission = SCALAR
|
||||
instance ToJSON Permission where toJSON = scalarToJSON
|
||||
instance FromJSON Permission where parseJSON = scalarFromJSON <=< parseJSON
|
||||
|
||||
hasPermission :: Scope -> Permission -> Permissions -> Bool
|
||||
hasPermission scope permission (Permissions permissionMap) =
|
||||
Map.findWithDefault None scope permissionMap >= permission
|
||||
|
||||
newtype Permissions = Permissions (Map Scope Permission)
|
||||
deriving (Show, Eq, Read, Generic, ToJSON, FromJSON, Semigroup, Monoid)
|
||||
|
||||
instance GQLType Permissions where type KIND Permissions = TYPE
|
||||
|
||||
instance PersistField Permissions where
|
||||
toPersistValue = toPersistValue . toJSON
|
||||
fromPersistValue = resultToEither . fromJSON <=< fromPersistValue
|
||||
where resultToEither (Success x) = Right x
|
||||
resultToEither (Error err) = Left $ T.pack err
|
||||
|
||||
instance PersistFieldSql Permissions where sqlType _ = sqlType (Proxy :: Proxy Value)
|
||||
|
||||
instance Ord Permissions where
|
||||
(Permissions a) <= (Permissions b) =
|
||||
and $ Map.intersectionWith (<=) a $ b <> (const None <$> Map.difference a b)
|
||||
readPermission :: Text -> Maybe (Map Scope Permission)
|
||||
readPermission = rightToMaybe . readEither . toString
|
||||
|
||||
newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic)
|
||||
|
||||
|
|
|
|||
|
|
@ -6,12 +6,8 @@ scalar Email
|
|||
|
||||
scalar KeyID
|
||||
|
||||
scalar Permission
|
||||
|
||||
scalar PhoneNumber
|
||||
|
||||
scalar Scope
|
||||
|
||||
scalar Time
|
||||
|
||||
scalar TokenID
|
||||
|
|
@ -23,11 +19,6 @@ enum Unit {
|
|||
Unit2
|
||||
}
|
||||
|
||||
input InputScopePermission {
|
||||
scope: Scope!
|
||||
permission: Permission!
|
||||
}
|
||||
|
||||
type PGPKey {
|
||||
id: KeyID!
|
||||
pgpKeyData: Base64!
|
||||
|
|
@ -36,11 +27,6 @@ type PGPKey {
|
|||
comment: String!
|
||||
}
|
||||
|
||||
type ScopePermission {
|
||||
scope: Scope!
|
||||
permission: Permission!
|
||||
}
|
||||
|
||||
type Token {
|
||||
id: TokenID!
|
||||
name: String
|
||||
|
|
@ -48,8 +34,7 @@ type Token {
|
|||
comment: String!
|
||||
issued: Time!
|
||||
expires: Time
|
||||
permissions: [ScopePermission!]!
|
||||
owner: User!
|
||||
permissions: String!
|
||||
}
|
||||
|
||||
type User {
|
||||
|
|
@ -63,7 +48,7 @@ type User {
|
|||
homeplace: String!
|
||||
registered: Time!
|
||||
accepted: Time
|
||||
permissions: [ScopePermission!]!
|
||||
permissions: String!
|
||||
isMember: Boolean!
|
||||
application: String!
|
||||
tokens: [Token!]!
|
||||
|
|
@ -75,15 +60,15 @@ type Query {
|
|||
users: [User!]!
|
||||
user(id: UserID): User
|
||||
applications: [User!]!
|
||||
permissions: [ScopePermission!]!
|
||||
permissions: String!
|
||||
}
|
||||
|
||||
type Mutation {
|
||||
apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
|
||||
verifyEmail(secret: String!): Boolean!
|
||||
resendVerificationEmail(user: UserID): Unit!
|
||||
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, permissions: [InputScopePermission!], user: UserID): User!
|
||||
newToken(comment: String, name: String, permissions: [InputScopePermission!]): Token!
|
||||
update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
|
||||
newToken(comment: String, name: String, permissions: String): Token!
|
||||
newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
|
||||
accept(user: UserID!): Unit!
|
||||
reject(user: UserID!): Unit!
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Datarekisteri.Frontend.Handlers
|
||||
( module Datarekisteri.Frontend.Handlers.Permissions
|
||||
, module Datarekisteri.Frontend.Handlers.Profile
|
||||
( module Datarekisteri.Frontend.Handlers.Profile
|
||||
, module Datarekisteri.Frontend.Handlers.Applications
|
||||
, module Datarekisteri.Frontend.Handlers.Apply
|
||||
, module Datarekisteri.Frontend.Handlers.Members
|
||||
|
|
@ -24,7 +23,6 @@ import Yesod
|
|||
import Yesod.Auth
|
||||
|
||||
import Datarekisteri.Frontend.Handlers.Profile
|
||||
import Datarekisteri.Frontend.Handlers.Permissions
|
||||
import Datarekisteri.Frontend.Handlers.Apply
|
||||
import Datarekisteri.Frontend.Handlers.Applications
|
||||
import Datarekisteri.Frontend.Handlers.VerifyEmail
|
||||
|
|
@ -32,4 +30,4 @@ import Datarekisteri.Frontend.Handlers.Members
|
|||
import Datarekisteri.Frontend.Types
|
||||
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = maybeAuthId >>= maybe (redirect $ AuthR LoginR) (redirect . ProfileR . userID)
|
||||
getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
|
||||
|
|
|
|||
|
|
@ -115,12 +115,12 @@ applicationsW applications = do
|
|||
.#{detailsClass}[open] { border-color: #339ca1; }
|
||||
|]
|
||||
|
||||
getApplicationsR :: Handler Html
|
||||
getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
getApplicationsR = do
|
||||
Applications applications <- apiRequest @Applications True ()
|
||||
defaultLayout $ applicationsW applications
|
||||
|
||||
postAcceptR :: Handler Html
|
||||
postAcceptR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
postAcceptR = do
|
||||
((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
|
||||
case result of
|
||||
|
|
@ -128,7 +128,7 @@ postAcceptR = do
|
|||
_ -> pure ()
|
||||
redirect ApplicationsR
|
||||
|
||||
postRejectR :: Handler Html
|
||||
postRejectR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
postRejectR = do
|
||||
((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
|
||||
case result of
|
||||
|
|
|
|||
|
|
@ -75,12 +75,12 @@ applyW (applyWidget, applyEnctype) = do
|
|||
^{form ApplyR applyEnctype formContent}
|
||||
|]
|
||||
|
||||
getApplyR :: Handler Html
|
||||
getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
getApplyR = do
|
||||
applyForm <- liftHandler $ generateFormPost applyForm
|
||||
defaultLayout $ applyW applyForm
|
||||
|
||||
postApplyR :: Handler Html
|
||||
postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
postApplyR = do
|
||||
((result, widget), enctype) <- runFormPost applyForm
|
||||
case result of
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ instance ToTableRow DataIdClient MembersPageUsers where
|
|||
tableHeader _ = toWidget <$> ["Nimi" :: Text, "Kutsumanimi", "Kotipaikka"]
|
||||
toCells MembersPageUsers {..} = toWidget <$> [name, nickname, homeplace]
|
||||
|
||||
getMembersR :: Handler Html
|
||||
getMembersR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
getMembersR = do
|
||||
MembersPage {..} <- apiRequest True ()
|
||||
defaultLayout $ do
|
||||
|
|
|
|||
|
|
@ -1,62 +0,0 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
|
||||
module Datarekisteri.Frontend.Handlers.Permissions where
|
||||
|
||||
import Relude hiding (id)
|
||||
|
||||
import Data.Morpheus.Client (raw, declareLocalTypesInline)
|
||||
|
||||
import Yesod
|
||||
import Yesod.Auth
|
||||
|
||||
import Datarekisteri.Core.Types
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Types
|
||||
import Datarekisteri.Frontend.Widgets
|
||||
|
||||
declareLocalTypesInline "schema.gql" [raw|
|
||||
query PermissionsPage($id: UserID!) {
|
||||
user(id: $id) {
|
||||
id
|
||||
name
|
||||
nickname
|
||||
permissions {
|
||||
scope
|
||||
permission
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
-- declareLocalTypesInline "schema.gql" [raw|
|
||||
-- mutation UpdatePermissions($user: UserID, $permissions: [InputScopePermission!]!) {
|
||||
-- update(user: $user, permissions: $permissions) {
|
||||
-- id
|
||||
-- }
|
||||
-- }
|
||||
-- |]
|
||||
|
||||
getPermissionsR :: UserID -> Handler Html
|
||||
getPermissionsR userID = defaultLayout $ do
|
||||
PermissionsPage {..} <- liftHandler $ apiRequest True (PermissionsPageArgs {id = userID})
|
||||
PermissionsPageUser {..} <- maybe undefined pure user
|
||||
let permissions' = (\PermissionsPageUserPermissions {..} -> (show scope, show permission) :: (Text, Text)) <$> permissions
|
||||
setTitle "Käyttöoikeudet"
|
||||
[whamlet|
|
||||
<h1>
|
||||
Käyttöoikeudet
|
||||
^{keyValueTable permissions'}
|
||||
|]
|
||||
|
||||
postPermissionsR :: UserID -> Handler Html
|
||||
postPermissionsR = undefined
|
||||
|
|
@ -26,7 +26,7 @@ import Datarekisteri.Frontend.FormFields
|
|||
import Datarekisteri.Frontend.Widgets
|
||||
|
||||
declareLocalTypesInline "schema.gql" [raw|
|
||||
query ProfilePage($id: UserID!) {
|
||||
query ProfilePage($id: UserID) {
|
||||
user(id: $id) {
|
||||
id
|
||||
name
|
||||
|
|
@ -39,6 +39,7 @@ query ProfilePage($id: UserID!) {
|
|||
isMember
|
||||
application
|
||||
}
|
||||
permissions
|
||||
}
|
||||
|]
|
||||
|
||||
|
|
@ -119,8 +120,8 @@ profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) =
|
|||
^{form route passwordEnctype passwordFormContent}
|
||||
|]
|
||||
|
||||
getProfileR :: UserID -> Handler Html
|
||||
getProfileR userID = do
|
||||
getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
|
||||
getProfile userID = do
|
||||
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
|
||||
passwordForm <- liftHandler $ generateFormPost passwordForm
|
||||
profileForm <- liftHandler $ generateFormPost $
|
||||
|
|
@ -130,9 +131,15 @@ getProfileR userID = do
|
|||
|
||||
fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
|
||||
|
||||
postProfileR :: UserID -> Handler Html
|
||||
getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
getOwnProfileR = getProfile Nothing
|
||||
|
||||
getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
|
||||
getProfileR = getProfile . Just
|
||||
|
||||
postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
|
||||
postProfileR userID = do
|
||||
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
|
||||
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
|
||||
((result, widget), enctype) <- runFormPost $ profileForm (fromJust user)
|
||||
case result of
|
||||
FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
|
||||
|
|
@ -141,14 +148,14 @@ postProfileR userID = do
|
|||
defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm
|
||||
--- XXX fromJust explodes if the user no longer exists
|
||||
|
||||
postUpdatePasswordR :: UserID -> Handler Html
|
||||
postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
|
||||
postUpdatePasswordR userID = do
|
||||
((result, widget), enctype) <- runFormPost passwordForm
|
||||
case result of
|
||||
FormSuccess new ->
|
||||
apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
|
||||
_ -> do
|
||||
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
|
||||
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
|
||||
profileForm <- liftHandler $ generateFormPost $ profileForm (fromJust user)
|
||||
defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
|
||||
--- XXX fromJust explodes if the user no longer exists
|
||||
|
|
|
|||
|
|
@ -33,17 +33,14 @@ getVerifyEmailR = do
|
|||
codeForm <- generateFormPost verifyForm
|
||||
defaultLayout $ verifyEmailW codeForm
|
||||
|
||||
postVerifyEmailR :: Handler Html
|
||||
postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
|
||||
postVerifyEmailR = do
|
||||
((result, widget), enctype) <- runFormPost verifyForm
|
||||
case result of
|
||||
FormSuccess verify -> do
|
||||
success <- apiRequest @VerifyEmail False verify
|
||||
case success of
|
||||
VerifyEmail True -> do
|
||||
setMessage "Sähköpostiosoite vahvistettu"
|
||||
user <- userID <$> requireAuthId
|
||||
redirect $ ProfileR user
|
||||
VerifyEmail True -> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
|
||||
VerifyEmail False -> setMessage "Virheellinen vahvistuskoodi" >> redirect VerifyEmailR
|
||||
_ -> defaultLayout $ verifyEmailW (widget, enctype)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -30,12 +29,10 @@ import Yesod
|
|||
import Yesod.Auth
|
||||
import Yesod.Static
|
||||
|
||||
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), Permissions(..))
|
||||
import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
|
||||
import Datarekisteri.Frontend.ApiRequests
|
||||
import Datarekisteri.Frontend.Auth
|
||||
|
||||
import qualified Datarekisteri.Core.Types as Core
|
||||
|
||||
data DataIdClient = DataIdClient
|
||||
{ getStatic :: Static
|
||||
, getConfig :: Config
|
||||
|
|
@ -54,8 +51,8 @@ instance PathPiece UserID where
|
|||
mkYesodData "DataIdClient" [parseRoutes|
|
||||
/ HomeR GET
|
||||
|
||||
/user/#UserID/profile ProfileR GET POST
|
||||
/user/#UserID/permissions PermissionsR GET POST
|
||||
/profile OwnProfileR GET
|
||||
/profile/#UserID ProfileR GET POST
|
||||
/update-password/#UserID UpdatePasswordR POST
|
||||
/verify-email VerifyEmailR GET POST
|
||||
|
||||
|
|
@ -73,9 +70,9 @@ mkYesodData "DataIdClient" [parseRoutes|
|
|||
|
||||
declareLocalTypesInline "schema.gql" [raw|
|
||||
query GetPermissions {
|
||||
permissions {
|
||||
scope
|
||||
permission
|
||||
permissions
|
||||
user {
|
||||
id
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
|
@ -84,47 +81,35 @@ declareLocalTypesInline "schema.gql" [raw|
|
|||
mutation GetWebUIToken {
|
||||
newToken(comment: "id.datat.fi webui") {
|
||||
tokenData
|
||||
owner {
|
||||
id
|
||||
}
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
data UserToken = UserToken
|
||||
{ userID :: UserID
|
||||
, token :: Text
|
||||
} deriving (Read, Show)
|
||||
|
||||
instance PathPiece UserToken where
|
||||
toPathPiece userToken = show userToken
|
||||
fromPathPiece s = readMaybe (toString s)
|
||||
|
||||
instance YesodAuth DataIdClient where
|
||||
type AuthId DataIdClient = UserToken
|
||||
maybeAuthId = (>>= readMaybe . toString) <$> lookupSession credsKey
|
||||
type AuthId DataIdClient = Text
|
||||
maybeAuthId = lookupSession credsKey
|
||||
loginDest = const HomeR
|
||||
logoutDest = const HomeR
|
||||
authPlugins = const $ [authExternalBasic getToken]
|
||||
where getToken :: Text -> HandlerFor DataIdClient (Maybe Text)
|
||||
getToken auth = do
|
||||
response <- (>>= rightToMaybe) <$> apiRequestAuth @GetWebUIToken [] (Just auth) ()
|
||||
pure $ do
|
||||
token <- tokenData . newToken <$> response
|
||||
userID <- (\GetWebUITokenNewTokenOwner {..} -> id) . owner . newToken <$> response
|
||||
pure $ show $ UserToken userID token
|
||||
authenticate = pure . maybe (ServerError "Couldn't read UserToken") Authenticated . readMaybe . toString . credsIdent
|
||||
where getToken auth = (>>= fmap (tokenData . newToken) . rightToMaybe) <$>
|
||||
apiRequestAuth @GetWebUIToken [] (Just auth) ()
|
||||
authenticate = pure . Authenticated . credsIdent
|
||||
|
||||
withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult
|
||||
withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m
|
||||
|
||||
readPermissions :: [GetPermissionsPermissions] -> Permissions
|
||||
readPermissions = Permissions . fromList . map (\GetPermissionsPermissions {..} -> (scope, permission))
|
||||
|
||||
hasPermission :: Scope -> Permission -> Handler Bool
|
||||
hasPermission scope permission = do
|
||||
GetPermissions {..} <- apiRequest @GetPermissions False ()
|
||||
pure $ Core.hasPermission scope permission $ readPermissions permissions
|
||||
let permissionMap = fromMaybe mempty $ readPermission permissions
|
||||
findPermission scope = findWithDefault None scope permissionMap
|
||||
userID = (\x -> id (x :: GetPermissionsUser)) <$> user
|
||||
scopes = scope :| case scope of
|
||||
Tokens uid | Just uid == userID -> [OwnTokens]
|
||||
Profile uid | Just uid == userID -> [OwnProfile]
|
||||
_ -> []
|
||||
-- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant
|
||||
pure $ (>= permission) $ maximum1 $ findPermission <$> scopes
|
||||
|
||||
requirePermission :: Scope -> Permission -> Handler AuthResult
|
||||
requirePermission scope permission = ifM (hasPermission scope permission)
|
||||
|
|
@ -133,7 +118,9 @@ requirePermission scope permission = ifM (hasPermission scope permission)
|
|||
where renderPermission ReadWrite = "kirjoitusoikeuden"
|
||||
renderPermission ReadOnly = "lukuoikeuden"
|
||||
renderPermission None = "nollaoikeuden"
|
||||
renderScope OwnProfile = "omaan profiliin"
|
||||
renderScope (Profile _) = "käyttäjän profiliin"
|
||||
renderScope OwnTokens = "omiin tokeneihin" -- TODO kunnon suomennos
|
||||
renderScope (Tokens _) = "käyttäjän tokeneihin" -- TODO kunnon suomennos
|
||||
renderScope Members = "kaikkiin jäseniin"
|
||||
renderScope Applications = "jäsenhakemuksiin"
|
||||
|
|
@ -152,6 +139,7 @@ instance Yesod DataIdClient where
|
|||
isAuthorized HomeR _ = pure Authorized
|
||||
isAuthorized ApplyR _ = pure Authorized
|
||||
isAuthorized VerifyEmailR _ = pure Authorized
|
||||
isAuthorized OwnProfileR isWrite = withAuthenticated $ const $ authorizedHelper OwnProfile isWrite
|
||||
isAuthorized (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
|
||||
isAuthorized (UpdatePasswordR user) isWrite =
|
||||
withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
|
||||
|
|
@ -203,10 +191,8 @@ instance Yesod DataIdClient where
|
|||
|]
|
||||
navigationBar :: Widget
|
||||
navigationBar = do
|
||||
maybeUser <- fmap userID <$> maybeAuthId
|
||||
applicationsRoute <- handlerToWidget $ maybeAuthorized ApplicationsR False
|
||||
profileRoute <- handlerToWidget $ maybe (pure Nothing)
|
||||
(\user -> maybeAuthorized (ProfileR user) False) maybeUser
|
||||
profileRoute <- handlerToWidget $ maybeAuthorized OwnProfileR False
|
||||
membersRoute <- handlerToWidget $ maybeAuthorized MembersR False
|
||||
currentRoute <- getCurrentRoute
|
||||
loggedIn <- isJust <$> maybeAuthId
|
||||
|
|
@ -315,7 +301,7 @@ fgColor = "#181c22"
|
|||
|
||||
instance ApiRequest DataIdClient where
|
||||
getApiUrl = configServerUrl . getConfig <$> getYesod
|
||||
authIdToAuthorization _ UserToken {..} = token
|
||||
authIdToAuthorization = flip const
|
||||
|
||||
instance RenderMessage DataIdClient FormMessage where
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
|
|
|
|||
Loading…
Reference in New Issue