subtree(users/wpcarro): docking briefcase at '24f5a642' r/3226

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c09813172c79820bcf526bb10cf4208
git-subtree-split: 24f5a642af3aa1627bbff977f0a101907a02c69f
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

1 files changed, 270 insertions, 0 deletions

diff --git a/users/wpcarro/assessments/tt/src/App.hs b/users/wpcarro/assessments/tt/src/App.hs
new file mode 100644
index 000000000000..742bc962dc55
--- /dev/null
+++ b/users/wpcarro/assessments/tt/src/App.hs
@@ -0,0 +1,270 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+--------------------------------------------------------------------------------
+module App where
+--------------------------------------------------------------------------------
+import Control.Monad.IO.Class (liftIO)
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import Servant
+import API
+import Utils
+import Web.Cookie
+
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Network.Wai.Middleware.Cors as Cors
+import qualified System.Random as Random
+import qualified Email as Email
+import qualified Data.UUID as UUID
+import qualified Types as T
+import qualified Accounts as Accounts
+import qualified Auth as Auth
+import qualified Trips as Trips
+import qualified Sessions as Sessions
+import qualified Invitations as Invitations
+import qualified LoginAttempts as LoginAttempts
+import qualified PendingAccounts as PendingAccounts
+--------------------------------------------------------------------------------
+
+err429 :: ServerError
+err429 = ServerError
+  { errHTTPCode = 429
+  , errReasonPhrase = "Too many requests"
+  , errBody = ""
+  , errHeaders = []
+  }
+
+-- | Send an email to recipient, `to`, with a secret code.
+sendVerifyEmail :: T.Config
+                -> T.Username
+                -> T.Email
+                -> T.RegistrationSecret
+                -> IO (Either Email.SendError Email.SendSuccess)
+sendVerifyEmail T.Config{..} (T.Username username) email (T.RegistrationSecret secretUUID) = do
+  Email.send mailgunAPIKey subject (cs body) email
+  where
+    subject = "Please confirm your account"
+    body =
+      let secret = secretUUID |> UUID.toString in
+        "To verify your account: POST /verify username=" ++ cs username ++ " secret=" ++ secret
+
+-- | Send an invitation email to recipient, `to`, with a secret code.
+sendInviteEmail :: T.Config
+                -> T.Email
+                -> T.InvitationSecret
+                -> IO (Either Email.SendError Email.SendSuccess)
+sendInviteEmail T.Config{..} email@(T.Email to) (T.InvitationSecret secretUUID) = do
+  Email.send mailgunAPIKey subject (cs body) email
+  where
+    subject = "You've been invited!"
+    body =
+      let secret = secretUUID |> UUID.toString in
+        "To accept the invitation: POST /accept-invitation username=<username> password=<password> email=" ++ cs to ++ " secret=" ++ secret
+
+server :: T.Config -> Server API
+server config@T.Config{..} = createAccount
+                        :<|> verifyAccount
+                        :<|> deleteAccount
+                        :<|> listAccounts
+                        :<|> createTrip
+                        :<|> updateTrip
+                        :<|> deleteTrip
+                        :<|> listTrips
+                        :<|> login
+                        :<|> 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)
+    -- Admit Admins only.
+    adminsOnly cookie = adminsAnd cookie (const True)
+
+    -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
+    createAccount :: Maybe T.SessionCookie
+                  -> T.CreateAccountRequest
+                  -> Handler NoContent
+    createAccount mCookie T.CreateAccountRequest{..} =
+      case (mCookie, createAccountRequestRole) of
+        (_, T.RegularUser) ->
+          doCreateAccount
+        (Nothing, T.Manager) ->
+          throwError err401 { errBody = "Only admins can create Manager accounts" }
+        (Nothing, T.Admin) ->
+          throwError err401 { errBody = "Only admins can create Admin accounts" }
+        (Just cookie, _) ->
+          adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) doCreateAccount
+      where
+        doCreateAccount :: Handler NoContent
+        doCreateAccount = do
+          secretUUID <- liftIO $ T.RegistrationSecret <$> Random.randomIO
+          liftIO $ PendingAccounts.create dbFile
+            secretUUID
+            createAccountRequestUsername
+            createAccountRequestPassword
+            createAccountRequestRole
+            createAccountRequestEmail
+          res <- liftIO $ sendVerifyEmail config
+            createAccountRequestUsername
+            createAccountRequestEmail
+            secretUUID
+          case res of
+            Left _ -> undefined
+            Right _ -> pure NoContent
+
+    verifyAccount :: T.VerifyAccountRequest -> Handler NoContent
+    verifyAccount T.VerifyAccountRequest{..} = do
+      mPendingAccount <- liftIO $ PendingAccounts.get dbFile verifyAccountRequestUsername
+      case mPendingAccount of
+        Nothing ->
+          throwError err401 { errBody = "Either your secret or your username (or both) is invalid" }
+        Just pendingAccount@T.PendingAccount{..} ->
+          if pendingAccountSecret == verifyAccountRequestSecret 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
+      liftIO $ Accounts.delete dbFile (T.Username username)
+      pure NoContent
+
+    listAccounts :: T.SessionCookie -> Handler [T.User]
+    listAccounts cookie = adminsOnly cookie $ do
+      liftIO $ Accounts.list dbFile
+
+    createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent
+    createTrip cookie trip@T.Trip{..} =
+      adminsAnd cookie (\T.Account{..} -> accountUsername == tripUsername) $ do
+        liftIO $ Trips.create dbFile trip
+        pure NoContent
+
+    updateTrip :: T.SessionCookie -> T.UpdateTripRequest -> Handler NoContent
+    updateTrip cookie updates@T.UpdateTripRequest{..} =
+      adminsAnd cookie (\T.Account{..} -> accountUsername == T.tripPKUsername updateTripRequestTripPK) $ do
+        mTrip <- liftIO $ Trips.get dbFile updateTripRequestTripPK
+        case mTrip of
+          Nothing -> throwError err400 { errBody = "tripKey is invalid" }
+          Just trip@T.Trip{..} -> do
+            -- TODO(wpcarro): Prefer function in Trips module that does this in a
+            -- DB transaction.
+            liftIO $ Trips.delete dbFile updateTripRequestTripPK
+            liftIO $ Trips.create dbFile (T.updateTrip updates trip)
+            pure NoContent
+
+    deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent
+    deleteTrip cookie tripPK@T.TripPK{..} =
+      adminsAnd cookie (\T.Account{..} -> accountUsername == tripPKUsername) $ do
+      liftIO $ Trips.delete dbFile tripPK
+      pure NoContent
+
+    listTrips :: T.SessionCookie -> Handler [T.Trip]
+    listTrips cookie = do
+      mAccount <- liftIO $ Auth.accountFromCookie dbFile cookie
+      case mAccount of
+        Nothing -> throwError err401 { errBody = "Your session cookie is invalid. Try logging out and logging back in." }
+        Just T.Account{..} ->
+          case accountRole of
+            T.Admin -> liftIO $ Trips.listAll dbFile
+            _ -> liftIO $ Trips.list dbFile accountUsername
+
+    login :: T.AccountCredentials
+          -> Handler (Headers '[Header "Set-Cookie" SetCookie] T.Session)
+    login (T.AccountCredentials username password) = do
+      mAccount <- liftIO $ Accounts.lookup dbFile username
+      case mAccount of
+        Just account@T.Account{..} -> do
+          mAttempts <- liftIO $ LoginAttempts.forUsername dbFile accountUsername
+          case mAttempts of
+            Nothing ->
+              if T.passwordsMatch password accountPassword then do
+                uuid <- liftIO $ Sessions.findOrCreate dbFile account
+                pure $ addHeader (Auth.mkCookie uuid)
+                  T.Session{ sessionUsername = accountUsername
+                           , sessionRole = accountRole
+                           }
+              else do
+                liftIO $ LoginAttempts.increment dbFile username
+                throwError err401 { errBody = "Your credentials are invalid" }
+            Just attempts ->
+              if attempts >= 3 then
+                throwError err429
+              else if T.passwordsMatch password accountPassword then do
+                uuid <- liftIO $ Sessions.findOrCreate dbFile account
+                pure $ addHeader (Auth.mkCookie uuid)
+                  T.Session{ sessionUsername = accountUsername
+                           , sessionRole = accountRole
+                           }
+              else do
+                liftIO $ LoginAttempts.increment dbFile username
+                throwError err401 { errBody = "Your credentials are invalid" }
+
+        -- In this branch, the user didn't supply a known username.
+        Nothing -> throwError err401 { errBody = "Your credentials are invalid" }
+
+    logout :: T.SessionCookie
+           -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent)
+    logout cookie = do
+      case Auth.uuidFromCookie cookie of
+        Nothing ->
+          pure $ addHeader Auth.emptyCookie NoContent
+        Just uuid -> do
+          liftIO $ Sessions.delete dbFile uuid
+          pure $ addHeader Auth.emptyCookie NoContent
+
+    unfreezeAccount :: T.SessionCookie
+                    -> T.UnfreezeAccountRequest
+                    -> Handler NoContent
+    unfreezeAccount cookie T.UnfreezeAccountRequest{..} =
+      adminsAnd cookie (\T.Account{..} -> accountRole == T.Manager) $ do
+        liftIO $ LoginAttempts.reset dbFile unfreezeAccountRequestUsername
+        pure NoContent
+
+    inviteUser :: T.SessionCookie
+               -> T.InviteUserRequest
+               -> Handler NoContent
+    inviteUser cookie T.InviteUserRequest{..} = adminsOnly cookie $ do
+      secretUUID <- liftIO $ T.InvitationSecret <$> Random.randomIO
+      liftIO $ Invitations.create dbFile
+        secretUUID
+        inviteUserRequestEmail
+        inviteUserRequestRole
+      res <- liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID
+      case res of
+        Left _ -> undefined
+        Right _ -> 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)
+  where
+    enforceCors = Cors.cors (const $ Just corsPolicy)
+    corsPolicy :: Cors.CorsResourcePolicy
+    corsPolicy =
+      Cors.simpleCorsResourcePolicy
+        { Cors.corsOrigins = Just ([cs configClient], True)
+        , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"]
+        , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"]
+        }