Database stuff

7 files changed, 194 insertions, 12 deletions

diff --git a/src/Data/Device.hs b/src/Data/Device.hs
new file mode 100644
index 0000000..73dbe6d
--- /dev/null
+++ b/src/Data/Device.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Data.Device where
+
+import Database.Persist.TH
+import Data.Text
+
+----------------------------------------------------------------------------------------------------
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+Device
+    ident Text -- figure out primary keys
+    name Text Maybe
+    Primary ident
+    deriving Show
+|]
diff --git a/src/Data/EventFilter.hs b/src/Data/EventFilter.hs
new file mode 100644
index 0000000..c918f65
--- /dev/null
+++ b/src/Data/EventFilter.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Data.EventFilter where
+
+import Database.Persist.TH
+import Data.Text
+
+----------------------------------------------------------------------------------------------------
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+EventFilter
+    limit Int default=10 -- smaller datatype as to max of 50 and unsigned?
+    notSenders [Text] Maybe
+    notTypes [Text] Maybe
+    sender [Text] Maybe
+    types [Text] Maybe
+    deriving Show
+|]
diff --git a/src/Data/Filter.hs b/src/Data/Filter.hs
new file mode 100644
index 0000000..ad9f6ed
--- /dev/null
+++ b/src/Data/Filter.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Data.Filter where
+
+import Database.Persist.TH
+import Data.Text
+import Data.EventFilter (EventFilter (..))
+import Data.RoomFilter (RoomFilter (..))
+
+----------------------------------------------------------------------------------------------------
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+Filter
+    accountData EventFilter Maybe
+    eventFields [Text] Maybe
+    eventFormat Text default='client'
+    presence EventFilter Maybe
+    room RoomFilter Maybe
+    deriving Show
+|]
diff --git a/src/Data/RoomEventFilter.hs b/src/Data/RoomEventFilter.hs
new file mode 100644
index 0000000..0e5b7cf
--- /dev/null
+++ b/src/Data/RoomEventFilter.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Data.RoomEventFilter where
+
+import Database.Persist.TH
+import Data.Text
+
+----------------------------------------------------------------------------------------------------
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+RoomEventFilter
+    containsUrl Bool Maybe
+    includeRedundantMembers Bool default=False
+    lazyLoadMembers Bool default=False
+    limit Bool default=10 -- smaller datatype as to max of 50 and unsigned?
+    notRooms [Text] Maybe
+    notSenders [Text] Maybe
+    notTypes [Text] Maybe
+    rooms [Text] Maybe
+    senders [Text] Maybe
+    types [Text] Maybe
+    unreadThreadNotifications Bool default=False
+    deriving Show
+|]
diff --git a/src/Data/RoomFilter.hs b/src/Data/RoomFilter.hs
new file mode 100644
index 0000000..f53fee7
--- /dev/null
+++ b/src/Data/RoomFilter.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+
+
+module Data.RoomFilter where
+
+import Database.Persist.TH
+import Data.Text
+import Data.RoomEventFilter (RoomEventFilter (..))
+
+----------------------------------------------------------------------------------------------------
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+RoomFilter
+    accountData RoomEventFilter Maybe
+    ephemeral RoomEventFilter Maybe
+    includeLeave Bool default=False
+    notRooms [Text] Maybe
+    rooms [Text] Maybe
+    state RoomEventFilter
+    timeline RoomEventFilter
+    deriving Show
+|]
diff --git a/src/Data/User.hs b/src/Data/User.hs
index 9064d36..f805bd3 100644
--- a/src/Data/User.hs
+++ b/src/Data/User.hs
@@ -28,6 +28,7 @@ User
     password Text
     displayName Text Maybe -- Figure snake_case out
     avatarUrl Text Maybe   -- Figure snake_case out
+    Primary ident
     UniqueName ident
     deriving Show
 |]
