diff options
| -rw-r--r-- | .gitignore | 5 | ||||
| -rw-r--r-- | src/Data/Device.hs | 31 | ||||
| -rw-r--r-- | src/Data/EventFilter.hs | 33 | ||||
| -rw-r--r-- | src/Data/Filter.hs | 35 | ||||
| -rw-r--r-- | src/Data/RoomEventFilter.hs | 39 | ||||
| -rw-r--r-- | src/Data/RoomFilter.hs | 36 | ||||
| -rw-r--r-- | src/Data/User.hs | 1 | ||||
| -rw-r--r-- | src/Endpoints/LoginEndpoint.hs | 31 | ||||
| -rw-r--r-- | stack.yaml | 5 | ||||
| -rw-r--r-- | stack.yaml.lock | 9 |
10 files changed, 205 insertions, 20 deletions
@@ -1 +1,6 @@ .stack-work +jamaa.cabal +jamaa.db +jamaa.db-shm +jamaa.db-wal +dist-newstyle 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 @@ -17,8 +17,7 @@ # # snapshot: ./custom-snapshot.yaml # snapshot: https://example.com/snapshots/2024-01-01.yaml -snapshot: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml +snapshot: lts-24.26 # User packages to be built. # Various formats can be used as shown in the example below. @@ -30,7 +29,7 @@ snapshot: # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the snapshot. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: diff --git a/stack.yaml.lock b/stack.yaml.lock index 1a24f91..7f40802 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,8 +6,7 @@ packages: [] snapshots: - completed: - sha256: 188228e10dbb5b533bae584049b112e72000902e64b17348679a69f92fbc0d32 - size: 726076 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml - original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml + sha256: d90eb1418667a225998b173817300e5ae2e1500ed03c0a9457cc2a0e78a0122a + size: 726337 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/26.yaml + original: lts-24.26 |