MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

#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
Conversation 0 Commits 2 Files Changed 4 +12 -6
3 changed files with 12 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 225e44d1a2 - Show all commits

8
src/API/Channels.hs
View File

@ -25,14 +25,16 @@ import Data.Aeson
import Control.Lens import Control.Lens
import Data.Generics.Product 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 ToJSON JsonChannel
instance FromJSON JsonChannel instance FromJSON JsonChannel
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI 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] :<|> "channels" :> Get '[JSON] [JsonChannel]
handler :: ServerT API AppM handler :: ServerT API AppM
@ -47,5 +49,5 @@ listChannelsHandler = requireLoggedIn $ \user ->
newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM JsonChannel newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM JsonChannel
newChannelHandler auth ch@JsonChannel{..} = flip requireLoggedIn auth $ \user -> do newChannelHandler auth ch@JsonChannel{..} = flip requireLoggedIn auth $ \user -> do
$logInfo $ "Creating channel for user " <> pack (show user) $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 return ch

7
src/Database/Channel.hs
View File

@ -5,6 +5,7 @@ module Database.Channel
( userChannels ( userChannels
, insertChannel , insertChannel
, attachChannel , attachChannel
, Visibility(..)
, clearChannels , clearChannels
, booksChannels , booksChannels
, Channel(..) , Channel(..)
@ -27,11 +28,11 @@ userChannels username = fromRels <$> query q
restrict (username' .== literal username) restrict (username' .== literal username)
return channel return channel
insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> SeldaT m () insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> Visibility -> SeldaT m ()
insertChannel username channel = do insertChannel username channel visibility = do
mUserId <- listToMaybe <$> getUser mUserId <- listToMaybe <$> getUser
void $ forM mUserId $ \userId -> void $ forM mUserId $ \userId ->
insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: def ] insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: visibility ]
where where
doesNotExist userId (_ :*: channel' :*: userId' :*: _) = channel' .== literal channel .&& userId' .== literal userId doesNotExist userId (_ :*: channel' :*: userId' :*: _) = channel' .== literal channel .&& userId' .== literal userId
getUser = query $ do getUser = query $ do

3
src/Database/Schema.hs
View File

@ -127,6 +127,9 @@ data Tag = Tag { identifier :: TagID
data Visibility = Public | Private | Followers data Visibility = Public | Private | Followers
deriving (Show, Read, Generic) deriving (Show, Read, Generic)
instance ToJSON Visibility
instance FromJSON Visibility
instance SqlType Visibility where instance SqlType Visibility where
mkLit = LCustom . LText . pack . show mkLit = LCustom . LText . pack . show
fromSql (SqlString x) = fromMaybe (error "fromSql: Not a valid visibility token") . readMay . unpack $ x fromSql (SqlString x) = fromMaybe (error "fromSql: Not a valid visibility token") . readMay . unpack $ x