diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/API.hs | 5 | ||||
| -rw-r--r-- | src/App.hs | 45 | ||||
| -rw-r--r-- | src/Invitations.hs | 7 | ||||
| -rw-r--r-- | src/Types.hs | 39 |
4 files changed, 77 insertions, 19 deletions
diff --git a/src/API.hs b/src/API.hs index caf42727db86..3c311591c210 100644 --- a/src/API.hs +++ b/src/API.hs @@ -21,7 +21,7 @@ type API = :> Post '[JSON] NoContent :<|> "verify" :> QueryParam' '[Required] "username" Text - :> QueryParam' '[Required] "secret" Text + :> QueryParam' '[Required] "secret" T.RegistrationSecret :> Get '[JSON] NoContent -- accounts: Read -- accounts: Update @@ -71,3 +71,6 @@ type API = :> SessionCookie :> ReqBody '[JSON] T.InviteUserRequest :> Post '[JSON] NoContent + :<|> "accept-invitation" + :> ReqBody '[JSON] T.AcceptInvitationRequest + :> Get '[JSON] NoContent diff --git a/src/App.hs b/src/App.hs index cec8a135b161..d83f75e30265 100644 --- a/src/App.hs +++ b/src/App.hs @@ -84,6 +84,7 @@ server config@T.Config{..} = createAccount :<|> logout :<|> unfreezeAccount :<|> inviteUser + :<|> acceptInvitation where -- Admit Admins + whatever the predicate `p` passes. adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct) @@ -120,22 +121,18 @@ server config@T.Config{..} = createAccount secretUUID pure NoContent - verifyAccount :: Text -> Text -> Handler NoContent - verifyAccount username secret = do - let mSecretUUID = T.RegistrationSecret <$> UUID.fromText secret in do - case mSecretUUID of - Nothing -> throwError err401 { errBody = "Invalid secret format" } - Just secretUUID -> do - mPendingAccount <- liftIO $ PendingAccounts.get dbFile (T.Username username) - case mPendingAccount of - Nothing -> - throwError err401 { errBody = "Either your secret or your username (or both) is invalid" } - Just pendingAccount@T.PendingAccount{..} -> - if pendingAccountSecret == secretUUID then do - liftIO $ Accounts.transferFromPending dbFile pendingAccount - pure NoContent - else - throwError err401 { errBody = "The secret you provided is invalid" } + verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent + verifyAccount username secretUUID = do + mPendingAccount <- liftIO $ PendingAccounts.get dbFile (T.Username username) + case mPendingAccount of + Nothing -> + throwError err401 { errBody = "Either your secret or your username (or both) is invalid" } + Just pendingAccount@T.PendingAccount{..} -> + if pendingAccountSecret == secretUUID then do + liftIO $ Accounts.transferFromPending dbFile pendingAccount + pure NoContent + else + throwError err401 { errBody = "The secret you provided is invalid" } deleteAccount :: T.SessionCookie -> Text -> Handler NoContent deleteAccount cookie username = adminsOnly cookie $ do @@ -245,6 +242,22 @@ server config@T.Config{..} = createAccount liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID pure NoContent + acceptInvitation :: T.AcceptInvitationRequest -> Handler NoContent + acceptInvitation T.AcceptInvitationRequest{..} = do + mInvitation <- liftIO $ Invitations.get dbFile acceptInvitationRequestEmail + case mInvitation of + Nothing -> throwError err404 { errBody = "No invitation for email" } + Just T.Invitation{..} -> + if invitationSecret == acceptInvitationRequestSecret then do + liftIO $ Accounts.create dbFile + acceptInvitationRequestUsername + acceptInvitationRequestPassword + invitationEmail + invitationRole + pure NoContent + else + throwError err401 { errBody = "You are not providing a valid secret" } + run :: T.Config -> IO () run config@T.Config{..} = Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server config) diff --git a/src/Invitations.hs b/src/Invitations.hs index 62038bb03646..0c700470f3e2 100644 --- a/src/Invitations.hs +++ b/src/Invitations.hs @@ -12,3 +12,10 @@ create :: FilePath -> T.InvitationSecret -> T.Email -> T.Role -> IO () create dbFile secret email role = withConnection dbFile $ \conn -> do execute conn "INSERT INTO Invitations (email,role,secret) VALUES (?,?,?)" (email, role, secret) + +get :: FilePath -> T.Email -> IO (Maybe T.Invitation) +get dbFile email = withConnection dbFile $ \conn -> do + res <- query conn "SELECT email,role,secret FROM Invitations WHERE email = ?" (Only email) + case res of + [x] -> pure (Just x) + _ -> pure Nothing diff --git a/src/Types.hs b/src/Types.hs index 7fe3f2b15d39..235e8a6d06df 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -401,7 +401,13 @@ instance FromHttpApiData SessionCookie where x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure newtype RegistrationSecret = RegistrationSecret UUID.UUID - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance FromHttpApiData RegistrationSecret where + parseQueryParam x = + case UUID.fromText x of + Nothing -> Left x + Just uuid -> Right (RegistrationSecret uuid) instance FromField RegistrationSecret where fromField field = @@ -482,7 +488,10 @@ instance FromJSON InviteUserRequest where pure InviteUserRequest{..} newtype InvitationSecret = InvitationSecret UUID.UUID - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance ToJSON InvitationSecret +instance FromJSON InvitationSecret instance ToField InvitationSecret where toField (InvitationSecret secretUUID) = @@ -496,3 +505,29 @@ instance FromField InvitationSecret where Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x) Just x -> Ok $ InvitationSecret x _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + +data Invitation = Invitation + { invitationEmail :: Email + , invitationRole :: Role + , invitationSecret :: InvitationSecret + } deriving (Eq, Show) + +instance FromRow Invitation where + fromRow = Invitation <$> field + <*> field + <*> field + +data AcceptInvitationRequest = AcceptInvitationRequest + { acceptInvitationRequestUsername :: Username + , acceptInvitationRequestPassword :: ClearTextPassword + , acceptInvitationRequestEmail :: Email + , acceptInvitationRequestSecret :: InvitationSecret + } deriving (Eq, Show) + +instance FromJSON AcceptInvitationRequest where + parseJSON = withObject "AcceptInvitationRequest" $ \x -> do + acceptInvitationRequestUsername <- x .: "username" + acceptInvitationRequestPassword <- x .: "password" + acceptInvitationRequestEmail <- x .: "email" + acceptInvitationRequestSecret <- x .: "secret" + pure AcceptInvitationRequest{..} |