From b3556648582c02fb5a9a10a6a4525e212397f945 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Tue, 28 Jul 2020 14:15:41 +0100
Subject: [PATCH] Support /login

Support basic authentication.

Note the TODOs that this commit introduces to track some of the remaining work.
---
 src/API.hs |  5 +++++
 src/App.hs | 28 +++++++++++++++++++++++++---
 2 files changed, 30 insertions(+), 3 deletions(-)

diff --git a/src/API.hs b/src/API.hs
index 134d27842..9ae618cd3 100644
--- a/src/API.hs
+++ b/src/API.hs
@@ -37,3 +37,8 @@ type API =
       -- trips: List
       :<|> "trips"
            :> Get '[JSON] [T.Trip]
+
+      -- Miscellaneous
+      :<|> "login"
+           :> ReqBody '[JSON] T.AccountCredentials
+           :> Post '[JSON] (Maybe T.Session)
diff --git a/src/App.hs b/src/App.hs
index e9c528ec4..f8b81ed98 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -1,18 +1,22 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeApplications #-}
 --------------------------------------------------------------------------------
 module App where
 --------------------------------------------------------------------------------
+import Control.Exception (throwIO)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Logger (runStderrLoggingT)
 import Data.Function ((&))
 import Data.String.Conversions (cs)
 import Data.Text (Text)
 import Database.SQLite.Simple
 import Network.Wai.Handler.Warp as Warp
 import Servant
-
 import API
+
+import qualified Crypto.KDF.BCrypt as BC
+import qualified Data.Text.Encoding as TE
 import qualified Types as T
 --------------------------------------------------------------------------------
 
@@ -23,14 +27,15 @@ server dbFile = createAccountH
            :<|> createTripH
            :<|> deleteTripH
            :<|> listTripsH
+           :<|> loginH
   where
     createAccountH newUser  = liftIO $ createAccount newUser
     deleteAccountH username = liftIO $ deleteAccount username
     listAccountsH           = liftIO $ listAccounts
-
     createTripH trip        = liftIO $ createTrip trip
     deleteTripH tripPK      = liftIO $ deleteTrip tripPK
     listTripsH              = liftIO $ listTrips
+    loginH creds            = liftIO $ login creds
 
     -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     createAccount :: T.CreateAccountRequest -> IO NoContent
@@ -73,6 +78,23 @@ server dbFile = createAccountH
           (tripPK & T.tripPKFields)
         pure NoContent
 
+    -- TODO(wpcarro): Create and store a session token
+    login :: T.AccountCredentials -> IO (Maybe T.Session)
+    login (T.AccountCredentials username password) =
+      withConnection dbFile $ \conn -> do
+        res <- query conn "SELECT * FROM Accounts WHERE username = ?"
+          (Only username)
+        case res of
+          [T.Account{T.accountUsername,T.accountPassword,T.accountRole}] ->
+            if T.passwordsMatch password accountPassword then
+              pure $ Just (T.Session accountUsername accountRole)
+            else
+              -- TODO(wpcarro): Catch and return errors over HTTP
+              throwIO $ err401 { errBody = "Your credentials are invalid" }
+
+          -- In this branch, the user didn't supply a known username.
+          _ -> throwIO $ err401 { errBody = "Your credentials are invalid" }
+
 mkApp :: FilePath -> IO Application
 mkApp dbFile = do
   pure $ serve (Proxy @ API) $ server dbFile