77 lines
3.2 KiB
Haskell
77 lines
3.2 KiB
Haskell
{-# Language DataKinds #-}
|
|
{-# Language TypeFamilies #-}
|
|
{-# Language TypeOperators #-}
|
|
{-# Language NoImplicitPrelude #-}
|
|
{-# Language MultiParamTypeClasses #-}
|
|
{-# Language OverloadedStrings #-}
|
|
{-# Language TemplateHaskell #-}
|
|
{-# Language QuasiQuotes #-}
|
|
{-# Language RecordWildCards #-}
|
|
{-# Language DeriveGeneric #-}
|
|
{-# Language FlexibleInstances #-}
|
|
{-# Language TypeApplications #-}
|
|
{-# Language DataKinds #-}
|
|
{-# Language DuplicateRecordFields #-}
|
|
{-# Language NamedFieldPuns #-}
|
|
module API.Channels (API, handler, JsonChannel(..)) where
|
|
|
|
import ClassyPrelude
|
|
import Control.Lens
|
|
import Control.Monad.Catch (throwM, MonadThrow)
|
|
import Control.Monad.Logger
|
|
import Data.Aeson
|
|
import Data.Generics.Product
|
|
import Database
|
|
import Database.Channel
|
|
import Servant
|
|
import Servant.Auth as SA
|
|
import Server.Auth
|
|
import Types
|
|
|
|
data JsonChannel = JsonChannel { channel :: Text
|
|
, visibility :: Visibility }
|
|
deriving (Show, Generic)
|
|
data UpdateChannel = UpdateChannel { identifier :: ChannelID
|
|
, channel :: Text
|
|
, visibility :: Visibility }
|
|
deriving (Show, Generic)
|
|
|
|
instance ToJSON JsonChannel
|
|
instance FromJSON JsonChannel
|
|
instance ToJSON UpdateChannel
|
|
instance FromJSON UpdateChannel
|
|
|
|
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
|
|
|
|
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
|
|
:<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
|
|
:<|> "channels" :> Get '[JSON] [JsonChannel]
|
|
|
|
handler :: ServerT API AppM
|
|
handler user = newChannelHandler user :<|> updateChannelHandler user :<|> listChannelsHandler user
|
|
|
|
requireChannelOwner :: AuthResult SafeUser -> ChannelID -> (SafeUser -> AppM a) -> AppM a
|
|
requireChannelOwner auth channelId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
|
|
unlessM (runDB . channelExists $ channelId) $ throwM err404
|
|
runDB (isChannelOwner channelId username) >>= \o -> if o then f u else throwM err403
|
|
|
|
updateChannelHandler :: AuthResult SafeUser -> ChannelID -> UpdateChannel -> AppM UpdateChannel
|
|
updateChannelHandler auth channelId UpdateChannel{visibility} = requireChannelOwner auth channelId $ \_ -> do
|
|
mChannel <- fmap toChannel <$> runDB (updateChannelPrivacy channelId visibility)
|
|
maybe (throwM err403) return mChannel
|
|
|
|
listChannelsHandler :: AuthResult SafeUser -> AppM [JsonChannel]
|
|
listChannelsHandler = requireLoggedIn $ \user ->
|
|
-- I could use the super thing from generic-lens, but then I would need to
|
|
-- use the 'channel' accessor somehow or export it
|
|
fmap (\Channel{..} -> JsonChannel{..}) <$> runDB (userChannels (view (field @"username") user))
|
|
|
|
newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM UpdateChannel
|
|
newChannelHandler auth JsonChannel{..} = flip requireLoggedIn auth $ \user -> do
|
|
$logInfo $ "Creating channel for user " <> pack (show user)
|
|
mChannel <- fmap toChannel <$> runDB (insertChannel (view (field @"username") user) channel visibility)
|
|
maybe (throwM err403{errBody="Could not create the channel"}) return mChannel
|
|
|
|
toChannel :: Channel -> UpdateChannel
|
|
toChannel Channel{..} = UpdateChannel{..}
|