Channels API

This commit is contained in:
Mats Rauhala 2018-08-05 23:13:49 +03:00
parent a4129ae5cf
commit f8f35007bf
10 changed files with 113 additions and 9 deletions

View File

@ -19,9 +19,11 @@ executable ebook-manager
main-is: Main.hs
other-modules: Devel.Main
, API
, API.Channels
, API.Users
, Configuration
, Database
, Database.Channel
, Database.Schema
, Database.User
, Server

View File

@ -19,14 +19,18 @@ import Types
import View
import qualified API.Users as Users
import qualified API.Channels as Channels
data Index = Index
type API = Get '[HTML] (AppView Index)
:<|> Users.API
:<|> Channels.API
handler :: ServerT API AppM
handler = indexHandler :<|> Users.handler
handler = indexHandler
:<|> Users.handler
:<|> Channels.handler
instance ToHtml Index where
toHtml _ = do

51
src/API/Channels.hs Normal file
View File

@ -0,0 +1,51 @@
{-# 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 #-}
module API.Channels (API, handler) where
import Servant
import Types
import ClassyPrelude
import Server.Auth
import Servant.Auth as SA
import Control.Monad.Logger
import Database
import Database.Channel
import Data.Aeson
import Control.Lens
import Data.Generics.Product
data JsonChannel = JsonChannel { channel :: Text } 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
:<|> "channels" :> Get '[JSON] [JsonChannel]
handler :: ServerT API AppM
handler user = newChannelHandler user :<|> listChannelsHandler user
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 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)
return ch

View File

@ -41,7 +41,7 @@ instance FromForm RegisterForm
instance ToForm RegisterForm
type API = Auth '[SA.BasicAuth] SafeUser :> "login" :> Get '[JSON] LoginStatus
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus
:<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
handler :: ServerT API AppM

View File

@ -9,6 +9,7 @@ module Database
, select
, gen
, fromRel
, fromRels
, toRel
, SeldaT )
where
@ -18,7 +19,7 @@ import Control.Lens (view)
import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select)
import Database.Selda.Generic (gen, fromRel, toRel)
import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
import ClassyPrelude
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))

34
src/Database/Channel.hs Normal file
View File

@ -0,0 +1,34 @@
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
module Database.Channel
( userChannels
, insertChannel
, Channel(..) )
where
import ClassyPrelude
import Database.Schema
import Database
import Database.Selda
userChannels :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Channel]
userChannels username = fromRels <$> query q
where
q = do
userId :*: _ :*: username' :*: _ <- select (gen users)
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
mUserId <- listToMaybe <$> getUser
void $ forM mUserId $ \userId ->
insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId ]
where
doesNotExist userId (_ :*: channel' :*: userId') = channel' .== literal channel .&& userId' .== literal userId
getUser = query $ do
userId :*: _ :*: user :*: _ <- select (gen users)
restrict (user .== literal username)
return userId

View File

@ -112,7 +112,7 @@ tags = genTable "tags" [ (identifier :: Tag -> RowID) :- autoPrimaryGen
i :*: _ = selectors (gen users)
channels :: GenTable Channel
channels = genTable "tags" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
channels = genTable "channels" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
, (owner :: Channel -> RowID) :- fkGen (gen users) i ]
where
i :*: _ = selectors (gen users)

View File

@ -19,7 +19,7 @@ import Types
import ClassyPrelude hiding (Handler)
import Control.Monad.Logger
import Control.Monad.Except
import Servant.Auth.Server
import Servant.Auth.Server as SAS
import Control.Lens
import Data.Generics.Product
@ -32,7 +32,8 @@ server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirec
myKey = view (field @"jwk") app
jwtCfg = defaultJWTSettings myKey
authCfg = authCheck app
cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
server' :: AppM :~> Servant.Handler
server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))
api :: Proxy API

View File

@ -5,7 +5,13 @@
{-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-}
module Server.Auth where
{-# Language TemplateHaskell #-}
module Server.Auth
( SafeUser(..)
, authCheck
, AuthResult(..)
, requireLoggedIn)
where
import ClassyPrelude
import Servant.Auth.Server as SAS
@ -16,6 +22,8 @@ import Database
import Types
import Control.Lens (view)
import Data.Generics.Product
import Servant (err401)
import Control.Monad.Logger
-- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
@ -44,3 +52,7 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
username' = Username $ decodeUtf8 username
password' = PlainPassword $ decodeUtf8 password
authenticated = SAS.Authenticated . view (super @SafeUser)
requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
requireLoggedIn f (Authenticated user) = f user
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401

View File

@ -8,7 +8,6 @@ module View
import ClassyPrelude
import Server.Auth
import Servant.Auth.Server
import Lucid (HtmlT, ToHtml(..))
import Lucid.Html5 as H