diff --git a/ebook-manager.cabal b/ebook-manager.cabal index e4bea20..56db2d4 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -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 diff --git a/src/API.hs b/src/API.hs index d21c7b1..32651a2 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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 diff --git a/src/API/Channels.hs b/src/API/Channels.hs new file mode 100644 index 0000000..335c15d --- /dev/null +++ b/src/API/Channels.hs @@ -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 diff --git a/src/API/Users.hs b/src/API/Users.hs index db30611..9c2ea4e 100644 --- a/src/API/Users.hs +++ b/src/API/Users.hs @@ -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 diff --git a/src/Database.hs b/src/Database.hs index da596f7..cb0d686 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -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)) diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs new file mode 100644 index 0000000..9d482e0 --- /dev/null +++ b/src/Database/Channel.hs @@ -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 diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index b4f02c8..5a47e94 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -112,8 +112,8 @@ tags = genTable "tags" [ (identifier :: Tag -> RowID) :- autoPrimaryGen i :*: _ = selectors (gen users) channels :: GenTable Channel -channels = genTable "tags" [ (identifier :: Channel -> RowID) :- autoPrimaryGen - , (owner :: Channel -> RowID) :- fkGen (gen users) i ] +channels = genTable "channels" [ (identifier :: Channel -> RowID) :- autoPrimaryGen + , (owner :: Channel -> RowID) :- fkGen (gen users) i ] where i :*: _ = selectors (gen users) diff --git a/src/Server.hs b/src/Server.hs index 0c230a9..7461b55 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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 diff --git a/src/Server/Auth.hs b/src/Server/Auth.hs index 75c6c68..d6ef079 100644 --- a/src/Server/Auth.hs +++ b/src/Server/Auth.hs @@ -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 diff --git a/src/View.hs b/src/View.hs index 66212d3..4eeb142 100644 --- a/src/View.hs +++ b/src/View.hs @@ -8,7 +8,6 @@ module View import ClassyPrelude import Server.Auth -import Servant.Auth.Server import Lucid (HtmlT, ToHtml(..)) import Lucid.Html5 as H