diff --git a/src/Endpoints/LoginEndpoint.hs b/src/Endpoints/LoginEndpoint.hs
index f7edc3d..4b20b1e 100644
--- a/src/Endpoints/LoginEndpoint.hs
+++ b/src/Endpoints/LoginEndpoint.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
@@ -28,6 +27,7 @@ import Control.Monad.IO.Class (MonadIO(..), liftIO)
 import Model.Login
 import Model.MatrixErrorResponse
 import Data.User
+import Data.Device
 import Model.AuthenticationHolder (AuthenticationHolder (AuthenticationHolder), server_password)
 
 ----------------------------------------------------------------------------------------------------
@@ -47,18 +47,23 @@ handleLoginGet = return $ LoginFlowsResponse [LoginFlow "m.login.password"]
 type PostLogin = "_matrix" :> "client" :> "v3" :> "login" :> ReqBody '[JSON] LoginRequest
                :> Post '[JSON] LoginResponse
 
-handleLoginPost :: LoginRequest -> Handler LoginResponse
-handleLoginPost LoginRequest { device_id = maybe_device_id, password = input_password, identifier } = do
-  safe_device_id <- getDeviceId maybe_device_id
+handleLoginPost :: LoginRequest -> Handler LoginResponse -- TODO: Let DB create device_id/primarykey?
+handleLoginPost LoginRequest {
+    device_id = maybe_device_id,
+    password = input_password,
+    initial_device_display_name = maybe_device_name,
+    identifier
+} = do
+  resolved_device_id <- resolveDeviceId maybe_device_id
 
   let
     username = user identifier
-    auth_holder = AuthenticationHolder username safe_device_id Nothing
-    either_token = hmacEncode HS256 server_password (BL.toStrict $ A.encode $ auth_holder)
+    auth_holder = AuthenticationHolder username resolved_device_id Nothing
+    either_token = hmacEncode HS256 server_password (BL.toStrict $ A.encode auth_holder)
 
   case either_token of
     Right (Jwt token) -> do
-      maybe_db_user <- liftIO $ runDb $ getBy $ UniqueName $ username
+      maybe_db_user <- liftIO $ runDb $ getBy $ UniqueName username
 
       case maybe_db_user of
         Just (Entity _ db_user) -> do
@@ -71,7 +76,7 @@ handleLoginPost LoginRequest { device_id = maybe_device_id, password = input_pas
                   { user_id      = T.concat ["@", username, ":localhost"]
                   , access_token = T.decodeUtf8 token
                   , home_server  = "localhost"
-                  , device_id    = safe_device_id
+                  , device_id    = resolved_device_id
                   }
                 else throwError $ err403 { errBody = A.encode invalid_credentials_error }
             _ -> throwError $ err500 { errBody = A.encode password_decoding_error }
@@ -83,13 +88,15 @@ handleLoginPost LoginRequest { device_id = maybe_device_id, password = input_pas
     invalid_credentials_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username or password"
     failed_token_generation = MatrixErrorResponse "M_UNKNOWN" "Access Token generation failed"
 
-    getDeviceId :: MonadIO m => Maybe T.Text -> m T.Text
-    getDeviceId mDeviceId = case mDeviceId of
+    resolveDeviceId :: MonadIO m => Maybe T.Text -> m T.Text
+    resolveDeviceId device_id = case device_id of
       Just did -> pure did
-      Nothing  -> liftIO generateDeviceId
+      Nothing  -> liftIO $ generateDeviceId
 
     generateDeviceId :: IO T.Text
     generateDeviceId = do
       bytes <- getRandomBytes 12
       let encoded = BURL.encode bytes
-      pure $ T.pack $ UTF8.toString $ B.take 16 encoded
\ No newline at end of file
+      let generated_id = T.pack $ UTF8.toString $ B.take 16 encoded
+      _ <- liftIO $ runDb $ insert $ Device generated_id maybe_device_name
+      pure generated_id