#13 Add visibility information to channels #21

Merged
MasseR merged 2 commits from sandbox/MasseR/13-channel-visibility into master 2018-08-15 22:38:36 +03:00
4 changed files with 27 additions and 10 deletions

View File

@ -0,0 +1 @@
alter table channels add column visibility text NOT NULL default 'Private';

View File

@ -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

View File

@ -5,6 +5,7 @@ module Database.Channel
( userChannels
, insertChannel
, attachChannel
, Visibility(..)
, clearChannels
, booksChannels
, Channel(..)
@ -22,18 +23,18 @@ 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
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 ]
insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: visibility ]
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 +63,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)

View File

@ -124,9 +124,22 @@ data Tag = Tag { identifier :: TagID
, owner :: UserID }
deriving (Show, Generic)
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
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