From 00a7e3d524a288f0ad680dc7a332791f5ea33184 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 15 Aug 2018 22:25:38 +0300 Subject: [PATCH 1/2] DB: Visibility #3 --- migrations/V1.1__Channel_visibility.sql | 1 + src/Database/Channel.hs | 8 ++++---- src/Database/Schema.hs | 12 +++++++++++- 3 files changed, 16 insertions(+), 5 deletions(-) create mode 100644 migrations/V1.1__Channel_visibility.sql diff --git a/migrations/V1.1__Channel_visibility.sql b/migrations/V1.1__Channel_visibility.sql new file mode 100644 index 0000000..aa3eb5d --- /dev/null +++ b/migrations/V1.1__Channel_visibility.sql @@ -0,0 +1 @@ +alter table channels add column visibility text NOT NULL default 'Private'; diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 4e4d33a..db4ca6f 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -22,7 +22,7 @@ userChannels username = fromRels <$> query q where q = do userId :*: _ :*: username' :*: _ <- select (gen users) - channel@(_ :*: _ :*: owner) <- select (gen channels) + channel@(_ :*: _ :*: owner :*: _) <- select (gen channels) restrict (owner .== userId) restrict (username' .== literal username) return channel @@ -31,9 +31,9 @@ insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> SeldaT m () insertChannel username channel = do mUserId <- listToMaybe <$> getUser void $ forM mUserId $ \userId -> - insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId ] + insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: def ] where - doesNotExist userId (_ :*: channel' :*: userId') = channel' .== literal channel .&& userId' .== literal userId + doesNotExist userId (_ :*: channel' :*: userId' :*: _) = channel' .== literal channel .&& userId' .== literal userId getUser = query $ do userId :*: _ :*: user :*: _ <- select (gen users) restrict (user .== literal username) @@ -62,7 +62,7 @@ attachChannel username bookId channel = do return channelId' channelQ = do userId :*: _ :*: username' :*: _ <- select (gen users) - ch@(_ :*: channel' :*: owner) <- select (gen channels) + ch@(_ :*: channel' :*: owner :*: _) <- select (gen channels) restrict (username' .== literal username) restrict (owner .== userId) restrict (channel' .== literal channel) diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 88b5ef2..16b1129 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -124,9 +124,19 @@ data Tag = Tag { identifier :: TagID , owner :: UserID } deriving (Show, Generic) +data Visibility = Public | Private | Followers + deriving (Show, Read, Generic) + +instance SqlType Visibility where + mkLit = LCustom . LText . pack . show + fromSql (SqlString x) = fromMaybe (error "fromSql: Not a valid visibility token") . readMay . unpack $ x + fromSql _ = error "fromSql: Not a valid visibility token" + defaultValue = mkLit Private + data Channel = Channel { identifier :: ChannelID , channel :: Text - , owner :: UserID } + , owner :: UserID + , visibility :: Visibility } deriving (Show, Generic) tags :: GenTable Tag -- 2.45.2 From 225e44d1a2b6b53aab1b50d540971479b6809751 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Wed, 15 Aug 2018 22:37:32 +0300 Subject: [PATCH 2/2] Insert the visibility information - It's still not actually used anywhere --- src/API/Channels.hs | 8 +++++--- src/Database/Channel.hs | 7 ++++--- src/Database/Schema.hs | 3 +++ 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/API/Channels.hs b/src/API/Channels.hs index 2e6c0ed..2321b83 100644 --- a/src/API/Channels.hs +++ b/src/API/Channels.hs @@ -25,14 +25,16 @@ import Data.Aeson import Control.Lens import Data.Generics.Product -data JsonChannel = JsonChannel { channel :: Text } deriving (Show, Generic) +data JsonChannel = JsonChannel { channel :: Text + , visibility :: Visibility } + deriving (Show, Generic) instance ToJSON JsonChannel instance FromJSON JsonChannel type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI -type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Put '[JSON] JsonChannel +type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] JsonChannel :<|> "channels" :> Get '[JSON] [JsonChannel] handler :: ServerT API AppM @@ -47,5 +49,5 @@ listChannelsHandler = requireLoggedIn $ \user -> newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM JsonChannel newChannelHandler auth ch@JsonChannel{..} = flip requireLoggedIn auth $ \user -> do $logInfo $ "Creating channel for user " <> pack (show user) - runDB (insertChannel (view (field @"username") user) channel) + runDB (insertChannel (view (field @"username") user) channel visibility) return ch diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index db4ca6f..5952f6c 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -5,6 +5,7 @@ module Database.Channel ( userChannels , insertChannel , attachChannel + , Visibility(..) , clearChannels , booksChannels , Channel(..) @@ -27,11 +28,11 @@ userChannels username = fromRels <$> query q restrict (username' .== literal username) return channel -insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> SeldaT m () -insertChannel username channel = do +insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> Visibility -> SeldaT m () +insertChannel username channel visibility = do mUserId <- listToMaybe <$> getUser void $ forM mUserId $ \userId -> - insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: def ] + insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: visibility ] where doesNotExist userId (_ :*: channel' :*: userId' :*: _) = channel' .== literal channel .&& userId' .== literal userId getUser = query $ do diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 16b1129..cfa07b4 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -127,6 +127,9 @@ data Tag = Tag { identifier :: TagID data Visibility = Public | Private | Followers deriving (Show, Read, Generic) +instance ToJSON Visibility +instance FromJSON Visibility + instance SqlType Visibility where mkLit = LCustom . LText . pack . show fromSql (SqlString x) = fromMaybe (error "fromSql: Not a valid visibility token") . readMay . unpack $ x -- 2.45.2