Support reading / writing cookies in API

Update my API type and handler types to reflect which handlers read and write
cookies.

TODO:
- Actually read from and write to Set-Cookie header
- Returning `pure NoContent` breaks my types, so I'm returning `undefined` now

src/API.hs

@@ -5,10 +5,14 @@ module API where
 --------------------------------------------------------------------------------
 import Data.Text
 import Servant.API
+import Web.Cookie
 
 import qualified Types as T
 --------------------------------------------------------------------------------
 
+-- | Once authenticated, users receive a SessionCookie.
+type SessionCookie = Header' '[Required] "Set-Cookie" T.SessionCookie
+
 type API =
       -- accounts: Create
            "accounts"
@@ -18,20 +22,24 @@ type API =
       -- accounts: Update
       -- accounts: Delete
       :<|> "accounts"
+           :> SessionCookie
            :> QueryParam' '[Required] "username" Text
            :> Delete '[JSON] NoContent
       -- accounts: List
       :<|> "accounts"
+           :> SessionCookie
            :> Get '[JSON] [T.User]
 
       -- trips: Create
       :<|> "trips"
+           :> SessionCookie
            :> ReqBody '[JSON] T.Trip
            :> Post '[JSON] NoContent
       -- trips: Read
       -- trips: Update
       -- trips: Delete
       :<|> "trips"
+           :> SessionCookie
            :> ReqBody '[JSON] T.TripPK
            :> Delete '[JSON] NoContent
       -- trips: List
@@ -41,4 +49,7 @@ type API =
       -- Miscellaneous
       :<|> "login"
            :> ReqBody '[JSON] T.AccountCredentials
-           :> Post '[JSON] NoContent
+           :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent)
+      :<|> "logout"
+           :> SessionCookie
+           :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent)

src/App.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -14,6 +15,7 @@ import Network.Wai.Handler.Warp as Warp
 import Servant
 import API
 import Utils
+import Web.Cookie
 
 import qualified Crypto.KDF.BCrypt as BC
 import qualified Data.Text.Encoding as TE
@@ -32,14 +34,16 @@ server dbFile = createAccountH
            :<|> deleteTripH
            :<|> listTripsH
            :<|> loginH
+           :<|> logoutH
   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
+    createAccountH newUser         = liftIO $ createAccount newUser
+    deleteAccountH cookie username = liftIO $ deleteAccount cookie username
+    listAccountsH cookie           = liftIO $ listAccounts cookie
+    createTripH cookie trip        = liftIO $ createTrip cookie trip
+    deleteTripH cookie tripPK      = liftIO $ deleteTrip cookie tripPK
+    listTripsH                     = liftIO $ listTrips
+    loginH creds                   = liftIO $ login creds
+    logoutH cookie                 = liftIO $ logout cookie
 
     -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     createAccount :: T.CreateAccountRequest -> IO NoContent
@@ -51,30 +55,30 @@ server dbFile = createAccountH
         (T.createAccountRequestRole request)
       pure NoContent
 
-    deleteAccount :: Text -> IO NoContent
-    deleteAccount username = do
+    deleteAccount :: T.SessionCookie -> Text -> IO NoContent
+    deleteAccount cookie username = do
       Accounts.delete dbFile (T.Username username)
       pure NoContent
 
-    listAccounts :: IO [T.User]
-    listAccounts = Accounts.list dbFile
+    listAccounts :: T.SessionCookie -> IO [T.User]
+    listAccounts cookie = Accounts.list dbFile
 
-    createTrip :: T.Trip -> IO NoContent
-    createTrip trip = do
+    createTrip :: T.SessionCookie -> T.Trip -> IO NoContent
+    createTrip cookie trip = do
       Trips.create dbFile trip
       pure NoContent
 
+    -- TODO(wpcarro): Validate incoming data like startDate.
+    deleteTrip :: T.SessionCookie -> T.TripPK -> IO NoContent
+    deleteTrip cookie tripPK = do
+      Trips.delete dbFile tripPK
+      pure NoContent
+
     listTrips :: IO [T.Trip]
     listTrips = Trips.list dbFile
 
-    -- TODO(wpcarro): Validate incoming data like startDate.
-    deleteTrip :: T.TripPK -> IO NoContent
-    deleteTrip tripPK = do
-      Trips.delete dbFile tripPK
-      pure NoContent
-
-    -- TODO(wpcarro): Create and store a session token
-    login :: T.AccountCredentials -> IO NoContent
+    login :: T.AccountCredentials
+          -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent)
     login (T.AccountCredentials username password) = do
       mAccount <- Accounts.lookup dbFile username
       case mAccount of
@@ -85,25 +89,31 @@ server dbFile = createAccountH
               if T.passwordsMatch password accountPassword then do
                 session <- Sessions.findOrCreate dbFile account
                 -- set cookie
-                pure NoContent
+                undefined
               else do
                 LoginAttempts.increment dbFile username
-                throwIO $ err401 { errBody = "Your credentials are invalid" }
+                throwIO err401 { errBody = "Your credentials are invalid" }
             Just attempts ->
               if attempts > 3 then
                 -- TODO(wpcarro): Prefer 429 error code
-                throwIO $ err401 { errBody = "Too many failed login attempts" }
+                throwIO err401 { errBody = "Too many failed login attempts" }
               else if T.passwordsMatch password accountPassword then do
                 session <- Sessions.findOrCreate dbFile account
                 -- set cookie
-                pure NoContent
+                undefined
               else do
                 LoginAttempts.increment dbFile username
                 -- TODO(wpcarro): Catch and return errors over HTTP
-                throwIO $ err401 { errBody = "Your credentials are invalid" }
+                throwIO err401 { errBody = "Your credentials are invalid" }
 
         -- In this branch, the user didn't supply a known username.
-        Nothing -> throwIO $ err401 { errBody = "Your credentials are invalid" }
+        Nothing -> throwIO err401 { errBody = "Your credentials are invalid" }
+
+    logout :: T.SessionCookie
+           -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent)
+    logout cookie = undefined
+      -- pull off SessionUUID from the request headers
+      -- delete the SessionUUID from the Sessions table.
 
 mkApp :: FilePath -> IO Application
 mkApp dbFile = do

src/Types.hs

@@ -14,6 +14,8 @@ import Database.SQLite.Simple.Ok
 import Database.SQLite.Simple.FromField
 import Database.SQLite.Simple.ToField
 import GHC.Generics
+import Web.Cookie
+import Servant.API
 import Crypto.Random.Types (MonadRandom)
 
 import qualified Crypto.KDF.BCrypt as BC
@@ -382,3 +384,11 @@ data LoginAttempt = LoginAttempt
 
 instance FromRow LoginAttempt where
   fromRow = LoginAttempt <$> field <*> field
+
+newtype SessionCookie = SessionCookie Cookies
+
+instance FromHttpApiData SessionCookie where
+  parseHeader x =
+    x |> parseCookies |> SessionCookie |> pure
+  parseQueryParam x =
+    x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure