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 main-is: Main.hs
other-modules: Devel.Main other-modules: Devel.Main
, API , API
, API.Channels
, API.Users , API.Users
, Configuration , Configuration
, Database , Database
, Database.Channel
, Database.Schema , Database.Schema
, Database.User , Database.User
, Server , Server

View File

@ -19,14 +19,18 @@ import Types
import View import View
import qualified API.Users as Users import qualified API.Users as Users
import qualified API.Channels as Channels
data Index = Index data Index = Index
type API = Get '[HTML] (AppView Index) type API = Get '[HTML] (AppView Index)
:<|> Users.API :<|> Users.API
:<|> Channels.API
handler :: ServerT API AppM handler :: ServerT API AppM
handler = indexHandler :<|> Users.handler handler = indexHandler
:<|> Users.handler
:<|> Channels.handler
instance ToHtml Index where instance ToHtml Index where
toHtml _ = do 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 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 :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
handler :: ServerT API AppM handler :: ServerT API AppM

View File

@ -9,6 +9,7 @@ module Database
, select , select
, gen , gen
, fromRel , fromRel
, fromRels
, toRel , toRel
, SeldaT ) , SeldaT )
where where
@ -18,7 +19,7 @@ import Control.Lens (view)
import Data.Pool (Pool, withResource) import Data.Pool (Pool, withResource)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT) import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select) import Database.Selda (query, select)
import Database.Selda.Generic (gen, fromRel, toRel) import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
import ClassyPrelude import ClassyPrelude
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection)) 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) i :*: _ = selectors (gen users)
channels :: GenTable Channel channels :: GenTable Channel
channels = genTable "tags" [ (identifier :: Channel -> RowID) :- autoPrimaryGen channels = genTable "channels" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
, (owner :: Channel -> RowID) :- fkGen (gen users) i ] , (owner :: Channel -> RowID) :- fkGen (gen users) i ]
where where
i :*: _ = selectors (gen users) i :*: _ = selectors (gen users)

View File

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

View File

@ -5,7 +5,13 @@
{-# Language TypeOperators #-} {-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-} {-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
module Server.Auth where {-# Language TemplateHaskell #-}
module Server.Auth
( SafeUser(..)
, authCheck
, AuthResult(..)
, requireLoggedIn)
where
import ClassyPrelude import ClassyPrelude
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
@ -16,6 +22,8 @@ import Database
import Types import Types
import Control.Lens (view) import Control.Lens (view)
import Data.Generics.Product import Data.Generics.Product
import Servant (err401)
import Control.Monad.Logger
-- generic-lens can convert similar types to this -- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone -- 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 username' = Username $ decodeUtf8 username
password' = PlainPassword $ decodeUtf8 password password' = PlainPassword $ decodeUtf8 password
authenticated = SAS.Authenticated . view (super @SafeUser) 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 ClassyPrelude
import Server.Auth import Server.Auth
import Servant.Auth.Server
import Lucid (HtmlT, ToHtml(..)) import Lucid (HtmlT, ToHtml(..))
import Lucid.Html5 as H import Lucid.Html5 as H